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