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