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