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-2010 by Miguel Sofer.
10 * Copyright (c) 2005-2007 by Donal K. Fellows.
11 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
12 * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
13 *
14 * See the file "license.terms" for information on usage and redistribution of
15 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 */
17
18 #include "tclInt.h"
19 #include "tclCompile.h"
20 #include "tclOOInt.h"
21 #include "tommath.h"
22 #include <math.h>
23 #include <assert.h>
24
25 /*
26 * Hack to determine whether we may expect IEEE floating point. The hack is
27 * formally incorrect in that non-IEEE platforms might have the same precision
28 * and range, but VAX, IBM, and Cray do not; are there any other floating
29 * point units that we might care about?
30 */
31
32 #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
33 #define IEEE_FLOATING_POINT
34 #endif
35
36 /*
37 * A mask (should be 2**n-1) that is used to work out when the bytecode engine
38 * should call Tcl_AsyncReady() to see whether there is a signal that needs
39 * handling.
40 */
41
42 #ifndef ASYNC_CHECK_COUNT_MASK
43 # define ASYNC_CHECK_COUNT_MASK 63
44 #endif /* !ASYNC_CHECK_COUNT_MASK */
45
46 /*
47 * Boolean flag indicating whether the Tcl bytecode interpreter has been
48 * initialized.
49 */
50
51 static int execInitialized = 0;
52 TCL_DECLARE_MUTEX(execMutex)
53
54 static int cachedInExit = 0;
55
56 #ifdef TCL_COMPILE_DEBUG
57 /*
58 * Variable that controls whether execution tracing is enabled and, if so,
59 * what level of tracing is desired:
60 * 0: no execution tracing
61 * 1: trace invocations of Tcl procs only
62 * 2: trace invocations of all (not compiled away) commands
63 * 3: display each instruction executed
64 * This variable is linked to the Tcl variable "tcl_traceExec".
65 */
66
67 int tclTraceExec = 0;
68 #endif
69
70 /*
71 * Mapping from expression instruction opcodes to strings; used for error
72 * messages. Note that these entries must match the order and number of the
73 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
74 *
75 * Does not include the string for INST_EXPON (and beyond), as that is
76 * disjoint for backward-compatability reasons.
77 */
78
79 static const char *const operatorStrings[] = {
80 "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
81 "+", "-", "*", "/", "%", "+", "-", "~", "!"
82 };
83
84 /*
85 * Mapping from Tcl result codes to strings; used for error and debugging
86 * messages.
87 */
88
89 #ifdef TCL_COMPILE_DEBUG
90 static const char *const resultStrings[] = {
91 "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
92 };
93 #endif
94
95 /*
96 * These are used by evalstats to monitor object usage in Tcl.
97 */
98
99 #ifdef TCL_COMPILE_STATS
100 long tclObjsAlloced = 0;
101 long tclObjsFreed = 0;
102 long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
103 #endif /* TCL_COMPILE_STATS */
104
105 /*
106 * Support pre-8.5 bytecodes unless specifically requested otherwise.
107 */
108
109 #ifndef TCL_SUPPORT_84_BYTECODE
110 #define TCL_SUPPORT_84_BYTECODE 1
111 #endif
112
113 #if TCL_SUPPORT_84_BYTECODE
114 /*
115 * We need to know the tclBuiltinFuncTable to support translation of pre-8.5
116 * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+.
117 */
118
119 typedef struct {
120 const char *name; /* Name of function. */
121 int numArgs; /* Number of arguments for function. */
122 } BuiltinFunc;
123
124 /*
125 * Table describing the built-in math functions. Entries in this table are
126 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
127 * operand byte.
128 */
129
130 static BuiltinFunc const tclBuiltinFuncTable[] = {
131 {"acos", 1},
132 {"asin", 1},
133 {"atan", 1},
134 {"atan2", 2},
135 {"ceil", 1},
136 {"cos", 1},
137 {"cosh", 1},
138 {"exp", 1},
139 {"floor", 1},
140 {"fmod", 2},
141 {"hypot", 2},
142 {"log", 1},
143 {"log10", 1},
144 {"pow", 2},
145 {"sin", 1},
146 {"sinh", 1},
147 {"sqrt", 1},
148 {"tan", 1},
149 {"tanh", 1},
150 {"abs", 1},
151 {"double", 1},
152 {"int", 1},
153 {"rand", 0},
154 {"round", 1},
155 {"srand", 1},
156 {"wide", 1},
157 {NULL, 0},
158 };
159
160 #define LAST_BUILTIN_FUNC 25
161 #endif
162
163 /*
164 * NR_TEBC
165 * Helpers for NR - non-recursive calls to TEBC
166 * Minimal data required to fully reconstruct the execution state.
167 */
168
169 typedef struct TEBCdata {
170 ByteCode *codePtr; /* Constant until the BC returns */
171 /* -----------------------------------------*/
172 ptrdiff_t *catchTop; /* These fields are used on return TO this */
173 Tcl_Obj *auxObjList; /* this level: they record the state when a */
174 CmdFrame cmdFrame; /* new codePtr was received for NR */
175 /* execution. */
176 void *stack[1]; /* Start of the actual combined catch and obj
177 * stacks; the struct will be expanded as
178 * necessary */
179 } TEBCdata;
180
181 #define TEBC_YIELD() \
182 do { \
183 esPtr->tosPtr = tosPtr; \
184 TclNRAddCallback(interp, TEBCresume, \
185 TD, pc, INT2PTR(cleanup), NULL); \
186 } while (0)
187
188 #define TEBC_DATA_DIG() \
189 do { \
190 tosPtr = esPtr->tosPtr; \
191 } while (0)
192
193 #define PUSH_TAUX_OBJ(objPtr) \
194 do { \
195 if (auxObjList) { \
196 objPtr->length += auxObjList->length; \
197 } \
198 objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \
199 auxObjList = objPtr; \
200 } while (0)
201
202 #define POP_TAUX_OBJ() \
203 do { \
204 tmpPtr = auxObjList; \
205 auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1; \
206 Tcl_DecrRefCount(tmpPtr); \
207 } while (0)
208
209 /*
210 * These variable-access macros have to coincide with those in tclVar.c
211 */
212
213 #define VarHashGetValue(hPtr) \
214 ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
215
216 static inline Var *
VarHashCreateVar(TclVarHashTable * tablePtr,Tcl_Obj * key,int * newPtr)217 VarHashCreateVar(
218 TclVarHashTable *tablePtr,
219 Tcl_Obj *key,
220 int *newPtr)
221 {
222 Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
223 key, newPtr);
224
225 if (!hPtr) {
226 return NULL;
227 }
228 return VarHashGetValue(hPtr);
229 }
230
231 #define VarHashFindVar(tablePtr, key) \
232 VarHashCreateVar((tablePtr), (key), NULL)
233
234 /*
235 * The new macro for ending an instruction; note that a reasonable C-optimiser
236 * will resolve all branches at compile time. (result) is always a constant;
237 * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
238 * at runtime for variable (nCleanup).
239 *
240 * ARGUMENTS:
241 * pcAdjustment: how much to increment pc
242 * nCleanup: how many objects to remove from the stack
243 * resultHandling: 0 indicates no object should be pushed on the stack;
244 * otherwise, push objResultPtr. If (result < 0), objResultPtr already
245 * has the correct reference count.
246 *
247 * We use the new compile-time assertions to check that nCleanup is constant
248 * and within range.
249 */
250
251 /* Verify the stack depth, only when no expansion is in progress */
252
253 #ifdef TCL_COMPILE_DEBUG
254 #define CHECK_STACK() \
255 do { \
256 ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
257 /*checkStack*/ !(starting || auxObjList)); \
258 starting = 0; \
259 } while (0)
260 #else
261 #define CHECK_STACK()
262 #endif
263
264 #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
265 do { \
266 TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
267 CHECK_STACK(); \
268 if (nCleanup == 0) { \
269 if (resultHandling != 0) { \
270 if ((resultHandling) > 0) { \
271 PUSH_OBJECT(objResultPtr); \
272 } else { \
273 *(++tosPtr) = objResultPtr; \
274 } \
275 } \
276 pc += (pcAdjustment); \
277 goto cleanup0; \
278 } else if (resultHandling != 0) { \
279 if ((resultHandling) > 0) { \
280 Tcl_IncrRefCount(objResultPtr); \
281 } \
282 pc += (pcAdjustment); \
283 switch (nCleanup) { \
284 case 1: goto cleanup1_pushObjResultPtr; \
285 case 2: goto cleanup2_pushObjResultPtr; \
286 case 0: break; \
287 } \
288 } else { \
289 pc += (pcAdjustment); \
290 switch (nCleanup) { \
291 case 1: goto cleanup1; \
292 case 2: goto cleanup2; \
293 case 0: break; \
294 } \
295 } \
296 } while (0)
297
298 #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
299 CHECK_STACK(); \
300 do { \
301 pc += (pcAdjustment); \
302 cleanup = (nCleanup); \
303 if (resultHandling) { \
304 if ((resultHandling) > 0) { \
305 Tcl_IncrRefCount(objResultPtr); \
306 } \
307 goto cleanupV_pushObjResultPtr; \
308 } else { \
309 goto cleanupV; \
310 } \
311 } while (0)
312
313 #ifndef TCL_COMPILE_DEBUG
314 #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
315 do { \
316 pc += (pcAdjustment); \
317 switch (*pc) { \
318 case INST_JUMP_FALSE1: \
319 NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
320 break; \
321 case INST_JUMP_TRUE1: \
322 NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
323 break; \
324 case INST_JUMP_FALSE4: \
325 NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
326 break; \
327 case INST_JUMP_TRUE4: \
328 NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
329 break; \
330 default: \
331 if ((condition) < 0) { \
332 TclNewIntObj(objResultPtr, -1); \
333 } else { \
334 objResultPtr = TCONST((condition) > 0); \
335 } \
336 NEXT_INST_F(0, (cleanup), 1); \
337 break; \
338 } \
339 } while (0)
340 #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
341 do { \
342 pc += (pcAdjustment); \
343 switch (*pc) { \
344 case INST_JUMP_FALSE1: \
345 NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
346 break; \
347 case INST_JUMP_TRUE1: \
348 NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
349 break; \
350 case INST_JUMP_FALSE4: \
351 NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
352 break; \
353 case INST_JUMP_TRUE4: \
354 NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
355 break; \
356 default: \
357 if ((condition) < 0) { \
358 TclNewIntObj(objResultPtr, -1); \
359 } else { \
360 objResultPtr = TCONST((condition) > 0); \
361 } \
362 NEXT_INST_V(0, (cleanup), 1); \
363 break; \
364 } \
365 } while (0)
366 #else /* TCL_COMPILE_DEBUG */
367 #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
368 do{ \
369 if ((condition) < 0) { \
370 TclNewIntObj(objResultPtr, -1); \
371 } else { \
372 objResultPtr = TCONST((condition) > 0); \
373 } \
374 NEXT_INST_F((pcAdjustment), (cleanup), 1); \
375 } while (0)
376 #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
377 do{ \
378 if ((condition) < 0) { \
379 TclNewIntObj(objResultPtr, -1); \
380 } else { \
381 objResultPtr = TCONST((condition) > 0); \
382 } \
383 NEXT_INST_V((pcAdjustment), (cleanup), 1); \
384 } while (0)
385 #endif
386
387 /*
388 * Macros used to cache often-referenced Tcl evaluation stack information
389 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
390 * pair must surround any call inside TclNRExecuteByteCode (and a few other
391 * procedures that use this scheme) that could result in a recursive call
392 * to TclNRExecuteByteCode.
393 */
394
395 #define CACHE_STACK_INFO() \
396 checkInterp = 1
397
398 #define DECACHE_STACK_INFO() \
399 esPtr->tosPtr = tosPtr
400
401 /*
402 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
403 * increments the object's ref count since it makes the stack have another
404 * reference pointing to the object. However, POP_OBJECT does not decrement
405 * the ref count. This is because the stack may hold the only reference to the
406 * object, so the object would be destroyed if its ref count were decremented
407 * before the caller had a chance to, e.g., store it in a variable. It is the
408 * caller's responsibility to decrement the ref count when it is finished with
409 * an object.
410 *
411 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
412 * macro. The actual parameter might be an expression with side effects, and
413 * this ensures that it will be executed only once.
414 */
415
416 #define PUSH_OBJECT(objPtr) \
417 Tcl_IncrRefCount(*(++tosPtr) = (objPtr))
418
419 #define POP_OBJECT() *(tosPtr--)
420
421 #define OBJ_AT_TOS *tosPtr
422
423 #define OBJ_UNDER_TOS *(tosPtr-1)
424
425 #define OBJ_AT_DEPTH(n) *(tosPtr-(n))
426
427 #define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
428
429 #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
430
431 /*
432 * Macros used to trace instruction execution. The macros TRACE,
433 * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
434 * only used in TRACE* calls to get a string from an object.
435 */
436
437 #ifdef TCL_COMPILE_DEBUG
438 # define TRACE(a) \
439 while (traceInstructions) { \
440 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
441 (int) CURR_DEPTH, \
442 (unsigned) (pc - codePtr->codeStart), \
443 GetOpcodeName(pc)); \
444 printf a; \
445 break; \
446 }
447 # define TRACE_APPEND(a) \
448 while (traceInstructions) { \
449 printf a; \
450 break; \
451 }
452 # define TRACE_ERROR(interp) \
453 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
454 # define TRACE_WITH_OBJ(a, objPtr) \
455 while (traceInstructions) { \
456 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
457 (int) CURR_DEPTH, \
458 (unsigned) (pc - codePtr->codeStart), \
459 GetOpcodeName(pc)); \
460 printf a; \
461 TclPrintObject(stdout, objPtr, 30); \
462 fprintf(stdout, "\n"); \
463 break; \
464 }
465 # define O2S(objPtr) \
466 (objPtr ? TclGetString(objPtr) : "")
467 #else /* !TCL_COMPILE_DEBUG */
468 # define TRACE(a)
469 # define TRACE_APPEND(a)
470 # define TRACE_ERROR(interp)
471 # define TRACE_WITH_OBJ(a, objPtr)
472 # define O2S(objPtr)
473 #endif /* TCL_COMPILE_DEBUG */
474
475 /*
476 * DTrace instruction probe macros.
477 */
478
479 #define TCL_DTRACE_INST_NEXT() \
480 do { \
481 if (TCL_DTRACE_INST_DONE_ENABLED()) { \
482 if (curInstName) { \
483 TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \
484 tosPtr); \
485 } \
486 curInstName = tclInstructionTable[*pc].name; \
487 if (TCL_DTRACE_INST_START_ENABLED()) { \
488 TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \
489 tosPtr); \
490 } \
491 } else if (TCL_DTRACE_INST_START_ENABLED()) { \
492 TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \
493 (int) CURR_DEPTH, tosPtr); \
494 } \
495 } while (0)
496 #define TCL_DTRACE_INST_LAST() \
497 do { \
498 if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \
499 TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
500 } \
501 } while (0)
502
503 /*
504 * Macro used in this file to save a function call for common uses of
505 * TclGetNumberFromObj(). The ANSI C "prototype" is:
506 *
507 * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
508 * ClientData *ptrPtr, int *tPtr);
509 */
510
511 #ifdef TCL_WIDE_INT_IS_LONG
512 #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
513 (((objPtr)->typePtr == &tclIntType) \
514 ? (*(tPtr) = TCL_NUMBER_LONG, \
515 *(ptrPtr) = (ClientData) \
516 (&((objPtr)->internalRep.longValue)), TCL_OK) : \
517 ((objPtr)->typePtr == &tclDoubleType) \
518 ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
519 ? (*(tPtr) = TCL_NUMBER_NAN) \
520 : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
521 *(ptrPtr) = (ClientData) \
522 (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
523 (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
524 ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
525 TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
526 #else /* !TCL_WIDE_INT_IS_LONG */
527 #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
528 (((objPtr)->typePtr == &tclIntType) \
529 ? (*(tPtr) = TCL_NUMBER_LONG, \
530 *(ptrPtr) = (ClientData) \
531 (&((objPtr)->internalRep.longValue)), TCL_OK) : \
532 ((objPtr)->typePtr == &tclWideIntType) \
533 ? (*(tPtr) = TCL_NUMBER_WIDE, \
534 *(ptrPtr) = (ClientData) \
535 (&((objPtr)->internalRep.wideValue)), TCL_OK) : \
536 ((objPtr)->typePtr == &tclDoubleType) \
537 ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
538 ? (*(tPtr) = TCL_NUMBER_NAN) \
539 : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
540 *(ptrPtr) = (ClientData) \
541 (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
542 (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
543 ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
544 TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
545 #endif /* TCL_WIDE_INT_IS_LONG */
546
547 /*
548 * Macro used in this file to save a function call for common uses of
549 * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
550 *
551 * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
552 * int *boolPtr);
553 */
554
555 #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
556 ((((objPtr)->typePtr == &tclIntType) \
557 || ((objPtr)->typePtr == &tclBooleanType)) \
558 ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
559 : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
560
561 /*
562 * Macro used to make the check for type overflow more mnemonic. This works by
563 * comparing sign bits; the rest of the word is irrelevant. The ANSI C
564 * "prototype" (where inttype_t is any integer type) is:
565 *
566 * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
567 *
568 * Check first the condition most likely to fail in usual code (at least for
569 * usage in [incr]: do the first summand and the sum have != signs?
570 */
571
572 #define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0))
573
574 /*
575 * Macro for checking whether the type is NaN, used when we're thinking about
576 * throwing an error for supplying a non-number number.
577 */
578
579 #ifndef ACCEPT_NAN
580 #define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN)
581 #else
582 #define IsErroringNaNType(type) 0
583 #endif
584
585 /*
586 * Auxiliary tables used to compute powers of small integers.
587 */
588
589 #if (LONG_MAX == 0x7FFFFFFF)
590
591 /*
592 * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
593 * signed integer.
594 */
595
596 static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
597 static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
598
599 /*
600 * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
601 * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
602 * powers of i+3; Exp32Value[i] gives the corresponding powers.
603 */
604
605 static const unsigned short Exp32Index[] = {
606 0, 11, 18, 23, 26, 29, 31, 32, 33
607 };
608 static const size_t Exp32IndexSize =
609 sizeof(Exp32Index) / sizeof(unsigned short);
610 static const long Exp32Value[] = {
611 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
612 129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
613 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
614 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
615 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
616 1000000000
617 };
618 static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
619 #endif /* LONG_MAX == 0x7FFFFFFF -- 32 bit machine */
620
621 #if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
622
623 /*
624 * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
625 * Tcl_WideInt.
626 */
627
628 static const Tcl_WideInt MaxBase64[] = {
629 (Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */
630 (Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208,
631 (Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127,
632 (Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28,
633 (Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15
634 };
635 static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt);
636
637 /*
638 * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
639 * results fit in a 64-bit signed integer.
640 */
641
642 static const unsigned short Exp64Index[] = {
643 0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76
644 };
645 static const size_t Exp64IndexSize =
646 sizeof(Exp64Index) / sizeof(unsigned short);
647 static const Tcl_WideInt Exp64Value[] = {
648 (Tcl_WideInt)243*243*243*3*3,
649 (Tcl_WideInt)243*243*243*3*3*3,
650 (Tcl_WideInt)243*243*243*3*3*3*3,
651 (Tcl_WideInt)243*243*243*243,
652 (Tcl_WideInt)243*243*243*243*3,
653 (Tcl_WideInt)243*243*243*243*3*3,
654 (Tcl_WideInt)243*243*243*243*3*3*3,
655 (Tcl_WideInt)243*243*243*243*3*3*3*3,
656 (Tcl_WideInt)243*243*243*243*243,
657 (Tcl_WideInt)243*243*243*243*243*3,
658 (Tcl_WideInt)243*243*243*243*243*3*3,
659 (Tcl_WideInt)243*243*243*243*243*3*3*3,
660 (Tcl_WideInt)243*243*243*243*243*3*3*3*3,
661 (Tcl_WideInt)243*243*243*243*243*243,
662 (Tcl_WideInt)243*243*243*243*243*243*3,
663 (Tcl_WideInt)243*243*243*243*243*243*3*3,
664 (Tcl_WideInt)243*243*243*243*243*243*3*3*3,
665 (Tcl_WideInt)243*243*243*243*243*243*3*3*3*3,
666 (Tcl_WideInt)243*243*243*243*243*243*243,
667 (Tcl_WideInt)243*243*243*243*243*243*243*3,
668 (Tcl_WideInt)243*243*243*243*243*243*243*3*3,
669 (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3,
670 (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3*3,
671 (Tcl_WideInt)1024*1024*1024*4*4,
672 (Tcl_WideInt)1024*1024*1024*4*4*4,
673 (Tcl_WideInt)1024*1024*1024*4*4*4*4,
674 (Tcl_WideInt)1024*1024*1024*1024,
675 (Tcl_WideInt)1024*1024*1024*1024*4,
676 (Tcl_WideInt)1024*1024*1024*1024*4*4,
677 (Tcl_WideInt)1024*1024*1024*1024*4*4*4,
678 (Tcl_WideInt)1024*1024*1024*1024*4*4*4*4,
679 (Tcl_WideInt)1024*1024*1024*1024*1024,
680 (Tcl_WideInt)1024*1024*1024*1024*1024*4,
681 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4,
682 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4,
683 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4*4,
684 (Tcl_WideInt)1024*1024*1024*1024*1024*1024,
685 (Tcl_WideInt)1024*1024*1024*1024*1024*1024*4,
686 (Tcl_WideInt)3125*3125*3125*5*5,
687 (Tcl_WideInt)3125*3125*3125*5*5*5,
688 (Tcl_WideInt)3125*3125*3125*5*5*5*5,
689 (Tcl_WideInt)3125*3125*3125*3125,
690 (Tcl_WideInt)3125*3125*3125*3125*5,
691 (Tcl_WideInt)3125*3125*3125*3125*5*5,
692 (Tcl_WideInt)3125*3125*3125*3125*5*5*5,
693 (Tcl_WideInt)3125*3125*3125*3125*5*5*5*5,
694 (Tcl_WideInt)3125*3125*3125*3125*3125,
695 (Tcl_WideInt)3125*3125*3125*3125*3125*5,
696 (Tcl_WideInt)3125*3125*3125*3125*3125*5*5,
697 (Tcl_WideInt)7776*7776*7776*6*6,
698 (Tcl_WideInt)7776*7776*7776*6*6*6,
699 (Tcl_WideInt)7776*7776*7776*6*6*6*6,
700 (Tcl_WideInt)7776*7776*7776*7776,
701 (Tcl_WideInt)7776*7776*7776*7776*6,
702 (Tcl_WideInt)7776*7776*7776*7776*6*6,
703 (Tcl_WideInt)7776*7776*7776*7776*6*6*6,
704 (Tcl_WideInt)7776*7776*7776*7776*6*6*6*6,
705 (Tcl_WideInt)16807*16807*16807*7*7,
706 (Tcl_WideInt)16807*16807*16807*7*7*7,
707 (Tcl_WideInt)16807*16807*16807*7*7*7*7,
708 (Tcl_WideInt)16807*16807*16807*16807,
709 (Tcl_WideInt)16807*16807*16807*16807*7,
710 (Tcl_WideInt)16807*16807*16807*16807*7*7,
711 (Tcl_WideInt)32768*32768*32768*8*8,
712 (Tcl_WideInt)32768*32768*32768*8*8*8,
713 (Tcl_WideInt)32768*32768*32768*8*8*8*8,
714 (Tcl_WideInt)32768*32768*32768*32768,
715 (Tcl_WideInt)59049*59049*59049*9*9,
716 (Tcl_WideInt)59049*59049*59049*9*9*9,
717 (Tcl_WideInt)59049*59049*59049*9*9*9*9,
718 (Tcl_WideInt)100000*100000*100000*10*10,
719 (Tcl_WideInt)100000*100000*100000*10*10*10,
720 (Tcl_WideInt)161051*161051*161051*11*11,
721 (Tcl_WideInt)161051*161051*161051*11*11*11,
722 (Tcl_WideInt)248832*248832*248832*12*12,
723 (Tcl_WideInt)371293*371293*371293*13*13
724 };
725 static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
726 #endif /* (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) */
727
728 /*
729 * Markers for ExecuteExtendedBinaryMathOp.
730 */
731
732 #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1)
733 #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2)
734 #define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3)
735
736 /*
737 * Declarations for local procedures to this file:
738 */
739
740 #ifdef TCL_COMPILE_STATS
741 static int EvalStatsCmd(ClientData clientData,
742 Tcl_Interp *interp, int objc,
743 Tcl_Obj *const objv[]);
744 #endif /* TCL_COMPILE_STATS */
745 #ifdef TCL_COMPILE_DEBUG
746 static const char * GetOpcodeName(const unsigned char *pc);
747 static void PrintByteCodeInfo(ByteCode *codePtr);
748 static const char * StringForResultCode(int result);
749 static void ValidatePcAndStackTop(ByteCode *codePtr,
750 const unsigned char *pc, int stackTop,
751 int checkStack);
752 #endif /* TCL_COMPILE_DEBUG */
753 static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
754 static void DeleteExecStack(ExecStack *esPtr);
755 static void DupExprCodeInternalRep(Tcl_Obj *srcPtr,
756 Tcl_Obj *copyPtr);
757 MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
758 Tcl_Obj *value2Ptr);
759 static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp,
760 int opcode, Tcl_Obj **constants,
761 Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
762 static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode,
763 Tcl_Obj *valuePtr);
764 static void FreeExprCodeInternalRep(Tcl_Obj *objPtr);
765 static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
766 int searchMode, ByteCode *codePtr);
767 static const char * GetSrcInfoForPc(const unsigned char *pc,
768 ByteCode *codePtr, int *lengthPtr,
769 const unsigned char **pcBeg, int *cmdIdxPtr);
770 static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
771 int move);
772 static void IllegalExprOperandType(Tcl_Interp *interp,
773 const unsigned char *pc, Tcl_Obj *opndPtr);
774 static void InitByteCodeExecution(Tcl_Interp *interp);
775 static inline int wordSkip(void *ptr);
776 static void ReleaseDictIterator(Tcl_Obj *objPtr);
777 /* Useful elsewhere, make available in tclInt.h or stubs? */
778 static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
779 static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
780 static Tcl_NRPostProc CopyCallback;
781 static Tcl_NRPostProc ExprObjCallback;
782 static Tcl_NRPostProc FinalizeOONext;
783 static Tcl_NRPostProc FinalizeOONextFilter;
784 static Tcl_NRPostProc TEBCresume;
785
786 /*
787 * The structure below defines a bytecode Tcl object type to hold the
788 * compiled bytecode for Tcl expressions.
789 */
790
791 static const Tcl_ObjType exprCodeType = {
792 "exprcode",
793 FreeExprCodeInternalRep, /* freeIntRepProc */
794 DupExprCodeInternalRep, /* dupIntRepProc */
795 NULL, /* updateStringProc */
796 NULL /* setFromAnyProc */
797 };
798
799 /*
800 * Custom object type only used in this file; values of its type should never
801 * be seen by user scripts.
802 */
803
804 static const Tcl_ObjType dictIteratorType = {
805 "dictIterator",
806 ReleaseDictIterator,
807 NULL, NULL, NULL
808 };
809
810 /*
811 *----------------------------------------------------------------------
812 *
813 * ReleaseDictIterator --
814 *
815 * This takes apart a dictionary iterator that is stored in the given Tcl
816 * object.
817 *
818 * Results:
819 * None.
820 *
821 * Side effects:
822 * Deallocates memory, marks the object as being untyped.
823 *
824 *----------------------------------------------------------------------
825 */
826
827 static void
ReleaseDictIterator(Tcl_Obj * objPtr)828 ReleaseDictIterator(
829 Tcl_Obj *objPtr)
830 {
831 Tcl_DictSearch *searchPtr;
832 Tcl_Obj *dictPtr;
833
834 /*
835 * First kill the search, and then release the reference to the dictionary
836 * that we were holding.
837 */
838
839 searchPtr = objPtr->internalRep.twoPtrValue.ptr1;
840 Tcl_DictObjDone(searchPtr);
841 ckfree(searchPtr);
842
843 dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
844 TclDecrRefCount(dictPtr);
845
846 objPtr->typePtr = NULL;
847 }
848
849 /*
850 *----------------------------------------------------------------------
851 *
852 * InitByteCodeExecution --
853 *
854 * This procedure is called once to initialize the Tcl bytecode
855 * interpreter.
856 *
857 * Results:
858 * None.
859 *
860 * Side effects:
861 * This procedure initializes the array of instruction names. If
862 * compiling with the TCL_COMPILE_STATS flag, it initializes the array
863 * that counts the executions of each instruction and it creates the
864 * "evalstats" command. It also establishes the link between the Tcl
865 * "tcl_traceExec" and C "tclTraceExec" variables.
866 *
867 *----------------------------------------------------------------------
868 */
869
870 static void
InitByteCodeExecution(Tcl_Interp * interp)871 InitByteCodeExecution(
872 Tcl_Interp *interp) /* Interpreter for which the Tcl variable
873 * "tcl_traceExec" is linked to control
874 * instruction tracing. */
875 {
876 #ifdef TCL_COMPILE_DEBUG
877 if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
878 TCL_LINK_INT) != TCL_OK) {
879 Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
880 }
881 #endif
882 #ifdef TCL_COMPILE_STATS
883 Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
884 #endif /* TCL_COMPILE_STATS */
885 }
886
887 /*
888 *----------------------------------------------------------------------
889 *
890 * TclCreateExecEnv --
891 *
892 * This procedure creates a new execution environment for Tcl bytecode
893 * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is
894 * typically created once for each Tcl interpreter (Interp structure) and
895 * recursively passed to TclNRExecuteByteCode to execute ByteCode sequences
896 * for nested commands.
897 *
898 * Results:
899 * A newly allocated ExecEnv is returned. This points to an empty
900 * evaluation stack of the standard initial size.
901 *
902 * Side effects:
903 * The bytecode interpreter is also initialized here, as this procedure
904 * will be called before any call to TclNRExecuteByteCode.
905 *
906 *----------------------------------------------------------------------
907 */
908
909 ExecEnv *
TclCreateExecEnv(Tcl_Interp * interp,int size)910 TclCreateExecEnv(
911 Tcl_Interp *interp, /* Interpreter for which the execution
912 * environment is being created. */
913 int size) /* The initial stack size, in number of words
914 * [sizeof(Tcl_Obj*)] */
915 {
916 ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
917 ExecStack *esPtr = ckalloc(TclOffset(ExecStack, stackWords)
918 + size * sizeof(Tcl_Obj *));
919
920 eePtr->execStackPtr = esPtr;
921 TclNewBooleanObj(eePtr->constants[0], 0);
922 Tcl_IncrRefCount(eePtr->constants[0]);
923 TclNewBooleanObj(eePtr->constants[1], 1);
924 Tcl_IncrRefCount(eePtr->constants[1]);
925 eePtr->interp = interp;
926 eePtr->callbackPtr = NULL;
927 eePtr->corPtr = NULL;
928 eePtr->rewind = 0;
929
930 esPtr->prevPtr = NULL;
931 esPtr->nextPtr = NULL;
932 esPtr->markerPtr = NULL;
933 esPtr->endPtr = &esPtr->stackWords[size-1];
934 esPtr->tosPtr = STACK_BASE(esPtr);
935
936 Tcl_MutexLock(&execMutex);
937 if (!execInitialized) {
938 InitByteCodeExecution(interp);
939 execInitialized = 1;
940 }
941 Tcl_MutexUnlock(&execMutex);
942
943 return eePtr;
944 }
945
946 /*
947 *----------------------------------------------------------------------
948 *
949 * TclDeleteExecEnv --
950 *
951 * Frees the storage for an ExecEnv.
952 *
953 * Results:
954 * None.
955 *
956 * Side effects:
957 * Storage for an ExecEnv and its contained storage (e.g. the evaluation
958 * stack) is freed.
959 *
960 *----------------------------------------------------------------------
961 */
962
963 static void
DeleteExecStack(ExecStack * esPtr)964 DeleteExecStack(
965 ExecStack *esPtr)
966 {
967 if (esPtr->markerPtr && !cachedInExit) {
968 Tcl_Panic("freeing an execStack which is still in use");
969 }
970
971 if (esPtr->prevPtr) {
972 esPtr->prevPtr->nextPtr = esPtr->nextPtr;
973 }
974 if (esPtr->nextPtr) {
975 esPtr->nextPtr->prevPtr = esPtr->prevPtr;
976 }
977 ckfree(esPtr);
978 }
979
980 void
TclDeleteExecEnv(ExecEnv * eePtr)981 TclDeleteExecEnv(
982 ExecEnv *eePtr) /* Execution environment to free. */
983 {
984 ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
985
986 cachedInExit = TclInExit();
987
988 /*
989 * Delete all stacks in this exec env.
990 */
991
992 while (esPtr->nextPtr) {
993 esPtr = esPtr->nextPtr;
994 }
995 while (esPtr) {
996 tmpPtr = esPtr;
997 esPtr = tmpPtr->prevPtr;
998 DeleteExecStack(tmpPtr);
999 }
1000
1001 TclDecrRefCount(eePtr->constants[0]);
1002 TclDecrRefCount(eePtr->constants[1]);
1003 if (eePtr->callbackPtr && !cachedInExit) {
1004 Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
1005 }
1006 if (eePtr->corPtr && !cachedInExit) {
1007 Tcl_Panic("Deleting execEnv with existing coroutine");
1008 }
1009 ckfree(eePtr);
1010 }
1011
1012 /*
1013 *----------------------------------------------------------------------
1014 *
1015 * TclFinalizeExecution --
1016 *
1017 * Finalizes the execution environment setup so that it can be later
1018 * reinitialized.
1019 *
1020 * Results:
1021 * None.
1022 *
1023 * Side effects:
1024 * After this call, the next time TclCreateExecEnv will be called it will
1025 * call InitByteCodeExecution.
1026 *
1027 *----------------------------------------------------------------------
1028 */
1029
1030 void
TclFinalizeExecution(void)1031 TclFinalizeExecution(void)
1032 {
1033 Tcl_MutexLock(&execMutex);
1034 execInitialized = 0;
1035 Tcl_MutexUnlock(&execMutex);
1036 }
1037
1038 /*
1039 * Auxiliary code to insure that GrowEvaluationStack always returns correctly
1040 * aligned memory.
1041 *
1042 * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN
1043 * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a
1044 * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
1045 */
1046
1047 #define WALLOCALIGN \
1048 (TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
1049
1050 /*
1051 * wordSkip computes how many words have to be skipped until the next aligned
1052 * word. Note that we are only interested in the low order bits of ptr, so
1053 * that any possible information loss in PTR2INT is of no consequence.
1054 */
1055
1056 static inline int
wordSkip(void * ptr)1057 wordSkip(
1058 void *ptr)
1059 {
1060 int mask = TCL_ALLOCALIGN-1;
1061 int base = PTR2INT(ptr) & mask;
1062 return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);
1063 }
1064
1065 /*
1066 * Given a marker, compute where the following aligned memory starts.
1067 */
1068
1069 #define MEMSTART(markerPtr) \
1070 ((markerPtr) + wordSkip(markerPtr))
1071
1072 /*
1073 *----------------------------------------------------------------------
1074 *
1075 * GrowEvaluationStack --
1076 *
1077 * This procedure grows a Tcl evaluation stack stored in an ExecEnv,
1078 * copying over the words since the last mark if so requested. A mark is
1079 * set at the beginning of the new area when no copying is requested.
1080 *
1081 * Results:
1082 * Returns a pointer to the first usable word in the (possibly) grown
1083 * stack.
1084 *
1085 * Side effects:
1086 * The size of the evaluation stack may be grown, a marker is set
1087 *
1088 *----------------------------------------------------------------------
1089 */
1090
1091 static Tcl_Obj **
GrowEvaluationStack(ExecEnv * eePtr,int growth,int move)1092 GrowEvaluationStack(
1093 ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
1094 * stack to enlarge. */
1095 int growth, /* How much larger than the current used
1096 * size. */
1097 int move) /* 1 if move words since last marker. */
1098 {
1099 ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
1100 int newBytes, newElems, currElems;
1101 int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
1102 Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
1103 int moveWords = 0;
1104
1105 if (move) {
1106 if (!markerPtr) {
1107 Tcl_Panic("STACK: Reallocating with no previous alloc");
1108 }
1109 if (needed <= 0) {
1110 return MEMSTART(markerPtr);
1111 }
1112 } else {
1113 #ifndef PURIFY
1114 Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
1115 int offset = wordSkip(tmpMarkerPtr);
1116
1117 if (needed + offset < 0) {
1118 /*
1119 * Put a marker pointing to the previous marker in this stack, and
1120 * store it in esPtr as the current marker. Return a pointer to
1121 * the start of aligned memory.
1122 */
1123
1124 esPtr->markerPtr = tmpMarkerPtr;
1125 memStart = tmpMarkerPtr + offset;
1126 esPtr->tosPtr = memStart - 1;
1127 *esPtr->markerPtr = (Tcl_Obj *) markerPtr;
1128 return memStart;
1129 }
1130 #endif
1131 }
1132
1133 /*
1134 * Reset move to hold the number of words to be moved to new stack (if
1135 * any) and growth to hold the complete stack requirements: add one for
1136 * the marker, (WALLOCALIGN-1) for the maximal possible offset.
1137 */
1138
1139 if (move) {
1140 moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
1141 }
1142 needed = growth + moveWords + WALLOCALIGN;
1143
1144
1145 /*
1146 * Check if there is enough room in the next stack (if there is one, it
1147 * should be both empty and the last one!)
1148 */
1149
1150 if (esPtr->nextPtr) {
1151 oldPtr = esPtr;
1152 esPtr = oldPtr->nextPtr;
1153 currElems = esPtr->endPtr - STACK_BASE(esPtr);
1154 if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) {
1155 Tcl_Panic("STACK: Stack after current is in use");
1156 }
1157 if (esPtr->nextPtr) {
1158 Tcl_Panic("STACK: Stack after current is not last");
1159 }
1160 if (needed <= currElems) {
1161 goto newStackReady;
1162 }
1163 DeleteExecStack(esPtr);
1164 esPtr = oldPtr;
1165 } else {
1166 currElems = esPtr->endPtr - STACK_BASE(esPtr);
1167 }
1168
1169 /*
1170 * We need to allocate a new stack! It needs to store 'growth' words,
1171 * including the elements to be copied over and the new marker.
1172 */
1173
1174 #ifndef PURIFY
1175 newElems = 2*currElems;
1176 while (needed > newElems) {
1177 newElems *= 2;
1178 }
1179 #else
1180 newElems = needed;
1181 #endif
1182
1183 newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
1184
1185 oldPtr = esPtr;
1186 esPtr = ckalloc(newBytes);
1187
1188 oldPtr->nextPtr = esPtr;
1189 esPtr->prevPtr = oldPtr;
1190 esPtr->nextPtr = NULL;
1191 esPtr->endPtr = &esPtr->stackWords[newElems-1];
1192
1193 newStackReady:
1194 eePtr->execStackPtr = esPtr;
1195
1196 /*
1197 * Store a NULL marker at the beginning of the stack, to indicate that
1198 * this is the first marker in this stack and that rewinding to here
1199 * should actually be a return to the previous stack.
1200 */
1201
1202 esPtr->stackWords[0] = NULL;
1203 esPtr->markerPtr = &esPtr->stackWords[0];
1204 memStart = MEMSTART(esPtr->markerPtr);
1205 esPtr->tosPtr = memStart - 1;
1206
1207 if (move) {
1208 memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *));
1209 esPtr->tosPtr += moveWords;
1210 oldPtr->markerPtr = (Tcl_Obj **) *markerPtr;
1211 oldPtr->tosPtr = markerPtr-1;
1212 }
1213
1214 /*
1215 * Free the old stack if it is now unused.
1216 */
1217
1218 if (!oldPtr->markerPtr) {
1219 DeleteExecStack(oldPtr);
1220 }
1221
1222 return memStart;
1223 }
1224
1225 /*
1226 *--------------------------------------------------------------
1227 *
1228 * TclStackAlloc, TclStackRealloc, TclStackFree --
1229 *
1230 * Allocate memory from the execution stack; it has to be returned later
1231 * with a call to TclStackFree.
1232 *
1233 * Results:
1234 * A pointer to the first byte allocated, or panics if the allocation did
1235 * not succeed.
1236 *
1237 * Side effects:
1238 * The execution stack may be grown.
1239 *
1240 *--------------------------------------------------------------
1241 */
1242
1243 static Tcl_Obj **
StackAllocWords(Tcl_Interp * interp,int numWords)1244 StackAllocWords(
1245 Tcl_Interp *interp,
1246 int numWords)
1247 {
1248 /*
1249 * Note that GrowEvaluationStack sets a marker in the stack. This marker
1250 * is read when rewinding, e.g., by TclStackFree.
1251 */
1252
1253 Interp *iPtr = (Interp *) interp;
1254 ExecEnv *eePtr = iPtr->execEnvPtr;
1255 Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0);
1256
1257 eePtr->execStackPtr->tosPtr += numWords;
1258 return resPtr;
1259 }
1260
1261 static Tcl_Obj **
StackReallocWords(Tcl_Interp * interp,int numWords)1262 StackReallocWords(
1263 Tcl_Interp *interp,
1264 int numWords)
1265 {
1266 Interp *iPtr = (Interp *) interp;
1267 ExecEnv *eePtr = iPtr->execEnvPtr;
1268 Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1);
1269
1270 eePtr->execStackPtr->tosPtr += numWords;
1271 return resPtr;
1272 }
1273
1274 void
TclStackFree(Tcl_Interp * interp,void * freePtr)1275 TclStackFree(
1276 Tcl_Interp *interp,
1277 void *freePtr)
1278 {
1279 Interp *iPtr = (Interp *) interp;
1280 ExecEnv *eePtr;
1281 ExecStack *esPtr;
1282 Tcl_Obj **markerPtr, *marker;
1283
1284 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1285 ckfree((char *) freePtr);
1286 return;
1287 }
1288
1289 /*
1290 * Rewind the stack to the previous marker position. The current marker,
1291 * as set in the last call to GrowEvaluationStack, contains a pointer to
1292 * the previous marker.
1293 */
1294
1295 eePtr = iPtr->execEnvPtr;
1296 esPtr = eePtr->execStackPtr;
1297 markerPtr = esPtr->markerPtr;
1298 marker = *markerPtr;
1299
1300 if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) {
1301 Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?",
1302 freePtr, MEMSTART(markerPtr));
1303 }
1304
1305 esPtr->tosPtr = markerPtr - 1;
1306 esPtr->markerPtr = (Tcl_Obj **) marker;
1307 if (marker) {
1308 return;
1309 }
1310
1311 /*
1312 * Return to previous active stack. Note that repeated expansions or
1313 * reallocs could have generated several unused intervening stacks: free
1314 * them too.
1315 */
1316
1317 while (esPtr->nextPtr) {
1318 esPtr = esPtr->nextPtr;
1319 }
1320 esPtr->tosPtr = STACK_BASE(esPtr);
1321 while (esPtr->prevPtr) {
1322 ExecStack *tmpPtr = esPtr->prevPtr;
1323 if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) {
1324 DeleteExecStack(tmpPtr);
1325 } else {
1326 break;
1327 }
1328 }
1329 if (esPtr->prevPtr) {
1330 eePtr->execStackPtr = esPtr->prevPtr;
1331 #ifdef PURIFY
1332 eePtr->execStackPtr->nextPtr = NULL;
1333 DeleteExecStack(esPtr);
1334 #endif
1335 } else {
1336 eePtr->execStackPtr = esPtr;
1337 }
1338 }
1339
1340 void *
TclStackAlloc(Tcl_Interp * interp,int numBytes)1341 TclStackAlloc(
1342 Tcl_Interp *interp,
1343 int numBytes)
1344 {
1345 Interp *iPtr = (Interp *) interp;
1346 int numWords;
1347
1348 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1349 return (void *) ckalloc(numBytes);
1350 }
1351 numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
1352 return (void *) StackAllocWords(interp, numWords);
1353 }
1354
1355 void *
TclStackRealloc(Tcl_Interp * interp,void * ptr,int numBytes)1356 TclStackRealloc(
1357 Tcl_Interp *interp,
1358 void *ptr,
1359 int numBytes)
1360 {
1361 Interp *iPtr = (Interp *) interp;
1362 ExecEnv *eePtr;
1363 ExecStack *esPtr;
1364 Tcl_Obj **markerPtr;
1365 int numWords;
1366
1367 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1368 return (void *) ckrealloc((char *) ptr, numBytes);
1369 }
1370
1371 eePtr = iPtr->execEnvPtr;
1372 esPtr = eePtr->execStackPtr;
1373 markerPtr = esPtr->markerPtr;
1374
1375 if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
1376 Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?");
1377 }
1378
1379 numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
1380 return (void *) StackReallocWords(interp, numWords);
1381 }
1382
1383 /*
1384 *--------------------------------------------------------------
1385 *
1386 * Tcl_ExprObj --
1387 *
1388 * Evaluate an expression in a Tcl_Obj.
1389 *
1390 * Results:
1391 * A standard Tcl object result. If the result is other than TCL_OK, then
1392 * the interpreter's result contains an error message. If the result is
1393 * TCL_OK, then a pointer to the expression's result value object is
1394 * stored in resultPtrPtr. In that case, the object's ref count is
1395 * incremented to reflect the reference returned to the caller; the
1396 * caller is then responsible for the resulting object and must, for
1397 * example, decrement the ref count when it is finished with the object.
1398 *
1399 * Side effects:
1400 * Any side effects caused by subcommands in the expression, if any. The
1401 * interpreter result is not modified unless there is an error.
1402 *
1403 *--------------------------------------------------------------
1404 */
1405
1406 int
Tcl_ExprObj(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_Obj ** resultPtrPtr)1407 Tcl_ExprObj(
1408 Tcl_Interp *interp, /* Context in which to evaluate the
1409 * expression. */
1410 Tcl_Obj *objPtr, /* Points to Tcl object containing expression
1411 * to evaluate. */
1412 Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
1413 * result is stored if no errors occur. */
1414 {
1415 NRE_callback *rootPtr = TOP_CB(interp);
1416 Tcl_Obj *resultPtr;
1417
1418 TclNewObj(resultPtr);
1419 TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
1420 NULL, NULL);
1421 Tcl_NRExprObj(interp, objPtr, resultPtr);
1422 return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
1423 }
1424
1425 static int
CopyCallback(ClientData data[],Tcl_Interp * interp,int result)1426 CopyCallback(
1427 ClientData data[],
1428 Tcl_Interp *interp,
1429 int result)
1430 {
1431 Tcl_Obj **resultPtrPtr = data[0];
1432 Tcl_Obj *resultPtr = data[1];
1433
1434 if (result == TCL_OK) {
1435 *resultPtrPtr = resultPtr;
1436 Tcl_IncrRefCount(resultPtr);
1437 } else {
1438 Tcl_DecrRefCount(resultPtr);
1439 }
1440 return result;
1441 }
1442
1443 /*
1444 *--------------------------------------------------------------
1445 *
1446 * Tcl_NRExprObj --
1447 *
1448 * Request evaluation of the expression in a Tcl_Obj by the NR stack.
1449 *
1450 * Results:
1451 * Returns TCL_OK.
1452 *
1453 * Side effects:
1454 * Compiles objPtr as a Tcl expression and places callbacks on the
1455 * NR stack to execute the bytecode and store the result in resultPtr.
1456 * If bytecode execution raises an exception, nothing is written
1457 * to resultPtr, and the exceptional return code flows up the NR
1458 * stack. If the exception is TCL_ERROR, an error message is left
1459 * in the interp result and the interp's return options dictionary
1460 * holds additional error information too. Execution of the bytecode
1461 * may have other side effects, depending on the expression.
1462 *
1463 *--------------------------------------------------------------
1464 */
1465
1466 int
Tcl_NRExprObj(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_Obj * resultPtr)1467 Tcl_NRExprObj(
1468 Tcl_Interp *interp,
1469 Tcl_Obj *objPtr,
1470 Tcl_Obj *resultPtr)
1471 {
1472 ByteCode *codePtr;
1473 Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK);
1474
1475 Tcl_ResetResult(interp);
1476 codePtr = CompileExprObj(interp, objPtr);
1477
1478 Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr,
1479 NULL, NULL);
1480 return TclNRExecuteByteCode(interp, codePtr);
1481 }
1482
1483 static int
ExprObjCallback(ClientData data[],Tcl_Interp * interp,int result)1484 ExprObjCallback(
1485 ClientData data[],
1486 Tcl_Interp *interp,
1487 int result)
1488 {
1489 Tcl_InterpState state = data[0];
1490 Tcl_Obj *resultPtr = data[1];
1491
1492 if (result == TCL_OK) {
1493 TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
1494 (void) Tcl_RestoreInterpState(interp, state);
1495 } else {
1496 Tcl_DiscardInterpState(state);
1497 }
1498 return result;
1499 }
1500
1501 /*
1502 *----------------------------------------------------------------------
1503 *
1504 * CompileExprObj --
1505 * Compile a Tcl expression value into ByteCode.
1506 *
1507 * Results:
1508 * A (ByteCode *) is returned pointing to the resulting ByteCode.
1509 * The caller must manage its refCount and arrange for a call to
1510 * TclCleanupByteCode() when the last reference disappears.
1511 *
1512 * Side effects:
1513 * The Tcl_ObjType of objPtr is changed to the "bytecode" type,
1514 * and the ByteCode is kept in the internal rep (along with context
1515 * data for checking validity) for faster operations the next time
1516 * CompileExprObj is called on the same value.
1517 *
1518 *----------------------------------------------------------------------
1519 */
1520
1521 static ByteCode *
CompileExprObj(Tcl_Interp * interp,Tcl_Obj * objPtr)1522 CompileExprObj(
1523 Tcl_Interp *interp,
1524 Tcl_Obj *objPtr)
1525 {
1526 Interp *iPtr = (Interp *) interp;
1527 CompileEnv compEnv; /* Compilation environment structure allocated
1528 * in frame. */
1529 ByteCode *codePtr = NULL;
1530 /* Tcl Internal type of bytecode. Initialized
1531 * to avoid compiler warning. */
1532
1533 /*
1534 * Get the expression ByteCode from the object. If it exists, make sure it
1535 * is valid in the current context.
1536 */
1537 if (objPtr->typePtr == &exprCodeType) {
1538 Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
1539
1540 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1541 if (((Interp *) *codePtr->interpHandle != iPtr)
1542 || (codePtr->compileEpoch != iPtr->compileEpoch)
1543 || (codePtr->nsPtr != namespacePtr)
1544 || (codePtr->nsEpoch != namespacePtr->resolverEpoch)
1545 || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
1546 FreeExprCodeInternalRep(objPtr);
1547 }
1548 }
1549 if (objPtr->typePtr != &exprCodeType) {
1550 /*
1551 * TIP #280: No invoker (yet) - Expression compilation.
1552 */
1553
1554 int length;
1555 const char *string = TclGetStringFromObj(objPtr, &length);
1556
1557 TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
1558 TclCompileExpr(interp, string, length, &compEnv, 0);
1559
1560 /*
1561 * Successful compilation. If the expression yielded no instructions,
1562 * push an zero object as the expression's result.
1563 */
1564
1565 if (compEnv.codeNext == compEnv.codeStart) {
1566 TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
1567 &compEnv);
1568 }
1569
1570 /*
1571 * Add a "done" instruction as the last instruction and change the
1572 * object into a ByteCode object. Ownership of the literal objects and
1573 * aux data items is given to the ByteCode object.
1574 */
1575
1576 TclEmitOpcode(INST_DONE, &compEnv);
1577 TclInitByteCodeObj(objPtr, &compEnv);
1578 objPtr->typePtr = &exprCodeType;
1579 TclFreeCompileEnv(&compEnv);
1580 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1581 if (iPtr->varFramePtr->localCachePtr) {
1582 codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
1583 codePtr->localCachePtr->refCount++;
1584 }
1585 #ifdef TCL_COMPILE_DEBUG
1586 if (tclTraceCompile == 2) {
1587 TclPrintByteCodeObj(interp, objPtr);
1588 fflush(stdout);
1589 }
1590 #endif /* TCL_COMPILE_DEBUG */
1591 }
1592 return codePtr;
1593 }
1594
1595 /*
1596 *----------------------------------------------------------------------
1597 *
1598 * DupExprCodeInternalRep --
1599 *
1600 * Part of the Tcl object type implementation for Tcl expression
1601 * bytecode. We do not copy the bytecode internalrep. Instead, we return
1602 * without setting copyPtr->typePtr, so the copy is a plain string copy
1603 * of the expression value, and if it is to be used as a compiled
1604 * expression, it will just need a recompile.
1605 *
1606 * This makes sense, because with Tcl's copy-on-write practices, the
1607 * usual (only?) time Tcl_DuplicateObj() will be called is when the copy
1608 * is about to be modified, which would invalidate any copied bytecode
1609 * anyway. The only reason it might make sense to copy the bytecode is if
1610 * we had some modifying routines that operated directly on the internalrep,
1611 * like we do for lists and dicts.
1612 *
1613 * Results:
1614 * None.
1615 *
1616 * Side effects:
1617 * None.
1618 *
1619 *----------------------------------------------------------------------
1620 */
1621
1622 static void
DupExprCodeInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)1623 DupExprCodeInternalRep(
1624 Tcl_Obj *srcPtr,
1625 Tcl_Obj *copyPtr)
1626 {
1627 return;
1628 }
1629
1630 /*
1631 *----------------------------------------------------------------------
1632 *
1633 * FreeExprCodeInternalRep --
1634 *
1635 * Part of the Tcl object type implementation for Tcl expression
1636 * bytecode. Frees the storage allocated to hold the internal rep, unless
1637 * ref counts indicate bytecode execution is still in progress.
1638 *
1639 * Results:
1640 * None.
1641 *
1642 * Side effects:
1643 * May free allocated memory. Leaves objPtr untyped.
1644 *
1645 *----------------------------------------------------------------------
1646 */
1647
1648 static void
FreeExprCodeInternalRep(Tcl_Obj * objPtr)1649 FreeExprCodeInternalRep(
1650 Tcl_Obj *objPtr)
1651 {
1652 ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1653
1654 objPtr->typePtr = NULL;
1655 if (codePtr->refCount-- <= 1) {
1656 TclCleanupByteCode(codePtr);
1657 }
1658 }
1659
1660 /*
1661 *----------------------------------------------------------------------
1662 *
1663 * TclCompileObj --
1664 *
1665 * This procedure compiles the script contained in a Tcl_Obj.
1666 *
1667 * Results:
1668 * A pointer to the corresponding ByteCode, never NULL.
1669 *
1670 * Side effects:
1671 * The object is shimmered to bytecode type.
1672 *
1673 *----------------------------------------------------------------------
1674 */
1675
1676 ByteCode *
TclCompileObj(Tcl_Interp * interp,Tcl_Obj * objPtr,const CmdFrame * invoker,int word)1677 TclCompileObj(
1678 Tcl_Interp *interp,
1679 Tcl_Obj *objPtr,
1680 const CmdFrame *invoker,
1681 int word)
1682 {
1683 Interp *iPtr = (Interp *) interp;
1684 ByteCode *codePtr; /* Tcl Internal type of bytecode. */
1685 Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
1686
1687 /*
1688 * If the object is not already of tclByteCodeType, compile it (and reset
1689 * the compilation flags in the interpreter; this should be done after any
1690 * compilation). Otherwise, check that it is "fresh" enough.
1691 */
1692
1693 if (objPtr->typePtr == &tclByteCodeType) {
1694 /*
1695 * Make sure the Bytecode hasn't been invalidated by, e.g., someone
1696 * redefining a command with a compile procedure (this might make the
1697 * compiled code wrong). The object needs to be recompiled if it was
1698 * compiled in/for a different interpreter, or for a different
1699 * namespace, or for the same namespace but with different name
1700 * resolution rules. Precompiled objects, however, are immutable and
1701 * therefore they are not recompiled, even if the epoch has changed.
1702 *
1703 * To be pedantically correct, we should also check that the
1704 * originating procPtr is the same as the current context procPtr
1705 * (assuming one exists at all - none for global level). This code is
1706 * #def'ed out because [info body] was changed to never return a
1707 * bytecode type object, which should obviate us from the extra checks
1708 * here.
1709 */
1710
1711 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1712 if (((Interp *) *codePtr->interpHandle != iPtr)
1713 || (codePtr->compileEpoch != iPtr->compileEpoch)
1714 || (codePtr->nsPtr != namespacePtr)
1715 || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
1716 if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
1717 goto recompileObj;
1718 }
1719 if ((Interp *) *codePtr->interpHandle != iPtr) {
1720 Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
1721 }
1722 codePtr->compileEpoch = iPtr->compileEpoch;
1723 }
1724
1725 /*
1726 * Check that any compiled locals do refer to the current proc
1727 * environment! If not, recompile.
1728 */
1729
1730 if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) &&
1731 (codePtr->procPtr == NULL) &&
1732 (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){
1733 goto recompileObj;
1734 }
1735
1736 /*
1737 * #280.
1738 * Literal sharing fix. This part of the fix is not required by 8.4
1739 * nor 8.5, because they eval-direct any literals, so just saving the
1740 * argument locations per command in bytecode is enough, embedded
1741 * 'eval' commands, etc. get the correct information.
1742 *
1743 * But in 8.6 all the embedded script are compiled, and the resulting
1744 * bytecode stored in the literal. Now the shared literal has bytecode
1745 * with location data for _one_ particular location this literal is
1746 * found at. If we get executed from a different location the bytecode
1747 * has to be recompiled to get the correct locations. Not doing this
1748 * will execute the saved bytecode with data for a different location,
1749 * causing 'info frame' to point to the wrong place in the sources.
1750 *
1751 * Future optimizations ...
1752 * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
1753 * case we recompile once per location of the literal, but not
1754 * continously, because the moment we have all locations we do not
1755 * need to recompile any longer.
1756 *
1757 * (2) Alternative: Do not recompile, tell the execution engine the
1758 * offset between saved starting line and actual one. Then modify
1759 * the users to adjust the locations they have by this offset.
1760 *
1761 * (3) Alternative 2: Do not fully recompile, adjust just the location
1762 * information.
1763 */
1764
1765 if (invoker == NULL) {
1766 return codePtr;
1767 } else {
1768 Tcl_HashEntry *hePtr =
1769 Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
1770 ExtCmdLoc *eclPtr;
1771 CmdFrame *ctxCopyPtr;
1772 int redo;
1773
1774 if (!hePtr) {
1775 return codePtr;
1776 }
1777
1778 eclPtr = Tcl_GetHashValue(hePtr);
1779 redo = 0;
1780 ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
1781 *ctxCopyPtr = *invoker;
1782
1783 if (invoker->type == TCL_LOCATION_BC) {
1784 /*
1785 * Note: Type BC => ctx.data.eval.path is not used.
1786 * ctx.data.tebc.codePtr used instead
1787 */
1788
1789 TclGetSrcInfoForPc(ctxCopyPtr);
1790 if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) {
1791 /*
1792 * The reference made by 'TclGetSrcInfoForPc' is dead.
1793 */
1794
1795 Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
1796 ctxCopyPtr->data.eval.path = NULL;
1797 }
1798 }
1799
1800 if (word < ctxCopyPtr->nline) {
1801 /*
1802 * Note: We do not care if the line[word] is -1. This is a
1803 * difference and requires a recompile (location changed from
1804 * absolute to relative, literal is used fixed and through
1805 * variable)
1806 *
1807 * Example:
1808 * test info-32.0 using literal of info-24.8
1809 * (dict with ... vs set body ...).
1810 */
1811
1812 redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
1813 && (eclPtr->start != ctxCopyPtr->line[word]))
1814 || ((eclPtr->type == TCL_LOCATION_BC)
1815 && (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
1816 }
1817
1818 TclStackFree(interp, ctxCopyPtr);
1819 if (!redo) {
1820 return codePtr;
1821 }
1822 }
1823 }
1824
1825 recompileObj:
1826 iPtr->errorLine = 1;
1827
1828 /*
1829 * TIP #280. Remember the invoker for a moment in the interpreter
1830 * structures so that the byte code compiler can pick it up when
1831 * initializing the compilation environment, i.e. the extended location
1832 * information.
1833 */
1834
1835 iPtr->invokeCmdFramePtr = invoker;
1836 iPtr->invokeWord = word;
1837 TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
1838 iPtr->invokeCmdFramePtr = NULL;
1839 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1840 if (iPtr->varFramePtr->localCachePtr) {
1841 codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
1842 codePtr->localCachePtr->refCount++;
1843 }
1844 return codePtr;
1845 }
1846
1847 /*
1848 *----------------------------------------------------------------------
1849 *
1850 * TclIncrObj --
1851 *
1852 * Increment an integeral value in a Tcl_Obj by an integeral value held
1853 * in another Tcl_Obj. Caller is responsible for making sure we can
1854 * update the first object.
1855 *
1856 * Results:
1857 * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
1858 * error, an error message is left in the interpreter (if it is not NULL,
1859 * of course).
1860 *
1861 * Side effects:
1862 * valuePtr gets the new incrmented value.
1863 *
1864 *----------------------------------------------------------------------
1865 */
1866
1867 int
TclIncrObj(Tcl_Interp * interp,Tcl_Obj * valuePtr,Tcl_Obj * incrPtr)1868 TclIncrObj(
1869 Tcl_Interp *interp,
1870 Tcl_Obj *valuePtr,
1871 Tcl_Obj *incrPtr)
1872 {
1873 ClientData ptr1, ptr2;
1874 int type1, type2;
1875 mp_int value, incr;
1876
1877 if (Tcl_IsShared(valuePtr)) {
1878 Tcl_Panic("%s called with shared object", "TclIncrObj");
1879 }
1880
1881 if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
1882 /*
1883 * Produce error message (reparse?!)
1884 */
1885
1886 return TclGetIntFromObj(interp, valuePtr, &type1);
1887 }
1888 if (GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) {
1889 /*
1890 * Produce error message (reparse?!)
1891 */
1892
1893 TclGetIntFromObj(interp, incrPtr, &type1);
1894 Tcl_AddErrorInfo(interp, "\n (reading increment)");
1895 return TCL_ERROR;
1896 }
1897
1898 if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
1899 long augend = *((const long *) ptr1);
1900 long addend = *((const long *) ptr2);
1901 long sum = augend + addend;
1902
1903 /*
1904 * Overflow when (augend and sum have different sign) and (augend and
1905 * addend have the same sign). This is encapsulated in the Overflowing
1906 * macro.
1907 */
1908
1909 if (!Overflowing(augend, addend, sum)) {
1910 TclSetLongObj(valuePtr, sum);
1911 return TCL_OK;
1912 }
1913 #ifndef TCL_WIDE_INT_IS_LONG
1914 {
1915 Tcl_WideInt w1 = (Tcl_WideInt) augend;
1916 Tcl_WideInt w2 = (Tcl_WideInt) addend;
1917
1918 /*
1919 * We know the sum value is outside the long range, so we use the
1920 * macro form that doesn't range test again.
1921 */
1922
1923 TclSetWideIntObj(valuePtr, w1 + w2);
1924 return TCL_OK;
1925 }
1926 #endif
1927 }
1928
1929 if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
1930 /*
1931 * Produce error message (reparse?!)
1932 */
1933
1934 return TclGetIntFromObj(interp, valuePtr, &type1);
1935 }
1936 if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
1937 /*
1938 * Produce error message (reparse?!)
1939 */
1940
1941 TclGetIntFromObj(interp, incrPtr, &type1);
1942 Tcl_AddErrorInfo(interp, "\n (reading increment)");
1943 return TCL_ERROR;
1944 }
1945
1946 #ifndef TCL_WIDE_INT_IS_LONG
1947 if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
1948 Tcl_WideInt w1, w2, sum;
1949
1950 TclGetWideIntFromObj(NULL, valuePtr, &w1);
1951 TclGetWideIntFromObj(NULL, incrPtr, &w2);
1952 sum = w1 + w2;
1953
1954 /*
1955 * Check for overflow.
1956 */
1957
1958 if (!Overflowing(w1, w2, sum)) {
1959 Tcl_SetWideIntObj(valuePtr, sum);
1960 return TCL_OK;
1961 }
1962 }
1963 #endif
1964
1965 Tcl_TakeBignumFromObj(interp, valuePtr, &value);
1966 Tcl_GetBignumFromObj(interp, incrPtr, &incr);
1967 mp_add(&value, &incr, &value);
1968 mp_clear(&incr);
1969 Tcl_SetBignumObj(valuePtr, &value);
1970 return TCL_OK;
1971 }
1972
1973 /*
1974 *----------------------------------------------------------------------
1975 *
1976 * ArgumentBCEnter --
1977 *
1978 * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates
1979 * a code sequence that is fairly common in the code but *not* commonly
1980 * called.
1981 *
1982 * Results:
1983 * None
1984 *
1985 * Side effects:
1986 * May register information about the bytecode in the command frame.
1987 *
1988 *----------------------------------------------------------------------
1989 */
1990
1991 static void
ArgumentBCEnter(Tcl_Interp * interp,ByteCode * codePtr,TEBCdata * tdPtr,const unsigned char * pc,int objc,Tcl_Obj ** objv)1992 ArgumentBCEnter(
1993 Tcl_Interp *interp,
1994 ByteCode *codePtr,
1995 TEBCdata *tdPtr,
1996 const unsigned char *pc,
1997 int objc,
1998 Tcl_Obj **objv)
1999 {
2000 int cmd;
2001
2002 if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
2003 TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
2004 pc - codePtr->codeStart);
2005 }
2006 }
2007
2008 /*
2009 *----------------------------------------------------------------------
2010 *
2011 * TclNRExecuteByteCode --
2012 *
2013 * This procedure executes the instructions of a ByteCode structure. It
2014 * returns when a "done" instruction is executed or an error occurs.
2015 *
2016 * Results:
2017 * The return value is one of the return codes defined in tcl.h (such as
2018 * TCL_OK), and interp->objResultPtr refers to a Tcl object that either
2019 * contains the result of executing the code or an error message.
2020 *
2021 * Side effects:
2022 * Almost certainly, depending on the ByteCode's instructions.
2023 *
2024 *----------------------------------------------------------------------
2025 */
2026 #define bcFramePtr (&TD->cmdFrame)
2027 #define initCatchTop ((ptrdiff_t *) (TD->stack-1))
2028 #define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
2029 #define esPtr (iPtr->execEnvPtr->execStackPtr)
2030
2031 int
TclNRExecuteByteCode(Tcl_Interp * interp,ByteCode * codePtr)2032 TclNRExecuteByteCode(
2033 Tcl_Interp *interp, /* Token for command interpreter. */
2034 ByteCode *codePtr) /* The bytecode sequence to interpret. */
2035 {
2036 Interp *iPtr = (Interp *) interp;
2037 TEBCdata *TD;
2038 int size = sizeof(TEBCdata) - 1
2039 + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
2040 * sizeof(void *);
2041 int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
2042
2043 codePtr->refCount++;
2044
2045 /*
2046 * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
2047 *
2048 * The execution uses a unified stack: first a TEBCdata, immediately
2049 * above it a CmdFrame, then the catch stack, then the execution stack.
2050 *
2051 * Make sure the catch stack is large enough to hold the maximum number of
2052 * catch commands that could ever be executing at the same time (this will
2053 * be no more than the exception range array's depth). Make sure the
2054 * execution stack is large enough to execute this ByteCode.
2055 */
2056
2057 TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
2058 esPtr->tosPtr = initTosPtr;
2059
2060 TD->codePtr = codePtr;
2061 TD->catchTop = initCatchTop;
2062 TD->auxObjList = NULL;
2063
2064 /*
2065 * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
2066 * every time that we call out from this TD, popped when we return to it.
2067 */
2068
2069 bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
2070 ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
2071 bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
2072 bcFramePtr->framePtr = iPtr->framePtr;
2073 bcFramePtr->nextPtr = iPtr->cmdFramePtr;
2074 bcFramePtr->nline = 0;
2075 bcFramePtr->line = NULL;
2076 bcFramePtr->litarg = NULL;
2077 bcFramePtr->data.tebc.codePtr = codePtr;
2078 bcFramePtr->data.tebc.pc = NULL;
2079 bcFramePtr->cmdObj = NULL;
2080 bcFramePtr->cmd = NULL;
2081 bcFramePtr->len = 0;
2082
2083 #ifdef TCL_COMPILE_STATS
2084 iPtr->stats.numExecutions++;
2085 #endif
2086
2087 /*
2088 * Test namespace-50.9 demonstrates the need for this call.
2089 * Use a --enable-symbols=mem bug to see.
2090 */
2091
2092 TclResetRewriteEnsemble(interp, 1);
2093
2094 /*
2095 * Push the callback for bytecode execution
2096 */
2097
2098 TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
2099 /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags));
2100
2101 /*
2102 * Reset discard result flag - because it is applicable for this call only,
2103 * and should not affect all the nested invocations may return result.
2104 */
2105 iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT;
2106
2107 return TCL_OK;
2108 }
2109
2110 static int
TEBCresume(ClientData data[],Tcl_Interp * interp,int result)2111 TEBCresume(
2112 ClientData data[],
2113 Tcl_Interp *interp,
2114 int result)
2115 {
2116 /*
2117 * Compiler cast directive - not a real variable.
2118 * Interp *iPtr = (Interp *) interp;
2119 */
2120 #define iPtr ((Interp *) interp)
2121
2122 /*
2123 * Check just the read-traced/write-traced bit of a variable.
2124 */
2125
2126 #define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
2127 #define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
2128 #define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET)
2129
2130 /*
2131 * Bottom of allocated stack holds the NR data
2132 */
2133
2134 /*
2135 * Constants: variables that do not change during the execution, used
2136 * sporadically: no special need for speed.
2137 */
2138
2139 int instructionCount = 0; /* Counter that is used to work out when to
2140 * call Tcl_AsyncReady() */
2141 const char *curInstName;
2142 #ifdef TCL_COMPILE_DEBUG
2143 int traceInstructions; /* Whether we are doing instruction-level
2144 * tracing or not. */
2145 #endif
2146
2147 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2148 Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
2149
2150 #define LOCAL(i) (&compiledLocals[(i)])
2151 #define TCONST(i) (constants[(i)])
2152
2153 /*
2154 * These macros are just meant to save some global variables that are not
2155 * used too frequently
2156 */
2157
2158 TEBCdata *TD = data[0];
2159 #define auxObjList (TD->auxObjList)
2160 #define catchTop (TD->catchTop)
2161 #define codePtr (TD->codePtr)
2162 #define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */
2163
2164 /*
2165 * Globals: variables that store state, must remain valid at all times.
2166 */
2167
2168 Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
2169 * stack. */
2170 const unsigned char *pc = data[1];
2171 /* The current program counter. */
2172 unsigned char inst; /* The currently running instruction */
2173
2174 /*
2175 * Transfer variables - needed only between opcodes, but not while
2176 * executing an instruction.
2177 */
2178
2179 int cleanup = PTR2INT(data[2]);
2180 Tcl_Obj *objResultPtr;
2181 int checkInterp = 0; /* Indicates when a check of interp readyness
2182 * is necessary. Set by CACHE_STACK_INFO() */
2183
2184 /*
2185 * Locals - variables that are used within opcodes or bounded sections of
2186 * the file (jumps between opcodes within a family).
2187 * NOTE: These are now mostly defined locally where needed.
2188 */
2189
2190 Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
2191 Tcl_Obj **objv = NULL;
2192 int objc = 0;
2193 int opnd, length, pcAdjustment;
2194 Var *varPtr, *arrayPtr;
2195 #ifdef TCL_COMPILE_DEBUG
2196 char cmdNameBuf[21];
2197 #endif
2198
2199 #ifdef TCL_COMPILE_DEBUG
2200 int starting = 1;
2201 traceInstructions = (tclTraceExec == 3);
2202 #endif
2203
2204 TEBC_DATA_DIG();
2205
2206 #ifdef TCL_COMPILE_DEBUG
2207 if (!pc && (tclTraceExec >= 2)) {
2208 PrintByteCodeInfo(codePtr);
2209 fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
2210 fflush(stdout);
2211 }
2212 #endif
2213
2214 if (!pc) {
2215 /* bytecode is starting from scratch */
2216 pc = codePtr->codeStart;
2217
2218 /*
2219 * Reset the interp's result to avoid possible duplications of large
2220 * objects [3c6e47363e], [781585], [804681], This can happen by start
2221 * also in nested compiled blocks (enclosed in parent cycle).
2222 * See else branch below for opposite handling by continuation/resume.
2223 */
2224
2225 objPtr = iPtr->objResultPtr;
2226 if (objPtr->refCount > 1) {
2227 TclDecrRefCount(objPtr);
2228 TclNewObj(objPtr);
2229 Tcl_IncrRefCount(objPtr);
2230 iPtr->objResultPtr = objPtr;
2231 }
2232
2233 goto cleanup0;
2234 } else {
2235 /* resume from invocation */
2236 CACHE_STACK_INFO();
2237
2238 NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
2239 if (bcFramePtr->cmdObj) {
2240 Tcl_DecrRefCount(bcFramePtr->cmdObj);
2241 bcFramePtr->cmdObj = NULL;
2242 bcFramePtr->cmd = NULL;
2243 }
2244 iPtr->cmdFramePtr = bcFramePtr->nextPtr;
2245 if (iPtr->flags & INTERP_DEBUG_FRAME) {
2246 TclArgumentBCRelease(interp, bcFramePtr);
2247 }
2248 if (iPtr->execEnvPtr->rewind) {
2249 result = TCL_ERROR;
2250 goto abnormalReturn;
2251 }
2252 if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
2253 codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
2254 checkInterp = 1;
2255 iPtr->flags |= ERR_ALREADY_LOGGED;
2256 }
2257
2258 if (result != TCL_OK) {
2259 pc--;
2260 goto processExceptionReturn;
2261 }
2262
2263 /*
2264 * Push the call's object result and continue execution with the next
2265 * instruction.
2266 */
2267
2268 TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
2269 objc, cmdNameBuf), Tcl_GetObjResult(interp));
2270
2271 /*
2272 * Obtain and reset interp's result to avoid possible duplications of
2273 * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any
2274 * side effects caused by the resetting of errorInfo and errorCode
2275 * [Bug 804681], which are not needed here. We chose instead to
2276 * manipulate the interp's object result directly.
2277 *
2278 * Note that the result object is now in objResultPtr, it keeps the
2279 * refCount it had in its role of iPtr->objResultPtr.
2280 */
2281
2282 objResultPtr = Tcl_GetObjResult(interp);
2283 TclNewObj(objPtr);
2284 Tcl_IncrRefCount(objPtr);
2285 iPtr->objResultPtr = objPtr;
2286 #ifndef TCL_COMPILE_DEBUG
2287 if (*pc == INST_POP) {
2288 TclDecrRefCount(objResultPtr);
2289 NEXT_INST_V(1, cleanup, 0);
2290 }
2291 #endif
2292 NEXT_INST_V(0, cleanup, -1);
2293 }
2294
2295 /*
2296 * Targets for standard instruction endings; unrolled for speed in the
2297 * most frequent cases (instructions that consume up to two stack
2298 * elements).
2299 *
2300 * This used to be a "for(;;)" loop, with each instruction doing its own
2301 * cleanup.
2302 */
2303
2304 cleanupV_pushObjResultPtr:
2305 switch (cleanup) {
2306 case 0:
2307 *(++tosPtr) = (objResultPtr);
2308 goto cleanup0;
2309 default:
2310 cleanup -= 2;
2311 while (cleanup--) {
2312 objPtr = POP_OBJECT();
2313 TclDecrRefCount(objPtr);
2314 }
2315 /* FALLTHRU */
2316 case 2:
2317 cleanup2_pushObjResultPtr:
2318 objPtr = POP_OBJECT();
2319 TclDecrRefCount(objPtr);
2320 /* FALLTHRU */
2321 case 1:
2322 cleanup1_pushObjResultPtr:
2323 objPtr = OBJ_AT_TOS;
2324 TclDecrRefCount(objPtr);
2325 }
2326 OBJ_AT_TOS = objResultPtr;
2327 goto cleanup0;
2328
2329 cleanupV:
2330 switch (cleanup) {
2331 default:
2332 cleanup -= 2;
2333 while (cleanup--) {
2334 objPtr = POP_OBJECT();
2335 TclDecrRefCount(objPtr);
2336 }
2337 /* FALLTHRU */
2338 case 2:
2339 cleanup2:
2340 objPtr = POP_OBJECT();
2341 TclDecrRefCount(objPtr);
2342 /* FALLTHRU */
2343 case 1:
2344 cleanup1:
2345 objPtr = POP_OBJECT();
2346 TclDecrRefCount(objPtr);
2347 /* FALLTHRU */
2348 case 0:
2349 /*
2350 * We really want to do nothing now, but this is needed for some
2351 * compilers (SunPro CC).
2352 */
2353
2354 break;
2355 }
2356 cleanup0:
2357
2358 /*
2359 * Check for asynchronous handlers [Bug 746722]; we do the check every
2360 * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
2361 */
2362
2363 if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
2364 DECACHE_STACK_INFO();
2365 if (TclAsyncReady(iPtr)) {
2366 result = Tcl_AsyncInvoke(interp, result);
2367 if (result == TCL_ERROR) {
2368 CACHE_STACK_INFO();
2369 goto gotError;
2370 }
2371 }
2372
2373 if (TclCanceled(iPtr)) {
2374 if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
2375 CACHE_STACK_INFO();
2376 goto gotError;
2377 }
2378 }
2379
2380 if (TclLimitReady(iPtr->limit)) {
2381 if (Tcl_LimitCheck(interp) == TCL_ERROR) {
2382 CACHE_STACK_INFO();
2383 goto gotError;
2384 }
2385 }
2386 CACHE_STACK_INFO();
2387 }
2388
2389 /*
2390 * These two instructions account for 26% of all instructions (according
2391 * to measurements on tclbench by Ben Vitale
2392 * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf]
2393 * Resolving them before the switch reduces the cost of branch
2394 * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!)
2395 * reduces total obj size.
2396 */
2397
2398 inst = *pc;
2399
2400 peepholeStart:
2401 #ifdef TCL_COMPILE_STATS
2402 iPtr->stats.instructionCount[*pc]++;
2403 #endif
2404
2405 #ifdef TCL_COMPILE_DEBUG
2406 /*
2407 * Skip the stack depth check if an expansion is in progress.
2408 */
2409
2410 CHECK_STACK();
2411 if (traceInstructions) {
2412 fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
2413 TclPrintInstruction(codePtr, pc);
2414 fflush(stdout);
2415 }
2416 #endif /* TCL_COMPILE_DEBUG */
2417
2418 TCL_DTRACE_INST_NEXT();
2419
2420 if (inst == INST_LOAD_SCALAR1) {
2421 goto instLoadScalar1;
2422 } else if (inst == INST_PUSH1) {
2423 PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
2424 TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS);
2425 inst = *(pc += 2);
2426 goto peepholeStart;
2427 } else if (inst == INST_START_CMD) {
2428 /*
2429 * Peephole: do not run INST_START_CMD, just skip it
2430 */
2431
2432 iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
2433 if (checkInterp) {
2434 if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
2435 (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
2436 !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
2437 goto instStartCmdFailed;
2438 }
2439 checkInterp = 0;
2440 }
2441 inst = *(pc += 9);
2442 goto peepholeStart;
2443 } else if (inst == INST_NOP) {
2444 #ifndef TCL_COMPILE_DEBUG
2445 while (inst == INST_NOP)
2446 #endif
2447 {
2448 inst = *++pc;
2449 }
2450 goto peepholeStart;
2451 }
2452
2453 switch (inst) {
2454 case INST_SYNTAX:
2455 case INST_RETURN_IMM: {
2456 int code = TclGetInt4AtPtr(pc+1);
2457 int level = TclGetUInt4AtPtr(pc+5);
2458
2459 /*
2460 * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr.
2461 */
2462
2463 TRACE(("%u %u => ", code, level));
2464 result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
2465 if (result == TCL_OK) {
2466 TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
2467 O2S(objResultPtr)));
2468 NEXT_INST_F(9, 1, 0);
2469 }
2470 Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
2471 if (*pc == INST_SYNTAX) {
2472 iPtr->flags &= ~ERR_ALREADY_LOGGED;
2473 }
2474 cleanup = 2;
2475 TRACE_APPEND(("\n"));
2476 goto processExceptionReturn;
2477 }
2478
2479 case INST_RETURN_STK:
2480 TRACE(("=> "));
2481 objResultPtr = POP_OBJECT();
2482 result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
2483 if (result == TCL_OK) {
2484 Tcl_DecrRefCount(OBJ_AT_TOS);
2485 OBJ_AT_TOS = objResultPtr;
2486 TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
2487 O2S(objResultPtr)));
2488 NEXT_INST_F(1, 0, 0);
2489 } else if (result == TCL_ERROR) {
2490 /*
2491 * BEWARE! Must do this in this order, because an error in the
2492 * option dictionary overrides the result (and can be verified by
2493 * test).
2494 */
2495
2496 Tcl_SetObjResult(interp, objResultPtr);
2497 Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
2498 Tcl_DecrRefCount(OBJ_AT_TOS);
2499 OBJ_AT_TOS = objResultPtr;
2500 } else {
2501 Tcl_DecrRefCount(OBJ_AT_TOS);
2502 OBJ_AT_TOS = objResultPtr;
2503 Tcl_SetObjResult(interp, objResultPtr);
2504 }
2505 cleanup = 1;
2506 TRACE_APPEND(("\n"));
2507 goto processExceptionReturn;
2508
2509 {
2510 CoroutineData *corPtr;
2511 int yieldParameter;
2512
2513 case INST_YIELD:
2514 corPtr = iPtr->execEnvPtr->corPtr;
2515 TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
2516 if (!corPtr) {
2517 TRACE_APPEND(("ERROR: yield outside coroutine\n"));
2518 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2519 "yield can only be called in a coroutine", -1));
2520 DECACHE_STACK_INFO();
2521 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
2522 NULL);
2523 CACHE_STACK_INFO();
2524 goto gotError;
2525 }
2526
2527 #ifdef TCL_COMPILE_DEBUG
2528 if (tclTraceExec >= 2) {
2529 if (traceInstructions) {
2530 TRACE_APPEND(("YIELD...\n"));
2531 } else {
2532 fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
2533 iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
2534 Tcl_GetString(OBJ_AT_TOS));
2535 }
2536 fflush(stdout);
2537 }
2538 #endif
2539 yieldParameter = 0;
2540 Tcl_SetObjResult(interp, OBJ_AT_TOS);
2541 goto doYield;
2542
2543 case INST_YIELD_TO_INVOKE:
2544 corPtr = iPtr->execEnvPtr->corPtr;
2545 valuePtr = OBJ_AT_TOS;
2546 if (!corPtr) {
2547 TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
2548 O2S(valuePtr)));
2549 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2550 "yieldto can only be called in a coroutine", -1));
2551 DECACHE_STACK_INFO();
2552 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
2553 NULL);
2554 CACHE_STACK_INFO();
2555 goto gotError;
2556 }
2557 if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
2558 TRACE(("[%.30s] => ERROR: yield in deleted\n",
2559 O2S(valuePtr)));
2560 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2561 "yieldto called in deleted namespace", -1));
2562 DECACHE_STACK_INFO();
2563 Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
2564 NULL);
2565 CACHE_STACK_INFO();
2566 goto gotError;
2567 }
2568
2569 #ifdef TCL_COMPILE_DEBUG
2570 if (tclTraceExec >= 2) {
2571 if (traceInstructions) {
2572 TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
2573 } else {
2574 /* FIXME: What is the right thing to trace? */
2575 fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
2576 iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
2577 Tcl_GetString(valuePtr));
2578 }
2579 fflush(stdout);
2580 }
2581 #endif
2582
2583 /*
2584 * Install a tailcall record in the caller and continue with the
2585 * yield. The yield is switched into multi-return mode (via the
2586 * 'yieldParameter').
2587 */
2588
2589 Tcl_IncrRefCount(valuePtr);
2590 iPtr->execEnvPtr = corPtr->callerEEPtr;
2591 TclSetTailcall(interp, valuePtr);
2592 iPtr->execEnvPtr = corPtr->eePtr;
2593 yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
2594
2595 doYield:
2596 /* TIP #280: Record the last piece of info needed by
2597 * 'TclGetSrcInfoForPc', and push the frame.
2598 */
2599
2600 bcFramePtr->data.tebc.pc = (char *) pc;
2601 iPtr->cmdFramePtr = bcFramePtr;
2602
2603 if (iPtr->flags & INTERP_DEBUG_FRAME) {
2604 ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
2605 }
2606
2607 pc++;
2608 cleanup = 1;
2609 TEBC_YIELD();
2610 TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
2611 INT2PTR(yieldParameter), NULL, NULL);
2612 return TCL_OK;
2613 }
2614
2615 case INST_TAILCALL: {
2616 Tcl_Obj *listPtr, *nsObjPtr;
2617
2618 opnd = TclGetUInt1AtPtr(pc+1);
2619
2620 if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
2621 TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
2622 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2623 "tailcall can only be called from a proc or lambda", -1));
2624 DECACHE_STACK_INFO();
2625 Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
2626 CACHE_STACK_INFO();
2627 goto gotError;
2628 }
2629
2630 #ifdef TCL_COMPILE_DEBUG
2631 /* FIXME: What is the right thing to trace? */
2632 {
2633 int i;
2634
2635 TRACE(("%d [", opnd));
2636 for (i=opnd-1 ; i>=0 ; i--) {
2637 TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
2638 if (i > 0) {
2639 TRACE_APPEND((" "));
2640 }
2641 }
2642 TRACE_APPEND(("] => RETURN..."));
2643 }
2644 #endif
2645
2646 /*
2647 * Push the evaluation of the called command into the NR callback
2648 * stack.
2649 */
2650
2651 listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
2652 nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
2653 TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
2654 if (iPtr->varFramePtr->tailcallPtr) {
2655 Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
2656 }
2657 iPtr->varFramePtr->tailcallPtr = listPtr;
2658
2659 result = TCL_RETURN;
2660 cleanup = opnd;
2661 goto processExceptionReturn;
2662 }
2663
2664 case INST_DONE:
2665 if (tosPtr > initTosPtr) {
2666
2667 if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) {
2668 /* simulate pop & fast done (like it does continue in loop) */
2669 TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
2670 objPtr = POP_OBJECT();
2671 TclDecrRefCount(objPtr);
2672 goto abnormalReturn;
2673 }
2674 /*
2675 * Set the interpreter's object result to point to the topmost
2676 * object from the stack, and check for a possible [catch]. The
2677 * stackTop's level and refCount will be handled by "processCatch"
2678 * or "abnormalReturn".
2679 */
2680
2681 Tcl_SetObjResult(interp, OBJ_AT_TOS);
2682 #ifdef TCL_COMPILE_DEBUG
2683 TRACE_WITH_OBJ(("=> return code=%d, result=", result),
2684 iPtr->objResultPtr);
2685 if (traceInstructions) {
2686 fprintf(stdout, "\n");
2687 }
2688 #endif
2689 goto checkForCatch;
2690 }
2691 (void) POP_OBJECT();
2692 goto abnormalReturn;
2693
2694 case INST_PUSH4:
2695 objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
2696 TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
2697 NEXT_INST_F(5, 0, 1);
2698 break;
2699
2700 case INST_POP:
2701 TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
2702 objPtr = POP_OBJECT();
2703 TclDecrRefCount(objPtr);
2704 NEXT_INST_F(1, 0, 0);
2705 break;
2706
2707 case INST_DUP:
2708 objResultPtr = OBJ_AT_TOS;
2709 TRACE_WITH_OBJ(("=> "), objResultPtr);
2710 NEXT_INST_F(1, 0, 1);
2711 break;
2712
2713 case INST_OVER:
2714 opnd = TclGetUInt4AtPtr(pc+1);
2715 objResultPtr = OBJ_AT_DEPTH(opnd);
2716 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2717 NEXT_INST_F(5, 0, 1);
2718 break;
2719
2720 case INST_REVERSE: {
2721 Tcl_Obj **a, **b;
2722
2723 opnd = TclGetUInt4AtPtr(pc+1);
2724 a = tosPtr-(opnd-1);
2725 b = tosPtr;
2726 while (a<b) {
2727 tmpPtr = *a;
2728 *a = *b;
2729 *b = tmpPtr;
2730 a++; b--;
2731 }
2732 TRACE(("%u => OK\n", opnd));
2733 NEXT_INST_F(5, 0, 0);
2734 }
2735 break;
2736
2737 case INST_STR_CONCAT1: {
2738 int appendLen = 0;
2739 char *bytes, *p;
2740 Tcl_Obj **currPtr;
2741 int onlyb = 1;
2742
2743 opnd = TclGetUInt1AtPtr(pc+1);
2744
2745 /*
2746 * Detect only-bytearray-or-null case.
2747 */
2748
2749 for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
2750 if (((*currPtr)->typePtr != &tclByteArrayType)
2751 && ((*currPtr)->bytes != tclEmptyStringRep)) {
2752 onlyb = 0;
2753 break;
2754 } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
2755 ((*currPtr)->bytes != NULL)) {
2756 onlyb = 0;
2757 break;
2758 }
2759 }
2760
2761 /*
2762 * Compute the length to be appended.
2763 */
2764
2765 if (onlyb) {
2766 for (currPtr = &OBJ_AT_DEPTH(opnd-2);
2767 appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
2768 if ((*currPtr)->bytes != tclEmptyStringRep) {
2769 Tcl_GetByteArrayFromObj(*currPtr, &length);
2770 appendLen += length;
2771 }
2772 }
2773 } else {
2774 for (currPtr = &OBJ_AT_DEPTH(opnd-2);
2775 appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
2776 bytes = TclGetStringFromObj(*currPtr, &length);
2777 if (bytes != NULL) {
2778 appendLen += length;
2779 }
2780 }
2781 }
2782
2783 if (appendLen < 0) {
2784 /* TODO: convert panic to error ? */
2785 Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
2786 }
2787
2788 /*
2789 * If nothing is to be appended, just return the first object by
2790 * dropping all the others from the stack; this saves both the
2791 * computation and copy of the string rep of the first object,
2792 * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
2793 */
2794
2795 if (appendLen == 0) {
2796 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2797 NEXT_INST_V(2, (opnd-1), 0);
2798 }
2799
2800 /*
2801 * If the first object is shared, we need a new obj for the result;
2802 * otherwise, we can reuse the first object. In any case, make sure it
2803 * has enough room to accomodate all the concatenated bytes. Note that
2804 * if it is unshared its bytes are copied by ckrealloc, so that we set
2805 * the loop parameters to avoid copying them again: p points to the
2806 * end of the already copied bytes, currPtr to the second object.
2807 */
2808
2809 objResultPtr = OBJ_AT_DEPTH(opnd-1);
2810 if (!onlyb) {
2811 bytes = TclGetStringFromObj(objResultPtr, &length);
2812 if (length + appendLen < 0) {
2813 /* TODO: convert panic to error ? */
2814 Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
2815 INT_MAX);
2816 }
2817 #ifndef TCL_COMPILE_DEBUG
2818 if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
2819 TclFreeIntRep(objResultPtr);
2820 objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
2821 objResultPtr->length = length + appendLen;
2822 p = TclGetString(objResultPtr) + length;
2823 currPtr = &OBJ_AT_DEPTH(opnd - 2);
2824 } else
2825 #endif
2826 {
2827 p = ckalloc(length + appendLen + 1);
2828 TclNewObj(objResultPtr);
2829 objResultPtr->bytes = p;
2830 objResultPtr->length = length + appendLen;
2831 currPtr = &OBJ_AT_DEPTH(opnd - 1);
2832 }
2833
2834 /*
2835 * Append the remaining characters.
2836 */
2837
2838 for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
2839 bytes = TclGetStringFromObj(*currPtr, &length);
2840 if (bytes != NULL) {
2841 memcpy(p, bytes, length);
2842 p += length;
2843 }
2844 }
2845 *p = '\0';
2846 } else {
2847 bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
2848 if (length + appendLen < 0) {
2849 /* TODO: convert panic to error ? */
2850 Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
2851 INT_MAX);
2852 }
2853 #ifndef TCL_COMPILE_DEBUG
2854 if (!Tcl_IsShared(objResultPtr)) {
2855 bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
2856 length + appendLen);
2857 p = bytes + length;
2858 currPtr = &OBJ_AT_DEPTH(opnd - 2);
2859 } else
2860 #endif
2861 {
2862 TclNewObj(objResultPtr);
2863 bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
2864 length + appendLen);
2865 p = bytes;
2866 currPtr = &OBJ_AT_DEPTH(opnd - 1);
2867 }
2868
2869 /*
2870 * Append the remaining characters.
2871 */
2872
2873 for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
2874 if ((*currPtr)->bytes != tclEmptyStringRep) {
2875 bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
2876 memcpy(p, bytes, length);
2877 p += length;
2878 }
2879 }
2880 }
2881
2882 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2883 NEXT_INST_V(2, opnd, 1);
2884 }
2885
2886 case INST_CONCAT_STK:
2887 /*
2888 * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
2889 * and then decrement their ref counts.
2890 */
2891
2892 opnd = TclGetUInt4AtPtr(pc+1);
2893 objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
2894 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2895 NEXT_INST_V(5, opnd, 1);
2896
2897 case INST_EXPAND_START:
2898 /*
2899 * Push an element to the auxObjList. This records the current
2900 * stack depth - i.e., the point in the stack where the expanded
2901 * command starts.
2902 *
2903 * Use a Tcl_Obj as linked list element; slight mem waste, but faster
2904 * allocation than ckalloc. This also abuses the Tcl_Obj structure, as
2905 * we do not define a special tclObjType for it. It is not dangerous
2906 * as the obj is never passed anywhere, so that all manipulations are
2907 * performed here and in INST_INVOKE_EXPANDED (in case of an expansion
2908 * error, also in INST_EXPAND_STKTOP).
2909 */
2910
2911 TclNewObj(objPtr);
2912 objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
2913 objPtr->length = 0;
2914 PUSH_TAUX_OBJ(objPtr);
2915 TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
2916 NEXT_INST_F(1, 0, 0);
2917 break;
2918
2919 case INST_EXPAND_DROP:
2920 /*
2921 * Drops an element of the auxObjList, popping stack elements to
2922 * restore the stack to the state before the point where the aux
2923 * element was created.
2924 */
2925
2926 CLANG_ASSERT(auxObjList);
2927 objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
2928 POP_TAUX_OBJ();
2929 #ifdef TCL_COMPILE_DEBUG
2930 /* Ugly abuse! */
2931 starting = 1;
2932 #endif
2933 TRACE(("=> drop %d items\n", objc));
2934 NEXT_INST_V(1, objc, 0);
2935
2936 case INST_EXPAND_STKTOP: {
2937 int i;
2938 ptrdiff_t moved;
2939
2940 /*
2941 * Make sure that the element at stackTop is a list; if not, just
2942 * leave with an error. Note that the element from the expand list
2943 * will be removed at checkForCatch.
2944 */
2945
2946 objPtr = OBJ_AT_TOS;
2947 TRACE(("\"%.30s\" => ", O2S(objPtr)));
2948 if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
2949 TRACE_ERROR(interp);
2950 goto gotError;
2951 }
2952 (void) POP_OBJECT();
2953
2954 /*
2955 * Make sure there is enough room in the stack to expand this list
2956 * *and* process the rest of the command (at least up to the next
2957 * argument expansion or command end). The operand is the current
2958 * stack depth, as seen by the compiler.
2959 */
2960
2961 auxObjList->length += objc - 1;
2962 if ((objc > 1) && (auxObjList->length > 0)) {
2963 length = auxObjList->length /* Total expansion room we need */
2964 + codePtr->maxStackDepth /* Beyond the original max */
2965 - CURR_DEPTH; /* Relative to where we are */
2966 DECACHE_STACK_INFO();
2967 moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
2968 - (Tcl_Obj **) TD;
2969 if (moved) {
2970 /*
2971 * Change the global data to point to the new stack: move the
2972 * TEBCdataPtr TD, recompute the position of every other
2973 * stack-allocated parameter, update the stack pointers.
2974 */
2975
2976 TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
2977
2978 catchTop += moved;
2979 tosPtr += moved;
2980 }
2981 }
2982
2983 /*
2984 * Expand the list at stacktop onto the stack; free the list. Knowing
2985 * that it has a freeIntRepProc we use Tcl_DecrRefCount().
2986 */
2987
2988 for (i = 0; i < objc; i++) {
2989 PUSH_OBJECT(objv[i]);
2990 }
2991
2992 TRACE_APPEND(("OK\n"));
2993 Tcl_DecrRefCount(objPtr);
2994 NEXT_INST_F(5, 0, 0);
2995 }
2996 break;
2997
2998 case INST_EXPR_STK: {
2999 ByteCode *newCodePtr;
3000
3001 bcFramePtr->data.tebc.pc = (char *) pc;
3002 iPtr->cmdFramePtr = bcFramePtr;
3003 DECACHE_STACK_INFO();
3004 newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
3005 CACHE_STACK_INFO();
3006 cleanup = 1;
3007 pc++;
3008 TEBC_YIELD();
3009 return TclNRExecuteByteCode(interp, newCodePtr);
3010 }
3011
3012 /*
3013 * INVOCATION BLOCK
3014 */
3015
3016 case INST_EVAL_STK:
3017 instEvalStk:
3018 bcFramePtr->data.tebc.pc = (char *) pc;
3019 iPtr->cmdFramePtr = bcFramePtr;
3020
3021 cleanup = 1;
3022 pc += 1;
3023 /* yield next instruction */
3024 TEBC_YIELD();
3025 /* add TEBCResume for object at top of stack */
3026 return TclNRExecuteByteCode(interp,
3027 TclCompileObj(interp, OBJ_AT_TOS, NULL, 0));
3028
3029 case INST_INVOKE_EXPANDED:
3030 CLANG_ASSERT(auxObjList);
3031 objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
3032 POP_TAUX_OBJ();
3033 if (objc) {
3034 pcAdjustment = 1;
3035 goto doInvocation;
3036 }
3037
3038 /*
3039 * Nothing was expanded, return {}.
3040 */
3041
3042 TclNewObj(objResultPtr);
3043 NEXT_INST_F(1, 0, 1);
3044 break;
3045
3046 case INST_INVOKE_STK4:
3047 objc = TclGetUInt4AtPtr(pc+1);
3048 pcAdjustment = 5;
3049 goto doInvocation;
3050
3051 case INST_INVOKE_STK1:
3052 objc = TclGetUInt1AtPtr(pc+1);
3053 pcAdjustment = 2;
3054
3055 doInvocation:
3056 objv = &OBJ_AT_DEPTH(objc-1);
3057 cleanup = objc;
3058
3059 #ifdef TCL_COMPILE_DEBUG
3060 if (tclTraceExec >= 2) {
3061 int i;
3062
3063 if (traceInstructions) {
3064 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
3065 TRACE(("%u => call ", objc));
3066 } else {
3067 fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
3068 (unsigned)(pc - codePtr->codeStart));
3069 }
3070 for (i = 0; i < objc; i++) {
3071 TclPrintObject(stdout, objv[i], 15);
3072 fprintf(stdout, " ");
3073 }
3074 fprintf(stdout, "\n");
3075 fflush(stdout);
3076 }
3077 #endif /*TCL_COMPILE_DEBUG*/
3078
3079 /*
3080 * Finally, let TclEvalObjv handle the command.
3081 *
3082 * TIP #280: Record the last piece of info needed by
3083 * 'TclGetSrcInfoForPc', and push the frame.
3084 */
3085
3086 bcFramePtr->data.tebc.pc = (char *) pc;
3087 iPtr->cmdFramePtr = bcFramePtr;
3088
3089 if (iPtr->flags & INTERP_DEBUG_FRAME) {
3090 ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
3091 }
3092
3093 DECACHE_STACK_INFO();
3094
3095 pc += pcAdjustment;
3096 TEBC_YIELD();
3097 return TclNREvalObjv(interp, objc, objv,
3098 TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
3099
3100 #if TCL_SUPPORT_84_BYTECODE
3101 case INST_CALL_BUILTIN_FUNC1:
3102 /*
3103 * Call one of the built-in pre-8.5 Tcl math functions. This
3104 * translates to INST_INVOKE_STK1 with the first argument of
3105 * ::tcl::mathfunc::$objv[0]. We need to insert the named math
3106 * function into the stack.
3107 */
3108
3109 opnd = TclGetUInt1AtPtr(pc+1);
3110 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
3111 TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
3112 Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd);
3113 }
3114
3115 TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::");
3116 Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);
3117
3118 /*
3119 * Only 0, 1 or 2 args.
3120 */
3121
3122 {
3123 int numArgs = tclBuiltinFuncTable[opnd].numArgs;
3124 Tcl_Obj *tmpPtr1, *tmpPtr2;
3125
3126 if (numArgs == 0) {
3127 PUSH_OBJECT(objPtr);
3128 } else if (numArgs == 1) {
3129 tmpPtr1 = POP_OBJECT();
3130 PUSH_OBJECT(objPtr);
3131 PUSH_OBJECT(tmpPtr1);
3132 Tcl_DecrRefCount(tmpPtr1);
3133 } else {
3134 tmpPtr2 = POP_OBJECT();
3135 tmpPtr1 = POP_OBJECT();
3136 PUSH_OBJECT(objPtr);
3137 PUSH_OBJECT(tmpPtr1);
3138 PUSH_OBJECT(tmpPtr2);
3139 Tcl_DecrRefCount(tmpPtr1);
3140 Tcl_DecrRefCount(tmpPtr2);
3141 }
3142 objc = numArgs + 1;
3143 }
3144 pcAdjustment = 2;
3145 goto doInvocation;
3146
3147 case INST_CALL_FUNC1:
3148 /*
3149 * Call a non-builtin Tcl math function previously registered by a
3150 * call to Tcl_CreateMathFunc pre-8.5. This is essentially
3151 * INST_INVOKE_STK1 converting the first arg to
3152 * ::tcl::mathfunc::$objv[0].
3153 */
3154
3155 objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function
3156 * name is the 0-th argument. */
3157
3158 objPtr = OBJ_AT_DEPTH(objc-1);
3159 TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::");
3160 Tcl_AppendObjToObj(tmpPtr, objPtr);
3161 Tcl_DecrRefCount(objPtr);
3162
3163 /*
3164 * Variation of PUSH_OBJECT.
3165 */
3166
3167 OBJ_AT_DEPTH(objc-1) = tmpPtr;
3168 Tcl_IncrRefCount(tmpPtr);
3169
3170 pcAdjustment = 2;
3171 goto doInvocation;
3172 #else
3173 /*
3174 * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
3175 * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support
3176 * remains for existing bytecode precompiled files.
3177 */
3178
3179 case INST_CALL_BUILTIN_FUNC1:
3180 Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
3181 case INST_CALL_FUNC1:
3182 Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
3183 #endif
3184
3185 case INST_INVOKE_REPLACE:
3186 objc = TclGetUInt4AtPtr(pc+1);
3187 opnd = TclGetUInt1AtPtr(pc+5);
3188 objPtr = POP_OBJECT();
3189 objv = &OBJ_AT_DEPTH(objc-1);
3190 cleanup = objc;
3191 #ifdef TCL_COMPILE_DEBUG
3192 if (tclTraceExec >= 2) {
3193 int i;
3194
3195 if (traceInstructions) {
3196 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
3197 TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
3198 } else {
3199 fprintf(stdout,
3200 "%d: (%u) invoking (using implementation %s) ",
3201 iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
3202 O2S(objPtr));
3203 }
3204 for (i = 0; i < objc; i++) {
3205 if (i < opnd) {
3206 fprintf(stdout, "<");
3207 TclPrintObject(stdout, objv[i], 15);
3208 fprintf(stdout, ">");
3209 } else {
3210 TclPrintObject(stdout, objv[i], 15);
3211 }
3212 fprintf(stdout, " ");
3213 }
3214 fprintf(stdout, "\n");
3215 fflush(stdout);
3216 }
3217 #endif /*TCL_COMPILE_DEBUG*/
3218
3219 bcFramePtr->data.tebc.pc = (char *) pc;
3220 iPtr->cmdFramePtr = bcFramePtr;
3221 if (iPtr->flags & INTERP_DEBUG_FRAME) {
3222 ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
3223 }
3224
3225 TclInitRewriteEnsemble(interp, opnd, 1, objv);
3226
3227 {
3228 Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
3229
3230 Tcl_ListObjAppendElement(NULL, copyPtr, objPtr);
3231 Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
3232 objc - opnd, objv + opnd);
3233 Tcl_DecrRefCount(objPtr);
3234 objPtr = copyPtr;
3235 }
3236
3237 DECACHE_STACK_INFO();
3238 pc += 6;
3239 TEBC_YIELD();
3240
3241 TclMarkTailcall(interp);
3242 TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
3243 Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
3244 TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
3245 return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
3246
3247 /*
3248 * -----------------------------------------------------------------
3249 * Start of INST_LOAD instructions.
3250 *
3251 * WARNING: more 'goto' here than your doctor recommended! The different
3252 * instructions set the value of some variables and then jump to some
3253 * common execution code.
3254 */
3255
3256 case INST_LOAD_SCALAR1:
3257 instLoadScalar1:
3258 opnd = TclGetUInt1AtPtr(pc+1);
3259 varPtr = LOCAL(opnd);
3260 while (TclIsVarLink(varPtr)) {
3261 varPtr = varPtr->value.linkPtr;
3262 }
3263 TRACE(("%u => ", opnd));
3264 if (TclIsVarDirectReadable(varPtr)) {
3265 /*
3266 * No errors, no traces: just get the value.
3267 */
3268
3269 objResultPtr = varPtr->value.objPtr;
3270 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3271 NEXT_INST_F(2, 0, 1);
3272 }
3273 pcAdjustment = 2;
3274 cleanup = 0;
3275 arrayPtr = NULL;
3276 part1Ptr = part2Ptr = NULL;
3277 goto doCallPtrGetVar;
3278
3279 case INST_LOAD_SCALAR4:
3280 opnd = TclGetUInt4AtPtr(pc+1);
3281 varPtr = LOCAL(opnd);
3282 while (TclIsVarLink(varPtr)) {
3283 varPtr = varPtr->value.linkPtr;
3284 }
3285 TRACE(("%u => ", opnd));
3286 if (TclIsVarDirectReadable(varPtr)) {
3287 /*
3288 * No errors, no traces: just get the value.
3289 */
3290
3291 objResultPtr = varPtr->value.objPtr;
3292 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3293 NEXT_INST_F(5, 0, 1);
3294 }
3295 pcAdjustment = 5;
3296 cleanup = 0;
3297 arrayPtr = NULL;
3298 part1Ptr = part2Ptr = NULL;
3299 goto doCallPtrGetVar;
3300
3301 case INST_LOAD_ARRAY4:
3302 opnd = TclGetUInt4AtPtr(pc+1);
3303 pcAdjustment = 5;
3304 goto doLoadArray;
3305
3306 case INST_LOAD_ARRAY1:
3307 opnd = TclGetUInt1AtPtr(pc+1);
3308 pcAdjustment = 2;
3309
3310 doLoadArray:
3311 part1Ptr = NULL;
3312 part2Ptr = OBJ_AT_TOS;
3313 arrayPtr = LOCAL(opnd);
3314 while (TclIsVarLink(arrayPtr)) {
3315 arrayPtr = arrayPtr->value.linkPtr;
3316 }
3317 TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
3318 if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
3319 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
3320 if (varPtr && TclIsVarDirectReadable(varPtr)) {
3321 /*
3322 * No errors, no traces: just get the value.
3323 */
3324
3325 objResultPtr = varPtr->value.objPtr;
3326 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3327 NEXT_INST_F(pcAdjustment, 1, 1);
3328 }
3329 }
3330 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
3331 TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
3332 if (varPtr == NULL) {
3333 TRACE_ERROR(interp);
3334 goto gotError;
3335 }
3336 cleanup = 1;
3337 goto doCallPtrGetVar;
3338
3339 case INST_LOAD_ARRAY_STK:
3340 cleanup = 2;
3341 part2Ptr = OBJ_AT_TOS; /* element name */
3342 objPtr = OBJ_UNDER_TOS; /* array name */
3343 TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr)));
3344 goto doLoadStk;
3345
3346 case INST_LOAD_STK:
3347 case INST_LOAD_SCALAR_STK:
3348 cleanup = 1;
3349 part2Ptr = NULL;
3350 objPtr = OBJ_AT_TOS; /* variable name */
3351 TRACE(("\"%.30s\" => ", O2S(objPtr)));
3352
3353 doLoadStk:
3354 part1Ptr = objPtr;
3355 varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
3356 TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1,
3357 &arrayPtr);
3358 if (!varPtr) {
3359 TRACE_ERROR(interp);
3360 goto gotError;
3361 }
3362
3363 if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
3364 /*
3365 * No errors, no traces: just get the value.
3366 */
3367
3368 objResultPtr = varPtr->value.objPtr;
3369 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3370 NEXT_INST_V(1, cleanup, 1);
3371 }
3372 pcAdjustment = 1;
3373 opnd = -1;
3374
3375 doCallPtrGetVar:
3376 /*
3377 * There are either errors or the variable is traced: call
3378 * TclPtrGetVar to process fully.
3379 */
3380
3381 DECACHE_STACK_INFO();
3382 objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr,
3383 part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
3384 CACHE_STACK_INFO();
3385 if (!objResultPtr) {
3386 TRACE_ERROR(interp);
3387 goto gotError;
3388 }
3389 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3390 NEXT_INST_V(pcAdjustment, cleanup, 1);
3391
3392 /*
3393 * End of INST_LOAD instructions.
3394 * -----------------------------------------------------------------
3395 * Start of INST_STORE and related instructions.
3396 *
3397 * WARNING: more 'goto' here than your doctor recommended! The different
3398 * instructions set the value of some variables and then jump to somme
3399 * common execution code.
3400 */
3401
3402 {
3403 int storeFlags, len;
3404
3405 case INST_STORE_ARRAY4:
3406 opnd = TclGetUInt4AtPtr(pc+1);
3407 pcAdjustment = 5;
3408 goto doStoreArrayDirect;
3409
3410 case INST_STORE_ARRAY1:
3411 opnd = TclGetUInt1AtPtr(pc+1);
3412 pcAdjustment = 2;
3413
3414 doStoreArrayDirect:
3415 valuePtr = OBJ_AT_TOS;
3416 part2Ptr = OBJ_UNDER_TOS;
3417 arrayPtr = LOCAL(opnd);
3418 TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
3419 O2S(valuePtr)));
3420 while (TclIsVarLink(arrayPtr)) {
3421 arrayPtr = arrayPtr->value.linkPtr;
3422 }
3423 if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) {
3424 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
3425 if (varPtr && TclIsVarDirectWritable(varPtr)) {
3426 tosPtr--;
3427 Tcl_DecrRefCount(OBJ_AT_TOS);
3428 OBJ_AT_TOS = valuePtr;
3429 goto doStoreVarDirect;
3430 }
3431 }
3432 cleanup = 2;
3433 storeFlags = TCL_LEAVE_ERR_MSG;
3434 part1Ptr = NULL;
3435 goto doStoreArrayDirectFailed;
3436
3437 case INST_STORE_SCALAR4:
3438 opnd = TclGetUInt4AtPtr(pc+1);
3439 pcAdjustment = 5;
3440 goto doStoreScalarDirect;
3441
3442 case INST_STORE_SCALAR1:
3443 opnd = TclGetUInt1AtPtr(pc+1);
3444 pcAdjustment = 2;
3445
3446 doStoreScalarDirect:
3447 valuePtr = OBJ_AT_TOS;
3448 varPtr = LOCAL(opnd);
3449 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
3450 while (TclIsVarLink(varPtr)) {
3451 varPtr = varPtr->value.linkPtr;
3452 }
3453 if (!TclIsVarDirectWritable(varPtr)) {
3454 storeFlags = TCL_LEAVE_ERR_MSG;
3455 part1Ptr = NULL;
3456 goto doStoreScalar;
3457 }
3458
3459 /*
3460 * No traces, no errors, plain 'set': we can safely inline. The value
3461 * *will* be set to what's requested, so that the stack top remains
3462 * pointing to the same Tcl_Obj.
3463 */
3464
3465 doStoreVarDirect:
3466 valuePtr = varPtr->value.objPtr;
3467 if (valuePtr != NULL) {
3468 TclDecrRefCount(valuePtr);
3469 }
3470 objResultPtr = OBJ_AT_TOS;
3471 varPtr->value.objPtr = objResultPtr;
3472 #ifndef TCL_COMPILE_DEBUG
3473 if (*(pc+pcAdjustment) == INST_POP) {
3474 tosPtr--;
3475 NEXT_INST_F((pcAdjustment+1), 0, 0);
3476 }
3477 #else
3478 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3479 #endif
3480 Tcl_IncrRefCount(objResultPtr);
3481 NEXT_INST_F(pcAdjustment, 0, 0);
3482
3483 case INST_LAPPEND_STK:
3484 valuePtr = OBJ_AT_TOS; /* value to append */
3485 part2Ptr = NULL;
3486 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3487 | TCL_LIST_ELEMENT);
3488 goto doStoreStk;
3489
3490 case INST_LAPPEND_ARRAY_STK:
3491 valuePtr = OBJ_AT_TOS; /* value to append */
3492 part2Ptr = OBJ_UNDER_TOS;
3493 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3494 | TCL_LIST_ELEMENT);
3495 goto doStoreStk;
3496
3497 case INST_APPEND_STK:
3498 valuePtr = OBJ_AT_TOS; /* value to append */
3499 part2Ptr = NULL;
3500 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3501 goto doStoreStk;
3502
3503 case INST_APPEND_ARRAY_STK:
3504 valuePtr = OBJ_AT_TOS; /* value to append */
3505 part2Ptr = OBJ_UNDER_TOS;
3506 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3507 goto doStoreStk;
3508
3509 case INST_STORE_ARRAY_STK:
3510 valuePtr = OBJ_AT_TOS;
3511 part2Ptr = OBJ_UNDER_TOS;
3512 storeFlags = TCL_LEAVE_ERR_MSG;
3513 goto doStoreStk;
3514
3515 case INST_STORE_STK:
3516 case INST_STORE_SCALAR_STK:
3517 valuePtr = OBJ_AT_TOS;
3518 part2Ptr = NULL;
3519 storeFlags = TCL_LEAVE_ERR_MSG;
3520
3521 doStoreStk:
3522 objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */
3523 part1Ptr = objPtr;
3524 #ifdef TCL_COMPILE_DEBUG
3525 if (part2Ptr == NULL) {
3526 TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr)));
3527 } else {
3528 TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
3529 O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
3530 }
3531 #endif
3532 varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,
3533 "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
3534 if (!varPtr) {
3535 TRACE_ERROR(interp);
3536 goto gotError;
3537 }
3538 cleanup = ((part2Ptr == NULL)? 2 : 3);
3539 pcAdjustment = 1;
3540 opnd = -1;
3541 goto doCallPtrSetVar;
3542
3543 case INST_LAPPEND_ARRAY4:
3544 opnd = TclGetUInt4AtPtr(pc+1);
3545 pcAdjustment = 5;
3546 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3547 | TCL_LIST_ELEMENT);
3548 goto doStoreArray;
3549
3550 case INST_LAPPEND_ARRAY1:
3551 opnd = TclGetUInt1AtPtr(pc+1);
3552 pcAdjustment = 2;
3553 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3554 | TCL_LIST_ELEMENT);
3555 goto doStoreArray;
3556
3557 case INST_APPEND_ARRAY4:
3558 opnd = TclGetUInt4AtPtr(pc+1);
3559 pcAdjustment = 5;
3560 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3561 goto doStoreArray;
3562
3563 case INST_APPEND_ARRAY1:
3564 opnd = TclGetUInt1AtPtr(pc+1);
3565 pcAdjustment = 2;
3566 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3567 goto doStoreArray;
3568
3569 doStoreArray:
3570 valuePtr = OBJ_AT_TOS;
3571 part2Ptr = OBJ_UNDER_TOS;
3572 arrayPtr = LOCAL(opnd);
3573 TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
3574 O2S(valuePtr)));
3575 while (TclIsVarLink(arrayPtr)) {
3576 arrayPtr = arrayPtr->value.linkPtr;
3577 }
3578 cleanup = 2;
3579 part1Ptr = NULL;
3580
3581 doStoreArrayDirectFailed:
3582 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
3583 TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
3584 if (!varPtr) {
3585 TRACE_ERROR(interp);
3586 goto gotError;
3587 }
3588 goto doCallPtrSetVar;
3589
3590 case INST_LAPPEND_SCALAR4:
3591 opnd = TclGetUInt4AtPtr(pc+1);
3592 pcAdjustment = 5;
3593 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3594 | TCL_LIST_ELEMENT);
3595 goto doStoreScalar;
3596
3597 case INST_LAPPEND_SCALAR1:
3598 opnd = TclGetUInt1AtPtr(pc+1);
3599 pcAdjustment = 2;
3600 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3601 | TCL_LIST_ELEMENT);
3602 goto doStoreScalar;
3603
3604 case INST_APPEND_SCALAR4:
3605 opnd = TclGetUInt4AtPtr(pc+1);
3606 pcAdjustment = 5;
3607 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3608 goto doStoreScalar;
3609
3610 case INST_APPEND_SCALAR1:
3611 opnd = TclGetUInt1AtPtr(pc+1);
3612 pcAdjustment = 2;
3613 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3614 goto doStoreScalar;
3615
3616 doStoreScalar:
3617 valuePtr = OBJ_AT_TOS;
3618 varPtr = LOCAL(opnd);
3619 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
3620 while (TclIsVarLink(varPtr)) {
3621 varPtr = varPtr->value.linkPtr;
3622 }
3623 cleanup = 1;
3624 arrayPtr = NULL;
3625 part1Ptr = part2Ptr = NULL;
3626
3627 doCallPtrSetVar:
3628 DECACHE_STACK_INFO();
3629 objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr,
3630 part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
3631 CACHE_STACK_INFO();
3632 if (!objResultPtr) {
3633 TRACE_ERROR(interp);
3634 goto gotError;
3635 }
3636 #ifndef TCL_COMPILE_DEBUG
3637 if (*(pc+pcAdjustment) == INST_POP) {
3638 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
3639 }
3640 #endif
3641 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3642 NEXT_INST_V(pcAdjustment, cleanup, 1);
3643
3644 case INST_LAPPEND_LIST:
3645 opnd = TclGetUInt4AtPtr(pc+1);
3646 valuePtr = OBJ_AT_TOS;
3647 varPtr = LOCAL(opnd);
3648 cleanup = 1;
3649 pcAdjustment = 5;
3650 while (TclIsVarLink(varPtr)) {
3651 varPtr = varPtr->value.linkPtr;
3652 }
3653 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
3654 if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
3655 != TCL_OK) {
3656 TRACE_ERROR(interp);
3657 goto gotError;
3658 }
3659 if (TclIsVarDirectReadable(varPtr)
3660 && TclIsVarDirectWritable(varPtr)) {
3661 goto lappendListDirect;
3662 }
3663 arrayPtr = NULL;
3664 part1Ptr = part2Ptr = NULL;
3665 goto lappendListPtr;
3666
3667 case INST_LAPPEND_LIST_ARRAY:
3668 opnd = TclGetUInt4AtPtr(pc+1);
3669 valuePtr = OBJ_AT_TOS;
3670 part1Ptr = NULL;
3671 part2Ptr = OBJ_UNDER_TOS;
3672 arrayPtr = LOCAL(opnd);
3673 cleanup = 2;
3674 pcAdjustment = 5;
3675 while (TclIsVarLink(arrayPtr)) {
3676 arrayPtr = arrayPtr->value.linkPtr;
3677 }
3678 TRACE(("%u \"%.30s\" \"%.30s\" => ",
3679 opnd, O2S(part2Ptr), O2S(valuePtr)));
3680 if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
3681 != TCL_OK) {
3682 TRACE_ERROR(interp);
3683 goto gotError;
3684 }
3685 if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)
3686 && !WriteTraced(arrayPtr)) {
3687 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
3688 if (varPtr && TclIsVarDirectReadable(varPtr)
3689 && TclIsVarDirectWritable(varPtr)) {
3690 goto lappendListDirect;
3691 }
3692 }
3693 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
3694 TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
3695 if (varPtr == NULL) {
3696 TRACE_ERROR(interp);
3697 goto gotError;
3698 }
3699 goto lappendListPtr;
3700
3701 case INST_LAPPEND_LIST_ARRAY_STK:
3702 pcAdjustment = 1;
3703 cleanup = 3;
3704 valuePtr = OBJ_AT_TOS;
3705 part2Ptr = OBJ_UNDER_TOS; /* element name */
3706 part1Ptr = OBJ_AT_DEPTH(2); /* array name */
3707 TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ",
3708 O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
3709 goto lappendList;
3710
3711 case INST_LAPPEND_LIST_STK:
3712 pcAdjustment = 1;
3713 cleanup = 2;
3714 valuePtr = OBJ_AT_TOS;
3715 part2Ptr = NULL;
3716 part1Ptr = OBJ_UNDER_TOS; /* variable name */
3717 TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
3718 goto lappendList;
3719
3720 lappendListDirect:
3721 objResultPtr = varPtr->value.objPtr;
3722 if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
3723 TRACE_ERROR(interp);
3724 goto gotError;
3725 }
3726 if (Tcl_IsShared(objResultPtr)) {
3727 Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
3728
3729 TclDecrRefCount(objResultPtr);
3730 varPtr->value.objPtr = objResultPtr = newValue;
3731 Tcl_IncrRefCount(newValue);
3732 }
3733 if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
3734 != TCL_OK) {
3735 TRACE_ERROR(interp);
3736 goto gotError;
3737 }
3738 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3739 NEXT_INST_V(pcAdjustment, cleanup, 1);
3740
3741 lappendList:
3742 opnd = -1;
3743 if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
3744 != TCL_OK) {
3745 TRACE_ERROR(interp);
3746 goto gotError;
3747 }
3748 DECACHE_STACK_INFO();
3749 varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
3750 TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
3751 CACHE_STACK_INFO();
3752 if (!varPtr) {
3753 TRACE_ERROR(interp);
3754 goto gotError;
3755 }
3756
3757 lappendListPtr:
3758 if (TclIsVarInHash(varPtr)) {
3759 VarHashRefCount(varPtr)++;
3760 }
3761 if (arrayPtr && TclIsVarInHash(arrayPtr)) {
3762 VarHashRefCount(arrayPtr)++;
3763 }
3764 DECACHE_STACK_INFO();
3765 objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr,
3766 part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
3767 CACHE_STACK_INFO();
3768 if (TclIsVarInHash(varPtr)) {
3769 VarHashRefCount(varPtr)--;
3770 }
3771 if (arrayPtr && TclIsVarInHash(arrayPtr)) {
3772 VarHashRefCount(arrayPtr)--;
3773 }
3774
3775 {
3776 int createdNewObj = 0;
3777 Tcl_Obj *valueToAssign;
3778
3779 if (!objResultPtr) {
3780 valueToAssign = valuePtr;
3781 } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
3782 TRACE_ERROR(interp);
3783 goto gotError;
3784 } else {
3785 if (Tcl_IsShared(objResultPtr)) {
3786 valueToAssign = Tcl_DuplicateObj(objResultPtr);
3787 createdNewObj = 1;
3788 } else {
3789 valueToAssign = objResultPtr;
3790 }
3791 if (Tcl_ListObjReplace(interp, valueToAssign, len, 0,
3792 objc, objv) != TCL_OK) {
3793 if (createdNewObj) {
3794 TclDecrRefCount(valueToAssign);
3795 }
3796 goto errorInLappendListPtr;
3797 }
3798 }
3799 DECACHE_STACK_INFO();
3800 Tcl_IncrRefCount(valueToAssign);
3801 objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
3802 part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd);
3803 TclDecrRefCount(valueToAssign);
3804 CACHE_STACK_INFO();
3805 if (!objResultPtr) {
3806 errorInLappendListPtr:
3807 TRACE_ERROR(interp);
3808 goto gotError;
3809 }
3810 }
3811 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3812 NEXT_INST_V(pcAdjustment, cleanup, 1);
3813 }
3814
3815 /*
3816 * End of INST_STORE and related instructions.
3817 * -----------------------------------------------------------------
3818 * Start of INST_INCR instructions.
3819 *
3820 * WARNING: more 'goto' here than your doctor recommended! The different
3821 * instructions set the value of some variables and then jump to somme
3822 * common execution code.
3823 */
3824
3825 /*TODO: Consider more untangling here; merge with LOAD and STORE ? */
3826
3827 {
3828 Tcl_Obj *incrPtr;
3829 #ifndef TCL_WIDE_INT_IS_LONG
3830 Tcl_WideInt w;
3831 #endif
3832 long increment;
3833
3834 case INST_INCR_SCALAR1:
3835 case INST_INCR_ARRAY1:
3836 case INST_INCR_ARRAY_STK:
3837 case INST_INCR_SCALAR_STK:
3838 case INST_INCR_STK:
3839 opnd = TclGetUInt1AtPtr(pc+1);
3840 incrPtr = POP_OBJECT();
3841 switch (*pc) {
3842 case INST_INCR_SCALAR1:
3843 pcAdjustment = 2;
3844 goto doIncrScalar;
3845 case INST_INCR_ARRAY1:
3846 pcAdjustment = 2;
3847 goto doIncrArray;
3848 default:
3849 pcAdjustment = 1;
3850 goto doIncrStk;
3851 }
3852
3853 case INST_INCR_ARRAY_STK_IMM:
3854 case INST_INCR_SCALAR_STK_IMM:
3855 case INST_INCR_STK_IMM:
3856 increment = TclGetInt1AtPtr(pc+1);
3857 TclNewIntObj(incrPtr, increment);
3858 Tcl_IncrRefCount(incrPtr);
3859 pcAdjustment = 2;
3860
3861 doIncrStk:
3862 if ((*pc == INST_INCR_ARRAY_STK_IMM)
3863 || (*pc == INST_INCR_ARRAY_STK)) {
3864 part2Ptr = OBJ_AT_TOS;
3865 objPtr = OBJ_UNDER_TOS;
3866 TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
3867 O2S(objPtr), O2S(part2Ptr), increment));
3868 } else {
3869 part2Ptr = NULL;
3870 objPtr = OBJ_AT_TOS;
3871 TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment));
3872 }
3873 part1Ptr = objPtr;
3874 opnd = -1;
3875 varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
3876 TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
3877 if (!varPtr) {
3878 DECACHE_STACK_INFO();
3879 Tcl_AddErrorInfo(interp,
3880 "\n (reading value of variable to increment)");
3881 CACHE_STACK_INFO();
3882 TRACE_ERROR(interp);
3883 Tcl_DecrRefCount(incrPtr);
3884 goto gotError;
3885 }
3886 cleanup = ((part2Ptr == NULL)? 1 : 2);
3887 goto doIncrVar;
3888
3889 case INST_INCR_ARRAY1_IMM:
3890 opnd = TclGetUInt1AtPtr(pc+1);
3891 increment = TclGetInt1AtPtr(pc+2);
3892 TclNewIntObj(incrPtr, increment);
3893 Tcl_IncrRefCount(incrPtr);
3894 pcAdjustment = 3;
3895
3896 doIncrArray:
3897 part1Ptr = NULL;
3898 part2Ptr = OBJ_AT_TOS;
3899 arrayPtr = LOCAL(opnd);
3900 cleanup = 1;
3901 while (TclIsVarLink(arrayPtr)) {
3902 arrayPtr = arrayPtr->value.linkPtr;
3903 }
3904 TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment));
3905 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
3906 TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
3907 if (!varPtr) {
3908 TRACE_ERROR(interp);
3909 Tcl_DecrRefCount(incrPtr);
3910 goto gotError;
3911 }
3912 goto doIncrVar;
3913
3914 case INST_INCR_SCALAR1_IMM:
3915 opnd = TclGetUInt1AtPtr(pc+1);
3916 increment = TclGetInt1AtPtr(pc+2);
3917 pcAdjustment = 3;
3918 cleanup = 0;
3919 varPtr = LOCAL(opnd);
3920 while (TclIsVarLink(varPtr)) {
3921 varPtr = varPtr->value.linkPtr;
3922 }
3923
3924 if (TclIsVarDirectModifyable(varPtr)) {
3925 ClientData ptr;
3926 int type;
3927
3928 objPtr = varPtr->value.objPtr;
3929 if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
3930 if (type == TCL_NUMBER_LONG) {
3931 long augend = *((const long *)ptr);
3932 long sum = augend + increment;
3933
3934 /*
3935 * Overflow when (augend and sum have different sign) and
3936 * (augend and increment have the same sign). This is
3937 * encapsulated in the Overflowing macro.
3938 */
3939
3940 if (!Overflowing(augend, increment, sum)) {
3941 TRACE(("%u %ld => ", opnd, increment));
3942 if (Tcl_IsShared(objPtr)) {
3943 objPtr->refCount--; /* We know it's shared. */
3944 TclNewLongObj(objResultPtr, sum);
3945 Tcl_IncrRefCount(objResultPtr);
3946 varPtr->value.objPtr = objResultPtr;
3947 } else {
3948 objResultPtr = objPtr;
3949 TclSetLongObj(objPtr, sum);
3950 }
3951 goto doneIncr;
3952 }
3953 #ifndef TCL_WIDE_INT_IS_LONG
3954 w = (Tcl_WideInt)augend;
3955
3956 TRACE(("%u %ld => ", opnd, increment));
3957 if (Tcl_IsShared(objPtr)) {
3958 objPtr->refCount--; /* We know it's shared. */
3959 objResultPtr = Tcl_NewWideIntObj(w+increment);
3960 Tcl_IncrRefCount(objResultPtr);
3961 varPtr->value.objPtr = objResultPtr;
3962 } else {
3963 objResultPtr = objPtr;
3964
3965 /*
3966 * We know the sum value is outside the long range;
3967 * use macro form that doesn't range test again.
3968 */
3969
3970 TclSetWideIntObj(objPtr, w+increment);
3971 }
3972 goto doneIncr;
3973 #endif
3974 } /* end if (type == TCL_NUMBER_LONG) */
3975 #ifndef TCL_WIDE_INT_IS_LONG
3976 if (type == TCL_NUMBER_WIDE) {
3977 Tcl_WideInt sum;
3978
3979 w = *((const Tcl_WideInt *) ptr);
3980 sum = w + increment;
3981
3982 /*
3983 * Check for overflow.
3984 */
3985
3986 if (!Overflowing(w, increment, sum)) {
3987 TRACE(("%u %ld => ", opnd, increment));
3988 if (Tcl_IsShared(objPtr)) {
3989 objPtr->refCount--; /* We know it's shared. */
3990 objResultPtr = Tcl_NewWideIntObj(sum);
3991 Tcl_IncrRefCount(objResultPtr);
3992 varPtr->value.objPtr = objResultPtr;
3993 } else {
3994 objResultPtr = objPtr;
3995
3996 /*
3997 * We *do not* know the sum value is outside the
3998 * long range (wide + long can yield long); use
3999 * the function call that checks range.
4000 */
4001
4002 Tcl_SetWideIntObj(objPtr, sum);
4003 }
4004 goto doneIncr;
4005 }
4006 }
4007 #endif
4008 }
4009 if (Tcl_IsShared(objPtr)) {
4010 objPtr->refCount--; /* We know it's shared */
4011 objResultPtr = Tcl_DuplicateObj(objPtr);
4012 Tcl_IncrRefCount(objResultPtr);
4013 varPtr->value.objPtr = objResultPtr;
4014 } else {
4015 objResultPtr = objPtr;
4016 }
4017 TclNewLongObj(incrPtr, increment);
4018 if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
4019 Tcl_DecrRefCount(incrPtr);
4020 TRACE_ERROR(interp);
4021 goto gotError;
4022 }
4023 Tcl_DecrRefCount(incrPtr);
4024 goto doneIncr;
4025 }
4026
4027 /*
4028 * All other cases, flow through to generic handling.
4029 */
4030
4031 TclNewLongObj(incrPtr, increment);
4032 Tcl_IncrRefCount(incrPtr);
4033
4034 doIncrScalar:
4035 varPtr = LOCAL(opnd);
4036 while (TclIsVarLink(varPtr)) {
4037 varPtr = varPtr->value.linkPtr;
4038 }
4039 arrayPtr = NULL;
4040 part1Ptr = part2Ptr = NULL;
4041 cleanup = 0;
4042 TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
4043
4044 doIncrVar:
4045 if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
4046 objPtr = varPtr->value.objPtr;
4047 if (Tcl_IsShared(objPtr)) {
4048 objPtr->refCount--; /* We know it's shared */
4049 objResultPtr = Tcl_DuplicateObj(objPtr);
4050 Tcl_IncrRefCount(objResultPtr);
4051 varPtr->value.objPtr = objResultPtr;
4052 } else {
4053 objResultPtr = objPtr;
4054 }
4055 if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
4056 Tcl_DecrRefCount(incrPtr);
4057 TRACE_ERROR(interp);
4058 goto gotError;
4059 }
4060 Tcl_DecrRefCount(incrPtr);
4061 } else {
4062 DECACHE_STACK_INFO();
4063 objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr,
4064 part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
4065 CACHE_STACK_INFO();
4066 Tcl_DecrRefCount(incrPtr);
4067 if (objResultPtr == NULL) {
4068 TRACE_ERROR(interp);
4069 goto gotError;
4070 }
4071 }
4072 doneIncr:
4073 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
4074 #ifndef TCL_COMPILE_DEBUG
4075 if (*(pc+pcAdjustment) == INST_POP) {
4076 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
4077 }
4078 #endif
4079 NEXT_INST_V(pcAdjustment, cleanup, 1);
4080 }
4081
4082 /*
4083 * End of INST_INCR instructions.
4084 * -----------------------------------------------------------------
4085 * Start of INST_EXIST instructions.
4086 */
4087
4088 case INST_EXIST_SCALAR:
4089 cleanup = 0;
4090 pcAdjustment = 5;
4091 opnd = TclGetUInt4AtPtr(pc+1);
4092 varPtr = LOCAL(opnd);
4093 while (TclIsVarLink(varPtr)) {
4094 varPtr = varPtr->value.linkPtr;
4095 }
4096 TRACE(("%u => ", opnd));
4097 if (ReadTraced(varPtr)) {
4098 DECACHE_STACK_INFO();
4099 TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
4100 TCL_TRACE_READS, 0, opnd);
4101 CACHE_STACK_INFO();
4102 if (TclIsVarUndefined(varPtr)) {
4103 TclCleanupVar(varPtr, NULL);
4104 varPtr = NULL;
4105 }
4106 }
4107 goto afterExistsPeephole;
4108
4109 case INST_EXIST_ARRAY:
4110 cleanup = 1;
4111 pcAdjustment = 5;
4112 opnd = TclGetUInt4AtPtr(pc+1);
4113 part2Ptr = OBJ_AT_TOS;
4114 arrayPtr = LOCAL(opnd);
4115 while (TclIsVarLink(arrayPtr)) {
4116 arrayPtr = arrayPtr->value.linkPtr;
4117 }
4118 TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
4119 if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
4120 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
4121 if (!varPtr || !ReadTraced(varPtr)) {
4122 goto afterExistsPeephole;
4123 }
4124 }
4125 varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access",
4126 0, 1, arrayPtr, opnd);
4127 if (varPtr) {
4128 if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
4129 DECACHE_STACK_INFO();
4130 TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
4131 TCL_TRACE_READS, 0, opnd);
4132 CACHE_STACK_INFO();
4133 }
4134 if (TclIsVarUndefined(varPtr)) {
4135 TclCleanupVar(varPtr, arrayPtr);
4136 varPtr = NULL;
4137 }
4138 }
4139 goto afterExistsPeephole;
4140
4141 case INST_EXIST_ARRAY_STK:
4142 cleanup = 2;
4143 pcAdjustment = 1;
4144 part2Ptr = OBJ_AT_TOS; /* element name */
4145 part1Ptr = OBJ_UNDER_TOS; /* array name */
4146 TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr)));
4147 goto doExistStk;
4148
4149 case INST_EXIST_STK:
4150 cleanup = 1;
4151 pcAdjustment = 1;
4152 part2Ptr = NULL;
4153 part1Ptr = OBJ_AT_TOS; /* variable name */
4154 TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
4155
4156 doExistStk:
4157 varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
4158 /*createPart1*/0, /*createPart2*/1, &arrayPtr);
4159 if (varPtr) {
4160 if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
4161 DECACHE_STACK_INFO();
4162 TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr,
4163 TCL_TRACE_READS, 0, -1);
4164 CACHE_STACK_INFO();
4165 }
4166 if (TclIsVarUndefined(varPtr)) {
4167 TclCleanupVar(varPtr, arrayPtr);
4168 varPtr = NULL;
4169 }
4170 }
4171
4172 /*
4173 * Peep-hole optimisation: if you're about to jump, do jump from here.
4174 */
4175
4176 afterExistsPeephole: {
4177 int found = (varPtr && !TclIsVarUndefined(varPtr));
4178
4179 TRACE_APPEND(("%d\n", found ? 1 : 0));
4180 JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup);
4181 }
4182
4183 /*
4184 * End of INST_EXIST instructions.
4185 * -----------------------------------------------------------------
4186 * Start of INST_UNSET instructions.
4187 */
4188
4189 {
4190 int flags;
4191
4192 case INST_UNSET_SCALAR:
4193 flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
4194 opnd = TclGetUInt4AtPtr(pc+2);
4195 varPtr = LOCAL(opnd);
4196 while (TclIsVarLink(varPtr)) {
4197 varPtr = varPtr->value.linkPtr;
4198 }
4199 TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd));
4200 if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
4201 /*
4202 * No errors, no traces, no searches: just make the variable cease
4203 * to exist.
4204 */
4205
4206 if (!TclIsVarUndefined(varPtr)) {
4207 TclDecrRefCount(varPtr->value.objPtr);
4208 } else if (flags & TCL_LEAVE_ERR_MSG) {
4209 goto slowUnsetScalar;
4210 }
4211 varPtr->value.objPtr = NULL;
4212 TRACE_APPEND(("OK\n"));
4213 NEXT_INST_F(6, 0, 0);
4214 }
4215
4216 slowUnsetScalar:
4217 DECACHE_STACK_INFO();
4218 if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags,
4219 opnd) != TCL_OK && flags) {
4220 goto errorInUnset;
4221 }
4222 CACHE_STACK_INFO();
4223 NEXT_INST_F(6, 0, 0);
4224
4225 case INST_UNSET_ARRAY:
4226 flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
4227 opnd = TclGetUInt4AtPtr(pc+2);
4228 part2Ptr = OBJ_AT_TOS;
4229 arrayPtr = LOCAL(opnd);
4230 while (TclIsVarLink(arrayPtr)) {
4231 arrayPtr = arrayPtr->value.linkPtr;
4232 }
4233 TRACE(("%s %u \"%.30s\" => ",
4234 (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
4235 if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)
4236 && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) {
4237 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
4238 if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
4239 /*
4240 * No nasty traces and element exists, so we can proceed to
4241 * unset it. Might still not exist though...
4242 */
4243
4244 if (!TclIsVarUndefined(varPtr)) {
4245 TclDecrRefCount(varPtr->value.objPtr);
4246 TclSetVarUndefined(varPtr);
4247 TclClearVarNamespaceVar(varPtr);
4248 TclCleanupVar(varPtr, arrayPtr);
4249 } else if (flags & TCL_LEAVE_ERR_MSG) {
4250 goto slowUnsetArray;
4251 }
4252 TRACE_APPEND(("OK\n"));
4253 NEXT_INST_F(6, 1, 0);
4254 } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) {
4255 /*
4256 * Don't need to do anything here.
4257 */
4258
4259 TRACE_APPEND(("OK\n"));
4260 NEXT_INST_F(6, 1, 0);
4261 }
4262 }
4263 slowUnsetArray:
4264 DECACHE_STACK_INFO();
4265 varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset",
4266 0, 0, arrayPtr, opnd);
4267 if (!varPtr) {
4268 if (flags & TCL_LEAVE_ERR_MSG) {
4269 goto errorInUnset;
4270 }
4271 } else if (TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, NULL, part2Ptr,
4272 flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
4273 goto errorInUnset;
4274 }
4275 CACHE_STACK_INFO();
4276 NEXT_INST_F(6, 1, 0);
4277
4278 case INST_UNSET_ARRAY_STK:
4279 flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
4280 cleanup = 2;
4281 part2Ptr = OBJ_AT_TOS; /* element name */
4282 part1Ptr = OBJ_UNDER_TOS; /* array name */
4283 TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"),
4284 O2S(part1Ptr), O2S(part2Ptr)));
4285 goto doUnsetStk;
4286
4287 case INST_UNSET_STK:
4288 flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
4289 cleanup = 1;
4290 part2Ptr = NULL;
4291 part1Ptr = OBJ_AT_TOS; /* variable name */
4292 TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"),
4293 O2S(part1Ptr)));
4294
4295 doUnsetStk:
4296 DECACHE_STACK_INFO();
4297 if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK
4298 && (flags & TCL_LEAVE_ERR_MSG)) {
4299 goto errorInUnset;
4300 }
4301 CACHE_STACK_INFO();
4302 TRACE_APPEND(("OK\n"));
4303 NEXT_INST_V(2, cleanup, 0);
4304
4305 errorInUnset:
4306 CACHE_STACK_INFO();
4307 TRACE_ERROR(interp);
4308 goto gotError;
4309
4310 /*
4311 * This is really an unset operation these days. Do not issue.
4312 */
4313
4314 case INST_DICT_DONE:
4315 opnd = TclGetUInt4AtPtr(pc+1);
4316 TRACE(("%u => OK\n", opnd));
4317 varPtr = LOCAL(opnd);
4318 while (TclIsVarLink(varPtr)) {
4319 varPtr = varPtr->value.linkPtr;
4320 }
4321 if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
4322 if (!TclIsVarUndefined(varPtr)) {
4323 TclDecrRefCount(varPtr->value.objPtr);
4324 }
4325 varPtr->value.objPtr = NULL;
4326 } else {
4327 DECACHE_STACK_INFO();
4328 TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd);
4329 CACHE_STACK_INFO();
4330 }
4331 NEXT_INST_F(5, 0, 0);
4332 }
4333 break;
4334
4335 /*
4336 * End of INST_UNSET instructions.
4337 * -----------------------------------------------------------------
4338 * Start of INST_ARRAY instructions.
4339 */
4340
4341 case INST_ARRAY_EXISTS_IMM:
4342 opnd = TclGetUInt4AtPtr(pc+1);
4343 pcAdjustment = 5;
4344 cleanup = 0;
4345 part1Ptr = NULL;
4346 arrayPtr = NULL;
4347 TRACE(("%u => ", opnd));
4348 varPtr = LOCAL(opnd);
4349 while (TclIsVarLink(varPtr)) {
4350 varPtr = varPtr->value.linkPtr;
4351 }
4352 goto doArrayExists;
4353 case INST_ARRAY_EXISTS_STK:
4354 opnd = -1;
4355 pcAdjustment = 1;
4356 cleanup = 1;
4357 part1Ptr = OBJ_AT_TOS;
4358 TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
4359 varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
4360 /*createPart1*/0, /*createPart2*/0, &arrayPtr);
4361 doArrayExists:
4362 DECACHE_STACK_INFO();
4363 result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd);
4364 CACHE_STACK_INFO();
4365 if (result == TCL_ERROR) {
4366 TRACE_ERROR(interp);
4367 goto gotError;
4368 }
4369 if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
4370 objResultPtr = TCONST(1);
4371 } else {
4372 objResultPtr = TCONST(0);
4373 }
4374 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
4375 NEXT_INST_V(pcAdjustment, cleanup, 1);
4376
4377 case INST_ARRAY_MAKE_IMM:
4378 opnd = TclGetUInt4AtPtr(pc+1);
4379 pcAdjustment = 5;
4380 cleanup = 0;
4381 part1Ptr = NULL;
4382 arrayPtr = NULL;
4383 TRACE(("%u => ", opnd));
4384 varPtr = LOCAL(opnd);
4385 while (TclIsVarLink(varPtr)) {
4386 varPtr = varPtr->value.linkPtr;
4387 }
4388 goto doArrayMake;
4389 case INST_ARRAY_MAKE_STK:
4390 opnd = -1;
4391 pcAdjustment = 1;
4392 cleanup = 1;
4393 part1Ptr = OBJ_AT_TOS;
4394 TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
4395 varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
4396 "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
4397 if (varPtr == NULL) {
4398 TRACE_ERROR(interp);
4399 goto gotError;
4400 }
4401 doArrayMake:
4402 if (varPtr && !TclIsVarArray(varPtr)) {
4403 if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
4404 /*
4405 * Either an array element, or a scalar: lose!
4406 */
4407
4408 TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
4409 "variable isn't array", opnd);
4410 DECACHE_STACK_INFO();
4411 Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
4412 CACHE_STACK_INFO();
4413 TRACE_ERROR(interp);
4414 goto gotError;
4415 }
4416 TclSetVarArray(varPtr);
4417 varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
4418 TclInitVarHashTable(varPtr->value.tablePtr,
4419 TclGetVarNsPtr(varPtr));
4420 #ifdef TCL_COMPILE_DEBUG
4421 TRACE_APPEND(("done\n"));
4422 } else {
4423 TRACE_APPEND(("nothing to do\n"));
4424 #endif
4425 }
4426 NEXT_INST_V(pcAdjustment, cleanup, 0);
4427
4428 /*
4429 * End of INST_ARRAY instructions.
4430 * -----------------------------------------------------------------
4431 * Start of variable linking instructions.
4432 */
4433
4434 {
4435 Var *otherPtr;
4436 CallFrame *framePtr, *savedFramePtr;
4437 Tcl_Namespace *nsPtr;
4438 Namespace *savedNsPtr;
4439
4440 case INST_UPVAR:
4441 TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1),
4442 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
4443
4444 if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) {
4445 TRACE_ERROR(interp);
4446 goto gotError;
4447 }
4448
4449 /*
4450 * Locate the other variable.
4451 */
4452
4453 savedFramePtr = iPtr->varFramePtr;
4454 iPtr->varFramePtr = framePtr;
4455 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
4456 TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1,
4457 /*createPart2*/ 1, &varPtr);
4458 iPtr->varFramePtr = savedFramePtr;
4459 if (!otherPtr) {
4460 TRACE_ERROR(interp);
4461 goto gotError;
4462 }
4463 goto doLinkVars;
4464
4465 case INST_NSUPVAR:
4466 TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1),
4467 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
4468 if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) {
4469 TRACE_ERROR(interp);
4470 goto gotError;
4471 }
4472
4473 /*
4474 * Locate the other variable.
4475 */
4476
4477 savedNsPtr = iPtr->varFramePtr->nsPtr;
4478 iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
4479 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
4480 (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
4481 "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
4482 iPtr->varFramePtr->nsPtr = savedNsPtr;
4483 if (!otherPtr) {
4484 TRACE_ERROR(interp);
4485 goto gotError;
4486 }
4487 goto doLinkVars;
4488
4489 case INST_VARIABLE:
4490 TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS)));
4491 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
4492 (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
4493 /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
4494 if (!otherPtr) {
4495 TRACE_ERROR(interp);
4496 goto gotError;
4497 }
4498
4499 /*
4500 * Do the [variable] magic.
4501 */
4502
4503 TclSetVarNamespaceVar(otherPtr);
4504
4505 doLinkVars:
4506
4507 /*
4508 * If we are here, the local variable has already been created: do the
4509 * little work of TclPtrMakeUpvar that remains to be done right here
4510 * if there are no errors; otherwise, let it handle the case.
4511 */
4512
4513 opnd = TclGetInt4AtPtr(pc+1);
4514 varPtr = LOCAL(opnd);
4515 if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
4516 && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
4517 if (!TclIsVarUndefined(varPtr)) {
4518 /*
4519 * Then it is a defined link.
4520 */
4521
4522 Var *linkPtr = varPtr->value.linkPtr;
4523
4524 if (linkPtr == otherPtr) {
4525 TRACE_APPEND(("already linked\n"));
4526 NEXT_INST_F(5, 1, 0);
4527 }
4528 if (TclIsVarInHash(linkPtr)) {
4529 VarHashRefCount(linkPtr)--;
4530 if (TclIsVarUndefined(linkPtr)) {
4531 TclCleanupVar(linkPtr, NULL);
4532 }
4533 }
4534 }
4535 TclSetVarLink(varPtr);
4536 varPtr->value.linkPtr = otherPtr;
4537 if (TclIsVarInHash(otherPtr)) {
4538 VarHashRefCount(otherPtr)++;
4539 }
4540 } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0,
4541 opnd) != TCL_OK) {
4542 TRACE_ERROR(interp);
4543 goto gotError;
4544 }
4545
4546 /*
4547 * Do not pop the namespace or frame index, it may be needed for other
4548 * variables - and [variable] did not push it at all.
4549 */
4550
4551 TRACE_APPEND(("link made\n"));
4552 NEXT_INST_F(5, 1, 0);
4553 }
4554 break;
4555
4556 /*
4557 * End of variable linking instructions.
4558 * -----------------------------------------------------------------
4559 */
4560
4561 case INST_JUMP1:
4562 opnd = TclGetInt1AtPtr(pc+1);
4563 TRACE(("%d => new pc %u\n", opnd,
4564 (unsigned)(pc + opnd - codePtr->codeStart)));
4565 NEXT_INST_F(opnd, 0, 0);
4566 break;
4567
4568 case INST_JUMP4:
4569 opnd = TclGetInt4AtPtr(pc+1);
4570 TRACE(("%d => new pc %u\n", opnd,
4571 (unsigned)(pc + opnd - codePtr->codeStart)));
4572 NEXT_INST_F(opnd, 0, 0);
4573
4574 {
4575 int jmpOffset[2], b;
4576
4577 /* TODO: consider rewrite so we don't compute the offset we're not
4578 * going to take. */
4579 case INST_JUMP_FALSE4:
4580 jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
4581 jmpOffset[1] = 5; /* TRUE offset */
4582 goto doCondJump;
4583
4584 case INST_JUMP_TRUE4:
4585 jmpOffset[0] = 5;
4586 jmpOffset[1] = TclGetInt4AtPtr(pc+1);
4587 goto doCondJump;
4588
4589 case INST_JUMP_FALSE1:
4590 jmpOffset[0] = TclGetInt1AtPtr(pc+1);
4591 jmpOffset[1] = 2;
4592 goto doCondJump;
4593
4594 case INST_JUMP_TRUE1:
4595 jmpOffset[0] = 2;
4596 jmpOffset[1] = TclGetInt1AtPtr(pc+1);
4597
4598 doCondJump:
4599 valuePtr = OBJ_AT_TOS;
4600 TRACE(("%d => ", jmpOffset[
4601 (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1]));
4602
4603 /* TODO - check claim that taking address of b harms performance */
4604 /* TODO - consider optimization search for constants */
4605 if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) {
4606 TRACE_ERROR(interp);
4607 goto gotError;
4608 }
4609
4610 #ifdef TCL_COMPILE_DEBUG
4611 if (b) {
4612 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
4613 TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr),
4614 (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
4615 } else {
4616 TRACE_APPEND(("%.20s true\n", O2S(valuePtr)));
4617 }
4618 } else {
4619 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
4620 TRACE_APPEND(("%.20s false\n", O2S(valuePtr)));
4621 } else {
4622 TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
4623 (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
4624 }
4625 }
4626 #endif
4627 NEXT_INST_F(jmpOffset[b], 1, 0);
4628 }
4629 break;
4630
4631 case INST_JUMP_TABLE: {
4632 Tcl_HashEntry *hPtr;
4633 JumptableInfo *jtPtr;
4634
4635 /*
4636 * Jump to location looked up in a hashtable; fall through to next
4637 * instr if lookup fails.
4638 */
4639
4640 opnd = TclGetInt4AtPtr(pc+1);
4641 jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
4642 TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS)));
4643 hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS));
4644 if (hPtr != NULL) {
4645 int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
4646
4647 TRACE_APPEND(("found in table, new pc %u\n",
4648 (unsigned)(pc - codePtr->codeStart + jumpOffset)));
4649 NEXT_INST_F(jumpOffset, 1, 0);
4650 } else {
4651 TRACE_APPEND(("not found in table\n"));
4652 NEXT_INST_F(5, 1, 0);
4653 }
4654 }
4655 break;
4656
4657 /*
4658 * These two instructions are now redundant: the complete logic of the LOR
4659 * and LAND is now handled by the expression compiler.
4660 */
4661
4662 case INST_LOR:
4663 case INST_LAND: {
4664 /*
4665 * Operands must be boolean or numeric. No int->double conversions are
4666 * performed.
4667 */
4668
4669 int i1, i2, iResult;
4670
4671 value2Ptr = OBJ_AT_TOS;
4672 valuePtr = OBJ_UNDER_TOS;
4673 if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
4674 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
4675 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
4676 DECACHE_STACK_INFO();
4677 IllegalExprOperandType(interp, pc, valuePtr);
4678 CACHE_STACK_INFO();
4679 goto gotError;
4680 }
4681
4682 if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
4683 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
4684 (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
4685 DECACHE_STACK_INFO();
4686 IllegalExprOperandType(interp, pc, value2Ptr);
4687 CACHE_STACK_INFO();
4688 goto gotError;
4689 }
4690
4691 if (*pc == INST_LOR) {
4692 iResult = (i1 || i2);
4693 } else {
4694 iResult = (i1 && i2);
4695 }
4696 objResultPtr = TCONST(iResult);
4697 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
4698 NEXT_INST_F(1, 2, 1);
4699 }
4700 break;
4701
4702 /*
4703 * -----------------------------------------------------------------
4704 * Start of general introspector instructions.
4705 */
4706
4707 case INST_NS_CURRENT: {
4708 Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
4709
4710 if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
4711 TclNewLiteralStringObj(objResultPtr, "::");
4712 } else {
4713 TclNewStringObj(objResultPtr, currNsPtr->fullName,
4714 strlen(currNsPtr->fullName));
4715 }
4716 TRACE_WITH_OBJ(("=> "), objResultPtr);
4717 NEXT_INST_F(1, 0, 1);
4718 }
4719 break;
4720 case INST_COROUTINE_NAME: {
4721 CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
4722
4723 TclNewObj(objResultPtr);
4724 if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
4725 Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
4726 objResultPtr);
4727 }
4728 TRACE_WITH_OBJ(("=> "), objResultPtr);
4729 NEXT_INST_F(1, 0, 1);
4730 }
4731 break;
4732 case INST_INFO_LEVEL_NUM:
4733 TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
4734 TRACE_WITH_OBJ(("=> "), objResultPtr);
4735 NEXT_INST_F(1, 0, 1);
4736 break;
4737 case INST_INFO_LEVEL_ARGS: {
4738 int level;
4739 CallFrame *framePtr = iPtr->varFramePtr;
4740 CallFrame *rootFramePtr = iPtr->rootFramePtr;
4741
4742 TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
4743 if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
4744 TRACE_ERROR(interp);
4745 goto gotError;
4746 }
4747 if (level <= 0) {
4748 level += framePtr->level;
4749 }
4750 for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
4751 framePtr = framePtr->callerVarPtr) {
4752 /* Empty loop body */
4753 }
4754 if (framePtr == rootFramePtr) {
4755 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4756 "bad level \"%s\"", TclGetString(OBJ_AT_TOS)));
4757 TRACE_ERROR(interp);
4758 DECACHE_STACK_INFO();
4759 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
4760 TclGetString(OBJ_AT_TOS), NULL);
4761 CACHE_STACK_INFO();
4762 goto gotError;
4763 }
4764 objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
4765 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
4766 NEXT_INST_F(1, 1, 1);
4767 }
4768 {
4769 Tcl_Command cmd, origCmd;
4770
4771 case INST_RESOLVE_COMMAND:
4772 cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
4773 TclNewObj(objResultPtr);
4774 if (cmd != NULL) {
4775 Tcl_GetCommandFullName(interp, cmd, objResultPtr);
4776 }
4777 TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
4778 NEXT_INST_F(1, 1, 1);
4779
4780 case INST_ORIGIN_COMMAND:
4781 TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
4782 cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
4783 if (cmd == NULL) {
4784 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4785 "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
4786 DECACHE_STACK_INFO();
4787 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
4788 TclGetString(OBJ_AT_TOS), NULL);
4789 CACHE_STACK_INFO();
4790 TRACE_APPEND(("ERROR: not command\n"));
4791 goto gotError;
4792 }
4793 origCmd = TclGetOriginalCommand(cmd);
4794 if (origCmd == NULL) {
4795 origCmd = cmd;
4796 }
4797 TclNewObj(objResultPtr);
4798 Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
4799 TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
4800 NEXT_INST_F(1, 1, 1);
4801 }
4802
4803 /*
4804 * -----------------------------------------------------------------
4805 * Start of TclOO support instructions.
4806 */
4807
4808 {
4809 Object *oPtr;
4810 CallFrame *framePtr;
4811 CallContext *contextPtr;
4812 int skip, newDepth;
4813
4814 case INST_TCLOO_SELF:
4815 framePtr = iPtr->varFramePtr;
4816 if (framePtr == NULL ||
4817 !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
4818 TRACE(("=> ERROR: no TclOO call context\n"));
4819 Tcl_SetObjResult(interp, Tcl_NewStringObj(
4820 "self may only be called from inside a method",
4821 -1));
4822 DECACHE_STACK_INFO();
4823 Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
4824 CACHE_STACK_INFO();
4825 goto gotError;
4826 }
4827 contextPtr = framePtr->clientData;
4828
4829 /*
4830 * Call out to get the name; it's expensive to compute but cached.
4831 */
4832
4833 objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
4834 TRACE_WITH_OBJ(("=> "), objResultPtr);
4835 NEXT_INST_F(1, 0, 1);
4836
4837 case INST_TCLOO_NEXT_CLASS:
4838 opnd = TclGetUInt1AtPtr(pc+1);
4839 framePtr = iPtr->varFramePtr;
4840 valuePtr = OBJ_AT_DEPTH(opnd - 2);
4841 objv = &OBJ_AT_DEPTH(opnd - 1);
4842 skip = 2;
4843 TRACE(("%d => ", opnd));
4844 if (framePtr == NULL ||
4845 !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
4846 TRACE_APPEND(("ERROR: no TclOO call context\n"));
4847 Tcl_SetObjResult(interp, Tcl_NewStringObj(
4848 "nextto may only be called from inside a method",
4849 -1));
4850 DECACHE_STACK_INFO();
4851 Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
4852 CACHE_STACK_INFO();
4853 goto gotError;
4854 }
4855 contextPtr = framePtr->clientData;
4856
4857 oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
4858 if (oPtr == NULL) {
4859 TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
4860 goto gotError;
4861 } else {
4862 Class *classPtr = oPtr->classPtr;
4863 struct MInvoke *miPtr;
4864 int i;
4865 const char *methodType;
4866
4867 if (classPtr == NULL) {
4868 TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
4869 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4870 "\"%s\" is not a class", TclGetString(valuePtr)));
4871 DECACHE_STACK_INFO();
4872 Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
4873 CACHE_STACK_INFO();
4874 goto gotError;
4875 }
4876
4877 for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
4878 miPtr = contextPtr->callPtr->chain + i;
4879 if (!miPtr->isFilter &&
4880 miPtr->mPtr->declaringClassPtr == classPtr) {
4881 newDepth = i;
4882 #ifdef TCL_COMPILE_DEBUG
4883 if (tclTraceExec >= 2) {
4884 if (traceInstructions) {
4885 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
4886 } else {
4887 fprintf(stdout, "%d: (%u) invoking ",
4888 iPtr->numLevels,
4889 (unsigned)(pc - codePtr->codeStart));
4890 }
4891 for (i = 0; i < opnd; i++) {
4892 TclPrintObject(stdout, objv[i], 15);
4893 fprintf(stdout, " ");
4894 }
4895 fprintf(stdout, "\n");
4896 fflush(stdout);
4897 }
4898 #endif /*TCL_COMPILE_DEBUG*/
4899 goto doInvokeNext;
4900 }
4901 }
4902
4903 if (contextPtr->callPtr->flags & CONSTRUCTOR) {
4904 methodType = "constructor";
4905 } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
4906 methodType = "destructor";
4907 } else {
4908 methodType = "method";
4909 }
4910
4911 TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
4912 O2S(valuePtr)));
4913 for (i=contextPtr->index ; i>=0 ; i--) {
4914 miPtr = contextPtr->callPtr->chain + i;
4915 if (miPtr->isFilter
4916 || miPtr->mPtr->declaringClassPtr != classPtr) {
4917 continue;
4918 }
4919 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4920 "%s implementation by \"%s\" not reachable from here",
4921 methodType, TclGetString(valuePtr)));
4922 DECACHE_STACK_INFO();
4923 Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
4924 NULL);
4925 CACHE_STACK_INFO();
4926 goto gotError;
4927 }
4928 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4929 "%s has no non-filter implementation by \"%s\"",
4930 methodType, TclGetString(valuePtr)));
4931 DECACHE_STACK_INFO();
4932 Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
4933 CACHE_STACK_INFO();
4934 goto gotError;
4935 }
4936
4937 case INST_TCLOO_NEXT:
4938 opnd = TclGetUInt1AtPtr(pc+1);
4939 objv = &OBJ_AT_DEPTH(opnd - 1);
4940 framePtr = iPtr->varFramePtr;
4941 skip = 1;
4942 TRACE(("%d => ", opnd));
4943 if (framePtr == NULL ||
4944 !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
4945 TRACE_APPEND(("ERROR: no TclOO call context\n"));
4946 Tcl_SetObjResult(interp, Tcl_NewStringObj(
4947 "next may only be called from inside a method",
4948 -1));
4949 DECACHE_STACK_INFO();
4950 Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
4951 CACHE_STACK_INFO();
4952 goto gotError;
4953 }
4954 contextPtr = framePtr->clientData;
4955
4956 newDepth = contextPtr->index + 1;
4957 if (newDepth >= contextPtr->callPtr->numChain) {
4958 /*
4959 * We're at the end of the chain; generate an error message unless
4960 * the interpreter is being torn down, in which case we might be
4961 * getting here because of methods/destructors doing a [next] (or
4962 * equivalent) unexpectedly.
4963 */
4964
4965 const char *methodType;
4966
4967 if (contextPtr->callPtr->flags & CONSTRUCTOR) {
4968 methodType = "constructor";
4969 } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
4970 methodType = "destructor";
4971 } else {
4972 methodType = "method";
4973 }
4974
4975 TRACE_APPEND(("ERROR: no TclOO next impl\n"));
4976 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
4977 "no next %s implementation", methodType));
4978 DECACHE_STACK_INFO();
4979 Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
4980 CACHE_STACK_INFO();
4981 goto gotError;
4982 #ifdef TCL_COMPILE_DEBUG
4983 } else if (tclTraceExec >= 2) {
4984 int i;
4985
4986 if (traceInstructions) {
4987 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
4988 } else {
4989 fprintf(stdout, "%d: (%u) invoking ",
4990 iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
4991 }
4992 for (i = 0; i < opnd; i++) {
4993 TclPrintObject(stdout, objv[i], 15);
4994 fprintf(stdout, " ");
4995 }
4996 fprintf(stdout, "\n");
4997 fflush(stdout);
4998 #endif /*TCL_COMPILE_DEBUG*/
4999 }
5000
5001 doInvokeNext:
5002 bcFramePtr->data.tebc.pc = (char *) pc;
5003 iPtr->cmdFramePtr = bcFramePtr;
5004
5005 if (iPtr->flags & INTERP_DEBUG_FRAME) {
5006 ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
5007 }
5008
5009 pcAdjustment = 2;
5010 cleanup = opnd;
5011 DECACHE_STACK_INFO();
5012 iPtr->varFramePtr = framePtr->callerVarPtr;
5013 pc += pcAdjustment;
5014 TEBC_YIELD();
5015
5016 TclPushTailcallPoint(interp);
5017 oPtr = contextPtr->oPtr;
5018 if (oPtr->flags & FILTER_HANDLING) {
5019 TclNRAddCallback(interp, FinalizeOONextFilter,
5020 framePtr, contextPtr, INT2PTR(contextPtr->index),
5021 INT2PTR(contextPtr->skip));
5022 } else {
5023 TclNRAddCallback(interp, FinalizeOONext,
5024 framePtr, contextPtr, INT2PTR(contextPtr->index),
5025 INT2PTR(contextPtr->skip));
5026 }
5027 contextPtr->skip = skip;
5028 contextPtr->index = newDepth;
5029 if (contextPtr->callPtr->chain[newDepth].isFilter
5030 || contextPtr->callPtr->flags & FILTER_HANDLING) {
5031 oPtr->flags |= FILTER_HANDLING;
5032 } else {
5033 oPtr->flags &= ~FILTER_HANDLING;
5034 }
5035
5036 {
5037 Method *const mPtr =
5038 contextPtr->callPtr->chain[newDepth].mPtr;
5039
5040 return mPtr->typePtr->callProc(mPtr->clientData, interp,
5041 (Tcl_ObjectContext) contextPtr, opnd, objv);
5042 }
5043
5044 case INST_TCLOO_IS_OBJECT:
5045 oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
5046 objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
5047 TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
5048 NEXT_INST_F(1, 1, 1);
5049 case INST_TCLOO_CLASS:
5050 oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
5051 if (oPtr == NULL) {
5052 TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
5053 goto gotError;
5054 }
5055 objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr);
5056 TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
5057 NEXT_INST_F(1, 1, 1);
5058 case INST_TCLOO_NS:
5059 oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
5060 if (oPtr == NULL) {
5061 TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
5062 goto gotError;
5063 }
5064
5065 /*
5066 * TclOO objects *never* have the global namespace as their NS.
5067 */
5068
5069 TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName,
5070 strlen(oPtr->namespacePtr->fullName));
5071 TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
5072 NEXT_INST_F(1, 1, 1);
5073 }
5074
5075 /*
5076 * End of TclOO support instructions.
5077 * -----------------------------------------------------------------
5078 * Start of INST_LIST and related instructions.
5079 */
5080
5081 {
5082 int index, numIndices, fromIdx, toIdx;
5083 int nocase, match, length2, cflags, s1len, s2len;
5084 const char *s1, *s2;
5085
5086 case INST_LIST:
5087 /*
5088 * Pop the opnd (objc) top stack elements into a new list obj and then
5089 * decrement their ref counts.
5090 */
5091
5092 opnd = TclGetUInt4AtPtr(pc+1);
5093 objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
5094 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
5095 NEXT_INST_V(5, opnd, 1);
5096
5097 case INST_LIST_LENGTH:
5098 TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
5099 if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) {
5100 TRACE_ERROR(interp);
5101 goto gotError;
5102 }
5103 TclNewIntObj(objResultPtr, length);
5104 TRACE_APPEND(("%d\n", length));
5105 NEXT_INST_F(1, 1, 1);
5106
5107 case INST_LIST_INDEX: /* lindex with objc == 3 */
5108 value2Ptr = OBJ_AT_TOS;
5109 valuePtr = OBJ_UNDER_TOS;
5110 TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
5111
5112 /*
5113 * Extract the desired list element.
5114 */
5115
5116 if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
5117 && (value2Ptr->typePtr != &tclListType)
5118 && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
5119 &index) == TCL_OK)) {
5120 TclDecrRefCount(value2Ptr);
5121 tosPtr--;
5122 pcAdjustment = 1;
5123 goto lindexFastPath;
5124 }
5125
5126 objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
5127 if (!objResultPtr) {
5128 TRACE_ERROR(interp);
5129 goto gotError;
5130 }
5131
5132 /*
5133 * Stash the list element on the stack.
5134 */
5135
5136 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5137 NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
5138
5139 case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode
5140 * stream */
5141
5142 /*
5143 * Pop the list and get the index.
5144 */
5145
5146 valuePtr = OBJ_AT_TOS;
5147 opnd = TclGetInt4AtPtr(pc+1);
5148 TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
5149
5150 /*
5151 * Get the contents of the list, making sure that it really is a list
5152 * in the process.
5153 */
5154
5155 if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
5156 TRACE_ERROR(interp);
5157 goto gotError;
5158 }
5159
5160 /* Decode end-offset index values. */
5161
5162 index = TclIndexDecode(opnd, objc - 1);
5163 pcAdjustment = 5;
5164
5165 lindexFastPath:
5166 if (index >= 0 && index < objc) {
5167 objResultPtr = objv[index];
5168 } else {
5169 TclNewObj(objResultPtr);
5170 }
5171
5172 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5173 NEXT_INST_F(pcAdjustment, 1, 1);
5174
5175 case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */
5176 /*
5177 * Determine the count of index args.
5178 */
5179
5180 opnd = TclGetUInt4AtPtr(pc+1);
5181 numIndices = opnd-1;
5182
5183 /*
5184 * Do the 'lindex' operation.
5185 */
5186
5187 TRACE(("%d => ", opnd));
5188 objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices),
5189 numIndices, &OBJ_AT_DEPTH(numIndices - 1));
5190 if (!objResultPtr) {
5191 TRACE_ERROR(interp);
5192 goto gotError;
5193 }
5194
5195 /*
5196 * Set result.
5197 */
5198
5199 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5200 NEXT_INST_V(5, opnd, -1);
5201
5202 case INST_LSET_FLAT:
5203 /*
5204 * Lset with 3, 5, or more args. Get the number of index args.
5205 */
5206
5207 opnd = TclGetUInt4AtPtr(pc + 1);
5208 numIndices = opnd - 2;
5209 TRACE(("%d => ", opnd));
5210
5211 /*
5212 * Get the old value of variable, and remove the stack ref. This is
5213 * safe because the variable still references the object; the ref
5214 * count will never go zero here - we can use the smaller macro
5215 * Tcl_DecrRefCount.
5216 */
5217
5218 valuePtr = POP_OBJECT();
5219 Tcl_DecrRefCount(valuePtr); /* This one should be done here */
5220
5221 /*
5222 * Compute the new variable value.
5223 */
5224
5225 objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
5226 &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
5227 if (!objResultPtr) {
5228 TRACE_ERROR(interp);
5229 goto gotError;
5230 }
5231
5232 /*
5233 * Set result.
5234 */
5235
5236 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5237 NEXT_INST_V(5, numIndices+1, -1);
5238
5239 case INST_LSET_LIST: /* 'lset' with 4 args */
5240 /*
5241 * Get the old value of variable, and remove the stack ref. This is
5242 * safe because the variable still references the object; the ref
5243 * count will never go zero here - we can use the smaller macro
5244 * Tcl_DecrRefCount.
5245 */
5246
5247 objPtr = POP_OBJECT();
5248 Tcl_DecrRefCount(objPtr); /* This one should be done here. */
5249
5250 /*
5251 * Get the new element value, and the index list.
5252 */
5253
5254 valuePtr = OBJ_AT_TOS;
5255 value2Ptr = OBJ_UNDER_TOS;
5256 TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
5257 O2S(value2Ptr), O2S(valuePtr), O2S(objPtr)));
5258
5259 /*
5260 * Compute the new variable value.
5261 */
5262
5263 objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
5264 if (!objResultPtr) {
5265 TRACE_ERROR(interp);
5266 goto gotError;
5267 }
5268
5269 /*
5270 * Set result.
5271 */
5272
5273 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5274 NEXT_INST_F(1, 2, -1);
5275
5276 case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
5277 * bytecode stream */
5278
5279 /*
5280 * Pop the list and get the indices.
5281 */
5282
5283 valuePtr = OBJ_AT_TOS;
5284 fromIdx = TclGetInt4AtPtr(pc+1);
5285 toIdx = TclGetInt4AtPtr(pc+5);
5286 TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
5287 TclGetInt4AtPtr(pc+5)));
5288
5289 /*
5290 * Get the contents of the list, making sure that it really is a list
5291 * in the process.
5292 */
5293
5294 if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
5295 TRACE_ERROR(interp);
5296 goto gotError;
5297 }
5298
5299 /*
5300 * Skip a lot of work if we're about to throw the result away (common
5301 * with uses of [lassign]).
5302 */
5303
5304 #ifndef TCL_COMPILE_DEBUG
5305 if (*(pc+9) == INST_POP) {
5306 NEXT_INST_F(10, 1, 0);
5307 }
5308 #endif
5309
5310 /* Every range of an empty list is an empty list */
5311 if (objc == 0) {
5312 /* avoid return of not canonical list (e. g. spaces in string repr.) */
5313 if (!valuePtr->bytes || !valuePtr->length) {
5314 TRACE_APPEND(("\n"));
5315 NEXT_INST_F(9, 0, 0);
5316 }
5317 goto emptyList;
5318 }
5319
5320 /* Decode index value operands. */
5321
5322 /*
5323 assert ( toIdx != TCL_INDEX_AFTER);
5324 *
5325 * Extra safety for legacy bytecodes:
5326 */
5327 if (toIdx == TCL_INDEX_AFTER) {
5328 toIdx = TCL_INDEX_END;
5329 }
5330
5331 if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
5332 goto emptyList;
5333 }
5334 toIdx = TclIndexDecode(toIdx, objc - 1);
5335 if (toIdx < 0) {
5336 goto emptyList;
5337 } else if (toIdx >= objc) {
5338 toIdx = objc - 1;
5339 }
5340
5341 assert ( toIdx >= 0 && toIdx < objc);
5342 /*
5343 assert ( fromIdx != TCL_INDEX_BEFORE );
5344 *
5345 * Extra safety for legacy bytecodes:
5346 */
5347 if (fromIdx == TCL_INDEX_BEFORE) {
5348 fromIdx = TCL_INDEX_START;
5349 }
5350
5351 fromIdx = TclIndexDecode(fromIdx, objc - 1);
5352 if (fromIdx < 0) {
5353 fromIdx = 0;
5354 }
5355
5356 if (fromIdx <= toIdx) {
5357 /* Construct the subsquence list */
5358 /* unshared optimization */
5359 if (Tcl_IsShared(valuePtr)) {
5360 objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
5361 } else {
5362 if (toIdx != objc - 1) {
5363 Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
5364 0, NULL);
5365 }
5366 Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
5367 TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
5368 NEXT_INST_F(9, 0, 0);
5369 }
5370 } else {
5371 emptyList:
5372 TclNewObj(objResultPtr);
5373 }
5374
5375 TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
5376 NEXT_INST_F(9, 1, 1);
5377
5378 case INST_LIST_IN:
5379 case INST_LIST_NOT_IN: /* Basic list containment operators. */
5380 value2Ptr = OBJ_AT_TOS;
5381 valuePtr = OBJ_UNDER_TOS;
5382
5383 s1 = TclGetStringFromObj(valuePtr, &s1len);
5384 TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
5385 if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
5386 TRACE_ERROR(interp);
5387 goto gotError;
5388 }
5389 match = 0;
5390 if (length > 0) {
5391 int i = 0;
5392 Tcl_Obj *o;
5393
5394 /*
5395 * An empty list doesn't match anything.
5396 */
5397
5398 do {
5399 Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
5400 if (o != NULL) {
5401 s2 = TclGetStringFromObj(o, &s2len);
5402 } else {
5403 s2 = "";
5404 s2len = 0;
5405 }
5406 if (s1len == s2len) {
5407 match = (memcmp(s1, s2, s1len) == 0);
5408 }
5409 i++;
5410 } while (i < length && match == 0);
5411 }
5412
5413 if (*pc == INST_LIST_NOT_IN) {
5414 match = !match;
5415 }
5416
5417 TRACE_APPEND(("%d\n", match));
5418
5419 /*
5420 * Peep-hole optimisation: if you're about to jump, do jump from here.
5421 * We're saving the effort of pushing a boolean value only to pop it
5422 * for branching.
5423 */
5424
5425 JUMP_PEEPHOLE_F(match, 1, 2);
5426
5427 case INST_LIST_CONCAT:
5428 value2Ptr = OBJ_AT_TOS;
5429 valuePtr = OBJ_UNDER_TOS;
5430 TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
5431 if (Tcl_IsShared(valuePtr)) {
5432 objResultPtr = Tcl_DuplicateObj(valuePtr);
5433 if (Tcl_ListObjAppendList(interp, objResultPtr,
5434 value2Ptr) != TCL_OK) {
5435 TRACE_ERROR(interp);
5436 TclDecrRefCount(objResultPtr);
5437 goto gotError;
5438 }
5439 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5440 NEXT_INST_F(1, 2, 1);
5441 } else {
5442 if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){
5443 TRACE_ERROR(interp);
5444 goto gotError;
5445 }
5446 TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
5447 NEXT_INST_F(1, 1, 0);
5448 }
5449
5450 /*
5451 * End of INST_LIST and related instructions.
5452 * -----------------------------------------------------------------
5453 * Start of string-related instructions.
5454 */
5455
5456 case INST_STR_EQ:
5457 case INST_STR_NEQ: /* String (in)equality check */
5458 case INST_STR_CMP: /* String compare. */
5459 stringCompare:
5460 value2Ptr = OBJ_AT_TOS;
5461 valuePtr = OBJ_UNDER_TOS;
5462
5463 {
5464 int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
5465 || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
5466 match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1);
5467 }
5468
5469 /*
5470 * Make sure only -1,0,1 is returned
5471 * TODO: consider peephole opt.
5472 */
5473
5474 if (*pc != INST_STR_CMP) {
5475 /*
5476 * Take care of the opcodes that goto'ed into here.
5477 */
5478
5479 switch (*pc) {
5480 case INST_STR_EQ:
5481 case INST_EQ:
5482 match = (match == 0);
5483 break;
5484 case INST_STR_NEQ:
5485 case INST_NEQ:
5486 match = (match != 0);
5487 break;
5488 case INST_LT:
5489 match = (match < 0);
5490 break;
5491 case INST_GT:
5492 match = (match > 0);
5493 break;
5494 case INST_LE:
5495 match = (match <= 0);
5496 break;
5497 case INST_GE:
5498 match = (match >= 0);
5499 break;
5500 }
5501 }
5502
5503 TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
5504 (match < 0 ? -1 : match > 0 ? 1 : 0)));
5505 JUMP_PEEPHOLE_F(match, 1, 2);
5506
5507 case INST_STR_LEN:
5508 valuePtr = OBJ_AT_TOS;
5509 length = Tcl_GetCharLength(valuePtr);
5510 TclNewIntObj(objResultPtr, length);
5511 TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
5512 NEXT_INST_F(1, 1, 1);
5513
5514 case INST_STR_UPPER:
5515 valuePtr = OBJ_AT_TOS;
5516 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
5517 if (Tcl_IsShared(valuePtr)) {
5518 s1 = TclGetStringFromObj(valuePtr, &length);
5519 TclNewStringObj(objResultPtr, s1, length);
5520 length = Tcl_UtfToUpper(TclGetString(objResultPtr));
5521 Tcl_SetObjLength(objResultPtr, length);
5522 TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
5523 NEXT_INST_F(1, 1, 1);
5524 } else {
5525 length = Tcl_UtfToUpper(TclGetString(valuePtr));
5526 Tcl_SetObjLength(valuePtr, length);
5527 TclFreeIntRep(valuePtr);
5528 TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
5529 NEXT_INST_F(1, 0, 0);
5530 }
5531 case INST_STR_LOWER:
5532 valuePtr = OBJ_AT_TOS;
5533 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
5534 if (Tcl_IsShared(valuePtr)) {
5535 s1 = TclGetStringFromObj(valuePtr, &length);
5536 TclNewStringObj(objResultPtr, s1, length);
5537 length = Tcl_UtfToLower(TclGetString(objResultPtr));
5538 Tcl_SetObjLength(objResultPtr, length);
5539 TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
5540 NEXT_INST_F(1, 1, 1);
5541 } else {
5542 length = Tcl_UtfToLower(TclGetString(valuePtr));
5543 Tcl_SetObjLength(valuePtr, length);
5544 TclFreeIntRep(valuePtr);
5545 TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
5546 NEXT_INST_F(1, 0, 0);
5547 }
5548 case INST_STR_TITLE:
5549 valuePtr = OBJ_AT_TOS;
5550 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
5551 if (Tcl_IsShared(valuePtr)) {
5552 s1 = TclGetStringFromObj(valuePtr, &length);
5553 TclNewStringObj(objResultPtr, s1, length);
5554 length = Tcl_UtfToTitle(TclGetString(objResultPtr));
5555 Tcl_SetObjLength(objResultPtr, length);
5556 TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
5557 NEXT_INST_F(1, 1, 1);
5558 } else {
5559 length = Tcl_UtfToTitle(TclGetString(valuePtr));
5560 Tcl_SetObjLength(valuePtr, length);
5561 TclFreeIntRep(valuePtr);
5562 TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
5563 NEXT_INST_F(1, 0, 0);
5564 }
5565
5566 case INST_STR_INDEX:
5567 value2Ptr = OBJ_AT_TOS;
5568 valuePtr = OBJ_UNDER_TOS;
5569 TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
5570
5571 /*
5572 * Get char length to calulate what 'end' means.
5573 */
5574
5575 length = Tcl_GetCharLength(valuePtr);
5576 if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
5577 TRACE_ERROR(interp);
5578 goto gotError;
5579 }
5580
5581 if ((index < 0) || (index >= length)) {
5582 TclNewObj(objResultPtr);
5583 } else if (TclIsPureByteArray(valuePtr)) {
5584 objResultPtr = Tcl_NewByteArrayObj(
5585 Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
5586 } else if (valuePtr->bytes && length == valuePtr->length) {
5587 objResultPtr = Tcl_NewStringObj((const char *)
5588 valuePtr->bytes+index, 1);
5589 } else {
5590 char buf[8] = "";
5591 int ch = TclGetUCS4(valuePtr, index);
5592
5593 length = TclUCS4ToUtf(ch, buf);
5594 objResultPtr = Tcl_NewStringObj(buf, length);
5595 }
5596
5597 TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
5598 NEXT_INST_F(1, 2, 1);
5599
5600 case INST_STR_RANGE:
5601 TRACE(("\"%.20s\" %.20s %.20s =>",
5602 O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
5603 length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
5604 if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
5605 &fromIdx) != TCL_OK
5606 || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
5607 &toIdx) != TCL_OK) {
5608 TRACE_ERROR(interp);
5609 goto gotError;
5610 }
5611
5612 if (fromIdx < 0) {
5613 fromIdx = 0;
5614 }
5615 if (toIdx >= length) {
5616 toIdx = length;
5617 }
5618 if (toIdx >= fromIdx) {
5619 objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
5620 } else {
5621 TclNewObj(objResultPtr);
5622 }
5623 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5624 NEXT_INST_V(1, 3, 1);
5625
5626 case INST_STR_RANGE_IMM:
5627 valuePtr = OBJ_AT_TOS;
5628 fromIdx = TclGetInt4AtPtr(pc+1);
5629 toIdx = TclGetInt4AtPtr(pc+5);
5630 length = Tcl_GetCharLength(valuePtr);
5631 TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
5632
5633 /* Every range of an empty value is an empty value */
5634 if (length == 0) {
5635 TRACE_APPEND(("\n"));
5636 NEXT_INST_F(9, 0, 0);
5637 }
5638
5639 /* Decode index operands. */
5640
5641 /*
5642 assert ( toIdx != TCL_INDEX_BEFORE );
5643 assert ( toIdx != TCL_INDEX_AFTER);
5644 *
5645 * Extra safety for legacy bytecodes:
5646 */
5647 if (toIdx == TCL_INDEX_BEFORE) {
5648 goto emptyRange;
5649 }
5650 if (toIdx == TCL_INDEX_AFTER) {
5651 toIdx = TCL_INDEX_END;
5652 }
5653
5654 toIdx = TclIndexDecode(toIdx, length - 1);
5655 if (toIdx < 0) {
5656 goto emptyRange;
5657 } else if (toIdx >= length) {
5658 toIdx = length - 1;
5659 }
5660
5661 assert ( toIdx >= 0 && toIdx < length );
5662
5663 /*
5664 assert ( fromIdx != TCL_INDEX_BEFORE );
5665 assert ( fromIdx != TCL_INDEX_AFTER);
5666 *
5667 * Extra safety for legacy bytecodes:
5668 */
5669 if (fromIdx == TCL_INDEX_BEFORE) {
5670 fromIdx = TCL_INDEX_START;
5671 }
5672 if (fromIdx == TCL_INDEX_AFTER) {
5673 goto emptyRange;
5674 }
5675
5676 fromIdx = TclIndexDecode(fromIdx, length - 1);
5677 if (fromIdx < 0) {
5678 fromIdx = 0;
5679 }
5680
5681 if (fromIdx <= toIdx) {
5682 objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
5683 } else {
5684 emptyRange:
5685 TclNewObj(objResultPtr);
5686 }
5687 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
5688 NEXT_INST_F(9, 1, 1);
5689
5690 {
5691 Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
5692 int length3, endIdx;
5693 Tcl_Obj *value3Ptr;
5694
5695 case INST_STR_REPLACE:
5696 value3Ptr = POP_OBJECT();
5697 valuePtr = OBJ_AT_DEPTH(2);
5698 endIdx = Tcl_GetCharLength(valuePtr) - 1;
5699 TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
5700 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
5701 if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
5702 &fromIdx) != TCL_OK
5703 || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
5704 &toIdx) != TCL_OK) {
5705 TclDecrRefCount(value3Ptr);
5706 TRACE_ERROR(interp);
5707 goto gotError;
5708 }
5709 TclDecrRefCount(OBJ_AT_TOS);
5710 (void) POP_OBJECT();
5711 TclDecrRefCount(OBJ_AT_TOS);
5712 (void) POP_OBJECT();
5713
5714 if ((toIdx < 0) ||
5715 (fromIdx > endIdx) ||
5716 (toIdx < fromIdx)) {
5717 TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
5718 TclDecrRefCount(value3Ptr);
5719 NEXT_INST_F(1, 0, 0);
5720 }
5721
5722 if (fromIdx < 0) {
5723 fromIdx = 0;
5724 }
5725
5726 if (toIdx > endIdx) {
5727 toIdx = endIdx;
5728 }
5729
5730 if (fromIdx == 0 && toIdx == endIdx) {
5731 TclDecrRefCount(OBJ_AT_TOS);
5732 OBJ_AT_TOS = value3Ptr;
5733 TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
5734 NEXT_INST_F(1, 0, 0);
5735 }
5736
5737 length3 = Tcl_GetCharLength(value3Ptr);
5738
5739 /*
5740 * See if we can splice in place. This happens when the number of
5741 * characters being replaced is the same as the number of characters
5742 * in the string to be inserted.
5743 */
5744
5745 if (length3 - 1 == toIdx - fromIdx) {
5746 unsigned char *bytes1, *bytes2;
5747
5748 if (Tcl_IsShared(valuePtr)) {
5749 objResultPtr = Tcl_DuplicateObj(valuePtr);
5750 } else {
5751 objResultPtr = valuePtr;
5752 }
5753 if (TclIsPureByteArray(objResultPtr)
5754 && TclIsPureByteArray(value3Ptr)) {
5755 bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
5756 bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
5757 memcpy(bytes1 + fromIdx, bytes2, length3);
5758 } else {
5759 ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
5760 ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
5761 memcpy(ustring1 + fromIdx, ustring2,
5762 length3 * sizeof(Tcl_UniChar));
5763 }
5764 Tcl_InvalidateStringRep(objResultPtr);
5765 TclDecrRefCount(value3Ptr);
5766 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5767 if (objResultPtr == valuePtr) {
5768 NEXT_INST_F(1, 0, 0);
5769 } else {
5770 NEXT_INST_F(1, 1, 1);
5771 }
5772 }
5773
5774 /*
5775 * Get the unicode representation; this is where we guarantee to lose
5776 * bytearrays.
5777 */
5778
5779 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
5780 length--;
5781
5782 /*
5783 * Remove substring using copying.
5784 */
5785
5786 objResultPtr = NULL;
5787 if (fromIdx > 0) {
5788 objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
5789 }
5790 if (length3 > 0) {
5791 if (objResultPtr) {
5792 Tcl_AppendObjToObj(objResultPtr, value3Ptr);
5793 } else if (Tcl_IsShared(value3Ptr)) {
5794 objResultPtr = Tcl_DuplicateObj(value3Ptr);
5795 } else {
5796 objResultPtr = value3Ptr;
5797 }
5798 }
5799 if (toIdx < length) {
5800 if (objResultPtr) {
5801 Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
5802 length - toIdx);
5803 } else {
5804 objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
5805 length - toIdx);
5806 }
5807 }
5808 if (objResultPtr == NULL) {
5809 /* This has to be the case [string replace $s 0 end {}] */
5810 /* which has result {} which is same as value3Ptr. */
5811 objResultPtr = value3Ptr;
5812 }
5813 if (objResultPtr == value3Ptr) {
5814 /* See [Bug 82e7f67325] */
5815 TclDecrRefCount(OBJ_AT_TOS);
5816 OBJ_AT_TOS = value3Ptr;
5817 TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
5818 NEXT_INST_F(1, 0, 0);
5819 }
5820 TclDecrRefCount(value3Ptr);
5821 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
5822 NEXT_INST_F(1, 1, 1);
5823
5824 case INST_STR_MAP:
5825 valuePtr = OBJ_AT_TOS; /* "Main" string. */
5826 value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */
5827 value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */
5828 if (value3Ptr == value2Ptr) {
5829 objResultPtr = valuePtr;
5830 goto doneStringMap;
5831 } else if (valuePtr == value2Ptr) {
5832 objResultPtr = value3Ptr;
5833 goto doneStringMap;
5834 }
5835 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
5836 if (length == 0) {
5837 objResultPtr = valuePtr;
5838 goto doneStringMap;
5839 }
5840 ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
5841 if (length2 > length || length2 == 0) {
5842 objResultPtr = valuePtr;
5843 goto doneStringMap;
5844 } else if (length2 == length) {
5845 if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
5846 objResultPtr = valuePtr;
5847 } else {
5848 objResultPtr = value3Ptr;
5849 }
5850 goto doneStringMap;
5851 }
5852 ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
5853
5854 objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
5855 p = ustring1;
5856 end = ustring1 + length;
5857 for (; ustring1 < end; ustring1++) {
5858 if ((*ustring1 == *ustring2) && (length2==1 ||
5859 memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
5860 == 0)) {
5861 if (p != ustring1) {
5862 Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
5863 p = ustring1 + length2;
5864 } else {
5865 p += length2;
5866 }
5867 ustring1 = p - 1;
5868
5869 Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
5870 }
5871 }
5872 if (p != ustring1) {
5873 /*
5874 * Put the rest of the unmapped chars onto result.
5875 */
5876
5877 Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
5878 }
5879 doneStringMap:
5880 TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
5881 O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
5882 NEXT_INST_V(1, 3, 1);
5883
5884 case INST_STR_FIND:
5885 ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
5886 ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
5887
5888 match = -1;
5889 if (length2 > 0 && length2 <= length) {
5890 end = ustring1 + length - length2 + 1;
5891 for (p=ustring1 ; p<end ; p++) {
5892 if ((*p == *ustring2) &&
5893 memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
5894 match = p - ustring1;
5895 break;
5896 }
5897 }
5898 }
5899
5900 TRACE(("%.20s %.20s => %d\n",
5901 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
5902 TclNewIntObj(objResultPtr, match);
5903 NEXT_INST_F(1, 2, 1);
5904
5905 case INST_STR_FIND_LAST:
5906 ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
5907 ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
5908
5909 match = -1;
5910 if (length2 > 0 && length2 <= length) {
5911 for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
5912 if ((*p == *ustring2) &&
5913 memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
5914 match = p - ustring1;
5915 break;
5916 }
5917 }
5918 }
5919
5920 TRACE(("%.20s %.20s => %d\n",
5921 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
5922
5923 TclNewIntObj(objResultPtr, match);
5924 NEXT_INST_F(1, 2, 1);
5925
5926 case INST_STR_CLASS:
5927 opnd = TclGetInt1AtPtr(pc+1);
5928 valuePtr = OBJ_AT_TOS;
5929 TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
5930 O2S(valuePtr)));
5931 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
5932 match = 1;
5933 if (length > 0) {
5934 int ch;
5935 end = ustring1 + length;
5936 for (p=ustring1 ; p<end ; ) {
5937 p += TclUniCharToUCS4(p, &ch);
5938 if (!tclStringClassTable[opnd].comparator(ch)) {
5939 match = 0;
5940 break;
5941 }
5942 }
5943 }
5944 TRACE_APPEND(("%d\n", match));
5945 JUMP_PEEPHOLE_F(match, 2, 1);
5946 }
5947
5948 case INST_STR_MATCH:
5949 nocase = TclGetInt1AtPtr(pc+1);
5950 valuePtr = OBJ_AT_TOS; /* String */
5951 value2Ptr = OBJ_UNDER_TOS; /* Pattern */
5952
5953 /*
5954 * Check that at least one of the objects is Unicode before promoting
5955 * both.
5956 */
5957
5958 if ((valuePtr->typePtr == &tclStringType)
5959 || (value2Ptr->typePtr == &tclStringType)) {
5960 Tcl_UniChar *ustring1, *ustring2;
5961
5962 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
5963 ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
5964 match = TclUniCharMatch(ustring1, length, ustring2, length2,
5965 nocase);
5966 } else if (TclIsPureByteArray(valuePtr) && !nocase) {
5967 unsigned char *bytes1, *bytes2;
5968
5969 bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length);
5970 bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
5971 match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0);
5972 } else {
5973 match = Tcl_StringCaseMatch(TclGetString(valuePtr),
5974 TclGetString(value2Ptr), nocase);
5975 }
5976
5977 /*
5978 * Reuse value2Ptr object already on stack if possible. Adjustment is
5979 * 2 due to the nocase byte
5980 */
5981
5982 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
5983
5984 /*
5985 * Peep-hole optimisation: if you're about to jump, do jump from here.
5986 */
5987
5988 JUMP_PEEPHOLE_F(match, 2, 2);
5989
5990 {
5991 const char *string1, *string2;
5992 int trim1, trim2;
5993
5994 case INST_STR_TRIM_LEFT:
5995 valuePtr = OBJ_UNDER_TOS; /* String */
5996 value2Ptr = OBJ_AT_TOS; /* TrimSet */
5997 string2 = TclGetStringFromObj(value2Ptr, &length2);
5998 string1 = TclGetStringFromObj(valuePtr, &length);
5999 trim1 = TclTrimLeft(string1, length, string2, length2);
6000 trim2 = 0;
6001 goto createTrimmedString;
6002 case INST_STR_TRIM_RIGHT:
6003 valuePtr = OBJ_UNDER_TOS; /* String */
6004 value2Ptr = OBJ_AT_TOS; /* TrimSet */
6005 string2 = TclGetStringFromObj(value2Ptr, &length2);
6006 string1 = TclGetStringFromObj(valuePtr, &length);
6007 trim2 = TclTrimRight(string1, length, string2, length2);
6008 trim1 = 0;
6009 goto createTrimmedString;
6010 case INST_STR_TRIM:
6011 valuePtr = OBJ_UNDER_TOS; /* String */
6012 value2Ptr = OBJ_AT_TOS; /* TrimSet */
6013 string2 = TclGetStringFromObj(value2Ptr, &length2);
6014 string1 = TclGetStringFromObj(valuePtr, &length);
6015 trim1 = TclTrim(string1, length, string2, length2, &trim2);
6016 createTrimmedString:
6017 /*
6018 * Careful here; trim set often contains non-ASCII characters so we
6019 * take care when printing. [Bug 971cb4f1db]
6020 */
6021
6022 #ifdef TCL_COMPILE_DEBUG
6023 if (traceInstructions) {
6024 TRACE(("\"%.30s\" ", O2S(valuePtr)));
6025 TclPrintObject(stdout, value2Ptr, 30);
6026 printf(" => ");
6027 }
6028 #endif
6029 if (trim1 == 0 && trim2 == 0) {
6030 #ifdef TCL_COMPILE_DEBUG
6031 if (traceInstructions) {
6032 TclPrintObject(stdout, valuePtr, 30);
6033 printf("\n");
6034 }
6035 #endif
6036 NEXT_INST_F(1, 1, 0);
6037 } else {
6038 objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2);
6039 #ifdef TCL_COMPILE_DEBUG
6040 if (traceInstructions) {
6041 TclPrintObject(stdout, objResultPtr, 30);
6042 printf("\n");
6043 }
6044 #endif
6045 NEXT_INST_F(1, 2, 1);
6046 }
6047 }
6048
6049 case INST_REGEXP:
6050 cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
6051 valuePtr = OBJ_AT_TOS; /* String */
6052 value2Ptr = OBJ_UNDER_TOS; /* Pattern */
6053 TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
6054
6055 /*
6056 * Compile and match the regular expression.
6057 */
6058
6059 {
6060 Tcl_RegExp regExpr =
6061 Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
6062
6063 if (regExpr == NULL) {
6064 TRACE_ERROR(interp);
6065 goto gotError;
6066 }
6067 match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
6068 if (match < 0) {
6069 TRACE_ERROR(interp);
6070 goto gotError;
6071 }
6072 }
6073
6074 TRACE_APPEND(("%d\n", match));
6075
6076 /*
6077 * Peep-hole optimisation: if you're about to jump, do jump from here.
6078 * Adjustment is 2 due to the nocase byte.
6079 */
6080
6081 JUMP_PEEPHOLE_F(match, 2, 2);
6082 }
6083
6084 /*
6085 * End of string-related instructions.
6086 * -----------------------------------------------------------------
6087 * Start of numeric operator instructions.
6088 */
6089
6090 {
6091 ClientData ptr1, ptr2;
6092 int type1, type2;
6093 long l1 = 0, l2, lResult;
6094
6095 case INST_NUM_TYPE:
6096 if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
6097 type1 = 0;
6098 } else if (type1 == TCL_NUMBER_LONG) {
6099 /* value is between LONG_MIN and LONG_MAX */
6100 /* [string is integer] is -UINT_MAX to UINT_MAX range */
6101 int i;
6102
6103 if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) {
6104 type1 = TCL_NUMBER_WIDE;
6105 }
6106 #ifndef TCL_WIDE_INT_IS_LONG
6107 } else if (type1 == TCL_NUMBER_WIDE) {
6108 /* value is between WIDE_MIN and WIDE_MAX */
6109 /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
6110 int i;
6111 if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
6112 type1 = TCL_NUMBER_LONG;
6113 }
6114 #endif
6115 } else if (type1 == TCL_NUMBER_BIG) {
6116 /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
6117 /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
6118 Tcl_WideInt w;
6119
6120 if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
6121 type1 = TCL_NUMBER_WIDE;
6122 }
6123 }
6124 TclNewIntObj(objResultPtr, type1);
6125 TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
6126 NEXT_INST_F(1, 1, 1);
6127
6128 case INST_EQ:
6129 case INST_NEQ:
6130 case INST_LT:
6131 case INST_GT:
6132 case INST_LE:
6133 case INST_GE: {
6134 int iResult = 0, compare = 0;
6135
6136 value2Ptr = OBJ_AT_TOS;
6137 valuePtr = OBJ_UNDER_TOS;
6138
6139 /*
6140 Try to determine, without triggering generation of a string
6141 representation, whether one value is not a number.
6142 */
6143 if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) {
6144 goto stringCompare;
6145 }
6146
6147 if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
6148 || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
6149 /*
6150 * At least one non-numeric argument - compare as strings.
6151 */
6152
6153 goto stringCompare;
6154 }
6155 if (type1 == TCL_NUMBER_NAN || type2 == TCL_NUMBER_NAN) {
6156 /*
6157 * NaN arg: NaN != to everything, other compares are false.
6158 */
6159
6160 iResult = (*pc == INST_NEQ);
6161 goto foundResult;
6162 }
6163 if (valuePtr == value2Ptr) {
6164 compare = MP_EQ;
6165 goto convertComparison;
6166 }
6167 if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
6168 l1 = *((const long *)ptr1);
6169 l2 = *((const long *)ptr2);
6170 compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
6171 } else {
6172 compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
6173 }
6174
6175 /*
6176 * Turn comparison outcome into appropriate result for opcode.
6177 */
6178
6179 convertComparison:
6180 switch (*pc) {
6181 case INST_EQ:
6182 iResult = (compare == MP_EQ);
6183 break;
6184 case INST_NEQ:
6185 iResult = (compare != MP_EQ);
6186 break;
6187 case INST_LT:
6188 iResult = (compare == MP_LT);
6189 break;
6190 case INST_GT:
6191 iResult = (compare == MP_GT);
6192 break;
6193 case INST_LE:
6194 iResult = (compare != MP_GT);
6195 break;
6196 case INST_GE:
6197 iResult = (compare != MP_LT);
6198 break;
6199 }
6200
6201 /*
6202 * Peep-hole optimisation: if you're about to jump, do jump from here.
6203 */
6204
6205 foundResult:
6206 TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
6207 iResult));
6208 JUMP_PEEPHOLE_F(iResult, 1, 2);
6209 }
6210
6211 case INST_MOD:
6212 case INST_LSHIFT:
6213 case INST_RSHIFT:
6214 case INST_BITOR:
6215 case INST_BITXOR:
6216 case INST_BITAND:
6217 value2Ptr = OBJ_AT_TOS;
6218 valuePtr = OBJ_UNDER_TOS;
6219
6220 if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
6221 || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) {
6222 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
6223 O2S(value2Ptr), (valuePtr->typePtr?
6224 valuePtr->typePtr->name : "null")));
6225 DECACHE_STACK_INFO();
6226 IllegalExprOperandType(interp, pc, valuePtr);
6227 CACHE_STACK_INFO();
6228 goto gotError;
6229 }
6230
6231 if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
6232 || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) {
6233 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
6234 O2S(value2Ptr), (value2Ptr->typePtr?
6235 value2Ptr->typePtr->name : "null")));
6236 DECACHE_STACK_INFO();
6237 IllegalExprOperandType(interp, pc, value2Ptr);
6238 CACHE_STACK_INFO();
6239 goto gotError;
6240 }
6241
6242 /*
6243 * Check for common, simple case.
6244 */
6245
6246 if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
6247 l1 = *((const long *)ptr1);
6248 l2 = *((const long *)ptr2);
6249
6250 switch (*pc) {
6251 case INST_MOD:
6252 if (l2 == 0) {
6253 TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
6254 O2S(value2Ptr)));
6255 goto divideByZero;
6256 } else if ((l2 == 1) || (l2 == -1)) {
6257 /*
6258 * Div. by |1| always yields remainder of 0.
6259 */
6260
6261 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6262 objResultPtr = TCONST(0);
6263 TRACE(("%s\n", O2S(objResultPtr)));
6264 NEXT_INST_F(1, 2, 1);
6265 } else if (l1 == 0) {
6266 /*
6267 * 0 % (non-zero) always yields remainder of 0.
6268 */
6269
6270 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6271 objResultPtr = TCONST(0);
6272 TRACE(("%s\n", O2S(objResultPtr)));
6273 NEXT_INST_F(1, 2, 1);
6274 } else {
6275 lResult = l1 / l2;
6276
6277 /*
6278 * Force Tcl's integer division rules.
6279 * TODO: examine for logic simplification
6280 */
6281
6282 if ((lResult < 0 || (lResult == 0 &&
6283 ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
6284 (lResult * l2 != l1)) {
6285 lResult -= 1;
6286 }
6287 lResult = l1 - l2*lResult;
6288 goto longResultOfArithmetic;
6289 }
6290 break;
6291
6292 case INST_RSHIFT:
6293 if (l2 < 0) {
6294 Tcl_SetObjResult(interp, Tcl_NewStringObj(
6295 "negative shift argument", -1));
6296 #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
6297 DECACHE_STACK_INFO();
6298 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
6299 "domain error: argument not in valid range",
6300 NULL);
6301 CACHE_STACK_INFO();
6302 #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
6303 goto gotError;
6304 } else if (l1 == 0) {
6305 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6306 objResultPtr = TCONST(0);
6307 TRACE(("%s\n", O2S(objResultPtr)));
6308 NEXT_INST_F(1, 2, 1);
6309 } else {
6310 /*
6311 * Quickly force large right shifts to 0 or -1.
6312 */
6313
6314 if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
6315 /*
6316 * We assume that INT_MAX is much larger than the
6317 * number of bits in a long. This is a pretty safe
6318 * assumption, given that the former is usually around
6319 * 4e9 and the latter 32 or 64...
6320 */
6321
6322 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6323 if (l1 > 0L) {
6324 objResultPtr = TCONST(0);
6325 } else {
6326 TclNewIntObj(objResultPtr, -1);
6327 }
6328 TRACE(("%s\n", O2S(objResultPtr)));
6329 NEXT_INST_F(1, 2, 1);
6330 }
6331
6332 /*
6333 * Handle shifts within the native long range.
6334 */
6335
6336 lResult = l1 >> ((int) l2);
6337 goto longResultOfArithmetic;
6338 }
6339 break;
6340
6341 case INST_LSHIFT:
6342 if (l2 < 0) {
6343 Tcl_SetObjResult(interp, Tcl_NewStringObj(
6344 "negative shift argument", -1));
6345 #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
6346 DECACHE_STACK_INFO();
6347 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
6348 "domain error: argument not in valid range",
6349 NULL);
6350 CACHE_STACK_INFO();
6351 #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
6352 goto gotError;
6353 } else if (l1 == 0) {
6354 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6355 objResultPtr = TCONST(0);
6356 TRACE(("%s\n", O2S(objResultPtr)));
6357 NEXT_INST_F(1, 2, 1);
6358 } else if (l2 > (long) INT_MAX) {
6359 /*
6360 * Technically, we could hold the value (1 << (INT_MAX+1))
6361 * in an mp_int, but since we're using mp_mul_2d() to do
6362 * the work, and it takes only an int argument, that's a
6363 * good place to draw the line.
6364 */
6365
6366 Tcl_SetObjResult(interp, Tcl_NewStringObj(
6367 "integer value too large to represent", -1));
6368 #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
6369 DECACHE_STACK_INFO();
6370 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
6371 "integer value too large to represent", NULL);
6372 CACHE_STACK_INFO();
6373 #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
6374 goto gotError;
6375 } else {
6376 int shift = (int) l2;
6377
6378 /*
6379 * Handle shifts within the native long range.
6380 */
6381
6382 if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0)
6383 && !((l1>0 ? l1 : ~l1) &
6384 -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
6385 lResult = l1 << shift;
6386 goto longResultOfArithmetic;
6387 }
6388 }
6389
6390 /*
6391 * Too large; need to use the broken-out function.
6392 */
6393
6394 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6395 break;
6396
6397 case INST_BITAND:
6398 lResult = l1 & l2;
6399 goto longResultOfArithmetic;
6400 case INST_BITOR:
6401 lResult = l1 | l2;
6402 goto longResultOfArithmetic;
6403 case INST_BITXOR:
6404 lResult = l1 ^ l2;
6405 longResultOfArithmetic:
6406 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6407 if (Tcl_IsShared(valuePtr)) {
6408 TclNewLongObj(objResultPtr, lResult);
6409 TRACE(("%s\n", O2S(objResultPtr)));
6410 NEXT_INST_F(1, 2, 1);
6411 }
6412 TclSetLongObj(valuePtr, lResult);
6413 TRACE(("%s\n", O2S(valuePtr)));
6414 NEXT_INST_F(1, 1, 0);
6415 }
6416 }
6417
6418 /*
6419 * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would
6420 * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which
6421 * is highly undesirable due to the overall impact on size.
6422 */
6423
6424 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6425 objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
6426 valuePtr, value2Ptr);
6427 if (objResultPtr == DIVIDED_BY_ZERO) {
6428 TRACE_APPEND(("DIVIDE BY ZERO\n"));
6429 goto divideByZero;
6430 } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
6431 TRACE_ERROR(interp);
6432 goto gotError;
6433 } else if (objResultPtr == NULL) {
6434 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6435 NEXT_INST_F(1, 1, 0);
6436 } else {
6437 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6438 NEXT_INST_F(1, 2, 1);
6439 }
6440
6441 case INST_EXPON:
6442 case INST_ADD:
6443 case INST_SUB:
6444 case INST_DIV:
6445 case INST_MULT:
6446 value2Ptr = OBJ_AT_TOS;
6447 valuePtr = OBJ_UNDER_TOS;
6448
6449 if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
6450 || IsErroringNaNType(type1)) {
6451 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
6452 O2S(value2Ptr), O2S(valuePtr),
6453 (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
6454 DECACHE_STACK_INFO();
6455 IllegalExprOperandType(interp, pc, valuePtr);
6456 CACHE_STACK_INFO();
6457 goto gotError;
6458 }
6459
6460 #ifdef ACCEPT_NAN
6461 if (type1 == TCL_NUMBER_NAN) {
6462 /*
6463 * NaN first argument -> result is also NaN.
6464 */
6465
6466 NEXT_INST_F(1, 1, 0);
6467 }
6468 #endif
6469
6470 if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
6471 || IsErroringNaNType(type2)) {
6472 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
6473 O2S(value2Ptr), O2S(valuePtr),
6474 (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
6475 DECACHE_STACK_INFO();
6476 IllegalExprOperandType(interp, pc, value2Ptr);
6477 CACHE_STACK_INFO();
6478 goto gotError;
6479 }
6480
6481 #ifdef ACCEPT_NAN
6482 if (type2 == TCL_NUMBER_NAN) {
6483 /*
6484 * NaN second argument -> result is also NaN.
6485 */
6486
6487 objResultPtr = value2Ptr;
6488 NEXT_INST_F(1, 2, 1);
6489 }
6490 #endif
6491
6492 /*
6493 * Handle (long,long) arithmetic as best we can without going out to
6494 * an external function.
6495 */
6496
6497 if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
6498 Tcl_WideInt w1, w2, wResult;
6499
6500 l1 = *((const long *)ptr1);
6501 l2 = *((const long *)ptr2);
6502
6503 switch (*pc) {
6504 case INST_ADD:
6505 w1 = (Tcl_WideInt) l1;
6506 w2 = (Tcl_WideInt) l2;
6507 wResult = w1 + w2;
6508 #ifdef TCL_WIDE_INT_IS_LONG
6509 /*
6510 * Check for overflow.
6511 */
6512
6513 if (Overflowing(w1, w2, wResult)) {
6514 goto overflow;
6515 }
6516 #endif
6517 goto wideResultOfArithmetic;
6518
6519 case INST_SUB:
6520 w1 = (Tcl_WideInt) l1;
6521 w2 = (Tcl_WideInt) l2;
6522 wResult = w1 - w2;
6523 #ifdef TCL_WIDE_INT_IS_LONG
6524 /*
6525 * Must check for overflow. The macro tests for overflows in
6526 * sums by looking at the sign bits. As we have a subtraction
6527 * here, we are adding -w2. As -w2 could in turn overflow, we
6528 * test with ~w2 instead: it has the opposite sign bit to w2
6529 * so it does the job. Note that the only "bad" case (w2==0)
6530 * is irrelevant for this macro, as in that case w1 and
6531 * wResult have the same sign and there is no overflow anyway.
6532 */
6533
6534 if (Overflowing(w1, ~w2, wResult)) {
6535 goto overflow;
6536 }
6537 #endif
6538 wideResultOfArithmetic:
6539 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6540 if (Tcl_IsShared(valuePtr)) {
6541 objResultPtr = Tcl_NewWideIntObj(wResult);
6542 TRACE(("%s\n", O2S(objResultPtr)));
6543 NEXT_INST_F(1, 2, 1);
6544 }
6545 Tcl_SetWideIntObj(valuePtr, wResult);
6546 TRACE(("%s\n", O2S(valuePtr)));
6547 NEXT_INST_F(1, 1, 0);
6548 break;
6549
6550 case INST_DIV:
6551 if (l2 == 0) {
6552 TRACE(("%s %s => DIVIDE BY ZERO\n",
6553 O2S(valuePtr), O2S(value2Ptr)));
6554 goto divideByZero;
6555 } else if ((l1 == LONG_MIN) && (l2 == -1)) {
6556 /*
6557 * Can't represent (-LONG_MIN) as a long.
6558 */
6559
6560 goto overflow;
6561 }
6562 lResult = l1 / l2;
6563
6564 /*
6565 * Force Tcl's integer division rules.
6566 * TODO: examine for logic simplification
6567 */
6568
6569 if (((lResult < 0) || ((lResult == 0) &&
6570 ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
6571 ((lResult * l2) != l1)) {
6572 lResult -= 1;
6573 }
6574 goto longResultOfArithmetic;
6575
6576 case INST_MULT:
6577 if (((sizeof(long) >= 2*sizeof(int))
6578 && (l1 <= INT_MAX) && (l1 >= INT_MIN)
6579 && (l2 <= INT_MAX) && (l2 >= INT_MIN))
6580 || ((sizeof(long) >= 2*sizeof(short))
6581 && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN)
6582 && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) {
6583 lResult = l1 * l2;
6584 goto longResultOfArithmetic;
6585 }
6586 }
6587
6588 /*
6589 * Fall through with INST_EXPON, INST_DIV and large multiplies.
6590 */
6591 }
6592
6593 overflow:
6594 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6595 objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
6596 valuePtr, value2Ptr);
6597 if (objResultPtr == DIVIDED_BY_ZERO) {
6598 TRACE_APPEND(("DIVIDE BY ZERO\n"));
6599 goto divideByZero;
6600 } else if (objResultPtr == EXPONENT_OF_ZERO) {
6601 TRACE_APPEND(("EXPONENT OF ZERO\n"));
6602 goto exponOfZero;
6603 } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
6604 TRACE_ERROR(interp);
6605 goto gotError;
6606 } else if (objResultPtr == NULL) {
6607 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6608 NEXT_INST_F(1, 1, 0);
6609 } else {
6610 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6611 NEXT_INST_F(1, 2, 1);
6612 }
6613
6614 case INST_LNOT: {
6615 int b;
6616
6617 valuePtr = OBJ_AT_TOS;
6618
6619 /* TODO - check claim that taking address of b harms performance */
6620 /* TODO - consider optimization search for constants */
6621 if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
6622 TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr),
6623 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6624 DECACHE_STACK_INFO();
6625 IllegalExprOperandType(interp, pc, valuePtr);
6626 CACHE_STACK_INFO();
6627 goto gotError;
6628 }
6629 /* TODO: Consider peephole opt. */
6630 objResultPtr = TCONST(!b);
6631 TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr);
6632 NEXT_INST_F(1, 1, 1);
6633 }
6634
6635 case INST_BITNOT:
6636 valuePtr = OBJ_AT_TOS;
6637 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
6638 if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
6639 || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
6640 /*
6641 * ... ~$NonInteger => raise an error.
6642 */
6643
6644 TRACE_APPEND(("ERROR: illegal type %s\n",
6645 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6646 DECACHE_STACK_INFO();
6647 IllegalExprOperandType(interp, pc, valuePtr);
6648 CACHE_STACK_INFO();
6649 goto gotError;
6650 }
6651 if (type1 == TCL_NUMBER_LONG) {
6652 l1 = *((const long *) ptr1);
6653 if (Tcl_IsShared(valuePtr)) {
6654 TclNewLongObj(objResultPtr, ~l1);
6655 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6656 NEXT_INST_F(1, 1, 1);
6657 }
6658 TclSetLongObj(valuePtr, ~l1);
6659 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6660 NEXT_INST_F(1, 0, 0);
6661 }
6662 objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
6663 if (objResultPtr != NULL) {
6664 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6665 NEXT_INST_F(1, 1, 1);
6666 } else {
6667 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6668 NEXT_INST_F(1, 0, 0);
6669 }
6670
6671 case INST_UMINUS:
6672 valuePtr = OBJ_AT_TOS;
6673 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
6674 if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
6675 || IsErroringNaNType(type1)) {
6676 TRACE_APPEND(("ERROR: illegal type %s \n",
6677 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6678 DECACHE_STACK_INFO();
6679 IllegalExprOperandType(interp, pc, valuePtr);
6680 CACHE_STACK_INFO();
6681 goto gotError;
6682 }
6683 switch (type1) {
6684 case TCL_NUMBER_NAN:
6685 /* -NaN => NaN */
6686 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6687 NEXT_INST_F(1, 0, 0);
6688 break;
6689 case TCL_NUMBER_LONG:
6690 l1 = *((const long *) ptr1);
6691 if (l1 != LONG_MIN) {
6692 if (Tcl_IsShared(valuePtr)) {
6693 TclNewLongObj(objResultPtr, -l1);
6694 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6695 NEXT_INST_F(1, 1, 1);
6696 }
6697 TclSetLongObj(valuePtr, -l1);
6698 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6699 NEXT_INST_F(1, 0, 0);
6700 }
6701 /* FALLTHROUGH */
6702 }
6703 objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
6704 if (objResultPtr != NULL) {
6705 TRACE_APPEND(("%s\n", O2S(objResultPtr)));
6706 NEXT_INST_F(1, 1, 1);
6707 } else {
6708 TRACE_APPEND(("%s\n", O2S(valuePtr)));
6709 NEXT_INST_F(1, 0, 0);
6710 }
6711
6712 case INST_UPLUS:
6713 case INST_TRY_CVT_TO_NUMERIC:
6714 /*
6715 * Try to convert the topmost stack object to numeric object. This is
6716 * done in order to support [expr]'s policy of interpreting operands
6717 * if at all possible as numbers first, then strings.
6718 */
6719
6720 valuePtr = OBJ_AT_TOS;
6721 TRACE(("\"%.20s\" => ", O2S(valuePtr)));
6722
6723 if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
6724 if (*pc == INST_UPLUS) {
6725 /*
6726 * ... +$NonNumeric => raise an error.
6727 */
6728
6729 TRACE_APPEND(("ERROR: illegal type %s\n",
6730 (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
6731 DECACHE_STACK_INFO();
6732 IllegalExprOperandType(interp, pc, valuePtr);
6733 CACHE_STACK_INFO();
6734 goto gotError;
6735 }
6736
6737 /* ... TryConvertToNumeric($NonNumeric) is acceptable */
6738 TRACE_APPEND(("not numeric\n"));
6739 NEXT_INST_F(1, 0, 0);
6740 }
6741 if (IsErroringNaNType(type1)) {
6742 if (*pc == INST_UPLUS) {
6743 /*
6744 * ... +$NonNumeric => raise an error.
6745 */
6746
6747 TRACE_APPEND(("ERROR: illegal type %s\n",
6748 (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
6749 DECACHE_STACK_INFO();
6750 IllegalExprOperandType(interp, pc, valuePtr);
6751 CACHE_STACK_INFO();
6752 } else {
6753 /*
6754 * Numeric conversion of NaN -> error.
6755 */
6756
6757 TRACE_APPEND(("ERROR: IEEE floating pt error\n"));
6758 DECACHE_STACK_INFO();
6759 TclExprFloatError(interp, *((const double *) ptr1));
6760 CACHE_STACK_INFO();
6761 }
6762 goto gotError;
6763 }
6764
6765 /*
6766 * Ensure that the numeric value has a string rep the same as the
6767 * formatted version of its internal rep. This is used, e.g., to make
6768 * sure that "expr {0001}" yields "1", not "0001". We implement this
6769 * by _discarding_ the string rep since we know it will be
6770 * regenerated, if needed later, by formatting the internal rep's
6771 * value.
6772 */
6773
6774 if (valuePtr->bytes == NULL) {
6775 TRACE_APPEND(("numeric, same Tcl_Obj\n"));
6776 NEXT_INST_F(1, 0, 0);
6777 }
6778 if (Tcl_IsShared(valuePtr)) {
6779 /*
6780 * Here we do some surgery within the Tcl_Obj internals. We want
6781 * to copy the internalrep, but not the string, so we temporarily hide
6782 * the string so we do not copy it.
6783 */
6784
6785 char *savedString = valuePtr->bytes;
6786
6787 valuePtr->bytes = NULL;
6788 objResultPtr = Tcl_DuplicateObj(valuePtr);
6789 valuePtr->bytes = savedString;
6790 TRACE_APPEND(("numeric, new Tcl_Obj\n"));
6791 NEXT_INST_F(1, 1, 1);
6792 }
6793 TclInvalidateStringRep(valuePtr);
6794 TRACE_APPEND(("numeric, same Tcl_Obj\n"));
6795 NEXT_INST_F(1, 0, 0);
6796 }
6797 break;
6798
6799 /*
6800 * End of numeric operator instructions.
6801 * -----------------------------------------------------------------
6802 */
6803
6804 case INST_TRY_CVT_TO_BOOLEAN:
6805 valuePtr = OBJ_AT_TOS;
6806 if (valuePtr->typePtr == &tclBooleanType) {
6807 objResultPtr = TCONST(1);
6808 } else {
6809 int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
6810 objResultPtr = TCONST(res);
6811 }
6812 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
6813 NEXT_INST_F(1, 0, 1);
6814 break;
6815
6816 case INST_BREAK:
6817 /*
6818 DECACHE_STACK_INFO();
6819 Tcl_ResetResult(interp);
6820 CACHE_STACK_INFO();
6821 */
6822 result = TCL_BREAK;
6823 cleanup = 0;
6824 TRACE(("=> BREAK!\n"));
6825 goto processExceptionReturn;
6826
6827 case INST_CONTINUE:
6828 /*
6829 DECACHE_STACK_INFO();
6830 Tcl_ResetResult(interp);
6831 CACHE_STACK_INFO();
6832 */
6833 result = TCL_CONTINUE;
6834 cleanup = 0;
6835 TRACE(("=> CONTINUE!\n"));
6836 goto processExceptionReturn;
6837
6838 {
6839 ForeachInfo *infoPtr;
6840 Var *iterVarPtr, *listVarPtr;
6841 Tcl_Obj *oldValuePtr, *listPtr, **elements;
6842 ForeachVarList *varListPtr;
6843 int numLists, iterNum, listTmpIndex, listLen, numVars;
6844 int varIndex, valIndex, continueLoop, j, iterTmpIndex;
6845 long i;
6846
6847 case INST_FOREACH_START4: /* DEPRECATED */
6848 /*
6849 * Initialize the temporary local var that holds the count of the
6850 * number of iterations of the loop body to -1.
6851 */
6852
6853 opnd = TclGetUInt4AtPtr(pc+1);
6854 infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
6855 iterTmpIndex = infoPtr->loopCtTemp;
6856 iterVarPtr = LOCAL(iterTmpIndex);
6857 oldValuePtr = iterVarPtr->value.objPtr;
6858
6859 if (oldValuePtr == NULL) {
6860 TclNewLongObj(iterVarPtr->value.objPtr, -1);
6861 Tcl_IncrRefCount(iterVarPtr->value.objPtr);
6862 } else {
6863 TclSetLongObj(oldValuePtr, -1);
6864 }
6865 TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
6866
6867 #ifndef TCL_COMPILE_DEBUG
6868 /*
6869 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately
6870 * after INST_FOREACH_START4 - let us just fall through instead of
6871 * jumping back to the top.
6872 */
6873
6874 pc += 5;
6875 TCL_DTRACE_INST_NEXT();
6876 #else
6877 NEXT_INST_F(5, 0, 0);
6878 #endif
6879
6880 case INST_FOREACH_STEP4: /* DEPRECATED */
6881 /*
6882 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
6883 * the next value list element to each loop var.
6884 */
6885
6886 opnd = TclGetUInt4AtPtr(pc+1);
6887 TRACE(("%u => ", opnd));
6888 infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
6889 numLists = infoPtr->numLists;
6890
6891 /*
6892 * Increment the temp holding the loop iteration number.
6893 */
6894
6895 iterVarPtr = LOCAL(infoPtr->loopCtTemp);
6896 valuePtr = iterVarPtr->value.objPtr;
6897 iterNum = valuePtr->internalRep.longValue + 1;
6898 TclSetLongObj(valuePtr, iterNum);
6899
6900 /*
6901 * Check whether all value lists are exhausted and we should stop the
6902 * loop.
6903 */
6904
6905 continueLoop = 0;
6906 listTmpIndex = infoPtr->firstValueTemp;
6907 for (i = 0; i < numLists; i++) {
6908 varListPtr = infoPtr->varLists[i];
6909 numVars = varListPtr->numVars;
6910
6911 listVarPtr = LOCAL(listTmpIndex);
6912 listPtr = listVarPtr->value.objPtr;
6913 if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
6914 TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n",
6915 i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
6916 goto gotError;
6917 }
6918 if (listLen > iterNum * numVars) {
6919 continueLoop = 1;
6920 }
6921 listTmpIndex++;
6922 }
6923
6924 /*
6925 * If some var in some var list still has a remaining list element
6926 * iterate one more time. Assign to var the next element from its
6927 * value list. We already checked above that each list temp holds a
6928 * valid list object (by calling Tcl_ListObjLength), but cannot rely
6929 * on that check remaining valid: one list could have been shimmered
6930 * as a side effect of setting a traced variable.
6931 */
6932
6933 if (continueLoop) {
6934 listTmpIndex = infoPtr->firstValueTemp;
6935 for (i = 0; i < numLists; i++) {
6936 varListPtr = infoPtr->varLists[i];
6937 numVars = varListPtr->numVars;
6938
6939 listVarPtr = LOCAL(listTmpIndex);
6940 listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
6941 TclListObjGetElements(interp, listPtr, &listLen, &elements);
6942
6943 valIndex = (iterNum * numVars);
6944 for (j = 0; j < numVars; j++) {
6945 if (valIndex >= listLen) {
6946 TclNewObj(valuePtr);
6947 } else {
6948 valuePtr = elements[valIndex];
6949 }
6950
6951 varIndex = varListPtr->varIndexes[j];
6952 varPtr = LOCAL(varIndex);
6953 while (TclIsVarLink(varPtr)) {
6954 varPtr = varPtr->value.linkPtr;
6955 }
6956 if (TclIsVarDirectWritable(varPtr)) {
6957 value2Ptr = varPtr->value.objPtr;
6958 if (valuePtr != value2Ptr) {
6959 if (value2Ptr != NULL) {
6960 TclDecrRefCount(value2Ptr);
6961 }
6962 varPtr->value.objPtr = valuePtr;
6963 Tcl_IncrRefCount(valuePtr);
6964 }
6965 } else {
6966 DECACHE_STACK_INFO();
6967 if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
6968 valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
6969 CACHE_STACK_INFO();
6970 TRACE_APPEND((
6971 "ERROR init. index temp %d: %s\n",
6972 varIndex, O2S(Tcl_GetObjResult(interp))));
6973 TclDecrRefCount(listPtr);
6974 goto gotError;
6975 }
6976 CACHE_STACK_INFO();
6977 }
6978 valIndex++;
6979 }
6980 TclDecrRefCount(listPtr);
6981 listTmpIndex++;
6982 }
6983 }
6984 TRACE_APPEND(("%d lists, iter %d, %s loop\n",
6985 numLists, iterNum, (continueLoop? "continue" : "exit")));
6986
6987 /*
6988 * Run-time peep-hole optimisation: the compiler ALWAYS follows
6989 * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
6990 * instruction and jump direct from here.
6991 */
6992
6993 pc += 5;
6994 if (*pc == INST_JUMP_FALSE1) {
6995 NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
6996 } else {
6997 NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
6998 }
6999
7000 }
7001 {
7002 ForeachInfo *infoPtr;
7003 Tcl_Obj *listPtr, **elements;
7004 ForeachVarList *varListPtr;
7005 int numLists, iterMax, listLen, numVars;
7006 int iterTmp, iterNum, listTmpDepth;
7007 int varIndex, valIndex, j;
7008 long i;
7009
7010 case INST_FOREACH_START:
7011 /*
7012 * Initialize the data for the looping construct, pushing the
7013 * corresponding Tcl_Objs to the stack.
7014 */
7015
7016 opnd = TclGetUInt4AtPtr(pc+1);
7017 infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
7018 numLists = infoPtr->numLists;
7019 TRACE(("%u => ", opnd));
7020
7021 /*
7022 * Compute the number of iterations that will be run: iterMax
7023 */
7024
7025 iterMax = 0;
7026 listTmpDepth = numLists-1;
7027 for (i = 0; i < numLists; i++) {
7028 varListPtr = infoPtr->varLists[i];
7029 numVars = varListPtr->numVars;
7030 listPtr = OBJ_AT_DEPTH(listTmpDepth);
7031 if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
7032 TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s",
7033 i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
7034 goto gotError;
7035 }
7036 if (Tcl_IsShared(listPtr)) {
7037 objPtr = TclListObjCopy(NULL, listPtr);
7038 Tcl_IncrRefCount(objPtr);
7039 Tcl_DecrRefCount(listPtr);
7040 OBJ_AT_DEPTH(listTmpDepth) = objPtr;
7041 }
7042 iterTmp = (listLen + (numVars - 1))/numVars;
7043 if (iterTmp > iterMax) {
7044 iterMax = iterTmp;
7045 }
7046 listTmpDepth--;
7047 }
7048
7049 /*
7050 * Store the iterNum and iterMax in a single Tcl_Obj; we keep a
7051 * nul-string obj with the pointer stored in the ptrValue so that the
7052 * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but
7053 * it will never leave this scope and is read-only.
7054 */
7055
7056 TclNewObj(tmpPtr);
7057 tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
7058 tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
7059 PUSH_OBJECT(tmpPtr); /* iterCounts object */
7060
7061 /*
7062 * Store a pointer to the ForeachInfo struct; same dirty trick
7063 * as above
7064 */
7065
7066 TclNewObj(tmpPtr);
7067 tmpPtr->internalRep.twoPtrValue.ptr1 = infoPtr;
7068 PUSH_OBJECT(tmpPtr); /* infoPtr object */
7069 TRACE_APPEND(("jump to loop step\n"));
7070
7071 /*
7072 * Jump directly to the INST_FOREACH_STEP instruction; the C code just
7073 * falls through.
7074 */
7075
7076 pc += 5 - infoPtr->loopCtTemp;
7077
7078 case INST_FOREACH_STEP:
7079 /*
7080 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
7081 * the next value list element to each loop var.
7082 */
7083
7084 tmpPtr = OBJ_AT_TOS;
7085 infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
7086 numLists = infoPtr->numLists;
7087 TRACE(("=> "));
7088
7089 tmpPtr = OBJ_AT_DEPTH(1);
7090 iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
7091 iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
7092
7093 /*
7094 * If some list still has a remaining list element iterate one more
7095 * time. Assign to var the next element from its value list.
7096 */
7097
7098 if (iterNum < iterMax) {
7099 /*
7100 * Set the variables and jump back to run the body
7101 */
7102
7103 tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
7104
7105 listTmpDepth = numLists + 1;
7106
7107 for (i = 0; i < numLists; i++) {
7108 varListPtr = infoPtr->varLists[i];
7109 numVars = varListPtr->numVars;
7110
7111 listPtr = OBJ_AT_DEPTH(listTmpDepth);
7112 TclListObjGetElements(interp, listPtr, &listLen, &elements);
7113
7114 valIndex = (iterNum * numVars);
7115 for (j = 0; j < numVars; j++) {
7116 if (valIndex >= listLen) {
7117 TclNewObj(valuePtr);
7118 } else {
7119 valuePtr = elements[valIndex];
7120 }
7121
7122 varIndex = varListPtr->varIndexes[j];
7123 varPtr = LOCAL(varIndex);
7124 while (TclIsVarLink(varPtr)) {
7125 varPtr = varPtr->value.linkPtr;
7126 }
7127 if (TclIsVarDirectWritable(varPtr)) {
7128 value2Ptr = varPtr->value.objPtr;
7129 if (valuePtr != value2Ptr) {
7130 if (value2Ptr != NULL) {
7131 TclDecrRefCount(value2Ptr);
7132 }
7133 varPtr->value.objPtr = valuePtr;
7134 Tcl_IncrRefCount(valuePtr);
7135 }
7136 } else {
7137 DECACHE_STACK_INFO();
7138 if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
7139 valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
7140 CACHE_STACK_INFO();
7141 TRACE_APPEND(("ERROR init. index temp %d: %.30s",
7142 varIndex, O2S(Tcl_GetObjResult(interp))));
7143 goto gotError;
7144 }
7145 CACHE_STACK_INFO();
7146 }
7147 valIndex++;
7148 }
7149 listTmpDepth--;
7150 }
7151 TRACE_APPEND(("jump to loop start\n"));
7152 /* loopCtTemp being 'misused' for storing the jump size */
7153 NEXT_INST_F(infoPtr->loopCtTemp, 0, 0);
7154 }
7155
7156 TRACE_APPEND(("loop has no more iterations\n"));
7157 #ifdef TCL_COMPILE_DEBUG
7158 NEXT_INST_F(1, 0, 0);
7159 #else
7160 /*
7161 * FALL THROUGH
7162 */
7163 pc++;
7164 #endif
7165
7166 case INST_FOREACH_END:
7167 /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
7168 tmpPtr = OBJ_AT_TOS;
7169 infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
7170 numLists = infoPtr->numLists;
7171 TRACE(("=> loop terminated\n"));
7172 NEXT_INST_V(1, numLists+2, 0);
7173
7174 case INST_LMAP_COLLECT:
7175 /*
7176 * This instruction is only issued by lmap. The stack is:
7177 * - result
7178 * - infoPtr
7179 * - loop counters
7180 * - valLists
7181 * - collecting obj (unshared)
7182 * The instruction lappends the result to the collecting obj.
7183 */
7184
7185 tmpPtr = OBJ_AT_DEPTH(1);
7186 infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
7187 numLists = infoPtr->numLists;
7188 TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
7189
7190 objPtr = OBJ_AT_DEPTH(3 + numLists);
7191 Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
7192 NEXT_INST_F(1, 1, 0);
7193 }
7194 break;
7195
7196 case INST_BEGIN_CATCH4:
7197 /*
7198 * Record start of the catch command with exception range index equal
7199 * to the operand. Push the current stack depth onto the special catch
7200 * stack.
7201 */
7202
7203 *(++catchTop) = CURR_DEPTH;
7204 TRACE(("%u => catchTop=%d, stackTop=%d\n",
7205 TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
7206 (int) CURR_DEPTH));
7207 NEXT_INST_F(5, 0, 0);
7208 break;
7209
7210 case INST_END_CATCH:
7211 catchTop--;
7212 DECACHE_STACK_INFO();
7213 Tcl_ResetResult(interp);
7214 CACHE_STACK_INFO();
7215 result = TCL_OK;
7216 TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
7217 NEXT_INST_F(1, 0, 0);
7218 break;
7219
7220 case INST_PUSH_RESULT:
7221 objResultPtr = Tcl_GetObjResult(interp);
7222 TRACE_WITH_OBJ(("=> "), objResultPtr);
7223
7224 /*
7225 * See the comments at INST_INVOKE_STK
7226 */
7227
7228 TclNewObj(objPtr);
7229 Tcl_IncrRefCount(objPtr);
7230 iPtr->objResultPtr = objPtr;
7231 NEXT_INST_F(1, 0, -1);
7232 break;
7233
7234 case INST_PUSH_RETURN_CODE:
7235 TclNewIntObj(objResultPtr, result);
7236 TRACE(("=> %u\n", result));
7237 NEXT_INST_F(1, 0, 1);
7238 break;
7239
7240 case INST_PUSH_RETURN_OPTIONS:
7241 DECACHE_STACK_INFO();
7242 objResultPtr = Tcl_GetReturnOptions(interp, result);
7243 CACHE_STACK_INFO();
7244 TRACE_WITH_OBJ(("=> "), objResultPtr);
7245 NEXT_INST_F(1, 0, 1);
7246 break;
7247
7248 case INST_RETURN_CODE_BRANCH: {
7249 int code;
7250
7251 if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) {
7252 Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!");
7253 }
7254 if (code == TCL_OK) {
7255 Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!");
7256 }
7257 if (code < TCL_ERROR || code > TCL_CONTINUE) {
7258 code = TCL_CONTINUE + 1;
7259 }
7260 TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1));
7261 NEXT_INST_F(2*code-1, 1, 0);
7262 }
7263
7264 /*
7265 * -----------------------------------------------------------------
7266 * Start of dictionary-related instructions.
7267 */
7268
7269 {
7270 int opnd2, allocateDict, done, i, allocdict;
7271 Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
7272 Tcl_Obj *emptyPtr, **keyPtrPtr;
7273 Tcl_DictSearch *searchPtr;
7274 DictUpdateInfo *duiPtr;
7275
7276 case INST_DICT_VERIFY:
7277 dictPtr = OBJ_AT_TOS;
7278 TRACE(("\"%.30s\" => ", O2S(dictPtr)));
7279 if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
7280 TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
7281 O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
7282 goto gotError;
7283 }
7284 TRACE_APPEND(("OK\n"));
7285 NEXT_INST_F(1, 1, 0);
7286
7287 case INST_DICT_GET:
7288 case INST_DICT_EXISTS: {
7289 Tcl_Interp *interp2 = interp;
7290 int found;
7291
7292 opnd = TclGetUInt4AtPtr(pc+1);
7293 TRACE(("%u => ", opnd));
7294 dictPtr = OBJ_AT_DEPTH(opnd);
7295 if (*pc == INST_DICT_EXISTS) {
7296 interp2 = NULL;
7297 }
7298 if (opnd > 1) {
7299 dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
7300 &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
7301 if (dictPtr == NULL) {
7302 if (*pc == INST_DICT_EXISTS) {
7303 found = 0;
7304 goto afterDictExists;
7305 }
7306 TRACE_WITH_OBJ((
7307 "ERROR tracing dictionary path into \"%.30s\": ",
7308 O2S(OBJ_AT_DEPTH(opnd))),
7309 Tcl_GetObjResult(interp));
7310 goto gotError;
7311 }
7312 }
7313 if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
7314 &objResultPtr) == TCL_OK) {
7315 if (*pc == INST_DICT_EXISTS) {
7316 found = (objResultPtr ? 1 : 0);
7317 goto afterDictExists;
7318 }
7319 if (!objResultPtr) {
7320 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
7321 "key \"%s\" not known in dictionary",
7322 TclGetString(OBJ_AT_TOS)));
7323 DECACHE_STACK_INFO();
7324 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
7325 TclGetString(OBJ_AT_TOS), NULL);
7326 CACHE_STACK_INFO();
7327 TRACE_ERROR(interp);
7328 goto gotError;
7329 }
7330 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
7331 NEXT_INST_V(5, opnd+1, 1);
7332 } else if (*pc != INST_DICT_EXISTS) {
7333 TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
7334 O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
7335 goto gotError;
7336 } else {
7337 found = 0;
7338 }
7339 afterDictExists:
7340 TRACE_APPEND(("%d\n", found));
7341
7342 /*
7343 * The INST_DICT_EXISTS instruction is usually followed by a
7344 * conditional jump, so we can take advantage of this to do some
7345 * peephole optimization (note that we're careful to not close out
7346 * someone doing something else).
7347 */
7348
7349 JUMP_PEEPHOLE_V(found, 5, opnd+1);
7350 }
7351
7352 case INST_DICT_SET:
7353 case INST_DICT_UNSET:
7354 case INST_DICT_INCR_IMM:
7355 opnd = TclGetUInt4AtPtr(pc+1);
7356 opnd2 = TclGetUInt4AtPtr(pc+5);
7357
7358 varPtr = LOCAL(opnd2);
7359 while (TclIsVarLink(varPtr)) {
7360 varPtr = varPtr->value.linkPtr;
7361 }
7362 TRACE(("%u %u => ", opnd, opnd2));
7363 if (TclIsVarDirectReadable(varPtr)) {
7364 dictPtr = varPtr->value.objPtr;
7365 } else {
7366 DECACHE_STACK_INFO();
7367 dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
7368 opnd2);
7369 CACHE_STACK_INFO();
7370 }
7371 if (dictPtr == NULL) {
7372 TclNewObj(dictPtr);
7373 allocateDict = 1;
7374 } else {
7375 allocateDict = Tcl_IsShared(dictPtr);
7376 if (allocateDict) {
7377 dictPtr = Tcl_DuplicateObj(dictPtr);
7378 }
7379 }
7380
7381 switch (*pc) {
7382 case INST_DICT_SET:
7383 cleanup = opnd + 1;
7384 result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd,
7385 &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS);
7386 break;
7387 case INST_DICT_INCR_IMM:
7388 cleanup = 1;
7389 opnd = TclGetInt4AtPtr(pc+1);
7390 result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
7391 if (result != TCL_OK) {
7392 break;
7393 }
7394 if (valuePtr == NULL) {
7395 Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
7396 } else {
7397 TclNewIntObj(value2Ptr, opnd);
7398 Tcl_IncrRefCount(value2Ptr);
7399 if (Tcl_IsShared(valuePtr)) {
7400 valuePtr = Tcl_DuplicateObj(valuePtr);
7401 Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr);
7402 }
7403 result = TclIncrObj(interp, valuePtr, value2Ptr);
7404 if (result == TCL_OK) {
7405 TclInvalidateStringRep(dictPtr);
7406 }
7407 TclDecrRefCount(value2Ptr);
7408 }
7409 break;
7410 case INST_DICT_UNSET:
7411 cleanup = opnd;
7412 result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,
7413 &OBJ_AT_DEPTH(opnd-1));
7414 break;
7415 default:
7416 cleanup = 0; /* stop compiler warning */
7417 Tcl_Panic("Should not happen!");
7418 }
7419
7420 if (result != TCL_OK) {
7421 if (allocateDict) {
7422 TclDecrRefCount(dictPtr);
7423 }
7424 TRACE_APPEND(("ERROR updating dictionary: %s\n",
7425 O2S(Tcl_GetObjResult(interp))));
7426 goto checkForCatch;
7427 }
7428
7429 if (TclIsVarDirectWritable(varPtr)) {
7430 if (allocateDict) {
7431 value2Ptr = varPtr->value.objPtr;
7432 Tcl_IncrRefCount(dictPtr);
7433 if (value2Ptr != NULL) {
7434 TclDecrRefCount(value2Ptr);
7435 }
7436 varPtr->value.objPtr = dictPtr;
7437 }
7438 objResultPtr = dictPtr;
7439 } else {
7440 Tcl_IncrRefCount(dictPtr);
7441 DECACHE_STACK_INFO();
7442 objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
7443 dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
7444 CACHE_STACK_INFO();
7445 TclDecrRefCount(dictPtr);
7446 if (objResultPtr == NULL) {
7447 TRACE_ERROR(interp);
7448 goto gotError;
7449 }
7450 }
7451 #ifndef TCL_COMPILE_DEBUG
7452 if (*(pc+9) == INST_POP) {
7453 NEXT_INST_V(10, cleanup, 0);
7454 }
7455 #endif
7456 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
7457 NEXT_INST_V(9, cleanup, 1);
7458
7459 case INST_DICT_APPEND:
7460 case INST_DICT_LAPPEND:
7461 opnd = TclGetUInt4AtPtr(pc+1);
7462 varPtr = LOCAL(opnd);
7463 while (TclIsVarLink(varPtr)) {
7464 varPtr = varPtr->value.linkPtr;
7465 }
7466 TRACE(("%u => ", opnd));
7467 if (TclIsVarDirectReadable(varPtr)) {
7468 dictPtr = varPtr->value.objPtr;
7469 } else {
7470 DECACHE_STACK_INFO();
7471 dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
7472 opnd);
7473 CACHE_STACK_INFO();
7474 }
7475 if (dictPtr == NULL) {
7476 TclNewObj(dictPtr);
7477 allocateDict = 1;
7478 } else {
7479 allocateDict = Tcl_IsShared(dictPtr);
7480 if (allocateDict) {
7481 dictPtr = Tcl_DuplicateObj(dictPtr);
7482 }
7483 }
7484
7485 if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
7486 &valuePtr) != TCL_OK) {
7487 if (allocateDict) {
7488 TclDecrRefCount(dictPtr);
7489 }
7490 TRACE_ERROR(interp);
7491 goto gotError;
7492 }
7493
7494 /*
7495 * Note that a non-existent key results in a NULL valuePtr, which is a
7496 * case handled separately below. What we *can* say at this point is
7497 * that the write-back will always succeed.
7498 */
7499
7500 switch (*pc) {
7501 case INST_DICT_APPEND:
7502 if (valuePtr == NULL) {
7503 Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS);
7504 } else if (Tcl_IsShared(valuePtr)) {
7505 valuePtr = Tcl_DuplicateObj(valuePtr);
7506 Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS);
7507 Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
7508 } else {
7509 Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS);
7510
7511 /*
7512 * Must invalidate the string representation of dictionary
7513 * here because we have directly updated the internal
7514 * representation; if we don't, callers could see the wrong
7515 * string rep despite the internal version of the dictionary
7516 * having the correct value. [Bug 3079830]
7517 */
7518
7519 TclInvalidateStringRep(dictPtr);
7520 }
7521 break;
7522 case INST_DICT_LAPPEND:
7523 /*
7524 * More complex because list-append can fail.
7525 */
7526
7527 if (valuePtr == NULL) {
7528 Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS,
7529 Tcl_NewListObj(1, &OBJ_AT_TOS));
7530 break;
7531 } else if (Tcl_IsShared(valuePtr)) {
7532 valuePtr = Tcl_DuplicateObj(valuePtr);
7533 if (Tcl_ListObjAppendElement(interp, valuePtr,
7534 OBJ_AT_TOS) != TCL_OK) {
7535 TclDecrRefCount(valuePtr);
7536 if (allocateDict) {
7537 TclDecrRefCount(dictPtr);
7538 }
7539 TRACE_ERROR(interp);
7540 goto gotError;
7541 }
7542 Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
7543 } else {
7544 if (Tcl_ListObjAppendElement(interp, valuePtr,
7545 OBJ_AT_TOS) != TCL_OK) {
7546 if (allocateDict) {
7547 TclDecrRefCount(dictPtr);
7548 }
7549 TRACE_ERROR(interp);
7550 goto gotError;
7551 }
7552
7553 /*
7554 * Must invalidate the string representation of dictionary
7555 * here because we have directly updated the internal
7556 * representation; if we don't, callers could see the wrong
7557 * string rep despite the internal version of the dictionary
7558 * having the correct value. [Bug 3079830]
7559 */
7560
7561 TclInvalidateStringRep(dictPtr);
7562 }
7563 break;
7564 default:
7565 Tcl_Panic("Should not happen!");
7566 }
7567
7568 if (TclIsVarDirectWritable(varPtr)) {
7569 if (allocateDict) {
7570 value2Ptr = varPtr->value.objPtr;
7571 Tcl_IncrRefCount(dictPtr);
7572 if (value2Ptr != NULL) {
7573 TclDecrRefCount(value2Ptr);
7574 }
7575 varPtr->value.objPtr = dictPtr;
7576 }
7577 objResultPtr = dictPtr;
7578 } else {
7579 Tcl_IncrRefCount(dictPtr);
7580 DECACHE_STACK_INFO();
7581 objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
7582 dictPtr, TCL_LEAVE_ERR_MSG, opnd);
7583 CACHE_STACK_INFO();
7584 TclDecrRefCount(dictPtr);
7585 if (objResultPtr == NULL) {
7586 TRACE_ERROR(interp);
7587 goto gotError;
7588 }
7589 }
7590 #ifndef TCL_COMPILE_DEBUG
7591 if (*(pc+5) == INST_POP) {
7592 NEXT_INST_F(6, 2, 0);
7593 }
7594 #endif
7595 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
7596 NEXT_INST_F(5, 2, 1);
7597
7598 case INST_DICT_FIRST:
7599 opnd = TclGetUInt4AtPtr(pc+1);
7600 TRACE(("%u => ", opnd));
7601 dictPtr = POP_OBJECT();
7602 searchPtr = ckalloc(sizeof(Tcl_DictSearch));
7603 if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
7604 &valuePtr, &done) != TCL_OK) {
7605
7606 /*
7607 * dictPtr is no longer on the stack, and we're not
7608 * moving it into the internalrep of an iterator. We need
7609 * to drop the refcount [Tcl Bug 9b352768e6].
7610 */
7611
7612 Tcl_DecrRefCount(dictPtr);
7613 ckfree(searchPtr);
7614 TRACE_ERROR(interp);
7615 goto gotError;
7616 }
7617 TclNewObj(statePtr);
7618 statePtr->typePtr = &dictIteratorType;
7619 statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
7620 statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
7621 varPtr = LOCAL(opnd);
7622 if (varPtr->value.objPtr) {
7623 if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
7624 Tcl_Panic("mis-issued dictFirst!");
7625 }
7626 TclDecrRefCount(varPtr->value.objPtr);
7627 }
7628 varPtr->value.objPtr = statePtr;
7629 Tcl_IncrRefCount(statePtr);
7630 goto pushDictIteratorResult;
7631
7632 case INST_DICT_NEXT:
7633 opnd = TclGetUInt4AtPtr(pc+1);
7634 TRACE(("%u => ", opnd));
7635 statePtr = (*LOCAL(opnd)).value.objPtr;
7636 if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
7637 Tcl_Panic("mis-issued dictNext!");
7638 }
7639 searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
7640 Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
7641 pushDictIteratorResult:
7642 if (done) {
7643 TclNewObj(emptyPtr);
7644 PUSH_OBJECT(emptyPtr);
7645 PUSH_OBJECT(emptyPtr);
7646 } else {
7647 PUSH_OBJECT(valuePtr);
7648 PUSH_OBJECT(keyPtr);
7649 }
7650 TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
7651 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
7652
7653 /*
7654 * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always
7655 * followed by a conditional jump, so we can take advantage of this to
7656 * do some peephole optimization (note that we're careful to not close
7657 * out someone doing something else).
7658 */
7659
7660 JUMP_PEEPHOLE_F(done, 5, 0);
7661
7662 case INST_DICT_UPDATE_START:
7663 opnd = TclGetUInt4AtPtr(pc+1);
7664 opnd2 = TclGetUInt4AtPtr(pc+5);
7665 TRACE(("%u => ", opnd));
7666 varPtr = LOCAL(opnd);
7667 duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
7668 while (TclIsVarLink(varPtr)) {
7669 varPtr = varPtr->value.linkPtr;
7670 }
7671 if (TclIsVarDirectReadable(varPtr)) {
7672 dictPtr = varPtr->value.objPtr;
7673 } else {
7674 DECACHE_STACK_INFO();
7675 dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL,
7676 TCL_LEAVE_ERR_MSG, opnd);
7677 CACHE_STACK_INFO();
7678 if (dictPtr == NULL) {
7679 TRACE_ERROR(interp);
7680 goto gotError;
7681 }
7682 }
7683 Tcl_IncrRefCount(dictPtr);
7684 if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
7685 &keyPtrPtr) != TCL_OK) {
7686 TRACE_ERROR(interp);
7687 goto gotError;
7688 }
7689 if (length != duiPtr->length) {
7690 Tcl_Panic("dictUpdateStart argument length mismatch");
7691 }
7692 for (i=0 ; i<length ; i++) {
7693 if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
7694 &valuePtr) != TCL_OK) {
7695 TRACE_ERROR(interp);
7696 Tcl_DecrRefCount(dictPtr);
7697 goto gotError;
7698 }
7699 varPtr = LOCAL(duiPtr->varIndices[i]);
7700 while (TclIsVarLink(varPtr)) {
7701 varPtr = varPtr->value.linkPtr;
7702 }
7703 DECACHE_STACK_INFO();
7704 if (valuePtr == NULL) {
7705 TclObjUnsetVar2(interp,
7706 localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
7707 NULL, 0);
7708 } else if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
7709 valuePtr, TCL_LEAVE_ERR_MSG,
7710 duiPtr->varIndices[i]) == NULL) {
7711 CACHE_STACK_INFO();
7712 TRACE_ERROR(interp);
7713 Tcl_DecrRefCount(dictPtr);
7714 goto gotError;
7715 }
7716 CACHE_STACK_INFO();
7717 }
7718 TclDecrRefCount(dictPtr);
7719 TRACE_APPEND(("OK\n"));
7720 NEXT_INST_F(9, 0, 0);
7721
7722 case INST_DICT_UPDATE_END:
7723 opnd = TclGetUInt4AtPtr(pc+1);
7724 opnd2 = TclGetUInt4AtPtr(pc+5);
7725 TRACE(("%u => ", opnd));
7726 varPtr = LOCAL(opnd);
7727 duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
7728 while (TclIsVarLink(varPtr)) {
7729 varPtr = varPtr->value.linkPtr;
7730 }
7731 if (TclIsVarDirectReadable(varPtr)) {
7732 dictPtr = varPtr->value.objPtr;
7733 } else {
7734 DECACHE_STACK_INFO();
7735 dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
7736 opnd);
7737 CACHE_STACK_INFO();
7738 }
7739 if (dictPtr == NULL) {
7740 TRACE_APPEND(("storage was unset\n"));
7741 NEXT_INST_F(9, 1, 0);
7742 }
7743 if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
7744 || TclListObjGetElements(interp, OBJ_AT_TOS, &length,
7745 &keyPtrPtr) != TCL_OK) {
7746 TRACE_ERROR(interp);
7747 goto gotError;
7748 }
7749 allocdict = Tcl_IsShared(dictPtr);
7750 if (allocdict) {
7751 dictPtr = Tcl_DuplicateObj(dictPtr);
7752 }
7753 if (length > 0) {
7754 TclInvalidateStringRep(dictPtr);
7755 }
7756 for (i=0 ; i<length ; i++) {
7757 Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);
7758
7759 while (TclIsVarLink(var2Ptr)) {
7760 var2Ptr = var2Ptr->value.linkPtr;
7761 }
7762 if (TclIsVarDirectReadable(var2Ptr)) {
7763 valuePtr = var2Ptr->value.objPtr;
7764 } else {
7765 DECACHE_STACK_INFO();
7766 valuePtr = TclPtrGetVarIdx(interp, var2Ptr, NULL, NULL, NULL,
7767 0, duiPtr->varIndices[i]);
7768 CACHE_STACK_INFO();
7769 }
7770 if (valuePtr == NULL) {
7771 Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
7772 } else if (dictPtr == valuePtr) {
7773 Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
7774 Tcl_DuplicateObj(valuePtr));
7775 } else {
7776 Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr);
7777 }
7778 }
7779 if (TclIsVarDirectWritable(varPtr)) {
7780 Tcl_IncrRefCount(dictPtr);
7781 TclDecrRefCount(varPtr->value.objPtr);
7782 varPtr->value.objPtr = dictPtr;
7783 } else {
7784 DECACHE_STACK_INFO();
7785 objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
7786 dictPtr, TCL_LEAVE_ERR_MSG, opnd);
7787 CACHE_STACK_INFO();
7788 if (objResultPtr == NULL) {
7789 if (allocdict) {
7790 TclDecrRefCount(dictPtr);
7791 }
7792 TRACE_ERROR(interp);
7793 goto gotError;
7794 }
7795 }
7796 TRACE_APPEND(("written back\n"));
7797 NEXT_INST_F(9, 1, 0);
7798
7799 case INST_DICT_EXPAND:
7800 dictPtr = OBJ_UNDER_TOS;
7801 listPtr = OBJ_AT_TOS;
7802 TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
7803 if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
7804 TRACE_ERROR(interp);
7805 goto gotError;
7806 }
7807 objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
7808 if (objResultPtr == NULL) {
7809 TRACE_ERROR(interp);
7810 goto gotError;
7811 }
7812 TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
7813 NEXT_INST_F(1, 2, 1);
7814
7815 case INST_DICT_RECOMBINE_STK:
7816 keysPtr = POP_OBJECT();
7817 varNamePtr = OBJ_UNDER_TOS;
7818 listPtr = OBJ_AT_TOS;
7819 TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
7820 O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
7821 if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
7822 TRACE_ERROR(interp);
7823 TclDecrRefCount(keysPtr);
7824 goto gotError;
7825 }
7826 varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
7827 TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
7828 if (varPtr == NULL) {
7829 TRACE_ERROR(interp);
7830 TclDecrRefCount(keysPtr);
7831 goto gotError;
7832 }
7833 DECACHE_STACK_INFO();
7834 result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1,
7835 objc, objv, keysPtr);
7836 CACHE_STACK_INFO();
7837 TclDecrRefCount(keysPtr);
7838 if (result != TCL_OK) {
7839 TRACE_ERROR(interp);
7840 goto gotError;
7841 }
7842 TRACE_APPEND(("OK\n"));
7843 NEXT_INST_F(1, 2, 0);
7844
7845 case INST_DICT_RECOMBINE_IMM:
7846 opnd = TclGetUInt4AtPtr(pc+1);
7847 listPtr = OBJ_UNDER_TOS;
7848 keysPtr = OBJ_AT_TOS;
7849 varPtr = LOCAL(opnd);
7850 TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
7851 O2S(keysPtr)));
7852 if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
7853 TRACE_ERROR(interp);
7854 goto gotError;
7855 }
7856 while (TclIsVarLink(varPtr)) {
7857 varPtr = varPtr->value.linkPtr;
7858 }
7859 DECACHE_STACK_INFO();
7860 result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd,
7861 objc, objv, keysPtr);
7862 CACHE_STACK_INFO();
7863 if (result != TCL_OK) {
7864 TRACE_ERROR(interp);
7865 goto gotError;
7866 }
7867 TRACE_APPEND(("OK\n"));
7868 NEXT_INST_F(5, 2, 0);
7869 }
7870 break;
7871
7872 /*
7873 * End of dictionary-related instructions.
7874 * -----------------------------------------------------------------
7875 */
7876
7877 case INST_CLOCK_READ:
7878 { /* Read the wall clock */
7879 Tcl_WideInt wval;
7880 Tcl_Time now;
7881 switch(TclGetUInt1AtPtr(pc+1)) {
7882 case 0: /* clicks */
7883 #ifdef TCL_WIDE_CLICKS
7884 wval = TclpGetWideClicks();
7885 #else
7886 wval = (Tcl_WideInt) TclpGetClicks();
7887 #endif
7888 break;
7889 case 1: /* microseconds */
7890 Tcl_GetTime(&now);
7891 wval = (Tcl_WideInt) now.sec * 1000000 + now.usec;
7892 break;
7893 case 2: /* milliseconds */
7894 Tcl_GetTime(&now);
7895 wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000;
7896 break;
7897 case 3: /* seconds */
7898 Tcl_GetTime(&now);
7899 wval = (Tcl_WideInt) now.sec;
7900 break;
7901 default:
7902 Tcl_Panic("clockRead instruction with unknown clock#");
7903 }
7904 objResultPtr = Tcl_NewWideIntObj(wval);
7905 TRACE_WITH_OBJ(("=> "), objResultPtr);
7906 NEXT_INST_F(2, 0, 1);
7907 }
7908 break;
7909
7910 default:
7911 Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
7912 } /* end of switch on opCode */
7913
7914 /*
7915 * Block for variables needed to process exception returns.
7916 */
7917
7918 {
7919 ExceptionRange *rangePtr;
7920 /* Points to closest loop or catch exception
7921 * range enclosing the pc. Used by various
7922 * instructions and processCatch to process
7923 * break, continue, and errors. */
7924 const char *bytes;
7925
7926 /*
7927 * An external evaluation (INST_INVOKE or INST_EVAL) returned
7928 * something different from TCL_OK, or else INST_BREAK or
7929 * INST_CONTINUE were called.
7930 */
7931
7932 processExceptionReturn:
7933 #ifdef TCL_COMPILE_DEBUG
7934 switch (*pc) {
7935 case INST_INVOKE_STK1:
7936 opnd = TclGetUInt1AtPtr(pc+1);
7937 TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
7938 break;
7939 case INST_INVOKE_STK4:
7940 opnd = TclGetUInt4AtPtr(pc+1);
7941 TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
7942 break;
7943 case INST_EVAL_STK:
7944 /*
7945 * Note that the object at stacktop has to be used before doing
7946 * the cleanup.
7947 */
7948
7949 TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
7950 break;
7951 default:
7952 TRACE(("=> "));
7953 }
7954 #endif
7955 if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
7956 rangePtr = GetExceptRangeForPc(pc, result, codePtr);
7957 if (rangePtr == NULL) {
7958 TRACE_APPEND(("no encl. loop or catch, returning %s\n",
7959 StringForResultCode(result)));
7960 goto abnormalReturn;
7961 }
7962 if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
7963 TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
7964 goto processCatch;
7965 }
7966 while (cleanup--) {
7967 valuePtr = POP_OBJECT();
7968 TclDecrRefCount(valuePtr);
7969 }
7970 if (result == TCL_BREAK) {
7971 result = TCL_OK;
7972 pc = (codePtr->codeStart + rangePtr->breakOffset);
7973 TRACE_APPEND(("%s, range at %d, new pc %d\n",
7974 StringForResultCode(result),
7975 rangePtr->codeOffset, rangePtr->breakOffset));
7976 NEXT_INST_F(0, 0, 0);
7977 }
7978 if (rangePtr->continueOffset == -1) {
7979 TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
7980 StringForResultCode(result)));
7981 goto checkForCatch;
7982 }
7983 result = TCL_OK;
7984 pc = (codePtr->codeStart + rangePtr->continueOffset);
7985 TRACE_APPEND(("%s, range at %d, new pc %d\n",
7986 StringForResultCode(result),
7987 rangePtr->codeOffset, rangePtr->continueOffset));
7988 NEXT_INST_F(0, 0, 0);
7989 }
7990 #ifdef TCL_COMPILE_DEBUG
7991 if (traceInstructions) {
7992 objPtr = Tcl_GetObjResult(interp);
7993 if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
7994 TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ",
7995 result, O2S(objPtr)));
7996 } else {
7997 TRACE_APPEND(("%s, result=\"%.30s\"\n",
7998 StringForResultCode(result), O2S(objPtr)));
7999 }
8000 }
8001 #endif
8002 goto checkForCatch;
8003
8004 /*
8005 * Division by zero in an expression. Control only reaches this point
8006 * by "goto divideByZero".
8007 */
8008
8009 divideByZero:
8010 Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
8011 DECACHE_STACK_INFO();
8012 Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
8013 CACHE_STACK_INFO();
8014 goto gotError;
8015
8016 /*
8017 * Exponentiation of zero by negative number in an expression. Control
8018 * only reaches this point by "goto exponOfZero".
8019 */
8020
8021 exponOfZero:
8022 Tcl_SetObjResult(interp, Tcl_NewStringObj(
8023 "exponentiation of zero by negative power", -1));
8024 DECACHE_STACK_INFO();
8025 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
8026 "exponentiation of zero by negative power", NULL);
8027 CACHE_STACK_INFO();
8028
8029 /*
8030 * Almost all error paths feed through here rather than assigning to
8031 * result themselves (for a small but consistent saving).
8032 */
8033
8034 gotError:
8035 result = TCL_ERROR;
8036
8037 /*
8038 * Execution has generated an "exception" such as TCL_ERROR. If the
8039 * exception is an error, record information about what was being
8040 * executed when the error occurred. Find the closest enclosing catch
8041 * range, if any. If no enclosing catch range is found, stop execution
8042 * and return the "exception" code.
8043 */
8044
8045 checkForCatch:
8046 if (iPtr->execEnvPtr->rewind) {
8047 goto abnormalReturn;
8048 }
8049 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
8050 const unsigned char *pcBeg;
8051
8052 bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL);
8053 DECACHE_STACK_INFO();
8054 TclLogCommandInfo(interp, codePtr->source, bytes,
8055 bytes ? length : 0, pcBeg, tosPtr);
8056 CACHE_STACK_INFO();
8057 }
8058 iPtr->flags &= ~ERR_ALREADY_LOGGED;
8059
8060 /*
8061 * Clear all expansions that may have started after the last
8062 * INST_BEGIN_CATCH.
8063 */
8064
8065 while (auxObjList) {
8066 if ((catchTop != initCatchTop)
8067 && (*catchTop > (ptrdiff_t)
8068 auxObjList->internalRep.twoPtrValue.ptr2)) {
8069 break;
8070 }
8071 POP_TAUX_OBJ();
8072 }
8073
8074 /*
8075 * We must not catch if the script in progress has been canceled with
8076 * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we
8077 * either hit another interpreter (presumably where the script in
8078 * progress has not been canceled) or we get to the top-level. We do
8079 * NOT modify the interpreter result here because we know it will
8080 * already be set prior to vectoring down to this point in the code.
8081 */
8082
8083 if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) {
8084 #ifdef TCL_COMPILE_DEBUG
8085 if (traceInstructions) {
8086 fprintf(stdout, " ... cancel with unwind, returning %s\n",
8087 StringForResultCode(result));
8088 }
8089 #endif
8090 goto abnormalReturn;
8091 }
8092
8093 /*
8094 * We must not catch an exceeded limit. Instead, it blows outwards
8095 * until we either hit another interpreter (presumably where the limit
8096 * is not exceeded) or we get to the top-level.
8097 */
8098
8099 if (TclLimitExceeded(iPtr->limit)) {
8100 #ifdef TCL_COMPILE_DEBUG
8101 if (traceInstructions) {
8102 fprintf(stdout, " ... limit exceeded, returning %s\n",
8103 StringForResultCode(result));
8104 }
8105 #endif
8106 goto abnormalReturn;
8107 }
8108 if (catchTop == initCatchTop) {
8109 #ifdef TCL_COMPILE_DEBUG
8110 if (traceInstructions) {
8111 fprintf(stdout, " ... no enclosing catch, returning %s\n",
8112 StringForResultCode(result));
8113 }
8114 #endif
8115 goto abnormalReturn;
8116 }
8117 rangePtr = GetExceptRangeForPc(pc, TCL_ERROR, codePtr);
8118 if (rangePtr == NULL) {
8119 /*
8120 * This is only possible when compiling a [catch] that sends its
8121 * script to INST_EVAL. Cannot correct the compiler without
8122 * breaking compat with previous .tbc compiled scripts.
8123 */
8124
8125 #ifdef TCL_COMPILE_DEBUG
8126 if (traceInstructions) {
8127 fprintf(stdout, " ... no enclosing catch, returning %s\n",
8128 StringForResultCode(result));
8129 }
8130 #endif
8131 goto abnormalReturn;
8132 }
8133
8134 /*
8135 * A catch exception range (rangePtr) was found to handle an
8136 * "exception". It was found either by checkForCatch just above or by
8137 * an instruction during break, continue, or error processing. Jump to
8138 * its catchOffset after unwinding the operand stack to the depth it
8139 * had when starting to execute the range's catch command.
8140 */
8141
8142 processCatch:
8143 while (CURR_DEPTH > *catchTop) {
8144 valuePtr = POP_OBJECT();
8145 TclDecrRefCount(valuePtr);
8146 }
8147 #ifdef TCL_COMPILE_DEBUG
8148 if (traceInstructions) {
8149 fprintf(stdout, " ... found catch at %d, catchTop=%d, "
8150 "unwound to %ld, new pc %u\n",
8151 rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
8152 (long) *catchTop, (unsigned) rangePtr->catchOffset);
8153 }
8154 #endif
8155 pc = (codePtr->codeStart + rangePtr->catchOffset);
8156 NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */
8157
8158 /*
8159 * end of infinite loop dispatching on instructions.
8160 */
8161
8162 /*
8163 * Done or abnormal return code. Restore the stack to state it had when
8164 * starting to execute the ByteCode. Panic if the stack is below the
8165 * initial level.
8166 */
8167
8168 abnormalReturn:
8169 TCL_DTRACE_INST_LAST();
8170
8171 /*
8172 * Clear all expansions and same-level NR calls.
8173 *
8174 * Note that expansion markers have a NULL type; avoid removing other
8175 * markers.
8176 */
8177
8178 while (auxObjList) {
8179 POP_TAUX_OBJ();
8180 }
8181 while (tosPtr > initTosPtr) {
8182 objPtr = POP_OBJECT();
8183 Tcl_DecrRefCount(objPtr);
8184 }
8185
8186 if (tosPtr < initTosPtr) {
8187 fprintf(stderr,
8188 "\nTclNRExecuteByteCode: abnormal return at pc %u: "
8189 "stack top %d < entry stack top %d\n",
8190 (unsigned)(pc - codePtr->codeStart),
8191 (unsigned) CURR_DEPTH, (unsigned) 0);
8192 Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
8193 }
8194 CLANG_ASSERT(bcFramePtr);
8195 }
8196
8197 iPtr->cmdFramePtr = bcFramePtr->nextPtr;
8198 if (codePtr->refCount-- <= 1) {
8199 TclCleanupByteCode(codePtr);
8200 }
8201 TclStackFree(interp, TD); /* free my stack */
8202
8203 return result;
8204
8205 /*
8206 * INST_START_CMD failure case removed where it doesn't bother that much
8207 *
8208 * Remark that if the interpreter is marked for deletion its
8209 * compileEpoch is modified, so that the epoch check also verifies
8210 * that the interp is not deleted. If no outside call has been made
8211 * since the last check, it is safe to omit the check.
8212
8213 * case INST_START_CMD:
8214 */
8215
8216 instStartCmdFailed:
8217 {
8218 const char *bytes;
8219
8220 length = 0;
8221
8222 if (TclInterpReady(interp) == TCL_ERROR) {
8223 goto gotError;
8224 }
8225
8226 /*
8227 * We used to switch to direct eval; for NRE-awareness we now
8228 * compile and eval the command so that this evaluation does not
8229 * add a new TEBC instance. Bug [2910748], bug [fa6bf38d07]
8230 *
8231 * TODO: recompile, search this command and eval a code starting from,
8232 * so that this evaluation does not add a new TEBC instance without
8233 * NRE-trampoline.
8234 */
8235
8236 codePtr->flags |= TCL_BYTECODE_RECOMPILE;
8237 bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL);
8238 opnd = TclGetUInt4AtPtr(pc+1);
8239 pc += (opnd-1);
8240 assert(bytes);
8241 PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
8242 goto instEvalStk;
8243 }
8244 }
8245
8246 #undef codePtr
8247 #undef iPtr
8248 #undef bcFramePtr
8249 #undef initCatchTop
8250 #undef initTosPtr
8251 #undef auxObjList
8252 #undef catchTop
8253 #undef TCONST
8254 #undef esPtr
8255
8256 static int
FinalizeOONext(ClientData data[],Tcl_Interp * interp,int result)8257 FinalizeOONext(
8258 ClientData data[],
8259 Tcl_Interp *interp,
8260 int result)
8261 {
8262 Interp *iPtr = (Interp *) interp;
8263 CallContext *contextPtr = data[1];
8264
8265 /*
8266 * Reset the variable lookup frame.
8267 */
8268
8269 iPtr->varFramePtr = data[0];
8270
8271 /*
8272 * Restore the call chain context index as we've finished the inner invoke
8273 * and want to operate in the outer context again.
8274 */
8275
8276 contextPtr->index = PTR2INT(data[2]);
8277 contextPtr->skip = PTR2INT(data[3]);
8278 contextPtr->oPtr->flags &= ~FILTER_HANDLING;
8279 return result;
8280 }
8281
8282 static int
FinalizeOONextFilter(ClientData data[],Tcl_Interp * interp,int result)8283 FinalizeOONextFilter(
8284 ClientData data[],
8285 Tcl_Interp *interp,
8286 int result)
8287 {
8288 Interp *iPtr = (Interp *) interp;
8289 CallContext *contextPtr = data[1];
8290
8291 /*
8292 * Reset the variable lookup frame.
8293 */
8294
8295 iPtr->varFramePtr = data[0];
8296
8297 /*
8298 * Restore the call chain context index as we've finished the inner invoke
8299 * and want to operate in the outer context again.
8300 */
8301
8302 contextPtr->index = PTR2INT(data[2]);
8303 contextPtr->skip = PTR2INT(data[3]);
8304 contextPtr->oPtr->flags |= FILTER_HANDLING;
8305 return result;
8306 }
8307
8308 /*
8309 * LongPwrSmallExpon -- , WidePwrSmallExpon --
8310 *
8311 * Helpers to calculate small powers of integers whose result is long or wide.
8312 */
8313 #if (LONG_MAX == 0x7FFFFFFF)
8314 static inline long
LongPwrSmallExpon(long l1,long exponent)8315 LongPwrSmallExpon(long l1, long exponent) {
8316
8317 long lResult;
8318
8319 lResult = l1 * l1; /* b**2 */
8320 switch (exponent) {
8321 case 2:
8322 break;
8323 case 3:
8324 lResult *= l1; /* b**3 */
8325 break;
8326 case 4:
8327 lResult *= lResult; /* b**4 */
8328 break;
8329 case 5:
8330 lResult *= lResult; /* b**4 */
8331 lResult *= l1; /* b**5 */
8332 break;
8333 case 6:
8334 lResult *= l1; /* b**3 */
8335 lResult *= lResult; /* b**6 */
8336 break;
8337 case 7:
8338 lResult *= l1; /* b**3 */
8339 lResult *= lResult; /* b**6 */
8340 lResult *= l1; /* b**7 */
8341 break;
8342 case 8:
8343 lResult *= lResult; /* b**4 */
8344 lResult *= lResult; /* b**8 */
8345 break;
8346 }
8347 return lResult;
8348 }
8349 #endif
8350 static inline Tcl_WideInt
WidePwrSmallExpon(Tcl_WideInt w1,long exponent)8351 WidePwrSmallExpon(Tcl_WideInt w1, long exponent) {
8352
8353 Tcl_WideInt wResult;
8354
8355 wResult = w1 * w1; /* b**2 */
8356 switch (exponent) {
8357 case 2:
8358 break;
8359 case 3:
8360 wResult *= w1; /* b**3 */
8361 break;
8362 case 4:
8363 wResult *= wResult; /* b**4 */
8364 break;
8365 case 5:
8366 wResult *= wResult; /* b**4 */
8367 wResult *= w1; /* b**5 */
8368 break;
8369 case 6:
8370 wResult *= w1; /* b**3 */
8371 wResult *= wResult; /* b**6 */
8372 break;
8373 case 7:
8374 wResult *= w1; /* b**3 */
8375 wResult *= wResult; /* b**6 */
8376 wResult *= w1; /* b**7 */
8377 break;
8378 case 8:
8379 wResult *= wResult; /* b**4 */
8380 wResult *= wResult; /* b**8 */
8381 break;
8382 case 9:
8383 wResult *= wResult; /* b**4 */
8384 wResult *= wResult; /* b**8 */
8385 wResult *= w1; /* b**9 */
8386 break;
8387 case 10:
8388 wResult *= wResult; /* b**4 */
8389 wResult *= w1; /* b**5 */
8390 wResult *= wResult; /* b**10 */
8391 break;
8392 case 11:
8393 wResult *= wResult; /* b**4 */
8394 wResult *= w1; /* b**5 */
8395 wResult *= wResult; /* b**10 */
8396 wResult *= w1; /* b**11 */
8397 break;
8398 case 12:
8399 wResult *= w1; /* b**3 */
8400 wResult *= wResult; /* b**6 */
8401 wResult *= wResult; /* b**12 */
8402 break;
8403 case 13:
8404 wResult *= w1; /* b**3 */
8405 wResult *= wResult; /* b**6 */
8406 wResult *= wResult; /* b**12 */
8407 wResult *= w1; /* b**13 */
8408 break;
8409 case 14:
8410 wResult *= w1; /* b**3 */
8411 wResult *= wResult; /* b**6 */
8412 wResult *= w1; /* b**7 */
8413 wResult *= wResult; /* b**14 */
8414 break;
8415 case 15:
8416 wResult *= w1; /* b**3 */
8417 wResult *= wResult; /* b**6 */
8418 wResult *= w1; /* b**7 */
8419 wResult *= wResult; /* b**14 */
8420 wResult *= w1; /* b**15 */
8421 break;
8422 case 16:
8423 wResult *= wResult; /* b**4 */
8424 wResult *= wResult; /* b**8 */
8425 wResult *= wResult; /* b**16 */
8426 break;
8427 }
8428 return wResult;
8429 }
8430 /*
8431 *----------------------------------------------------------------------
8432 *
8433 * ExecuteExtendedBinaryMathOp, ExecuteExtendedUnaryMathOp --
8434 *
8435 * These functions do advanced math for binary and unary operators
8436 * respectively, so that the main TEBC code does not bear the cost of
8437 * them.
8438 *
8439 * Results:
8440 * A Tcl_Obj* result, or a NULL (in which case valuePtr is updated to
8441 * hold the result value), or one of the special flag values
8442 * GENERAL_ARITHMETIC_ERROR, EXPONENT_OF_ZERO or DIVIDED_BY_ZERO. The
8443 * latter two signify a zero value raised to a negative power or a value
8444 * divided by zero, respectively. With GENERAL_ARITHMETIC_ERROR, all
8445 * error information will have already been reported in the interpreter
8446 * result.
8447 *
8448 * Side effects:
8449 * May update the Tcl_Obj indicated valuePtr if it is unshared. Will
8450 * return a NULL when that happens.
8451 *
8452 *----------------------------------------------------------------------
8453 */
8454
8455 static Tcl_Obj *
ExecuteExtendedBinaryMathOp(Tcl_Interp * interp,int opcode,Tcl_Obj ** constants,Tcl_Obj * valuePtr,Tcl_Obj * value2Ptr)8456 ExecuteExtendedBinaryMathOp(
8457 Tcl_Interp *interp, /* Where to report errors. */
8458 int opcode, /* What operation to perform. */
8459 Tcl_Obj **constants, /* The execution environment's constants. */
8460 Tcl_Obj *valuePtr, /* The first operand on the stack. */
8461 Tcl_Obj *value2Ptr) /* The second operand on the stack. */
8462 {
8463 #define LONG_RESULT(l) \
8464 if (Tcl_IsShared(valuePtr)) { \
8465 TclNewLongObj(objResultPtr, l); \
8466 return objResultPtr; \
8467 } else { \
8468 Tcl_SetLongObj(valuePtr, l); \
8469 return NULL; \
8470 }
8471 #define WIDE_RESULT(w) \
8472 if (Tcl_IsShared(valuePtr)) { \
8473 return Tcl_NewWideIntObj(w); \
8474 } else { \
8475 Tcl_SetWideIntObj(valuePtr, w); \
8476 return NULL; \
8477 }
8478 #define BIG_RESULT(b) \
8479 if (Tcl_IsShared(valuePtr)) { \
8480 return Tcl_NewBignumObj(b); \
8481 } else { \
8482 Tcl_SetBignumObj(valuePtr, b); \
8483 return NULL; \
8484 }
8485 #define DOUBLE_RESULT(d) \
8486 if (Tcl_IsShared(valuePtr)) { \
8487 TclNewDoubleObj(objResultPtr, (d)); \
8488 return objResultPtr; \
8489 } else { \
8490 Tcl_SetDoubleObj(valuePtr, (d)); \
8491 return NULL; \
8492 }
8493
8494 int type1, type2;
8495 ClientData ptr1, ptr2;
8496 double d1, d2, dResult;
8497 long l1, l2, lResult;
8498 Tcl_WideInt w1, w2, wResult;
8499 mp_int big1, big2, bigResult, bigRemainder;
8500 Tcl_Obj *objResultPtr;
8501 int invalid, zero;
8502 long shift;
8503
8504 (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
8505 (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
8506
8507 switch (opcode) {
8508 case INST_MOD:
8509 /* TODO: Attempts to re-use unshared operands on stack */
8510
8511 l2 = 0; /* silence gcc warning */
8512 if (type2 == TCL_NUMBER_LONG) {
8513 l2 = *((const long *)ptr2);
8514 if (l2 == 0) {
8515 return DIVIDED_BY_ZERO;
8516 }
8517 if ((l2 == 1) || (l2 == -1)) {
8518 /*
8519 * Div. by |1| always yields remainder of 0.
8520 */
8521
8522 return constants[0];
8523 }
8524 }
8525 #ifndef TCL_WIDE_INT_IS_LONG
8526 if (type1 == TCL_NUMBER_WIDE) {
8527 w1 = *((const Tcl_WideInt *)ptr1);
8528 if (type2 != TCL_NUMBER_BIG) {
8529 Tcl_WideInt wQuotient, wRemainder;
8530 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
8531 wQuotient = w1 / w2;
8532
8533 /*
8534 * Force Tcl's integer division rules.
8535 * TODO: examine for logic simplification
8536 */
8537
8538 if (((wQuotient < (Tcl_WideInt) 0)
8539 || ((wQuotient == (Tcl_WideInt) 0)
8540 && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
8541 || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
8542 && (wQuotient * w2 != w1)) {
8543 wQuotient -= (Tcl_WideInt) 1;
8544 }
8545 wRemainder = w1 - w2*wQuotient;
8546 WIDE_RESULT(wRemainder);
8547 }
8548
8549 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
8550
8551 /* TODO: internals intrusion */
8552 if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) {
8553 /*
8554 * Arguments are opposite sign; remainder is sum.
8555 */
8556
8557 TclBNInitBignumFromWideInt(&big1, w1);
8558 mp_add(&big2, &big1, &big2);
8559 mp_clear(&big1);
8560 BIG_RESULT(&big2);
8561 }
8562
8563 /*
8564 * Arguments are same sign; remainder is first operand.
8565 */
8566
8567 mp_clear(&big2);
8568 return NULL;
8569 }
8570 #endif
8571 Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
8572 Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
8573 mp_init(&bigResult);
8574 mp_init(&bigRemainder);
8575 mp_div(&big1, &big2, &bigResult, &bigRemainder);
8576 if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) {
8577 /*
8578 * Convert to Tcl's integer division rules.
8579 */
8580
8581 mp_sub_d(&bigResult, 1, &bigResult);
8582 mp_add(&bigRemainder, &big2, &bigRemainder);
8583 }
8584 mp_copy(&bigRemainder, &bigResult);
8585 mp_clear(&bigRemainder);
8586 mp_clear(&big1);
8587 mp_clear(&big2);
8588 BIG_RESULT(&bigResult);
8589
8590 case INST_LSHIFT:
8591 case INST_RSHIFT: {
8592 /*
8593 * Reject negative shift argument.
8594 */
8595
8596 switch (type2) {
8597 case TCL_NUMBER_LONG:
8598 invalid = (*((const long *)ptr2) < 0L);
8599 break;
8600 #ifndef TCL_WIDE_INT_IS_LONG
8601 case TCL_NUMBER_WIDE:
8602 invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
8603 break;
8604 #endif
8605 case TCL_NUMBER_BIG:
8606 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
8607 invalid = (mp_cmp_d(&big2, 0) == MP_LT);
8608 mp_clear(&big2);
8609 break;
8610 default:
8611 /* Unused, here to silence compiler warning */
8612 invalid = 0;
8613 }
8614 if (invalid) {
8615 Tcl_SetObjResult(interp, Tcl_NewStringObj(
8616 "negative shift argument", -1));
8617 return GENERAL_ARITHMETIC_ERROR;
8618 }
8619
8620 /*
8621 * Zero shifted any number of bits is still zero.
8622 */
8623
8624 if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
8625 return constants[0];
8626 }
8627
8628 if (opcode == INST_LSHIFT) {
8629 /*
8630 * Large left shifts create integer overflow.
8631 *
8632 * BEWARE! Can't use Tcl_GetIntFromObj() here because that
8633 * converts values in the (unsigned) range to their signed int
8634 * counterparts, leading to incorrect results.
8635 */
8636
8637 if ((type2 != TCL_NUMBER_LONG)
8638 || (*((const long *)ptr2) > (long) INT_MAX)) {
8639 /*
8640 * Technically, we could hold the value (1 << (INT_MAX+1)) in
8641 * an mp_int, but since we're using mp_mul_2d() to do the
8642 * work, and it takes only an int argument, that's a good
8643 * place to draw the line.
8644 */
8645
8646 Tcl_SetObjResult(interp, Tcl_NewStringObj(
8647 "integer value too large to represent", -1));
8648 return GENERAL_ARITHMETIC_ERROR;
8649 }
8650 shift = (int)(*((const long *)ptr2));
8651
8652 /*
8653 * Handle shifts within the native wide range.
8654 */
8655
8656 if ((type1 != TCL_NUMBER_BIG)
8657 && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
8658 TclGetWideIntFromObj(NULL, valuePtr, &w1);
8659 if (!((w1>0 ? w1 : ~w1)
8660 & -(((Tcl_WideInt)1)
8661 << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
8662 WIDE_RESULT(w1 << shift);
8663 }
8664 }
8665 } else {
8666 /*
8667 * Quickly force large right shifts to 0 or -1.
8668 */
8669
8670 if ((type2 != TCL_NUMBER_LONG)
8671 || (*(const long *)ptr2 > INT_MAX)) {
8672 /*
8673 * Again, technically, the value to be shifted could be an
8674 * mp_int so huge that a right shift by (INT_MAX+1) bits could
8675 * not take us to the result of 0 or -1, but since we're using
8676 * mp_div_2d to do the work, and it takes only an int
8677 * argument, we draw the line there.
8678 */
8679
8680 switch (type1) {
8681 case TCL_NUMBER_LONG:
8682 zero = (*(const long *)ptr1 > 0L);
8683 break;
8684 #ifndef TCL_WIDE_INT_IS_LONG
8685 case TCL_NUMBER_WIDE:
8686 zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
8687 break;
8688 #endif
8689 case TCL_NUMBER_BIG:
8690 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
8691 zero = (mp_cmp_d(&big1, 0) == MP_GT);
8692 mp_clear(&big1);
8693 break;
8694 default:
8695 /* Unused, here to silence compiler warning. */
8696 zero = 0;
8697 }
8698 if (zero) {
8699 return constants[0];
8700 }
8701 LONG_RESULT(-1);
8702 }
8703 shift = (int)(*(const long *)ptr2);
8704
8705 #ifndef TCL_WIDE_INT_IS_LONG
8706 /*
8707 * Handle shifts within the native wide range.
8708 */
8709
8710 if (type1 == TCL_NUMBER_WIDE) {
8711 w1 = *(const Tcl_WideInt *)ptr1;
8712 if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
8713 if (w1 >= (Tcl_WideInt)0) {
8714 return constants[0];
8715 }
8716 LONG_RESULT(-1);
8717 }
8718 WIDE_RESULT(w1 >> shift);
8719 }
8720 #endif
8721 }
8722
8723 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
8724
8725 mp_init(&bigResult);
8726 if (opcode == INST_LSHIFT) {
8727 mp_mul_2d(&big1, shift, &bigResult);
8728 } else {
8729 mp_signed_rsh(&big1, shift, &bigResult);
8730 }
8731 mp_clear(&big1);
8732 BIG_RESULT(&bigResult);
8733 }
8734
8735 case INST_BITOR:
8736 case INST_BITXOR:
8737 case INST_BITAND:
8738 if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
8739 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
8740 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
8741
8742 mp_init(&bigResult);
8743
8744 switch (opcode) {
8745 case INST_BITAND:
8746 mp_and(&big1, &big2, &bigResult);
8747 break;
8748
8749 case INST_BITOR:
8750 mp_or(&big1, &big2, &bigResult);
8751 break;
8752
8753 case INST_BITXOR:
8754 mp_xor(&big1, &big2, &bigResult);
8755 break;
8756 }
8757
8758 mp_clear(&big1);
8759 mp_clear(&big2);
8760 BIG_RESULT(&bigResult);
8761 }
8762
8763 #ifndef TCL_WIDE_INT_IS_LONG
8764 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
8765 TclGetWideIntFromObj(NULL, valuePtr, &w1);
8766 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
8767
8768 switch (opcode) {
8769 case INST_BITAND:
8770 wResult = w1 & w2;
8771 break;
8772 case INST_BITOR:
8773 wResult = w1 | w2;
8774 break;
8775 case INST_BITXOR:
8776 wResult = w1 ^ w2;
8777 break;
8778 default:
8779 /* Unused, here to silence compiler warning. */
8780 wResult = 0;
8781 }
8782 WIDE_RESULT(wResult);
8783 }
8784 #endif
8785 l1 = *((const long *)ptr1);
8786 l2 = *((const long *)ptr2);
8787
8788 switch (opcode) {
8789 case INST_BITAND:
8790 lResult = l1 & l2;
8791 break;
8792 case INST_BITOR:
8793 lResult = l1 | l2;
8794 break;
8795 case INST_BITXOR:
8796 lResult = l1 ^ l2;
8797 break;
8798 default:
8799 /* Unused, here to silence compiler warning. */
8800 lResult = 0;
8801 }
8802 LONG_RESULT(lResult);
8803
8804 case INST_EXPON: {
8805 int oddExponent = 0, negativeExponent = 0;
8806 unsigned short base;
8807
8808 if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
8809 Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
8810 Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
8811
8812 if (d1==0.0 && d2<0.0) {
8813 return EXPONENT_OF_ZERO;
8814 }
8815 dResult = pow(d1, d2);
8816 goto doubleResult;
8817 }
8818 l1 = l2 = 0;
8819 w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */
8820 switch (type2) {
8821 case TCL_NUMBER_LONG:
8822 l2 = *((const long *) ptr2);
8823 #ifndef TCL_WIDE_INT_IS_LONG
8824 pwrLongExpon:
8825 #endif
8826 if (l2 == 0) {
8827 /*
8828 * Anything to the zero power is 1.
8829 */
8830
8831 return constants[1];
8832 } else if (l2 == 1) {
8833 /*
8834 * Anything to the first power is itself
8835 */
8836
8837 return NULL;
8838 }
8839 negativeExponent = (l2 < 0);
8840 oddExponent = (int) (l2 & 1);
8841 break;
8842 #ifndef TCL_WIDE_INT_IS_LONG
8843 case TCL_NUMBER_WIDE:
8844 w2 = *((const Tcl_WideInt *)ptr2);
8845 /* check it fits in long */
8846 l2 = (long)w2;
8847 if (w2 == l2) {
8848 type2 = TCL_NUMBER_LONG;
8849 goto pwrLongExpon;
8850 }
8851 negativeExponent = (w2 < 0);
8852 oddExponent = (int) (w2 & (Tcl_WideInt)1);
8853 break;
8854 #endif
8855 case TCL_NUMBER_BIG:
8856 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
8857 negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
8858 mp_mod_2d(&big2, 1, &big2);
8859 oddExponent = !mp_iszero(&big2);
8860 mp_clear(&big2);
8861 break;
8862 }
8863
8864 switch (type1) {
8865 case TCL_NUMBER_LONG:
8866 l1 = *((const long *)ptr1);
8867 #ifndef TCL_WIDE_INT_IS_LONG
8868 pwrLongBase:
8869 #endif
8870 switch (l1) {
8871 case 0:
8872 /*
8873 * Zero to a positive power is zero.
8874 * Zero to a negative power is div by zero error.
8875 */
8876
8877 return (!negativeExponent) ? constants[0] : EXPONENT_OF_ZERO;
8878 case 1:
8879 /*
8880 * 1 to any power is 1.
8881 */
8882
8883 return constants[1];
8884 case -1:
8885 if (!negativeExponent) {
8886 if (!oddExponent) {
8887 return constants[1];
8888 }
8889 LONG_RESULT(-1);
8890 }
8891 /* negativeExponent */
8892 if (oddExponent) {
8893 LONG_RESULT(-1);
8894 }
8895 return constants[1];
8896 }
8897 break;
8898 #ifndef TCL_WIDE_INT_IS_LONG
8899 case TCL_NUMBER_WIDE:
8900 w1 = *((const Tcl_WideInt *) ptr1);
8901 /* check it fits in long */
8902 l1 = (long)w1;
8903 if (w1 == l1) {
8904 type1 = TCL_NUMBER_LONG;
8905 goto pwrLongBase;
8906 }
8907 #endif
8908 }
8909 if (negativeExponent) {
8910
8911 /*
8912 * Integers with magnitude greater than 1 raise to a negative
8913 * power yield the answer zero (see TIP 123).
8914 */
8915 return constants[0];
8916 }
8917
8918
8919 if (type1 == TCL_NUMBER_BIG) {
8920 goto overflowExpon;
8921 }
8922
8923 /*
8924 * We refuse to accept exponent arguments that exceed one mp_digit
8925 * which means the max exponent value is 2**28-1 = 0x0FFFFFFF =
8926 * 268435455, which fits into a signed 32 bit int which is within the
8927 * range of the long type. This means any numeric Tcl_Obj value
8928 * not using TCL_NUMBER_LONG type must hold a value larger than we
8929 * accept.
8930 */
8931
8932 if (type2 != TCL_NUMBER_LONG) {
8933 Tcl_SetObjResult(interp, Tcl_NewStringObj(
8934 "exponent too large", -1));
8935 return GENERAL_ARITHMETIC_ERROR;
8936 }
8937
8938 /* From here (up to overflowExpon) exponent is long (l2). */
8939
8940 if (type1 == TCL_NUMBER_LONG) {
8941 if (l1 == 2) {
8942 /*
8943 * Reduce small powers of 2 to shifts.
8944 */
8945
8946 if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
8947 LONG_RESULT(1L << l2);
8948 }
8949 #if !defined(TCL_WIDE_INT_IS_LONG)
8950 if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
8951 WIDE_RESULT(((Tcl_WideInt) 1) << l2);
8952 }
8953 #endif
8954 goto overflowExpon;
8955 }
8956 if (l1 == -2) {
8957 int signum = oddExponent ? -1 : 1;
8958
8959 /*
8960 * Reduce small powers of 2 to shifts.
8961 */
8962
8963 if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
8964 LONG_RESULT(signum * (1L << l2));
8965 }
8966 #if !defined(TCL_WIDE_INT_IS_LONG)
8967 if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
8968 WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
8969 }
8970 #endif
8971 goto overflowExpon;
8972 }
8973 #if (LONG_MAX == 0x7FFFFFFF)
8974 if (l2 - 2 < (long)MaxBase32Size
8975 && l1 <= MaxBase32[l2 - 2]
8976 && l1 >= -MaxBase32[l2 - 2]) {
8977 /*
8978 * Small powers of 32-bit integers.
8979 */
8980 lResult = LongPwrSmallExpon(l1, l2);
8981
8982 LONG_RESULT(lResult);
8983 }
8984
8985 if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize
8986 && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
8987 base = Exp32Index[l1 - 3]
8988 + (unsigned short) (l2 - 2 - MaxBase32Size);
8989 if (base < Exp32Index[l1 - 2]) {
8990 /*
8991 * 32-bit number raised to intermediate power, done by
8992 * table lookup.
8993 */
8994
8995 LONG_RESULT(Exp32Value[base]);
8996 }
8997 }
8998 if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
8999 && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
9000 base = Exp32Index[-l1 - 3]
9001 + (unsigned short) (l2 - 2 - MaxBase32Size);
9002 if (base < Exp32Index[-l1 - 2]) {
9003 /*
9004 * 32-bit number raised to intermediate power, done by
9005 * table lookup.
9006 */
9007
9008 lResult = (oddExponent) ?
9009 -Exp32Value[base] : Exp32Value[base];
9010 LONG_RESULT(lResult);
9011 }
9012 }
9013 #endif
9014 #if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
9015 /* Code below (up to overflowExpon) works with wide-int base */
9016 w1 = l1;
9017 #endif
9018 }
9019
9020 #if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
9021
9022 /* From here (up to overflowExpon) base is wide-int (w1). */
9023
9024 if (l2 - 2 < (long)MaxBase64Size
9025 && w1 <= MaxBase64[l2 - 2]
9026 && w1 >= -MaxBase64[l2 - 2]) {
9027 /*
9028 * Small powers of integers whose result is wide.
9029 */
9030 wResult = WidePwrSmallExpon(w1, l2);
9031
9032 WIDE_RESULT(wResult);
9033 }
9034
9035 /*
9036 * Handle cases of powers > 16 that still fit in a 64-bit word by
9037 * doing table lookup.
9038 */
9039
9040 if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
9041 && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
9042 base = Exp64Index[w1 - 3]
9043 + (unsigned short) (l2 - 2 - MaxBase64Size);
9044 if (base < Exp64Index[w1 - 2]) {
9045 /*
9046 * 64-bit number raised to intermediate power, done by
9047 * table lookup.
9048 */
9049
9050 WIDE_RESULT(Exp64Value[base]);
9051 }
9052 }
9053
9054 if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
9055 && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
9056 base = Exp64Index[-w1 - 3]
9057 + (unsigned short) (l2 - 2 - MaxBase64Size);
9058 if (base < Exp64Index[-w1 - 2]) {
9059 /*
9060 * 64-bit number raised to intermediate power, done by
9061 * table lookup.
9062 */
9063
9064 wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
9065 WIDE_RESULT(wResult);
9066 }
9067 }
9068 #endif
9069
9070 overflowExpon:
9071
9072 if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
9073 || (value2Ptr->typePtr != &tclIntType)
9074 || (Tcl_WideUInt)w2 >= (1<<28)) {
9075 Tcl_SetObjResult(interp, Tcl_NewStringObj(
9076 "exponent too large", -1));
9077 return GENERAL_ARITHMETIC_ERROR;
9078 }
9079 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
9080 mp_init(&bigResult);
9081 mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
9082 mp_clear(&big1);
9083 BIG_RESULT(&bigResult);
9084 }
9085
9086 case INST_ADD:
9087 case INST_SUB:
9088 case INST_MULT:
9089 case INST_DIV:
9090 if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
9091 /*
9092 * At least one of the values is floating-point, so perform
9093 * floating point calculations.
9094 */
9095
9096 Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
9097 Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
9098
9099 switch (opcode) {
9100 case INST_ADD:
9101 dResult = d1 + d2;
9102 break;
9103 case INST_SUB:
9104 dResult = d1 - d2;
9105 break;
9106 case INST_MULT:
9107 dResult = d1 * d2;
9108 break;
9109 case INST_DIV:
9110 #ifndef IEEE_FLOATING_POINT
9111 if (d2 == 0.0) {
9112 return DIVIDED_BY_ZERO;
9113 }
9114 #endif
9115 /*
9116 * We presume that we are running with zero-divide unmasked if
9117 * we're on an IEEE box. Otherwise, this statement might cause
9118 * demons to fly out our noses.
9119 */
9120
9121 dResult = d1 / d2;
9122 break;
9123 default:
9124 /* Unused, here to silence compiler warning. */
9125 dResult = 0;
9126 }
9127
9128 doubleResult:
9129 #ifndef ACCEPT_NAN
9130 /*
9131 * Check now for IEEE floating-point error.
9132 */
9133
9134 if (TclIsNaN(dResult)) {
9135 TclExprFloatError(interp, dResult);
9136 return GENERAL_ARITHMETIC_ERROR;
9137 }
9138 #endif
9139 DOUBLE_RESULT(dResult);
9140 }
9141 if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
9142 TclGetWideIntFromObj(NULL, valuePtr, &w1);
9143 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
9144
9145 switch (opcode) {
9146 case INST_ADD:
9147 wResult = w1 + w2;
9148 #ifndef TCL_WIDE_INT_IS_LONG
9149 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
9150 #endif
9151 {
9152 /*
9153 * Check for overflow.
9154 */
9155
9156 if (Overflowing(w1, w2, wResult)) {
9157 goto overflowBasic;
9158 }
9159 }
9160 break;
9161
9162 case INST_SUB:
9163 wResult = w1 - w2;
9164 #ifndef TCL_WIDE_INT_IS_LONG
9165 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
9166 #endif
9167 {
9168 /*
9169 * Must check for overflow. The macro tests for overflows
9170 * in sums by looking at the sign bits. As we have a
9171 * subtraction here, we are adding -w2. As -w2 could in
9172 * turn overflow, we test with ~w2 instead: it has the
9173 * opposite sign bit to w2 so it does the job. Note that
9174 * the only "bad" case (w2==0) is irrelevant for this
9175 * macro, as in that case w1 and wResult have the same
9176 * sign and there is no overflow anyway.
9177 */
9178
9179 if (Overflowing(w1, ~w2, wResult)) {
9180 goto overflowBasic;
9181 }
9182 }
9183 break;
9184
9185 case INST_MULT:
9186 if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG)
9187 || (sizeof(Tcl_WideInt) < 2*sizeof(long))) {
9188 goto overflowBasic;
9189 }
9190 wResult = w1 * w2;
9191 break;
9192
9193 case INST_DIV:
9194 if (w2 == 0) {
9195 return DIVIDED_BY_ZERO;
9196 }
9197
9198 /*
9199 * Need a bignum to represent (LLONG_MIN / -1)
9200 */
9201
9202 if ((w1 == LLONG_MIN) && (w2 == -1)) {
9203 goto overflowBasic;
9204 }
9205 wResult = w1 / w2;
9206
9207 /*
9208 * Force Tcl's integer division rules.
9209 * TODO: examine for logic simplification
9210 */
9211
9212 if (((wResult < 0) || ((wResult == 0) &&
9213 ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
9214 (wResult*w2 != w1)) {
9215 wResult -= 1;
9216 }
9217 break;
9218
9219 default:
9220 /*
9221 * Unused, here to silence compiler warning.
9222 */
9223
9224 wResult = 0;
9225 }
9226
9227 WIDE_RESULT(wResult);
9228 }
9229
9230 overflowBasic:
9231 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
9232 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
9233 mp_init(&bigResult);
9234 switch (opcode) {
9235 case INST_ADD:
9236 mp_add(&big1, &big2, &bigResult);
9237 break;
9238 case INST_SUB:
9239 mp_sub(&big1, &big2, &bigResult);
9240 break;
9241 case INST_MULT:
9242 mp_mul(&big1, &big2, &bigResult);
9243 break;
9244 case INST_DIV:
9245 if (mp_iszero(&big2)) {
9246 mp_clear(&big1);
9247 mp_clear(&big2);
9248 mp_clear(&bigResult);
9249 return DIVIDED_BY_ZERO;
9250 }
9251 mp_init(&bigRemainder);
9252 mp_div(&big1, &big2, &bigResult, &bigRemainder);
9253 /* TODO: internals intrusion */
9254 if (!mp_iszero(&bigRemainder)
9255 && (bigRemainder.sign != big2.sign)) {
9256 /*
9257 * Convert to Tcl's integer division rules.
9258 */
9259
9260 mp_sub_d(&bigResult, 1, &bigResult);
9261 mp_add(&bigRemainder, &big2, &bigRemainder);
9262 }
9263 mp_clear(&bigRemainder);
9264 break;
9265 }
9266 mp_clear(&big1);
9267 mp_clear(&big2);
9268 BIG_RESULT(&bigResult);
9269 }
9270
9271 Tcl_Panic("unexpected opcode");
9272 return NULL;
9273 }
9274
9275 static Tcl_Obj *
ExecuteExtendedUnaryMathOp(int opcode,Tcl_Obj * valuePtr)9276 ExecuteExtendedUnaryMathOp(
9277 int opcode, /* What operation to perform. */
9278 Tcl_Obj *valuePtr) /* The operand on the stack. */
9279 {
9280 ClientData ptr = NULL;
9281 int type;
9282 Tcl_WideInt w;
9283 mp_int big;
9284 Tcl_Obj *objResultPtr;
9285
9286 (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
9287
9288 switch (opcode) {
9289 case INST_BITNOT:
9290 #ifndef TCL_WIDE_INT_IS_LONG
9291 if (type == TCL_NUMBER_WIDE) {
9292 w = *((const Tcl_WideInt *) ptr);
9293 WIDE_RESULT(~w);
9294 }
9295 #endif
9296 Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
9297 /* ~a = - a - 1 */
9298 (void)mp_neg(&big, &big);
9299 mp_sub_d(&big, 1, &big);
9300 BIG_RESULT(&big);
9301 case INST_UMINUS:
9302 switch (type) {
9303 case TCL_NUMBER_DOUBLE:
9304 DOUBLE_RESULT(-(*((const double *) ptr)));
9305 case TCL_NUMBER_LONG:
9306 w = (Tcl_WideInt) (*((const long *) ptr));
9307 if (w != LLONG_MIN) {
9308 WIDE_RESULT(-w);
9309 }
9310 TclBNInitBignumFromLong(&big, *(const long *) ptr);
9311 break;
9312 #ifndef TCL_WIDE_INT_IS_LONG
9313 case TCL_NUMBER_WIDE:
9314 w = *((const Tcl_WideInt *) ptr);
9315 if (w != LLONG_MIN) {
9316 WIDE_RESULT(-w);
9317 }
9318 TclBNInitBignumFromWideInt(&big, w);
9319 break;
9320 #endif
9321 default:
9322 Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
9323 }
9324 (void)mp_neg(&big, &big);
9325 BIG_RESULT(&big);
9326 }
9327
9328 Tcl_Panic("unexpected opcode");
9329 return NULL;
9330 }
9331 #undef LONG_RESULT
9332 #undef WIDE_RESULT
9333 #undef BIG_RESULT
9334 #undef DOUBLE_RESULT
9335
9336 /*
9337 *----------------------------------------------------------------------
9338 *
9339 * CompareTwoNumbers --
9340 *
9341 * This function compares a pair of numbers in Tcl_Objs. Each argument
9342 * must already be known to be numeric and not NaN.
9343 *
9344 * Results:
9345 * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less
9346 * than, equal to, or greater than value2Ptr (respectively).
9347 *
9348 * Side effects:
9349 * None, provided both values are numeric.
9350 *
9351 *----------------------------------------------------------------------
9352 */
9353
9354 int
TclCompareTwoNumbers(Tcl_Obj * valuePtr,Tcl_Obj * value2Ptr)9355 TclCompareTwoNumbers(
9356 Tcl_Obj *valuePtr,
9357 Tcl_Obj *value2Ptr)
9358 {
9359 int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare;
9360 ClientData ptr1, ptr2;
9361 mp_int big1, big2;
9362 double d1, d2, tmp;
9363 long l1, l2;
9364 #ifndef TCL_WIDE_INT_IS_LONG
9365 Tcl_WideInt w1, w2;
9366 #endif
9367
9368 (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
9369 (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
9370
9371 switch (type1) {
9372 case TCL_NUMBER_LONG:
9373 l1 = *((const long *)ptr1);
9374 switch (type2) {
9375 case TCL_NUMBER_LONG:
9376 l2 = *((const long *)ptr2);
9377 longCompare:
9378 return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
9379 #ifndef TCL_WIDE_INT_IS_LONG
9380 case TCL_NUMBER_WIDE:
9381 w2 = *((const Tcl_WideInt *)ptr2);
9382 w1 = (Tcl_WideInt)l1;
9383 goto wideCompare;
9384 #endif
9385 case TCL_NUMBER_DOUBLE:
9386 d2 = *((const double *)ptr2);
9387 d1 = (double) l1;
9388
9389 /*
9390 * If the double has a fractional part, or if the long can be
9391 * converted to double without loss of precision, then compare as
9392 * doubles.
9393 */
9394
9395 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1
9396 || modf(d2, &tmp) != 0.0) {
9397 goto doubleCompare;
9398 }
9399
9400 /*
9401 * Otherwise, to make comparision based on full precision, need to
9402 * convert the double to a suitably sized integer.
9403 *
9404 * Need this to get comparsions like
9405 * expr 20000000000000003 < 20000000000000004.0
9406 * right. Converting the first argument to double will yield two
9407 * double values that are equivalent within double precision.
9408 * Converting the double to an integer gets done exactly, then
9409 * integer comparison can tell the difference.
9410 */
9411
9412 if (d2 < (double)LONG_MIN) {
9413 return MP_GT;
9414 }
9415 if (d2 > (double)LONG_MAX) {
9416 return MP_LT;
9417 }
9418 l2 = (long) d2;
9419 goto longCompare;
9420 case TCL_NUMBER_BIG:
9421 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
9422 if (mp_cmp_d(&big2, 0) == MP_LT) {
9423 compare = MP_GT;
9424 } else {
9425 compare = MP_LT;
9426 }
9427 mp_clear(&big2);
9428 return compare;
9429 }
9430 break;
9431
9432 #ifndef TCL_WIDE_INT_IS_LONG
9433 case TCL_NUMBER_WIDE:
9434 w1 = *((const Tcl_WideInt *)ptr1);
9435 switch (type2) {
9436 case TCL_NUMBER_WIDE:
9437 w2 = *((const Tcl_WideInt *)ptr2);
9438 wideCompare:
9439 return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
9440 case TCL_NUMBER_LONG:
9441 l2 = *((const long *)ptr2);
9442 w2 = (Tcl_WideInt)l2;
9443 goto wideCompare;
9444 case TCL_NUMBER_DOUBLE:
9445 d2 = *((const double *)ptr2);
9446 d1 = (double) w1;
9447 if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
9448 || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) {
9449 goto doubleCompare;
9450 }
9451 if (d2 < (double)LLONG_MIN) {
9452 return MP_GT;
9453 }
9454 if (d2 > (double)LLONG_MAX) {
9455 return MP_LT;
9456 }
9457 w2 = (Tcl_WideInt) d2;
9458 goto wideCompare;
9459 case TCL_NUMBER_BIG:
9460 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
9461 if (mp_isneg(&big2)) {
9462 compare = MP_GT;
9463 } else {
9464 compare = MP_LT;
9465 }
9466 mp_clear(&big2);
9467 return compare;
9468 }
9469 break;
9470 #endif
9471
9472 case TCL_NUMBER_DOUBLE:
9473 d1 = *((const double *)ptr1);
9474 switch (type2) {
9475 case TCL_NUMBER_DOUBLE:
9476 d2 = *((const double *)ptr2);
9477 doubleCompare:
9478 return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
9479 case TCL_NUMBER_LONG:
9480 l2 = *((const long *)ptr2);
9481 d2 = (double) l2;
9482 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2
9483 || modf(d1, &tmp) != 0.0) {
9484 goto doubleCompare;
9485 }
9486 if (d1 < (double)LONG_MIN) {
9487 return MP_LT;
9488 }
9489 if (d1 > (double)LONG_MAX) {
9490 return MP_GT;
9491 }
9492 l1 = (long) d1;
9493 goto longCompare;
9494 #ifndef TCL_WIDE_INT_IS_LONG
9495 case TCL_NUMBER_WIDE:
9496 w2 = *((const Tcl_WideInt *)ptr2);
9497 d2 = (double) w2;
9498 if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
9499 || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) {
9500 goto doubleCompare;
9501 }
9502 if (d1 < (double)LLONG_MIN) {
9503 return MP_LT;
9504 }
9505 if (d1 > (double)LLONG_MAX) {
9506 return MP_GT;
9507 }
9508 w1 = (Tcl_WideInt) d1;
9509 goto wideCompare;
9510 #endif
9511 case TCL_NUMBER_BIG:
9512 if (TclIsInfinite(d1)) {
9513 return (d1 > 0.0) ? MP_GT : MP_LT;
9514 }
9515 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
9516 if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
9517 if (mp_isneg(&big2)) {
9518 compare = MP_GT;
9519 } else {
9520 compare = MP_LT;
9521 }
9522 mp_clear(&big2);
9523 return compare;
9524 }
9525 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
9526 && modf(d1, &tmp) != 0.0) {
9527 d2 = TclBignumToDouble(&big2);
9528 mp_clear(&big2);
9529 goto doubleCompare;
9530 }
9531 Tcl_InitBignumFromDouble(NULL, d1, &big1);
9532 goto bigCompare;
9533 }
9534 break;
9535
9536 case TCL_NUMBER_BIG:
9537 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
9538 switch (type2) {
9539 #ifndef TCL_WIDE_INT_IS_LONG
9540 case TCL_NUMBER_WIDE:
9541 #endif
9542 case TCL_NUMBER_LONG:
9543 compare = mp_cmp_d(&big1, 0);
9544 mp_clear(&big1);
9545 return compare;
9546 case TCL_NUMBER_DOUBLE:
9547 d2 = *((const double *)ptr2);
9548 if (TclIsInfinite(d2)) {
9549 compare = (d2 > 0.0) ? MP_LT : MP_GT;
9550 mp_clear(&big1);
9551 return compare;
9552 }
9553 if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
9554 compare = mp_cmp_d(&big1, 0);
9555 mp_clear(&big1);
9556 return compare;
9557 }
9558 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
9559 && modf(d2, &tmp) != 0.0) {
9560 d1 = TclBignumToDouble(&big1);
9561 mp_clear(&big1);
9562 goto doubleCompare;
9563 }
9564 Tcl_InitBignumFromDouble(NULL, d2, &big2);
9565 goto bigCompare;
9566 case TCL_NUMBER_BIG:
9567 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
9568 bigCompare:
9569 compare = mp_cmp(&big1, &big2);
9570 mp_clear(&big1);
9571 mp_clear(&big2);
9572 return compare;
9573 }
9574 break;
9575 default:
9576 Tcl_Panic("unexpected number type");
9577 }
9578 return TCL_ERROR;
9579 }
9580
9581 #ifdef TCL_COMPILE_DEBUG
9582 /*
9583 *----------------------------------------------------------------------
9584 *
9585 * PrintByteCodeInfo --
9586 *
9587 * This procedure prints a summary about a bytecode object to stdout. It
9588 * is called by TclNRExecuteByteCode when starting to execute the bytecode
9589 * object if tclTraceExec has the value 2 or more.
9590 *
9591 * Results:
9592 * None.
9593 *
9594 * Side effects:
9595 * None.
9596 *
9597 *----------------------------------------------------------------------
9598 */
9599
9600 static void
PrintByteCodeInfo(ByteCode * codePtr)9601 PrintByteCodeInfo(
9602 ByteCode *codePtr) /* The bytecode whose summary is printed to
9603 * stdout. */
9604 {
9605 Proc *procPtr = codePtr->procPtr;
9606 Interp *iPtr = (Interp *) *codePtr->interpHandle;
9607
9608 fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
9609 codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
9610 iPtr->compileEpoch);
9611
9612 fprintf(stdout, " Source: ");
9613 TclPrintSource(stdout, codePtr->source, 60);
9614
9615 fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
9616 codePtr->numCommands, codePtr->numSrcBytes,
9617 codePtr->numCodeBytes, codePtr->numLitObjects,
9618 codePtr->numAuxDataItems, codePtr->maxStackDepth,
9619 #ifdef TCL_COMPILE_STATS
9620 codePtr->numSrcBytes?
9621 ((float)codePtr->structureSize)/codePtr->numSrcBytes :
9622 #endif
9623 0.0);
9624
9625 #ifdef TCL_COMPILE_STATS
9626 fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
9627 (unsigned long) codePtr->structureSize,
9628 (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)),
9629 codePtr->numCodeBytes,
9630 (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
9631 (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
9632 (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
9633 codePtr->numCmdLocBytes);
9634 #endif /* TCL_COMPILE_STATS */
9635 if (procPtr != NULL) {
9636 fprintf(stdout,
9637 " Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
9638 procPtr, procPtr->refCount, procPtr->numArgs,
9639 procPtr->numCompiledLocals);
9640 }
9641 }
9642 #endif /* TCL_COMPILE_DEBUG */
9643
9644 /*
9645 *----------------------------------------------------------------------
9646 *
9647 * ValidatePcAndStackTop --
9648 *
9649 * This procedure is called by TclNRExecuteByteCode when debugging to
9650 * verify that the program counter and stack top are valid during
9651 * execution.
9652 *
9653 * Results:
9654 * None.
9655 *
9656 * Side effects:
9657 * Prints a message to stderr and panics if either the pc or stack top
9658 * are invalid.
9659 *
9660 *----------------------------------------------------------------------
9661 */
9662
9663 #ifdef TCL_COMPILE_DEBUG
9664 static void
ValidatePcAndStackTop(ByteCode * codePtr,const unsigned char * pc,int stackTop,int checkStack)9665 ValidatePcAndStackTop(
9666 ByteCode *codePtr, /* The bytecode whose summary is printed to
9667 * stdout. */
9668 const unsigned char *pc, /* Points to first byte of a bytecode
9669 * instruction. The program counter. */
9670 int stackTop, /* Current stack top. Must be between
9671 * stackLowerBound and stackUpperBound
9672 * (inclusive). */
9673 int checkStack) /* 0 if the stack depth check should be
9674 * skipped. */
9675 {
9676 int stackUpperBound = codePtr->maxStackDepth;
9677 /* Greatest legal value for stackTop. */
9678 size_t relativePc = (size_t) (pc - codePtr->codeStart);
9679 size_t codeStart = (size_t) codePtr->codeStart;
9680 size_t codeEnd = (size_t)
9681 (codePtr->codeStart + codePtr->numCodeBytes);
9682 unsigned char opCode = *pc;
9683
9684 if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) {
9685 fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
9686 pc);
9687 Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
9688 }
9689 if ((unsigned) opCode > LAST_INST_OPCODE) {
9690 fprintf(stderr, "\nBad opcode %d at pc %lu in TclNRExecuteByteCode\n",
9691 (unsigned) opCode, (unsigned long)relativePc);
9692 Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
9693 }
9694 if (checkStack &&
9695 ((stackTop < 0) || (stackTop > stackUpperBound))) {
9696 int numChars;
9697 const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
9698
9699 fprintf(stderr, "\nBad stack top %d at pc %lu in TclNRExecuteByteCode (min 0, max %i)",
9700 stackTop, (unsigned long)relativePc, stackUpperBound);
9701 if (cmd != NULL) {
9702 Tcl_Obj *message;
9703
9704 TclNewLiteralStringObj(message, "\n executing ");
9705 Tcl_IncrRefCount(message);
9706 Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
9707 fprintf(stderr,"%s\n", Tcl_GetString(message));
9708 Tcl_DecrRefCount(message);
9709 } else {
9710 fprintf(stderr, "\n");
9711 }
9712 Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top");
9713 }
9714 }
9715 #endif /* TCL_COMPILE_DEBUG */
9716
9717 /*
9718 *----------------------------------------------------------------------
9719 *
9720 * IllegalExprOperandType --
9721 *
9722 * Used by TclNRExecuteByteCode to append an error message to the interp
9723 * result when an illegal operand type is detected by an expression
9724 * instruction. The argument opndPtr holds the operand object in error.
9725 *
9726 * Results:
9727 * None.
9728 *
9729 * Side effects:
9730 * An error message is appended to the interp result.
9731 *
9732 *----------------------------------------------------------------------
9733 */
9734
9735 static void
IllegalExprOperandType(Tcl_Interp * interp,const unsigned char * pc,Tcl_Obj * opndPtr)9736 IllegalExprOperandType(
9737 Tcl_Interp *interp, /* Interpreter to which error information
9738 * pertains. */
9739 const unsigned char *pc, /* Points to the instruction being executed
9740 * when the illegal type was found. */
9741 Tcl_Obj *opndPtr) /* Points to the operand holding the value
9742 * with the illegal type. */
9743 {
9744 ClientData ptr;
9745 int type;
9746 const unsigned char opcode = *pc;
9747 const char *description, *op = "unknown";
9748
9749 if (opcode == INST_EXPON) {
9750 op = "**";
9751 } else if (opcode <= INST_LNOT) {
9752 op = operatorStrings[opcode - INST_LOR];
9753 }
9754
9755 if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
9756 int numBytes;
9757 const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
9758
9759 if (numBytes == 0) {
9760 description = "empty string";
9761 } else if (TclCheckBadOctal(NULL, bytes)) {
9762 description = "invalid octal number";
9763 } else {
9764 description = "non-numeric string";
9765 }
9766 } else if (type == TCL_NUMBER_NAN) {
9767 description = "non-numeric floating-point value";
9768 } else if (type == TCL_NUMBER_DOUBLE) {
9769 description = "floating-point value";
9770 } else {
9771 /* TODO: No caller needs this. Eliminate? */
9772 description = "(big) integer";
9773 }
9774
9775 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
9776 "can't use %s as operand of \"%s\"", description, op));
9777 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
9778 }
9779
9780 /*
9781 *----------------------------------------------------------------------
9782 *
9783 * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
9784 *
9785 * Given a program counter value, finds the closest command in the
9786 * bytecode code unit's CmdLocation array and returns information about
9787 * that command's source: a pointer to its first byte and the number of
9788 * characters.
9789 *
9790 * Results:
9791 * If a command is found that encloses the program counter value, a
9792 * pointer to the command's source is returned and the length of the
9793 * source is stored at *lengthPtr. If multiple commands resulted in code
9794 * at pc, information about the closest enclosing command is returned. If
9795 * no matching command is found, NULL is returned and *lengthPtr is
9796 * unchanged.
9797 *
9798 * Side effects:
9799 * The CmdFrame at *cfPtr is updated.
9800 *
9801 *----------------------------------------------------------------------
9802 */
9803
9804 Tcl_Obj *
TclGetSourceFromFrame(CmdFrame * cfPtr,int objc,Tcl_Obj * const objv[])9805 TclGetSourceFromFrame(
9806 CmdFrame *cfPtr,
9807 int objc,
9808 Tcl_Obj *const objv[])
9809 {
9810 if (cfPtr == NULL) {
9811 return Tcl_NewListObj(objc, objv);
9812 }
9813 if (cfPtr->cmdObj == NULL) {
9814 if (cfPtr->cmd == NULL) {
9815 ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
9816
9817 cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
9818 cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
9819 }
9820 if (cfPtr->cmd) {
9821 cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
9822 } else {
9823 cfPtr->cmdObj = Tcl_NewListObj(objc, objv);
9824 }
9825 Tcl_IncrRefCount(cfPtr->cmdObj);
9826 }
9827 return cfPtr->cmdObj;
9828 }
9829
9830 void
TclGetSrcInfoForPc(CmdFrame * cfPtr)9831 TclGetSrcInfoForPc(
9832 CmdFrame *cfPtr)
9833 {
9834 ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
9835
9836 assert(cfPtr->type == TCL_LOCATION_BC);
9837
9838 if (cfPtr->cmd == NULL) {
9839
9840 cfPtr->cmd = GetSrcInfoForPc(
9841 (unsigned char *) cfPtr->data.tebc.pc, codePtr,
9842 &cfPtr->len, NULL, NULL);
9843 }
9844
9845 if (cfPtr->cmd != NULL) {
9846 /*
9847 * We now have the command. We can get the srcOffset back and from
9848 * there find the list of word locations for this command.
9849 */
9850
9851 ExtCmdLoc *eclPtr;
9852 ECL *locPtr = NULL;
9853 int srcOffset, i;
9854 Interp *iPtr = (Interp *) *codePtr->interpHandle;
9855 Tcl_HashEntry *hePtr =
9856 Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
9857
9858 if (!hePtr) {
9859 return;
9860 }
9861
9862 srcOffset = cfPtr->cmd - codePtr->source;
9863 eclPtr = Tcl_GetHashValue(hePtr);
9864
9865 for (i=0; i < eclPtr->nuloc; i++) {
9866 if (eclPtr->loc[i].srcOffset == srcOffset) {
9867 locPtr = eclPtr->loc+i;
9868 break;
9869 }
9870 }
9871 if (locPtr == NULL) {
9872 Tcl_Panic("LocSearch failure");
9873 }
9874
9875 cfPtr->line = locPtr->line;
9876 cfPtr->nline = locPtr->nline;
9877 cfPtr->type = eclPtr->type;
9878
9879 if (eclPtr->type == TCL_LOCATION_SOURCE) {
9880 cfPtr->data.eval.path = eclPtr->path;
9881 Tcl_IncrRefCount(cfPtr->data.eval.path);
9882 }
9883
9884 /*
9885 * Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for
9886 * cfPtr->data.tebc.codePtr.
9887 */
9888 }
9889 }
9890
9891 static const char *
GetSrcInfoForPc(const unsigned char * pc,ByteCode * codePtr,int * lengthPtr,const unsigned char ** pcBeg,int * cmdIdxPtr)9892 GetSrcInfoForPc(
9893 const unsigned char *pc, /* The program counter value for which to
9894 * return the closest command's source info.
9895 * This points within a bytecode instruction
9896 * in codePtr's code. */
9897 ByteCode *codePtr, /* The bytecode sequence in which to look up
9898 * the command source for the pc. */
9899 int *lengthPtr, /* If non-NULL, the location where the length
9900 * of the command's source should be stored.
9901 * If NULL, no length is stored. */
9902 const unsigned char **pcBeg,/* If non-NULL, the bytecode location
9903 * where the current instruction starts.
9904 * If NULL; no pointer is stored. */
9905 int *cmdIdxPtr) /* If non-NULL, the location where the index
9906 * of the command containing the pc should
9907 * be stored. */
9908 {
9909 int pcOffset = (pc - codePtr->codeStart);
9910 int numCmds = codePtr->numCommands;
9911 unsigned char *codeDeltaNext, *codeLengthNext;
9912 unsigned char *srcDeltaNext, *srcLengthNext;
9913 int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
9914 int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
9915 int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
9916 int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
9917 int bestCmdIdx = -1;
9918
9919 /* The pc must point within the bytecode */
9920 assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes));
9921
9922 /*
9923 * Decode the code and source offset and length for each command. The
9924 * closest enclosing command is the last one whose code started before
9925 * pcOffset.
9926 */
9927
9928 codeDeltaNext = codePtr->codeDeltaStart;
9929 codeLengthNext = codePtr->codeLengthStart;
9930 srcDeltaNext = codePtr->srcDeltaStart;
9931 srcLengthNext = codePtr->srcLengthStart;
9932 codeOffset = srcOffset = 0;
9933 for (i = 0; i < numCmds; i++) {
9934 if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
9935 codeDeltaNext++;
9936 delta = TclGetInt4AtPtr(codeDeltaNext);
9937 codeDeltaNext += 4;
9938 } else {
9939 delta = TclGetInt1AtPtr(codeDeltaNext);
9940 codeDeltaNext++;
9941 }
9942 codeOffset += delta;
9943
9944 if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
9945 codeLengthNext++;
9946 codeLen = TclGetInt4AtPtr(codeLengthNext);
9947 codeLengthNext += 4;
9948 } else {
9949 codeLen = TclGetInt1AtPtr(codeLengthNext);
9950 codeLengthNext++;
9951 }
9952 codeEnd = (codeOffset + codeLen - 1);
9953
9954 if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
9955 srcDeltaNext++;
9956 delta = TclGetInt4AtPtr(srcDeltaNext);
9957 srcDeltaNext += 4;
9958 } else {
9959 delta = TclGetInt1AtPtr(srcDeltaNext);
9960 srcDeltaNext++;
9961 }
9962 srcOffset += delta;
9963
9964 if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
9965 srcLengthNext++;
9966 srcLen = TclGetInt4AtPtr(srcLengthNext);
9967 srcLengthNext += 4;
9968 } else {
9969 srcLen = TclGetInt1AtPtr(srcLengthNext);
9970 srcLengthNext++;
9971 }
9972
9973 if (codeOffset > pcOffset) { /* Best cmd already found */
9974 break;
9975 }
9976 if (pcOffset <= codeEnd) { /* This cmd's code encloses pc */
9977 int dist = (pcOffset - codeOffset);
9978
9979 if (dist <= bestDist) {
9980 bestDist = dist;
9981 bestSrcOffset = srcOffset;
9982 bestSrcLength = srcLen;
9983 bestCmdIdx = i;
9984 }
9985 }
9986 }
9987
9988 if (pcBeg != NULL) {
9989 const unsigned char *curr, *prev;
9990
9991 /*
9992 * Walk from beginning of command or BC to pc, by complete
9993 * instructions. Stop when crossing pc; keep previous.
9994 */
9995
9996 curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist);
9997 prev = curr;
9998 while (curr <= pc) {
9999 prev = curr;
10000 curr += tclInstructionTable[*curr].numBytes;
10001 }
10002 *pcBeg = prev;
10003 }
10004
10005 if (bestDist == INT_MAX) {
10006 return NULL;
10007 }
10008
10009 if (lengthPtr != NULL) {
10010 *lengthPtr = bestSrcLength;
10011 }
10012
10013 if (cmdIdxPtr != NULL) {
10014 *cmdIdxPtr = bestCmdIdx;
10015 }
10016
10017 return (codePtr->source + bestSrcOffset);
10018 }
10019
10020 /*
10021 *----------------------------------------------------------------------
10022 *
10023 * GetExceptRangeForPc --
10024 *
10025 * Given a program counter value, return the closest enclosing
10026 * ExceptionRange.
10027 *
10028 * Results:
10029 * If the searchMode is TCL_ERROR, this procedure ignores loop exception
10030 * ranges and returns a pointer to the closest catch range. If the
10031 * searchMode is TCL_BREAK, this procedure returns a pointer to the most
10032 * closely enclosing ExceptionRange regardless of whether it is a loop or
10033 * catch exception range. If the searchMode is TCL_CONTINUE, this
10034 * procedure returns a pointer to the most closely enclosing
10035 * ExceptionRange (of any type) skipping only loop exception ranges if
10036 * they don't have a sensible continueOffset defined. If no matching
10037 * ExceptionRange is found that encloses pc, a NULL is returned.
10038 *
10039 * Side effects:
10040 * None.
10041 *
10042 *----------------------------------------------------------------------
10043 */
10044
10045 static ExceptionRange *
GetExceptRangeForPc(const unsigned char * pc,int searchMode,ByteCode * codePtr)10046 GetExceptRangeForPc(
10047 const unsigned char *pc, /* The program counter value for which to
10048 * search for a closest enclosing exception
10049 * range. This points to a bytecode
10050 * instruction in codePtr's code. */
10051 int searchMode, /* If TCL_BREAK, consider either loop or catch
10052 * ExceptionRanges in search. If TCL_ERROR
10053 * consider only catch ranges (and ignore any
10054 * closer loop ranges). If TCL_CONTINUE, look
10055 * for loop ranges that define a continue
10056 * point or a catch range. */
10057 ByteCode *codePtr) /* Points to the ByteCode in which to search
10058 * for the enclosing ExceptionRange. */
10059 {
10060 ExceptionRange *rangeArrayPtr;
10061 int numRanges = codePtr->numExceptRanges;
10062 ExceptionRange *rangePtr;
10063 int pcOffset = pc - codePtr->codeStart;
10064 int start;
10065
10066 if (numRanges == 0) {
10067 return NULL;
10068 }
10069
10070 /*
10071 * This exploits peculiarities of our compiler: nested ranges are always
10072 * *after* their containing ranges, so that by scanning backwards we are
10073 * sure that the first matching range is indeed the deepest.
10074 */
10075
10076 rangeArrayPtr = codePtr->exceptArrayPtr;
10077 rangePtr = rangeArrayPtr + numRanges;
10078 while (--rangePtr >= rangeArrayPtr) {
10079 start = rangePtr->codeOffset;
10080 if ((start <= pcOffset) &&
10081 (pcOffset < (start + rangePtr->numCodeBytes))) {
10082 if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
10083 return rangePtr;
10084 }
10085 if (searchMode == TCL_BREAK) {
10086 return rangePtr;
10087 }
10088 if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){
10089 return rangePtr;
10090 }
10091 }
10092 }
10093 return NULL;
10094 }
10095
10096 /*
10097 *----------------------------------------------------------------------
10098 *
10099 * GetOpcodeName --
10100 *
10101 * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used
10102 * in TclNRExecuteByteCode when debugging. It returns the name of the
10103 * bytecode instruction at a specified instruction pc.
10104 *
10105 * Results:
10106 * A character string for the instruction.
10107 *
10108 * Side effects:
10109 * None.
10110 *
10111 *----------------------------------------------------------------------
10112 */
10113
10114 #ifdef TCL_COMPILE_DEBUG
10115 static const char *
GetOpcodeName(const unsigned char * pc)10116 GetOpcodeName(
10117 const unsigned char *pc) /* Points to the instruction whose name should
10118 * be returned. */
10119 {
10120 unsigned char opCode = *pc;
10121
10122 return tclInstructionTable[opCode].name;
10123 }
10124 #endif /* TCL_COMPILE_DEBUG */
10125
10126 /*
10127 *----------------------------------------------------------------------
10128 *
10129 * TclExprFloatError --
10130 *
10131 * This procedure is called when an error occurs during a floating-point
10132 * operation. It reads errno and sets interp->objResultPtr accordingly.
10133 *
10134 * Results:
10135 * interp->objResultPtr is set to hold an error message.
10136 *
10137 * Side effects:
10138 * None.
10139 *
10140 *----------------------------------------------------------------------
10141 */
10142
10143 void
TclExprFloatError(Tcl_Interp * interp,double value)10144 TclExprFloatError(
10145 Tcl_Interp *interp, /* Where to store error message. */
10146 double value) /* Value returned after error; used to
10147 * distinguish underflows from overflows. */
10148 {
10149 const char *s;
10150
10151 if ((errno == EDOM) || TclIsNaN(value)) {
10152 s = "domain error: argument not in valid range";
10153 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
10154 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
10155 } else if ((errno == ERANGE) || TclIsInfinite(value)) {
10156 if (value == 0.0) {
10157 s = "floating-point value too small to represent";
10158 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
10159 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL);
10160 } else {
10161 s = "floating-point value too large to represent";
10162 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
10163 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL);
10164 }
10165 } else {
10166 Tcl_Obj *objPtr = Tcl_ObjPrintf(
10167 "unknown floating-point error, errno = %d", errno);
10168
10169 Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
10170 Tcl_GetString(objPtr), NULL);
10171 Tcl_SetObjResult(interp, objPtr);
10172 }
10173 }
10174
10175 #ifdef TCL_COMPILE_STATS
10176 /*
10177 *----------------------------------------------------------------------
10178 *
10179 * TclLog2 --
10180 *
10181 * Procedure used while collecting compilation statistics to determine
10182 * the log base 2 of an integer.
10183 *
10184 * Results:
10185 * Returns the log base 2 of the operand. If the argument is less than or
10186 * equal to zero, a zero is returned.
10187 *
10188 * Side effects:
10189 * None.
10190 *
10191 *----------------------------------------------------------------------
10192 */
10193
10194 int
TclLog2(int value)10195 TclLog2(
10196 int value) /* The integer for which to compute the log
10197 * base 2. */
10198 {
10199 int n = value;
10200 int result = 0;
10201
10202 while (n > 1) {
10203 n = n >> 1;
10204 result++;
10205 }
10206 return result;
10207 }
10208
10209 /*
10210 *----------------------------------------------------------------------
10211 *
10212 * EvalStatsCmd --
10213 *
10214 * Implements the "evalstats" command that prints instruction execution
10215 * counts to stdout.
10216 *
10217 * Results:
10218 * Standard Tcl results.
10219 *
10220 * Side effects:
10221 * None.
10222 *
10223 *----------------------------------------------------------------------
10224 */
10225
10226 static int
EvalStatsCmd(ClientData unused,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])10227 EvalStatsCmd(
10228 ClientData unused, /* Unused. */
10229 Tcl_Interp *interp, /* The current interpreter. */
10230 int objc, /* The number of arguments. */
10231 Tcl_Obj *const objv[]) /* The argument strings. */
10232 {
10233 Interp *iPtr = (Interp *) interp;
10234 LiteralTable *globalTablePtr = &iPtr->literalTable;
10235 ByteCodeStats *statsPtr = &iPtr->stats;
10236 double totalCodeBytes, currentCodeBytes;
10237 double totalLiteralBytes, currentLiteralBytes;
10238 double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
10239 double strBytesSharedMultX, strBytesSharedOnce;
10240 double numInstructions, currentHeaderBytes;
10241 long numCurrentByteCodes, numByteCodeLits;
10242 long refCountSum, literalMgmtBytes, sum;
10243 int numSharedMultX, numSharedOnce;
10244 int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
10245 char *litTableStats;
10246 LiteralEntry *entryPtr;
10247 Tcl_Obj *objPtr;
10248
10249 #define Percent(a,b) ((a) * 100.0 / (b))
10250
10251 TclNewObj(objPtr);
10252 Tcl_IncrRefCount(objPtr);
10253
10254 numInstructions = 0.0;
10255 for (i = 0; i < 256; i++) {
10256 if (statsPtr->instructionCount[i] != 0) {
10257 numInstructions += statsPtr->instructionCount[i];
10258 }
10259 }
10260
10261 totalLiteralBytes = sizeof(LiteralTable)
10262 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
10263 + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
10264 + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
10265 + statsPtr->totalLitStringBytes;
10266 totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
10267
10268 numCurrentByteCodes =
10269 statsPtr->numCompilations - statsPtr->numByteCodesFreed;
10270 currentHeaderBytes = numCurrentByteCodes
10271 * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time));
10272 literalMgmtBytes = sizeof(LiteralTable)
10273 + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
10274 + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
10275 currentLiteralBytes = literalMgmtBytes
10276 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
10277 + statsPtr->currentLitStringBytes;
10278 currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
10279
10280 /*
10281 * Summary statistics, total and current source and ByteCode sizes.
10282 */
10283
10284 Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
10285 Tcl_AppendPrintfToObj(objPtr,
10286 "Compilation and execution statistics for interpreter %#lx\n",
10287 (unsigned long)(size_t)iPtr);
10288
10289 Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
10290 statsPtr->numExecutions);
10291 Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
10292 statsPtr->numCompilations);
10293 Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
10294 statsPtr->numExecutions / (float)statsPtr->numCompilations);
10295
10296 Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
10297 numInstructions);
10298 Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n",
10299 numInstructions / statsPtr->numCompilations);
10300 Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
10301 numInstructions / statsPtr->numExecutions);
10302
10303 Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
10304 statsPtr->numCompilations);
10305 Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
10306 statsPtr->totalSrcBytes);
10307 Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
10308 totalCodeBytes);
10309 Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
10310 statsPtr->totalByteCodeBytes);
10311 Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
10312 totalLiteralBytes);
10313 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
10314 (unsigned long) sizeof(LiteralTable),
10315 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
10316 (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
10317 (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
10318 statsPtr->totalLitStringBytes);
10319 Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
10320 totalCodeBytes / statsPtr->numCompilations);
10321 Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
10322 totalCodeBytes / statsPtr->totalSrcBytes);
10323
10324 Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
10325 numCurrentByteCodes);
10326 Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
10327 statsPtr->currentSrcBytes);
10328 Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
10329 currentCodeBytes);
10330 Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
10331 statsPtr->currentByteCodeBytes);
10332 Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
10333 currentLiteralBytes);
10334 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
10335 (unsigned long) sizeof(LiteralTable),
10336 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
10337 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
10338 (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
10339 statsPtr->currentLitStringBytes);
10340 Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
10341 currentCodeBytes / statsPtr->currentSrcBytes);
10342 Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
10343 (currentCodeBytes + statsPtr->currentSrcBytes),
10344 (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
10345
10346 /*
10347 * Tcl_IsShared statistics check
10348 *
10349 * This gives the refcount of each obj as Tcl_IsShared was called for it.
10350 * Shared objects must be duplicated before they can be modified.
10351 */
10352
10353 numSharedMultX = 0;
10354 Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
10355 Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n",
10356 tclObjsShared[1]);
10357 for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
10358 Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
10359 i, tclObjsShared[i]);
10360 numSharedMultX += tclObjsShared[i];
10361 }
10362 Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
10363 i, tclObjsShared[0]);
10364 numSharedMultX += tclObjsShared[0];
10365 Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
10366 numSharedMultX);
10367
10368 /*
10369 * Literal table statistics.
10370 */
10371
10372 numByteCodeLits = 0;
10373 refCountSum = 0;
10374 numSharedMultX = 0;
10375 numSharedOnce = 0;
10376 objBytesIfUnshared = 0.0;
10377 strBytesIfUnshared = 0.0;
10378 strBytesSharedMultX = 0.0;
10379 strBytesSharedOnce = 0.0;
10380 for (i = 0; i < globalTablePtr->numBuckets; i++) {
10381 for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
10382 entryPtr = entryPtr->nextPtr) {
10383 if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
10384 numByteCodeLits++;
10385 }
10386 (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
10387 refCountSum += entryPtr->refCount;
10388 objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
10389 strBytesIfUnshared += (entryPtr->refCount * (length+1));
10390 if (entryPtr->refCount > 1) {
10391 numSharedMultX++;
10392 strBytesSharedMultX += (length+1);
10393 } else {
10394 numSharedOnce++;
10395 strBytesSharedOnce += (length+1);
10396 }
10397 }
10398 }
10399 sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
10400 - currentLiteralBytes;
10401
10402 Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
10403 tclObjsAlloced);
10404 Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
10405 (tclObjsAlloced - tclObjsFreed));
10406 Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
10407 statsPtr->numLiteralsCreated);
10408
10409 Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
10410 globalTablePtr->numEntries,
10411 Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
10412 Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
10413 numByteCodeLits,
10414 Percent(numByteCodeLits, globalTablePtr->numEntries));
10415 Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
10416 numSharedMultX);
10417 Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
10418 ((double) refCountSum) / globalTablePtr->numEntries);
10419 Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n",
10420 (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
10421 Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n",
10422 (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
10423 Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n",
10424 sharingBytesSaved,
10425 Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
10426 Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n",
10427 currentLiteralBytes);
10428 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
10429 (unsigned long) sizeof(LiteralTable),
10430 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
10431 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
10432 (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
10433 statsPtr->currentLitStringBytes);
10434 Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
10435 (objBytesIfUnshared + strBytesIfUnshared),
10436 objBytesIfUnshared, strBytesIfUnshared);
10437 Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
10438 (strBytesIfUnshared - statsPtr->currentLitStringBytes),
10439 strBytesIfUnshared, statsPtr->currentLitStringBytes);
10440 Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n",
10441 literalMgmtBytes,
10442 Percent(literalMgmtBytes, currentLiteralBytes));
10443 Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
10444 (unsigned long) sizeof(LiteralTable),
10445 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
10446 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)));
10447
10448 /*
10449 * Breakdown of current ByteCode space requirements.
10450 */
10451
10452 Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n");
10453 Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n");
10454 Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n");
10455 Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n",
10456 statsPtr->currentByteCodeBytes,
10457 statsPtr->currentByteCodeBytes / numCurrentByteCodes);
10458 Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n",
10459 currentHeaderBytes,
10460 Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
10461 currentHeaderBytes / numCurrentByteCodes);
10462 Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n",
10463 statsPtr->currentInstBytes,
10464 Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes),
10465 statsPtr->currentInstBytes / numCurrentByteCodes);
10466 Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
10467 statsPtr->currentLitBytes,
10468 Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes),
10469 statsPtr->currentLitBytes / numCurrentByteCodes);
10470 Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n",
10471 statsPtr->currentExceptBytes,
10472 Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes),
10473 statsPtr->currentExceptBytes / numCurrentByteCodes);
10474 Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
10475 statsPtr->currentAuxBytes,
10476 Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes),
10477 statsPtr->currentAuxBytes / numCurrentByteCodes);
10478 Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n",
10479 statsPtr->currentCmdMapBytes,
10480 Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes),
10481 statsPtr->currentCmdMapBytes / numCurrentByteCodes);
10482
10483 /*
10484 * Detailed literal statistics.
10485 */
10486
10487 Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
10488 Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
10489 maxSizeDecade = 0;
10490 for (i = 31; i >= 0; i--) {
10491 if (statsPtr->literalCount[i] > 0) {
10492 maxSizeDecade = i;
10493 break;
10494 }
10495 }
10496 sum = 0;
10497 for (i = 0; i <= maxSizeDecade; i++) {
10498 decadeHigh = (1 << (i+1)) - 1;
10499 sum += statsPtr->literalCount[i];
10500 Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
10501 decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
10502 }
10503
10504 litTableStats = TclLiteralStats(globalTablePtr);
10505 Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
10506 litTableStats);
10507 ckfree(litTableStats);
10508
10509 /*
10510 * Source and ByteCode size distributions.
10511 */
10512
10513 Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
10514 Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
10515 minSizeDecade = maxSizeDecade = 0;
10516 for (i = 0; i < 31; i++) {
10517 if (statsPtr->srcCount[i] > 0) {
10518 minSizeDecade = i;
10519 break;
10520 }
10521 }
10522 for (i = 31; i >= 0; i--) {
10523 if (statsPtr->srcCount[i] > 0) {
10524 maxSizeDecade = i;
10525 break;
10526 }
10527 }
10528 sum = 0;
10529 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
10530 decadeHigh = (1 << (i+1)) - 1;
10531 sum += statsPtr->srcCount[i];
10532 Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
10533 decadeHigh, Percent(sum, statsPtr->numCompilations));
10534 }
10535
10536 Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
10537 Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
10538 minSizeDecade = maxSizeDecade = 0;
10539 for (i = 0; i < 31; i++) {
10540 if (statsPtr->byteCodeCount[i] > 0) {
10541 minSizeDecade = i;
10542 break;
10543 }
10544 }
10545 for (i = 31; i >= 0; i--) {
10546 if (statsPtr->byteCodeCount[i] > 0) {
10547 maxSizeDecade = i;
10548 break;
10549 }
10550 }
10551 sum = 0;
10552 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
10553 decadeHigh = (1 << (i+1)) - 1;
10554 sum += statsPtr->byteCodeCount[i];
10555 Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
10556 decadeHigh, Percent(sum, statsPtr->numCompilations));
10557 }
10558
10559 Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
10560 Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
10561 minSizeDecade = maxSizeDecade = 0;
10562 for (i = 0; i < 31; i++) {
10563 if (statsPtr->lifetimeCount[i] > 0) {
10564 minSizeDecade = i;
10565 break;
10566 }
10567 }
10568 for (i = 31; i >= 0; i--) {
10569 if (statsPtr->lifetimeCount[i] > 0) {
10570 maxSizeDecade = i;
10571 break;
10572 }
10573 }
10574 sum = 0;
10575 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
10576 decadeHigh = (1 << (i+1)) - 1;
10577 sum += statsPtr->lifetimeCount[i];
10578 Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n",
10579 decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
10580 }
10581
10582 /*
10583 * Instruction counts.
10584 */
10585
10586 Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
10587 for (i = 0; i <= LAST_INST_OPCODE; i++) {
10588 Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
10589 tclInstructionTable[i].name, statsPtr->instructionCount[i]);
10590 if (statsPtr->instructionCount[i]) {
10591 Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
10592 Percent(statsPtr->instructionCount[i], numInstructions));
10593 } else {
10594 Tcl_AppendPrintfToObj(objPtr, "0\n");
10595 }
10596 }
10597
10598 #ifdef TCL_MEM_DEBUG
10599 Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
10600 TclDumpMemoryInfo((ClientData) objPtr, 1);
10601 #endif
10602 Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
10603
10604 if (objc == 1) {
10605 Tcl_SetObjResult(interp, objPtr);
10606 } else {
10607 Tcl_Channel outChan;
10608 char *str = Tcl_GetStringFromObj(objv[1], &length);
10609
10610 if (length) {
10611 if (strcmp(str, "stdout") == 0) {
10612 outChan = Tcl_GetStdChannel(TCL_STDOUT);
10613 } else if (strcmp(str, "stderr") == 0) {
10614 outChan = Tcl_GetStdChannel(TCL_STDERR);
10615 } else {
10616 outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664);
10617 }
10618 } else {
10619 outChan = Tcl_GetStdChannel(TCL_STDOUT);
10620 }
10621 if (outChan != NULL) {
10622 Tcl_WriteObj(outChan, objPtr);
10623 }
10624 }
10625 Tcl_DecrRefCount(objPtr);
10626 return TCL_OK;
10627 }
10628 #endif /* TCL_COMPILE_STATS */
10629
10630 #ifdef TCL_COMPILE_DEBUG
10631 /*
10632 *----------------------------------------------------------------------
10633 *
10634 * StringForResultCode --
10635 *
10636 * Procedure that returns a human-readable string representing a Tcl
10637 * result code such as TCL_ERROR.
10638 *
10639 * Results:
10640 * If the result code is one of the standard Tcl return codes, the result
10641 * is a string representing that code such as "TCL_ERROR". Otherwise, the
10642 * result string is that code formatted as a sequence of decimal digit
10643 * characters. Note that the resulting string must not be modified by the
10644 * caller.
10645 *
10646 * Side effects:
10647 * None.
10648 *
10649 *----------------------------------------------------------------------
10650 */
10651
10652 static const char *
StringForResultCode(int result)10653 StringForResultCode(
10654 int result) /* The Tcl result code for which to generate a
10655 * string. */
10656 {
10657 static char buf[TCL_INTEGER_SPACE];
10658
10659 if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
10660 return resultStrings[result];
10661 }
10662 TclFormatInt(buf, result);
10663 return buf;
10664 }
10665 #endif /* TCL_COMPILE_DEBUG */
10666
10667 /*
10668 * Local Variables:
10669 * mode: c
10670 * c-basic-offset: 4
10671 * fill-column: 78
10672 * End:
10673 */
10674