Changeset adeddd8 in git for external/tcl
- Timestamp:
- May 29, 2019, 2:53:12 PM (6 years ago)
- Branches:
- ImprovedOutputFile, Timing, master
- Children:
- 969eb19
- Parents:
- e15936c
- Location:
- external/tcl
- Files:
-
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
external/tcl/tcl.h
re15936c radeddd8 488 488 EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); 489 489 490 #ifdef TCL_MEM_DEBUG491 # define Tcl_IncrRefCount(objPtr) \492 Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)493 # define Tcl_DecrRefCount(objPtr) \494 Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)495 # define Tcl_IsShared(objPtr) \496 Tcl_DbIsShared(objPtr, __FILE__, __LINE__)497 #else498 490 # define Tcl_IncrRefCount(objPtr) \ 499 491 ++(objPtr)->refCount … … 502 494 # define Tcl_IsShared(objPtr) \ 503 495 ((objPtr)->refCount > 1) 504 #endif505 496 506 497 /* 507 498 * Macros and definitions that help to debug the use of Tcl objects. 508 * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are509 * overridden to call debugging versions of the object creation procedures.510 499 */ 511 500 … … 519 508 EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes, 520 509 int length)); 521 522 #ifdef TCL_MEM_DEBUG523 # define Tcl_NewBooleanObj(val) \524 Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)525 # define Tcl_NewDoubleObj(val) \526 Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)527 # define Tcl_NewIntObj(val) \528 Tcl_DbNewLongObj(val, __FILE__, __LINE__)529 # define Tcl_NewListObj(objc, objv) \530 Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)531 # define Tcl_NewLongObj(val) \532 Tcl_DbNewLongObj(val, __FILE__, __LINE__)533 # define Tcl_NewObj() \534 Tcl_DbNewObj(__FILE__, __LINE__)535 # define Tcl_NewStringObj(bytes, len) \536 Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)537 #endif /* TCL_MEM_DEBUG */538 510 539 511 /* … … 726 698 unsigned int size)); 727 699 728 #ifdef TCL_MEM_DEBUG729 730 # define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)731 # define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__)732 # define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)733 # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)734 # define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)735 # define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)736 737 EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName));738 EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,739 int line));740 741 #else742 743 700 /* 744 701 * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of … … 760 717 # define Tcl_DumpActiveMemory(x) 761 718 # define Tcl_ValidateAllMemory(x,y) 762 763 #endif /* TCL_MEM_DEBUG */764 719 765 720 /* -
external/tcl/tclBasic.c
re15936c radeddd8 3287 3287 TclInitByteCodeObj(objPtr, &compEnv); 3288 3288 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; 3289 if (tclTraceCompile == 2) {3290 TclPrintByteCodeObj(interp, objPtr);3291 }3292 3289 TclFreeCompileEnv(&compEnv); 3293 3290 } else { -
external/tcl/tclCkalloc.c
re15936c radeddd8 22 22 #define TRUE 1 23 23 24 #ifdef TCL_MEM_DEBUG25 26 /*27 * One of the following structures is allocated each time the28 * "memory tag" command is invoked, to hold the current tag.29 */30 31 typedef struct MemTag {32 int refCount; /* Number of mem_headers referencing33 * this tag. */34 char string[4]; /* Actual size of string will be as35 * large as needed for actual tag. This36 * must be the last field in the structure. */37 } MemTag;38 39 #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)40 41 static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers42 * (set by "memory tag" command). */43 44 /*45 * One of the following structures is allocated just before each46 * dynamically allocated chunk of memory, both to record information47 * about the chunk and to help detect chunk under-runs.48 */49 50 #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)51 struct mem_header {52 struct mem_header *flink;53 struct mem_header *blink;54 MemTag *tagPtr; /* Tag from "memory tag" command; may be55 * NULL. */56 char *file;57 long length;58 int line;59 unsigned char low_guard[LOW_GUARD_SIZE];60 /* Aligns body on 8-byte boundary, plus61 * provides at least 8 additional guard bytes62 * to detect underruns. */63 char body[1]; /* First byte of client's space. Actual64 * size of this field will be larger than65 * one. */66 };67 68 static struct mem_header *allocHead = NULL; /* List of allocated structures */69 70 #define GUARD_VALUE 014171 72 /*73 * The following macro determines the amount of guard space *above* each74 * chunk of memory.75 */76 77 #define HIGH_GUARD_SIZE 878 79 /*80 * The following macro computes the offset of the "body" field within81 * mem_header. It is used to get back to the header pointer from the82 * body pointer that's used by clients.83 */84 85 #define BODY_OFFSET \86 ((unsigned long) (&((struct mem_header *) 0)->body))87 88 static int total_mallocs = 0;89 static int total_frees = 0;90 static int current_bytes_malloced = 0;91 static int maximum_bytes_malloced = 0;92 static int current_malloc_packets = 0;93 static int maximum_malloc_packets = 0;94 static int break_on_malloc = 0;95 static int trace_on_at_malloc = 0;96 static int alloc_tracing = FALSE;97 static int init_malloced_bodies = TRUE;98 #ifdef MEM_VALIDATE99 static int validate_memory = TRUE;100 #else101 static int validate_memory = FALSE;102 #endif103 104 /*105 * Prototypes for procedures defined in this file:106 */107 108 static int MemoryCmd _ANSI_ARGS_((ClientData clientData,109 Tcl_Interp *interp, int argc, char **argv));110 static void ValidateMemory _ANSI_ARGS_((111 struct mem_header *memHeaderP, char *file,112 int line, int nukeGuards));113 114 115 /*116 *----------------------------------------------------------------------117 *118 * TclDumpMemoryInfo --119 * Display the global memory management statistics.120 *121 *----------------------------------------------------------------------122 */123 void124 TclDumpMemoryInfo(outFile)125 FILE *outFile;126 {127 fprintf(outFile,"total mallocs %10d\n",128 total_mallocs);129 fprintf(outFile,"total frees %10d\n",130 total_frees);131 fprintf(outFile,"current packets allocated %10d\n",132 current_malloc_packets);133 fprintf(outFile,"current bytes allocated %10d\n",134 current_bytes_malloced);135 fprintf(outFile,"maximum packets allocated %10d\n",136 maximum_malloc_packets);137 fprintf(outFile,"maximum bytes allocated %10d\n",138 maximum_bytes_malloced);139 }140 141 142 /*143 *----------------------------------------------------------------------144 *145 * ValidateMemory --146 * Procedure to validate allocted memory guard zones.147 *148 *----------------------------------------------------------------------149 */150 static void151 ValidateMemory(memHeaderP, file, line, nukeGuards)152 struct mem_header *memHeaderP;153 char *file;154 int line;155 int nukeGuards;156 {157 unsigned char *hiPtr;158 int idx;159 int guard_failed = FALSE;160 int byte;161 162 for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {163 byte = *(memHeaderP->low_guard + idx);164 if (byte != GUARD_VALUE) {165 guard_failed = TRUE;166 fflush(stdout);167 byte &= 0xff;168 fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte,169 (isprint(UCHAR(byte)) ? byte : ' '));170 }171 }172 if (guard_failed) {173 TclDumpMemoryInfo (stderr);174 fprintf(stderr, "low guard failed at %lx, %s %d\n",175 (long unsigned int) memHeaderP->body, file, line);176 fflush(stderr); /* In case name pointer is bad. */177 fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,178 memHeaderP->file, memHeaderP->line);179 panic ("Memory validation failure");180 }181 182 hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;183 for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {184 byte = *(hiPtr + idx);185 if (byte != GUARD_VALUE) {186 guard_failed = TRUE;187 fflush (stdout);188 byte &= 0xff;189 fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte,190 (isprint(UCHAR(byte)) ? byte : ' '));191 }192 }193 194 if (guard_failed) {195 TclDumpMemoryInfo (stderr);196 fprintf(stderr, "high guard failed at %lx, %s %d\n",197 (long unsigned int) memHeaderP->body, file, line);198 fflush(stderr); /* In case name pointer is bad. */199 fprintf(stderr, "%ld bytes allocated at (%s %d)\n",200 memHeaderP->length, memHeaderP->file,201 memHeaderP->line);202 panic("Memory validation failure");203 }204 205 if (nukeGuards) {206 memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);207 memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE);208 }209 210 }211 212 213 /*214 *----------------------------------------------------------------------215 *216 * Tcl_ValidateAllMemory --217 * Validates guard regions for all allocated memory.218 *219 *----------------------------------------------------------------------220 */221 void222 Tcl_ValidateAllMemory (file, line)223 char *file;224 int line;225 {226 struct mem_header *memScanP;227 228 for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)229 ValidateMemory(memScanP, file, line, FALSE);230 231 }232 233 234 /*235 *----------------------------------------------------------------------236 *237 * Tcl_DumpActiveMemory --238 * Displays all allocated memory to stderr.239 *240 * Results:241 * Return TCL_ERROR if an error accessing the file occures, `errno'242 * will have the file error number left in it.243 *----------------------------------------------------------------------244 */245 int246 Tcl_DumpActiveMemory (fileName)247 char *fileName;248 {249 FILE *fileP;250 struct mem_header *memScanP;251 char *address;252 253 fileP = fopen(fileName, "w");254 if (fileP == NULL)255 return TCL_ERROR;256 257 for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {258 address = &memScanP->body [0];259 fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",260 (long unsigned int) address,261 (long unsigned int) address + memScanP->length - 1,262 memScanP->length, memScanP->file, memScanP->line,263 (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);264 (void) fputc('\n', fileP);265 }266 fclose (fileP);267 return TCL_OK;268 }269 270 271 /*272 *----------------------------------------------------------------------273 *274 * Tcl_DbCkalloc - debugging ckalloc275 *276 * Allocate the requested amount of space plus some extra for277 * guard bands at both ends of the request, plus a size, panicing278 * if there isn't enough space, then write in the guard bands279 * and return the address of the space in the middle that the280 * user asked for.281 *282 * The second and third arguments are file and line, these contain283 * the filename and line number corresponding to the caller.284 * These are sent by the ckalloc macro; it uses the preprocessor285 * autodefines __FILE__ and __LINE__.286 *287 *----------------------------------------------------------------------288 */289 char *290 Tcl_DbCkalloc(size, file, line)291 unsigned int size;292 char *file;293 int line;294 {295 struct mem_header *result;296 297 if (validate_memory)298 Tcl_ValidateAllMemory (file, line);299 300 result = (struct mem_header *) TclpAlloc((unsigned)size +301 sizeof(struct mem_header) + HIGH_GUARD_SIZE);302 if (result == NULL) {303 fflush(stdout);304 TclDumpMemoryInfo(stderr);305 panic("unable to alloc %d bytes, %s line %d", size, file,306 line);307 }308 309 /*310 * Fill in guard zones and size. Also initialize the contents of311 * the block with bogus bytes to detect uses of initialized data.312 * Link into allocated list.313 */314 if (init_malloced_bodies) {315 memset ((VOID *) result, GUARD_VALUE,316 size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);317 } else {318 memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);319 memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);320 }321 result->length = size;322 result->tagPtr = curTagPtr;323 if (curTagPtr != NULL) {324 curTagPtr->refCount++;325 }326 result->file = file;327 result->line = line;328 result->flink = allocHead;329 result->blink = NULL;330 if (allocHead != NULL)331 allocHead->blink = result;332 allocHead = result;333 334 total_mallocs++;335 if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {336 (void) fflush(stdout);337 fprintf(stderr, "reached malloc trace enable point (%d)\n",338 total_mallocs);339 fflush(stderr);340 alloc_tracing = TRUE;341 trace_on_at_malloc = 0;342 }343 344 if (alloc_tracing)345 fprintf(stderr,"ckalloc %lx %d %s %d\n",346 (long unsigned int) result->body, size, file, line);347 348 if (break_on_malloc && (total_mallocs >= break_on_malloc)) {349 break_on_malloc = 0;350 (void) fflush(stdout);351 fprintf(stderr,"reached malloc break limit (%d)\n",352 total_mallocs);353 fprintf(stderr, "program will now enter C debugger\n");354 (void) fflush(stderr);355 abort();356 }357 358 current_malloc_packets++;359 if (current_malloc_packets > maximum_malloc_packets)360 maximum_malloc_packets = current_malloc_packets;361 current_bytes_malloced += size;362 if (current_bytes_malloced > maximum_bytes_malloced)363 maximum_bytes_malloced = current_bytes_malloced;364 365 return result->body;366 }367 368 369 /*370 *----------------------------------------------------------------------371 *372 * Tcl_DbCkfree - debugging ckfree373 *374 * Verify that the low and high guards are intact, and if so375 * then free the buffer else panic.376 *377 * The guards are erased after being checked to catch duplicate378 * frees.379 *380 * The second and third arguments are file and line, these contain381 * the filename and line number corresponding to the caller.382 * These are sent by the ckfree macro; it uses the preprocessor383 * autodefines __FILE__ and __LINE__.384 *385 *----------------------------------------------------------------------386 */387 388 int389 Tcl_DbCkfree(ptr, file, line)390 char * ptr;391 char *file;392 int line;393 {394 /*395 * The following cast is *very* tricky. Must convert the pointer396 * to an integer before doing arithmetic on it, because otherwise397 * the arithmetic will be done differently (and incorrectly) on398 * word-addressed machines such as Crays (will subtract only bytes,399 * even though BODY_OFFSET is in words on these machines).400 */401 402 struct mem_header *memp = (struct mem_header *)403 (((unsigned long) ptr) - BODY_OFFSET);404 405 if (alloc_tracing)406 fprintf(stderr, "ckfree %lx %ld %s %d\n",407 (long unsigned int) memp->body, memp->length, file, line);408 409 if (validate_memory)410 Tcl_ValidateAllMemory(file, line);411 412 ValidateMemory(memp, file, line, TRUE);413 if (init_malloced_bodies) {414 memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);415 }416 417 total_frees++;418 current_malloc_packets--;419 current_bytes_malloced -= memp->length;420 421 if (memp->tagPtr != NULL) {422 memp->tagPtr->refCount--;423 if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {424 TclpFree((char *) memp->tagPtr);425 }426 }427 428 /*429 * Delink from allocated list430 */431 if (memp->flink != NULL)432 memp->flink->blink = memp->blink;433 if (memp->blink != NULL)434 memp->blink->flink = memp->flink;435 if (allocHead == memp)436 allocHead = memp->flink;437 TclpFree((char *) memp);438 return 0;439 }440 441 442 /*443 *--------------------------------------------------------------------444 *445 * Tcl_DbCkrealloc - debugging ckrealloc446 *447 * Reallocate a chunk of memory by allocating a new one of the448 * right size, copying the old data to the new location, and then449 * freeing the old memory space, using all the memory checking450 * features of this package.451 *452 *--------------------------------------------------------------------453 */454 char *455 Tcl_DbCkrealloc(ptr, size, file, line)456 char *ptr;457 unsigned int size;458 char *file;459 int line;460 {461 char *new;462 unsigned int copySize;463 464 /*465 * See comment from Tcl_DbCkfree before you change the following466 * line.467 */468 469 struct mem_header *memp = (struct mem_header *)470 (((unsigned long) ptr) - BODY_OFFSET);471 472 copySize = size;473 if (copySize > (unsigned int) memp->length) {474 copySize = memp->length;475 }476 new = Tcl_DbCkalloc(size, file, line);477 memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);478 Tcl_DbCkfree(ptr, file, line);479 return(new);480 }481 482 483 484 /*485 *----------------------------------------------------------------------486 *487 * Tcl_Alloc, et al. --488 *489 * These functions are defined in terms of the debugging versions490 * when TCL_MEM_DEBUG is set.491 *492 * Results:493 * Same as the debug versions.494 *495 * Side effects:496 * Same as the debug versions.497 *498 *----------------------------------------------------------------------499 */500 501 #undef Tcl_Alloc502 #undef Tcl_Free503 #undef Tcl_Realloc504 505 char *506 Tcl_Alloc(size)507 unsigned int size;508 {509 return Tcl_DbCkalloc(size, "unknown", 0);510 }511 512 void513 Tcl_Free(ptr)514 char *ptr;515 {516 Tcl_DbCkfree(ptr, "unknown", 0);517 }518 519 char *520 Tcl_Realloc(ptr, size)521 char *ptr;522 unsigned int size;523 {524 return Tcl_DbCkrealloc(ptr, size, "unknown", 0);525 }526 527 528 /*529 *----------------------------------------------------------------------530 *531 * MemoryCmd --532 * Implements the TCL memory command:533 * memory info534 * memory display535 * break_on_malloc count536 * trace_on_at_malloc count537 * trace on|off538 * validate on|off539 *540 * Results:541 * Standard TCL results.542 *543 *----------------------------------------------------------------------544 */545 /* ARGSUSED */546 static int547 MemoryCmd (clientData, interp, argc, argv)548 ClientData clientData;549 Tcl_Interp *interp;550 int argc;551 char **argv;552 {553 char *fileName;554 Tcl_DString buffer;555 int result;556 557 if (argc < 2) {558 Tcl_AppendResult(interp, "wrong # args: should be \"",559 argv[0], " option [args..]\"", (char *) NULL);560 return TCL_ERROR;561 }562 563 if (strcmp(argv[1],"active") == 0) {564 if (argc != 3) {565 Tcl_AppendResult(interp, "wrong # args: should be \"",566 argv[0], " active file\"", (char *) NULL);567 return TCL_ERROR;568 }569 fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);570 if (fileName == NULL) {571 return TCL_ERROR;572 }573 result = Tcl_DumpActiveMemory (fileName);574 Tcl_DStringFree(&buffer);575 if (result != TCL_OK) {576 Tcl_AppendResult(interp, "error accessing ", argv[2],577 (char *) NULL);578 return TCL_ERROR;579 }580 return TCL_OK;581 }582 if (strcmp(argv[1],"break_on_malloc") == 0) {583 if (argc != 3) {584 goto argError;585 }586 if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {587 return TCL_ERROR;588 }589 return TCL_OK;590 }591 if (strcmp(argv[1],"info") == 0) {592 TclDumpMemoryInfo(stdout);593 return TCL_OK;594 }595 if (strcmp(argv[1],"init") == 0) {596 if (argc != 3) {597 goto bad_suboption;598 }599 init_malloced_bodies = (strcmp(argv[2],"on") == 0);600 return TCL_OK;601 }602 if (strcmp(argv[1],"tag") == 0) {603 if (argc != 3) {604 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],605 " tag string\"", (char *) NULL);606 return TCL_ERROR;607 }608 if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {609 TclpFree((char *) curTagPtr);610 }611 curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));612 curTagPtr->refCount = 0;613 strcpy(curTagPtr->string, argv[2]);614 return TCL_OK;615 }616 if (strcmp(argv[1],"trace") == 0) {617 if (argc != 3) {618 goto bad_suboption;619 }620 alloc_tracing = (strcmp(argv[2],"on") == 0);621 return TCL_OK;622 }623 624 if (strcmp(argv[1],"trace_on_at_malloc") == 0) {625 if (argc != 3) {626 goto argError;627 }628 if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {629 return TCL_ERROR;630 }631 return TCL_OK;632 }633 if (strcmp(argv[1],"validate") == 0) {634 if (argc != 3) {635 goto bad_suboption;636 }637 validate_memory = (strcmp(argv[2],"on") == 0);638 return TCL_OK;639 }640 641 Tcl_AppendResult(interp, "bad option \"", argv[1],642 "\": should be active, break_on_malloc, info, init, ",643 "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);644 return TCL_ERROR;645 646 argError:647 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],648 " ", argv[1], " count\"", (char *) NULL);649 return TCL_ERROR;650 651 bad_suboption:652 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],653 " ", argv[1], " on|off\"", (char *) NULL);654 return TCL_ERROR;655 }656 657 658 /*659 *----------------------------------------------------------------------660 *661 * Tcl_InitMemory --662 * Initialize the memory command.663 *664 *----------------------------------------------------------------------665 */666 void667 Tcl_InitMemory(interp)668 Tcl_Interp *interp;669 {670 Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,671 (Tcl_CmdDeleteProc *) NULL);672 }673 674 #else675 676 677 678 24 /* 679 25 *---------------------------------------------------------------------- 680 26 * 681 27 * Tcl_Alloc -- 682 * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check683 * 28 * Interface to TclpAlloc. 29 * It does check that memory was actually allocated. 684 30 * 685 31 *---------------------------------------------------------------------- … … 722 68 * 723 69 * Tcl_Realloc -- 724 * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does725 * 70 * Interface to TclpRealloc. 71 * It does check that memory was actually allocated. 726 72 * 727 73 *---------------------------------------------------------------------- … … 765 111 * 766 112 * Tcl_Free -- 767 * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here 768 * rather in the macro to keep some modules from being compiled with 769 * TCL_MEM_DEBUG enabled and some with it disabled. 113 * Interface to TclpFree. 770 114 * 771 115 *---------------------------------------------------------------------- … … 778 122 TclpFree(ptr); 779 123 } 780 781 int782 Tcl_DbCkfree(ptr, file, line)783 char * ptr;784 char *file;785 int line;786 {787 TclpFree(ptr);788 return 0;789 }790 791 792 /*793 *----------------------------------------------------------------------794 *795 * Tcl_InitMemory --796 * Dummy initialization for memory command, which is only available797 * if TCL_MEM_DEBUG is on.798 *799 *----------------------------------------------------------------------800 */801 /* ARGSUSED */802 void803 Tcl_InitMemory(interp)804 Tcl_Interp *interp;805 {806 }807 808 #undef Tcl_DumpActiveMemory809 #undef Tcl_ValidateAllMemory810 811 extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName));812 extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,813 int line));814 815 int816 Tcl_DumpActiveMemory(fileName)817 char *fileName;818 {819 return TCL_OK;820 }821 822 void823 Tcl_ValidateAllMemory(file, line)824 char *file;825 int line;826 {827 }828 829 #endif -
external/tcl/tclCompExpr.c
re15936c radeddd8 31 31 #define ERANGE 34 32 32 #endif 33 34 /*35 * Boolean variable that controls whether expression compilation tracing36 * is enabled.37 */38 39 #ifdef TCL_COMPILE_DEBUG40 static int traceCompileExpr = 0;41 #endif /* TCL_COMPILE_DEBUG */42 33 43 34 /* … … 132 123 #define NOT (COLON + 1) 133 124 #define BIT_NOT (NOT + 1) 134 135 /*136 * Mapping from tokens to strings; used for debugging messages. These137 * entries must match the order and number of the token definitions above.138 */139 140 #ifdef TCL_COMPILE_DEBUG141 static char *tokenStrings[] = {142 "LITERAL", "FUNCNAME",143 "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN",144 "*", "/", "%", "+", "-",145 "<<", ">>", "<", ">", "<=", ">=", "==", "!=",146 "&", "^", "|", "&&", "||", "?", ":",147 "!", "~"148 };149 #endif /* TCL_COMPILE_DEBUG */150 125 151 126 /* … … 198 173 ExprInfo *infoPtr, CompileEnv *envPtr)); 199 174 200 /*201 * Macro used to debug the execution of the recursive descent parser used202 * to compile expressions.203 */204 205 #ifdef TCL_COMPILE_DEBUG206 #define HERE(production, level) \207 if (traceCompileExpr) { \208 fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \209 (level), " ", (production), tokenStrings[infoPtr->token], \210 infoPtr->next); \211 }212 #else213 #define HERE(production, level)214 #endif /* TCL_COMPILE_DEBUG */215 175 216 176 … … 277 237 * to execute the expression. */ 278 238 int result; 279 280 #ifdef TCL_COMPILE_DEBUG281 if (traceCompileExpr) {282 fprintf(stderr, "expr: string=\"%.30s\"\n", string);283 }284 #endif /* TCL_COMPILE_DEBUG */285 239 286 240 /* … … 409 363 int elseCodeOffset, currCodeOffset, jumpDist, result; 410 364 411 HERE("condExpr", 1);412 365 result = CompileLorExpr(interp, infoPtr, flags, envPtr); 413 366 if (result != TCL_OK) { … … 571 524 Tcl_Obj *objPtr; 572 525 573 HERE("lorExpr", 2);574 526 result = CompileLandExpr(interp, infoPtr, flags, envPtr); 575 527 if ((result != TCL_OK) || (infoPtr->token != OR)) { … … 739 691 Tcl_Obj *objPtr; 740 692 741 HERE("landExpr", 3);742 693 result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); 743 694 if ((result != TCL_OK) || (infoPtr->token != AND)) { … … 899 850 int result; 900 851 901 HERE("bitOrExpr", 4);902 852 result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); 903 853 if (result != TCL_OK) { … … 970 920 int result; 971 921 972 HERE("bitXorExpr", 5);973 922 result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); 974 923 if (result != TCL_OK) { … … 1041 990 int result; 1042 991 1043 HERE("bitAndExpr", 6);1044 992 result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); 1045 993 if (result != TCL_OK) { … … 1112 1060 int op, result; 1113 1061 1114 HERE("equalityExpr", 7);1115 1062 result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); 1116 1063 if (result != TCL_OK) { … … 1190 1137 int op, result; 1191 1138 1192 HERE("relationalExpr", 8);1193 1139 result = CompileShiftExpr(interp, infoPtr, flags, envPtr); 1194 1140 if (result != TCL_OK) { … … 1277 1223 int op, result; 1278 1224 1279 HERE("shiftExpr", 9);1280 1225 result = CompileAddExpr(interp, infoPtr, flags, envPtr); 1281 1226 if (result != TCL_OK) { … … 1355 1300 int op, result; 1356 1301 1357 HERE("addExpr", 10);1358 1302 result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); 1359 1303 if (result != TCL_OK) { … … 1433 1377 int op, result; 1434 1378 1435 HERE("multiplyExpr", 11);1436 1379 result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); 1437 1380 if (result != TCL_OK) { … … 1513 1456 int op, result; 1514 1457 1515 HERE("unaryExpr", 12);1516 1458 op = infoPtr->token; 1517 1459 if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { … … 1608 1550 */ 1609 1551 1610 HERE("primaryExpr", 13);1611 1552 theToken = infoPtr->token; 1612 1553 -
external/tcl/tclCompile.c
re15936c radeddd8 17 17 #include "tclInt.h" 18 18 #include "tclCompile.h" 19 20 /*21 * Variable that controls whether compilation tracing is enabled and, if so,22 * what level of tracing is desired:23 * 0: no compilation tracing24 * 1: summarize compilation of top level cmds and proc bodies25 * 2: display all instructions of each ByteCode compiled26 * This variable is linked to the Tcl variable "tcl_traceCompile".27 */28 29 int tclTraceCompile = 0;30 static int traceInitialized = 0;31 32 /*33 * Count of the number of compilations and various other compilation-34 * related statistics.35 */36 37 #ifdef TCL_COMPILE_STATS38 long tclNumCompilations = 0;39 double tclTotalSourceBytes = 0.0;40 double tclTotalCodeBytes = 0.0;41 42 double tclTotalInstBytes = 0.0;43 double tclTotalObjBytes = 0.0;44 double tclTotalExceptBytes = 0.0;45 double tclTotalAuxBytes = 0.0;46 double tclTotalCmdMapBytes = 0.0;47 48 double tclCurrentSourceBytes = 0.0;49 double tclCurrentCodeBytes = 0.0;50 51 int tclSourceCount[32];52 int tclByteCodeCount[32];53 #endif /* TCL_COMPILE_STATS */54 19 55 20 /* … … 443 408 *---------------------------------------------------------------------- 444 409 * 445 * TclPrintByteCodeObj --446 *447 * This procedure prints ("disassembles") the instructions of a448 * bytecode object to stdout.449 *450 * Results:451 * None.452 *453 * Side effects:454 * None.455 *456 *----------------------------------------------------------------------457 */458 459 void460 TclPrintByteCodeObj(interp, objPtr)461 Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */462 Tcl_Obj *objPtr; /* The bytecode object to disassemble. */463 {464 ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;465 unsigned char *codeStart, *codeLimit, *pc;466 unsigned char *codeDeltaNext, *codeLengthNext;467 unsigned char *srcDeltaNext, *srcLengthNext;468 int codeOffset, codeLen, srcOffset, srcLen;469 int numCmds, numObjs, delta, objBytes, i;470 471 if (codePtr->refCount <= 0) {472 return; /* already freed */473 }474 475 codeStart = codePtr->codeStart;476 codeLimit = (codeStart + codePtr->numCodeBytes);477 numCmds = codePtr->numCommands;478 numObjs = codePtr->numObjects;479 480 objBytes = (numObjs * sizeof(Tcl_Obj));481 for (i = 0; i < numObjs; i++) {482 Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];483 if (litObjPtr->bytes != NULL) {484 objBytes += litObjPtr->length;485 }486 }487 488 /*489 * Print header lines describing the ByteCode.490 */491 492 fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",493 (unsigned int) codePtr, codePtr->refCount,494 codePtr->compileEpoch, (unsigned int) codePtr->iPtr,495 codePtr->iPtr->compileEpoch);496 fprintf(stdout, " Source ");497 TclPrintSource(stdout, codePtr->source,498 TclMin(codePtr->numSrcChars, 70));499 fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",500 numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,501 codePtr->numAuxDataItems, codePtr->maxStackDepth,502 (codePtr->numSrcChars?503 ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));504 fprintf(stdout, " Code %zu = %u(header)+%d(inst)+%d(objs)+%u(exc)+%u(aux)+%d(cmd map)\n",505 codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,506 objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),507 (codePtr->numAuxDataItems * sizeof(AuxData)),508 codePtr->numCmdLocBytes);509 510 /*511 * If the ByteCode is the compiled body of a Tcl procedure, print512 * information about that procedure. Note that we don't know the513 * procedure's name since ByteCode's can be shared among procedures.514 */515 516 if (codePtr->procPtr != NULL) {517 Proc *procPtr = codePtr->procPtr;518 int numCompiledLocals = procPtr->numCompiledLocals;519 fprintf(stdout,520 " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",521 (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,522 numCompiledLocals);523 if (numCompiledLocals > 0) {524 CompiledLocal *localPtr = procPtr->firstLocalPtr;525 for (i = 0; i < numCompiledLocals; i++) {526 fprintf(stdout, " %d: slot %d%s%s%s%s%s%s",527 i, localPtr->frameIndex,528 ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),529 ((localPtr->flags & VAR_ARRAY)? ", array" : ""),530 ((localPtr->flags & VAR_LINK)? ", link" : ""),531 ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),532 ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),533 ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));534 if (TclIsVarTemporary(localPtr)) {535 fprintf(stdout, "\n");536 } else {537 fprintf(stdout, ", name=\"%s\"\n", localPtr->name);538 }539 localPtr = localPtr->nextPtr;540 }541 }542 }543 544 /*545 * Print the ExceptionRange array.546 */547 548 if (codePtr->numExcRanges > 0) {549 fprintf(stdout, " Exception ranges %d, depth %d:\n",550 codePtr->numExcRanges, codePtr->maxExcRangeDepth);551 for (i = 0; i < codePtr->numExcRanges; i++) {552 ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);553 fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",554 i, rangePtr->nestingLevel,555 ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),556 rangePtr->codeOffset,557 (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));558 switch (rangePtr->type) {559 case LOOP_EXCEPTION_RANGE:560 fprintf(stdout, "continue %d, break %d\n",561 rangePtr->continueOffset, rangePtr->breakOffset);562 break;563 case CATCH_EXCEPTION_RANGE:564 fprintf(stdout, "catch %d\n", rangePtr->catchOffset);565 break;566 default:567 panic("TclPrintSource: unrecognized ExceptionRange type %d\n",568 rangePtr->type);569 }570 }571 }572 573 /*574 * If there were no commands (e.g., an expression or an empty string575 * was compiled), just print all instructions and return.576 */577 578 if (numCmds == 0) {579 pc = codeStart;580 while (pc < codeLimit) {581 fprintf(stdout, " ");582 pc += TclPrintInstruction(codePtr, pc);583 }584 return;585 }586 587 /*588 * Print table showing the code offset, source offset, and source589 * length for each command. These are encoded as a sequence of bytes.590 */591 592 fprintf(stdout, " Commands %d:", numCmds);593 codeDeltaNext = codePtr->codeDeltaStart;594 codeLengthNext = codePtr->codeLengthStart;595 srcDeltaNext = codePtr->srcDeltaStart;596 srcLengthNext = codePtr->srcLengthStart;597 codeOffset = srcOffset = 0;598 for (i = 0; i < numCmds; i++) {599 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {600 codeDeltaNext++;601 delta = TclGetInt4AtPtr(codeDeltaNext);602 codeDeltaNext += 4;603 } else {604 delta = TclGetInt1AtPtr(codeDeltaNext);605 codeDeltaNext++;606 }607 codeOffset += delta;608 609 if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {610 codeLengthNext++;611 codeLen = TclGetInt4AtPtr(codeLengthNext);612 codeLengthNext += 4;613 } else {614 codeLen = TclGetInt1AtPtr(codeLengthNext);615 codeLengthNext++;616 }617 618 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {619 srcDeltaNext++;620 delta = TclGetInt4AtPtr(srcDeltaNext);621 srcDeltaNext += 4;622 } else {623 delta = TclGetInt1AtPtr(srcDeltaNext);624 srcDeltaNext++;625 }626 srcOffset += delta;627 628 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {629 srcLengthNext++;630 srcLen = TclGetInt4AtPtr(srcLengthNext);631 srcLengthNext += 4;632 } else {633 srcLen = TclGetInt1AtPtr(srcLengthNext);634 srcLengthNext++;635 }636 637 fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d",638 ((i % 2)? " " : "\n "),639 (i+1), codeOffset, (codeOffset + codeLen - 1),640 srcOffset, (srcOffset + srcLen - 1));641 }642 if ((numCmds > 0) && ((numCmds % 2) != 0)) {643 fprintf(stdout, "\n");644 }645 646 /*647 * Print each instruction. If the instruction corresponds to the start648 * of a command, print the command's source. Note that we don't need649 * the code length here.650 */651 652 codeDeltaNext = codePtr->codeDeltaStart;653 srcDeltaNext = codePtr->srcDeltaStart;654 srcLengthNext = codePtr->srcLengthStart;655 codeOffset = srcOffset = 0;656 pc = codeStart;657 for (i = 0; i < numCmds; i++) {658 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {659 codeDeltaNext++;660 delta = TclGetInt4AtPtr(codeDeltaNext);661 codeDeltaNext += 4;662 } else {663 delta = TclGetInt1AtPtr(codeDeltaNext);664 codeDeltaNext++;665 }666 codeOffset += delta;667 668 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {669 srcDeltaNext++;670 delta = TclGetInt4AtPtr(srcDeltaNext);671 srcDeltaNext += 4;672 } else {673 delta = TclGetInt1AtPtr(srcDeltaNext);674 srcDeltaNext++;675 }676 srcOffset += delta;677 678 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {679 srcLengthNext++;680 srcLen = TclGetInt4AtPtr(srcLengthNext);681 srcLengthNext += 4;682 } else {683 srcLen = TclGetInt1AtPtr(srcLengthNext);684 srcLengthNext++;685 }686 687 /*688 * Print instructions before command i.689 */690 691 while ((pc-codeStart) < codeOffset) {692 fprintf(stdout, " ");693 pc += TclPrintInstruction(codePtr, pc);694 }695 696 fprintf(stdout, " Command %d: ", (i+1));697 TclPrintSource(stdout, (codePtr->source + srcOffset),698 TclMin(srcLen, 70));699 fprintf(stdout, "\n");700 }701 if (pc < codeLimit) {702 /*703 * Print instructions after the last command.704 */705 706 while (pc < codeLimit) {707 fprintf(stdout, " ");708 pc += TclPrintInstruction(codePtr, pc);709 }710 }711 }712 713 714 /*715 *----------------------------------------------------------------------716 *717 * TclPrintInstruction --718 *719 * This procedure prints ("disassembles") one instruction from a720 * bytecode object to stdout.721 *722 * Results:723 * Returns the length in bytes of the current instruiction.724 *725 * Side effects:726 * None.727 *728 *----------------------------------------------------------------------729 */730 731 int732 TclPrintInstruction(codePtr, pc)733 ByteCode* codePtr; /* Bytecode containing the instruction. */734 unsigned char *pc; /* Points to first byte of instruction. */735 {736 Proc *procPtr = codePtr->procPtr;737 unsigned char opCode = *pc;738 register InstructionDesc *instDesc = &instructionTable[opCode];739 unsigned char *codeStart = codePtr->codeStart;740 unsigned int pcOffset = (pc - codeStart);741 int opnd, elemLen, i, j;742 Tcl_Obj *elemPtr;743 char *string;744 745 fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);746 for (i = 0; i < instDesc->numOperands; i++) {747 switch (instDesc->opTypes[i]) {748 case OPERAND_INT1:749 opnd = TclGetInt1AtPtr(pc+1+i);750 if ((i == 0) && ((opCode == INST_JUMP1)751 || (opCode == INST_JUMP_TRUE1)752 || (opCode == INST_JUMP_FALSE1))) {753 fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));754 } else {755 fprintf(stdout, "%d", opnd);756 }757 break;758 case OPERAND_INT4:759 opnd = TclGetInt4AtPtr(pc+1+i);760 if ((i == 0) && ((opCode == INST_JUMP4)761 || (opCode == INST_JUMP_TRUE4)762 || (opCode == INST_JUMP_FALSE4))) {763 fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));764 } else {765 fprintf(stdout, "%d", opnd);766 }767 break;768 case OPERAND_UINT1:769 opnd = TclGetUInt1AtPtr(pc+1+i);770 if ((i == 0) && (opCode == INST_PUSH1)) {771 elemPtr = codePtr->objArrayPtr[opnd];772 string = Tcl_GetStringFromObj(elemPtr, &elemLen);773 fprintf(stdout, "%u # ", (unsigned int) opnd);774 TclPrintSource(stdout, string, TclMin(elemLen, 40));775 } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)776 || (opCode == INST_LOAD_ARRAY1)777 || (opCode == INST_STORE_SCALAR1)778 || (opCode == INST_STORE_ARRAY1))) {779 int localCt = procPtr->numCompiledLocals;780 CompiledLocal *localPtr = procPtr->firstLocalPtr;781 if (opnd >= localCt) {782 panic("TclPrintInstruction: bad local var index %u (%u locals)\n",783 (unsigned int) opnd, localCt);784 return instDesc->numBytes;785 }786 for (j = 0; j < opnd; j++) {787 localPtr = localPtr->nextPtr;788 }789 if (TclIsVarTemporary(localPtr)) {790 fprintf(stdout, "%u # temp var %u",791 (unsigned int) opnd, (unsigned int) opnd);792 } else {793 fprintf(stdout, "%u # var ", (unsigned int) opnd);794 TclPrintSource(stdout, localPtr->name, 40);795 }796 } else {797 fprintf(stdout, "%u ", (unsigned int) opnd);798 }799 break;800 case OPERAND_UINT4:801 opnd = TclGetUInt4AtPtr(pc+1+i);802 if (opCode == INST_PUSH4) {803 elemPtr = codePtr->objArrayPtr[opnd];804 string = Tcl_GetStringFromObj(elemPtr, &elemLen);805 fprintf(stdout, "%u # ", opnd);806 TclPrintSource(stdout, string, TclMin(elemLen, 40));807 } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)808 || (opCode == INST_LOAD_ARRAY4)809 || (opCode == INST_STORE_SCALAR4)810 || (opCode == INST_STORE_ARRAY4))) {811 int localCt = procPtr->numCompiledLocals;812 CompiledLocal *localPtr = procPtr->firstLocalPtr;813 if (opnd >= localCt) {814 panic("TclPrintInstruction: bad local var index %u (%u locals)\n",815 (unsigned int) opnd, localCt);816 return instDesc->numBytes;817 }818 for (j = 0; j < opnd; j++) {819 localPtr = localPtr->nextPtr;820 }821 if (TclIsVarTemporary(localPtr)) {822 fprintf(stdout, "%u # temp var %u",823 (unsigned int) opnd, (unsigned int) opnd);824 } else {825 fprintf(stdout, "%u # var ", (unsigned int) opnd);826 TclPrintSource(stdout, localPtr->name, 40);827 }828 } else {829 fprintf(stdout, "%u ", (unsigned int) opnd);830 }831 break;832 case OPERAND_NONE:833 default:834 break;835 }836 }837 fprintf(stdout, "\n");838 return instDesc->numBytes;839 }840 841 842 /*843 *----------------------------------------------------------------------844 *845 410 * TclPrintSource -- 846 411 * … … 972 537 register int i; 973 538 974 #ifdef TCL_COMPILE_STATS975 tclCurrentSourceBytes -= (double) codePtr->numSrcChars;976 tclCurrentCodeBytes -= (double) codePtr->totalSize;977 #endif /* TCL_COMPILE_STATS */978 979 539 /* 980 540 * A single heap object holds the ByteCode structure and its code, … … 1067 627 int length, result; 1068 628 1069 if (!traceInitialized) {1070 if (Tcl_LinkVar(interp, "tcl_traceCompile",1071 (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {1072 panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");1073 }1074 traceInitialized = 1;1075 }1076 1077 629 string = Tcl_GetStringFromObj(objPtr, &length); 1078 630 TclInitCompileEnv(interp, &compEnv, string); … … 1113 665 TclFreeCompileEnv(&compEnv); 1114 666 1115 if (result == TCL_OK) {1116 if (tclTraceCompile == 2) {1117 TclPrintByteCodeObj(interp, objPtr);1118 }1119 }1120 667 return result; 1121 668 } … … 1311 858 int numObjects, i; 1312 859 Namespace *namespacePtr; 1313 #ifdef TCL_COMPILE_STATS1314 int srcLenLog2, sizeLog2;1315 #endif /*TCL_COMPILE_STATS*/1316 860 1317 861 codeBytes = (envPtr->codeNext - envPtr->codeStart); … … 1342 886 } 1343 887 totalSize = (size + objBytes); 1344 1345 #ifdef TCL_COMPILE_STATS1346 tclNumCompilations++;1347 tclTotalSourceBytes += (double) srcLen;1348 tclTotalCodeBytes += (double) totalSize;1349 1350 tclTotalInstBytes += (double) codeBytes;1351 tclTotalObjBytes += (double) objBytes;1352 tclTotalExceptBytes += exceptArrayBytes;1353 tclTotalAuxBytes += (double) auxDataArrayBytes;1354 tclTotalCmdMapBytes += (double) cmdLocBytes;1355 1356 tclCurrentSourceBytes += (double) srcLen;1357 tclCurrentCodeBytes += (double) totalSize;1358 1359 srcLenLog2 = TclLog2(srcLen);1360 sizeLog2 = TclLog2((int) totalSize);1361 if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {1362 panic("TclInitByteCodeObj: bad source or code sizes\n");1363 }1364 tclSourceCount[srcLenLog2]++;1365 tclByteCodeCount[sizeLog2]++;1366 #endif /* TCL_COMPILE_STATS */1367 888 1368 889 if (envPtr->iPtr->varFramePtr != NULL) { … … 1820 1341 cmdCodeOffset); 1821 1342 1822 if ((!(flags & TCL_BRACKET_TERM))1823 && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {1824 /*1825 * Display a line summarizing the top level command we are about1826 * to compile.1827 */1828 1829 char *p = cmdSrcStart;1830 int numChars, complete;1831 1832 while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)1833 || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {1834 p++;1835 }1836 numChars = (p - cmdSrcStart);1837 complete = 1;1838 if (numChars > 60) {1839 numChars = 60;1840 complete = 0;1841 } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {1842 complete = 0;1843 }1844 fprintf(stdout, "Compiling: %.*s%s\n",1845 numChars, cmdSrcStart, (complete? "" : " ..."));1846 }1847 1848 1343 while ((type != TCL_COMMAND_END) 1849 1344 || ((c == ']') && !(flags & TCL_BRACKET_TERM))) { -
external/tcl/tclCompile.h
re15936c radeddd8 36 36 37 37 extern Tcl_ObjType tclCmdNameType; 38 39 /*40 * Variable that controls whether compilation tracing is enabled and, if so,41 * what level of tracing is desired:42 * 0: no compilation tracing43 * 1: summarize compilation of top level cmds and proc bodies44 * 2: display all instructions of each ByteCode compiled45 * This variable is linked to the Tcl variable "tcl_traceCompile".46 */47 48 extern int tclTraceCompile;49 50 /*51 * Variable that controls whether execution tracing is enabled and, if so,52 * what level of tracing is desired:53 * 0: no execution tracing54 * 1: trace invocations of Tcl procs only55 * 2: trace invocations of all (not compiled away) commands56 * 3: display each instruction executed57 * This variable is linked to the Tcl variable "tcl_traceExec".58 */59 60 extern int tclTraceExec;61 62 /*63 * The number of bytecode compilations and various other compilation-related64 * statistics. The tclByteCodeCount and tclSourceCount arrays are used to65 * hold the count of ByteCodes and sources whose sizes fall into various66 * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes67 * with size larger than 2**4 and less than or equal to 2**5.68 */69 70 #ifdef TCL_COMPILE_STATS71 extern long tclNumCompilations;72 extern double tclTotalSourceBytes;73 extern double tclTotalCodeBytes;74 75 extern double tclTotalInstBytes;76 extern double tclTotalObjBytes;77 extern double tclTotalExceptBytes;78 extern double tclTotalAuxBytes;79 extern double tclTotalCmdMapBytes;80 81 extern double tclCurrentSourceBytes;82 extern double tclCurrentCodeBytes;83 84 extern int tclSourceCount[32];85 extern int tclByteCodeCount[32];86 #endif /* TCL_COMPILE_STATS */87 38 88 39 /* … … 816 767 EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( 817 768 JumpFixupArray *fixupArrayPtr)); 818 #ifdef TCL_COMPILE_STATS819 EXTERN int TclLog2 _ANSI_ARGS_((int value));820 #endif /*TCL_COMPILE_STATS*/821 769 EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start, 822 770 int length, int allocStrRep, int inHeap, 823 771 CompileEnv *envPtr)); 824 EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr,825 unsigned char *pc));826 EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,827 char *string, int maxChars));828 772 EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); 829 773 -
external/tcl/tclExecute.c
re15936c radeddd8 51 51 52 52 /* 53 * Variable that controls whether execution tracing is enabled and, if so,54 * what level of tracing is desired:55 * 0: no execution tracing56 * 1: trace invocations of Tcl procs only57 * 2: trace invocations of all (not compiled away) commands58 * 3: display each instruction executed59 * This variable is linked to the Tcl variable "tcl_traceExec".60 */61 62 int tclTraceExec = 0;63 64 /*65 53 * The following global variable is use to signal matherr that Tcl 66 54 * is responsible for the arithmetic, so errors can be handled in a … … 102 90 }; 103 91 104 /*105 * Mapping from Tcl result codes to strings; used for error and debugging106 * messages.107 */108 109 #ifdef TCL_COMPILE_DEBUG110 static char *resultStrings[] = {111 "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"112 };113 #endif /* TCL_COMPILE_DEBUG */114 115 /*116 * The following are statistics-related variables that record information117 * about the bytecode compiler and interpreter's operation. This includes118 * an array that records for each instruction how often it is executed.119 */120 121 #ifdef TCL_COMPILE_STATS122 static long numExecutions = 0;123 static int instructionCount[256];124 #endif /* TCL_COMPILE_STATS */125 126 92 /* 127 93 * Macros for testing floating-point values for certain special cases. Test … … 187 153 #define POP_OBJECT() \ 188 154 (stackPtr[stackTop--].o) 189 190 /*191 * Macros used to trace instruction execution. The macros TRACE,192 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.193 * O2S is only used in TRACE* calls to get a string from an object.194 *195 * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S196 * STRING REP CONTAINS NULLS.197 */198 199 #ifdef TCL_COMPILE_DEBUG200 201 #define O2S(objPtr) \202 Tcl_GetStringFromObj((objPtr), &length)203 204 #ifdef TCL_COMPILE_STATS205 #define TRACE(a) \206 if (traceInstructions) { \207 fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \208 stackTop, (tclObjsAlloced - tclObjsFreed), \209 (unsigned int)(pc - codePtr->codeStart)); \210 printf a; \211 fflush(stdout); \212 }213 #define TRACE_WITH_OBJ(a, objPtr) \214 if (traceInstructions) { \215 fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \216 stackTop, (tclObjsAlloced - tclObjsFreed), \217 (unsigned int)(pc - codePtr->codeStart)); \218 printf a; \219 bytes = Tcl_GetStringFromObj((objPtr), &length); \220 TclPrintSource(stdout, bytes, TclMin(length, 30)); \221 fprintf(stdout, "\n"); \222 fflush(stdout); \223 }224 #else /* not TCL_COMPILE_STATS */225 #define TRACE(a) \226 if (traceInstructions) { \227 fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \228 (unsigned int)(pc - codePtr->codeStart)); \229 printf a; \230 fflush(stdout); \231 }232 #define TRACE_WITH_OBJ(a, objPtr) \233 if (traceInstructions) { \234 fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \235 (unsigned int)(pc - codePtr->codeStart)); \236 printf a; \237 bytes = Tcl_GetStringFromObj((objPtr), &length); \238 TclPrintSource(stdout, bytes, TclMin(length, 30)); \239 fprintf(stdout, "\n"); \240 fflush(stdout); \241 }242 #endif /* TCL_COMPILE_STATS */243 244 #else /* not TCL_COMPILE_DEBUG */245 246 #define TRACE(a)247 #define TRACE_WITH_OBJ(a, objPtr)248 #define O2S(objPtr)249 250 #endif /* TCL_COMPILE_DEBUG */251 155 252 156 /* … … 274 178 static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, 275 179 ExecEnv *eePtr, ClientData clientData)); 276 #ifdef TCL_COMPILE_STATS277 static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,278 Tcl_Interp *interp, int argc, char **argv));279 #endif /* TCL_COMPILE_STATS */280 180 static void FreeCmdNameInternalRep _ANSI_ARGS_(( 281 181 Tcl_Obj *objPtr)); … … 293 193 static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, 294 194 Tcl_Obj *objPtr)); 295 #ifdef TCL_COMPILE_DEBUG296 static char * StringForResultCode _ANSI_ARGS_((int result));297 #endif /* TCL_COMPILE_DEBUG */298 195 static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); 299 #ifdef TCL_COMPILE_DEBUG300 static void ValidatePcAndStackTop _ANSI_ARGS_((301 ByteCode *codePtr, unsigned char *pc,302 int stackTop, int stackLowerBound,303 int stackUpperBound));304 #endif /* TCL_COMPILE_DEBUG */305 196 306 197 /* … … 368 259 * 369 260 * Side effects: 370 * This procedure initializes the array of instruction names. If 371 * compiling with the TCL_COMPILE_STATS flag, it initializes the 372 * array that counts the executions of each instruction and it 373 * creates the "evalstats" command. It also registers the command name 374 * Tcl_ObjType. It also establishes the link between the Tcl 375 * "tcl_traceExec" and C "tclTraceExec" variables. 261 * This procedure initializes the array of instruction names. 376 262 * 377 263 *---------------------------------------------------------------------- … … 391 277 for (i = 0; instructionTable[i].name != NULL; i++) { 392 278 opName[i] = instructionTable[i].name; 393 }394 395 #ifdef TCL_COMPILE_STATS396 (VOID *) memset(instructionCount, 0, sizeof(instructionCount));397 (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));398 (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));399 400 Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,401 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);402 #endif /* TCL_COMPILE_STATS */403 404 if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,405 TCL_LINK_INT) != TCL_OK) {406 panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");407 279 } 408 280 } … … 598 470 * process break, continue, and errors. */ 599 471 int result = TCL_OK; /* Return code returned after execution. */ 600 int traceInstructions = (tclTraceExec == 3);601 472 Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr; 602 473 char *bytes; 603 474 int length; 604 475 long i; 605 Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2606 * holds a string representing the last607 * command invoked. */608 476 609 477 /* … … 620 488 621 489 /* 622 * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.623 */624 625 if (tclTraceExec >= 2) {626 PrintByteCodeInfo(codePtr);627 #ifdef TCL_COMPILE_STATS628 fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",629 eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));630 #else631 fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);632 #endif /* TCL_COMPILE_STATS */633 fflush(stdout);634 }635 636 #ifdef TCL_COMPILE_STATS637 numExecutions++;638 #endif /* TCL_COMPILE_STATS */639 640 /*641 490 * Make sure the catch stack is large enough to hold the maximum number 642 491 * of catch commands that could ever be executing at the same time. This … … 659 508 660 509 /* 661 * Initialize the buffer that holds a string containing the name and662 * arguments for the last invoked command.663 */664 665 Tcl_DStringInit(&command);666 667 /*668 510 * Loop executing instructions until a "done" instruction, a TCL_RETURN, 669 511 * or some error. … … 671 513 672 514 for (;;) { 673 #ifdef TCL_COMPILE_DEBUG674 ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,675 eePtr->stackEnd);676 #else /* not TCL_COMPILE_DEBUG */677 if (traceInstructions) {678 #ifdef TCL_COMPILE_STATS679 fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,680 (tclObjsAlloced - tclObjsFreed));681 #else /* TCL_COMPILE_STATS */682 fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop);683 #endif /* TCL_COMPILE_STATS */684 TclPrintInstruction(codePtr, pc);685 fflush(stdout);686 }687 #endif /* TCL_COMPILE_DEBUG */688 689 515 opCode = *pc; 690 #ifdef TCL_COMPILE_STATS691 instructionCount[opCode]++;692 #endif /* TCL_COMPILE_STATS */693 516 694 517 switch (opCode) { … … 710 533 panic("TclExecuteByteCode execution failure: end stack top != start stack top"); 711 534 } 712 TRACE_WITH_OBJ(("done => return code=%d, result is ", result),713 iPtr->objResultPtr);714 535 goto done; 715 536 … … 717 538 valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; 718 539 PUSH_OBJECT(valuePtr); 719 TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),720 valuePtr);721 540 ADJUST_PC(2); 722 541 … … 724 543 valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; 725 544 PUSH_OBJECT(valuePtr); 726 TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),727 valuePtr);728 545 ADJUST_PC(5); 729 546 730 547 case INST_POP: 731 548 valuePtr = POP_OBJECT(); 732 TRACE_WITH_OBJ(("pop => discarding "), valuePtr);733 549 TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ 734 550 ADJUST_PC(1); … … 737 553 valuePtr = stackPtr[stackTop].o; 738 554 PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); 739 TRACE_WITH_OBJ(("dup => "), valuePtr);740 555 ADJUST_PC(1); 741 556 … … 790 605 791 606 PUSH_OBJECT(concatObjPtr); 792 TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr);793 607 ADJUST_PC(2); 794 608 } … … 815 629 * Init. to avoid compiler warning. */ 816 630 Tcl_Command cmd; 817 #ifdef TCL_COMPILE_DEBUG818 int isUnknownCmd = 0;819 char cmdNameBuf[30];820 #endif /* TCL_COMPILE_DEBUG */821 631 822 632 /* … … 867 677 "invalid command name \"", cmdName, "\"", 868 678 (char *) NULL); 869 TRACE(("%s %u => unknown proc not found: ",870 opName[opCode], objc));871 679 result = TCL_ERROR; 872 680 goto checkForCatch; 873 681 } 874 682 cmdPtr = (Command *) cmd; 875 #ifdef TCL_COMPILE_DEBUG876 isUnknownCmd = 1;877 #endif /*TCL_COMPILE_DEBUG*/878 683 stackTop++; /* need room for new inserted objv[0] */ 879 684 for (i = objc; i >= 0; i--) { … … 918 723 Tcl_ResetResult(interp); 919 724 920 if (tclTraceExec >= 2) {921 char buffer[50];922 923 sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels,924 (unsigned int)(pc - codePtr->codeStart));925 Tcl_DStringAppend(&command, buffer, -1);926 927 #ifdef TCL_COMPILE_DEBUG928 if (traceInstructions) { /* tclTraceExec == 3 */929 strncpy(cmdNameBuf, cmdName, 20);930 TRACE(("%s %u => call ", opName[opCode],931 (isUnknownCmd? objc-1 : objc)));932 } else {933 fprintf(stdout, "%s", buffer);934 }935 #else /* TCL_COMPILE_DEBUG */936 fprintf(stdout, "%s", buffer);937 #endif /*TCL_COMPILE_DEBUG*/938 939 for (i = 0; i < objc; i++) {940 bytes = TclGetStringFromObj(objv[i], &length);941 TclPrintSource(stdout, bytes, TclMin(length, 15));942 fprintf(stdout, " ");943 944 sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes);945 Tcl_DStringAppend(&command, buffer, -1);946 }947 fprintf(stdout, "\n");948 fflush(stdout);949 950 Tcl_DStringFree(&command);951 }952 953 725 iPtr->cmdCount++; 954 726 DECACHE_STACK_INFO(); … … 996 768 */ 997 769 PUSH_OBJECT(Tcl_GetObjResult(interp)); 998 TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=",999 opName[opCode], objc, cmdNameBuf),1000 Tcl_GetObjResult(interp));1001 770 ADJUST_PC(pcAdjustment); 1002 771 … … 1015 784 /*catchOnly*/ 0, codePtr); 1016 785 if (rangePtr == NULL) { 1017 TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",1018 opName[opCode], objc, cmdNameBuf,1019 StringForResultCode(result)));1020 786 goto abnormalReturn; /* no catch exists to check */ 1021 787 } … … 1025 791 newPcOffset = rangePtr->breakOffset; 1026 792 } else if (rangePtr->continueOffset == -1) { 1027 TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",1028 opName[opCode], objc, cmdNameBuf,1029 StringForResultCode(result)));1030 793 goto checkForCatch; 1031 794 } else { 1032 795 newPcOffset = rangePtr->continueOffset; 1033 796 } 1034 TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n",1035 opName[opCode], objc, cmdNameBuf,1036 StringForResultCode(result),1037 rangePtr->codeOffset, newPcOffset));1038 797 break; 1039 798 case CATCH_EXCEPTION_RANGE: 1040 TRACE(("%s %u => ... after \"%.20s\", %s...\n",1041 opName[opCode], objc, cmdNameBuf,1042 StringForResultCode(result)));1043 799 goto processCatch; /* it will use rangePtr */ 1044 800 default: … … 1054 810 * enclosing catch exception range, if any. 1055 811 */ 1056 TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ",1057 opName[opCode], objc, cmdNameBuf),1058 Tcl_GetObjResult(interp));1059 812 goto checkForCatch; 1060 813 … … 1065 818 * for an enclosing catch exception range, if any. 1066 819 */ 1067 TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n",1068 opName[opCode], objc, cmdNameBuf));1069 820 goto checkForCatch; 1070 821 1071 822 default: 1072 TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ",1073 opName[opCode], objc, cmdNameBuf, result),1074 Tcl_GetObjResult(interp));1075 823 goto checkForCatch; 1076 824 } /* end of switch on result from invoke instruction */ … … 1088 836 1089 837 PUSH_OBJECT(Tcl_GetObjResult(interp)); 1090 TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)),1091 Tcl_GetObjResult(interp));1092 838 TclDecrRefCount(objPtr); 1093 839 ADJUST_PC(1); … … 1109 855 codePtr); 1110 856 if (rangePtr == NULL) { 1111 TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n",1112 O2S(objPtr), StringForResultCode(result)));1113 857 Tcl_DecrRefCount(objPtr); 1114 858 goto abnormalReturn; /* no catch exists to check */ … … 1119 863 newPcOffset = rangePtr->breakOffset; 1120 864 } else if (rangePtr->continueOffset == -1) { 1121 TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n",1122 O2S(objPtr), StringForResultCode(result)));1123 865 Tcl_DecrRefCount(objPtr); 1124 866 goto checkForCatch; … … 1127 869 } 1128 870 result = TCL_OK; 1129 TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ",1130 O2S(objPtr), StringForResultCode(result),1131 rangePtr->codeOffset, newPcOffset), valuePtr);1132 871 break; 1133 872 case CATCH_EXCEPTION_RANGE: 1134 TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ",1135 O2S(objPtr), StringForResultCode(result)),1136 valuePtr);1137 873 Tcl_DecrRefCount(objPtr); 1138 874 goto processCatch; /* it will use rangePtr */ … … 1144 880 continue; /* restart outer instruction loop at pc */ 1145 881 } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ 1146 TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),1147 Tcl_GetObjResult(interp));1148 882 Tcl_DecrRefCount(objPtr); 1149 883 goto checkForCatch; … … 1157 891 CACHE_STACK_INFO(); 1158 892 if (result != TCL_OK) { 1159 TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",1160 O2S(objPtr)), Tcl_GetObjResult(interp));1161 893 Tcl_DecrRefCount(objPtr); 1162 894 goto checkForCatch; 1163 895 } 1164 896 stackPtr[++stackTop].o = valuePtr; /* already has right refct */ 1165 TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);1166 897 TclDecrRefCount(objPtr); 1167 898 ADJUST_PC(1); … … 1182 913 CACHE_STACK_INFO(); 1183 914 if (valuePtr == NULL) { 1184 TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd),1185 Tcl_GetObjResult(interp));1186 915 result = TCL_ERROR; 1187 916 goto checkForCatch; 1188 917 } 1189 918 PUSH_OBJECT(valuePtr); 1190 TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr);1191 919 ADJUST_PC(pcAdjustment); 1192 920 … … 1198 926 CACHE_STACK_INFO(); 1199 927 if (valuePtr == NULL) { 1200 TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",1201 O2S(namePtr)), Tcl_GetObjResult(interp));1202 928 Tcl_DecrRefCount(namePtr); 1203 929 result = TCL_ERROR; … … 1205 931 } 1206 932 PUSH_OBJECT(valuePtr); 1207 TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",1208 O2S(namePtr)), valuePtr);1209 933 TclDecrRefCount(namePtr); 1210 934 ADJUST_PC(1); … … 1228 952 CACHE_STACK_INFO(); 1229 953 if (valuePtr == NULL) { 1230 TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ",1231 opName[opCode], opnd, O2S(elemPtr)),1232 Tcl_GetObjResult(interp));1233 954 Tcl_DecrRefCount(elemPtr); 1234 955 result = TCL_ERROR; … … 1236 957 } 1237 958 PUSH_OBJECT(valuePtr); 1238 TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",1239 opName[opCode], opnd, O2S(elemPtr)), valuePtr);1240 959 TclDecrRefCount(elemPtr); 1241 960 } … … 1252 971 CACHE_STACK_INFO(); 1253 972 if (valuePtr == NULL) { 1254 TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",1255 O2S(namePtr), O2S(elemPtr)),1256 Tcl_GetObjResult(interp));1257 973 Tcl_DecrRefCount(namePtr); 1258 974 Tcl_DecrRefCount(elemPtr); … … 1261 977 } 1262 978 PUSH_OBJECT(valuePtr); 1263 TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",1264 O2S(namePtr), O2S(elemPtr)), valuePtr);1265 979 TclDecrRefCount(namePtr); 1266 980 TclDecrRefCount(elemPtr); … … 1275 989 CACHE_STACK_INFO(); 1276 990 if (valuePtr == NULL) { 1277 TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",1278 O2S(namePtr)), Tcl_GetObjResult(interp));1279 991 Tcl_DecrRefCount(namePtr); 1280 992 result = TCL_ERROR; … … 1282 994 } 1283 995 PUSH_OBJECT(valuePtr); 1284 TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),1285 valuePtr);1286 996 TclDecrRefCount(namePtr); 1287 997 ADJUST_PC(1); … … 1303 1013 CACHE_STACK_INFO(); 1304 1014 if (value2Ptr == NULL) { 1305 TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ",1306 opName[opCode], opnd, O2S(valuePtr)),1307 Tcl_GetObjResult(interp));1308 1015 Tcl_DecrRefCount(valuePtr); 1309 1016 result = TCL_ERROR; … … 1311 1018 } 1312 1019 PUSH_OBJECT(value2Ptr); 1313 TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",1314 opName[opCode], opnd, O2S(valuePtr)), value2Ptr);1315 1020 TclDecrRefCount(valuePtr); 1316 1021 ADJUST_PC(pcAdjustment); … … 1324 1029 CACHE_STACK_INFO(); 1325 1030 if (value2Ptr == NULL) { 1326 TRACE_WITH_OBJ(1327 ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",1328 O2S(namePtr), O2S(valuePtr)),1329 Tcl_GetObjResult(interp));1330 1031 Tcl_DecrRefCount(namePtr); 1331 1032 Tcl_DecrRefCount(valuePtr); … … 1334 1035 } 1335 1036 PUSH_OBJECT(value2Ptr); 1336 TRACE_WITH_OBJ(1337 ("storeScalarStk \"%.30s\" <- \"%.30s\" => ",1338 O2S(namePtr),1339 O2S(valuePtr)),1340 value2Ptr);1341 1037 TclDecrRefCount(namePtr); 1342 1038 TclDecrRefCount(valuePtr); … … 1363 1059 CACHE_STACK_INFO(); 1364 1060 if (value2Ptr == NULL) { 1365 TRACE_WITH_OBJ(1366 ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",1367 opName[opCode], opnd, O2S(elemPtr),1368 O2S(valuePtr)), Tcl_GetObjResult(interp));1369 1061 Tcl_DecrRefCount(elemPtr); 1370 1062 Tcl_DecrRefCount(valuePtr); … … 1373 1065 } 1374 1066 PUSH_OBJECT(value2Ptr); 1375 TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ",1376 opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)),1377 value2Ptr);1378 1067 TclDecrRefCount(elemPtr); 1379 1068 TclDecrRefCount(valuePtr); … … 1393 1082 CACHE_STACK_INFO(); 1394 1083 if (value2Ptr == NULL) { 1395 TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",1396 O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),1397 Tcl_GetObjResult(interp));1398 1084 Tcl_DecrRefCount(namePtr); 1399 1085 Tcl_DecrRefCount(elemPtr); … … 1403 1089 } 1404 1090 PUSH_OBJECT(value2Ptr); 1405 TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",1406 O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),1407 value2Ptr);1408 1091 TclDecrRefCount(namePtr); 1409 1092 TclDecrRefCount(elemPtr); … … 1420 1103 CACHE_STACK_INFO(); 1421 1104 if (value2Ptr == NULL) { 1422 TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",1423 O2S(namePtr), O2S(valuePtr)),1424 Tcl_GetObjResult(interp));1425 1105 Tcl_DecrRefCount(namePtr); 1426 1106 Tcl_DecrRefCount(valuePtr); … … 1429 1109 } 1430 1110 PUSH_OBJECT(value2Ptr); 1431 TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",1432 O2S(namePtr), O2S(valuePtr)), value2Ptr);1433 1111 TclDecrRefCount(namePtr); 1434 1112 TclDecrRefCount(valuePtr); … … 1441 1119 result = tclIntType.setFromAnyProc(interp, valuePtr); 1442 1120 if (result != TCL_OK) { 1443 TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ",1444 opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));1445 1121 Tcl_DecrRefCount(valuePtr); 1446 1122 goto checkForCatch; … … 1452 1128 CACHE_STACK_INFO(); 1453 1129 if (value2Ptr == NULL) { 1454 TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ",1455 opnd, i), Tcl_GetObjResult(interp));1456 1130 Tcl_DecrRefCount(valuePtr); 1457 1131 result = TCL_ERROR; … … 1459 1133 } 1460 1134 PUSH_OBJECT(value2Ptr); 1461 TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),1462 value2Ptr);1463 1135 TclDecrRefCount(valuePtr); 1464 1136 ADJUST_PC(2); … … 1471 1143 result = tclIntType.setFromAnyProc(interp, valuePtr); 1472 1144 if (result != TCL_OK) { 1473 TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",1474 opName[opCode], O2S(namePtr), O2S(valuePtr)),1475 Tcl_GetObjResult(interp));1476 1145 Tcl_DecrRefCount(namePtr); 1477 1146 Tcl_DecrRefCount(valuePtr); … … 1485 1154 CACHE_STACK_INFO(); 1486 1155 if (value2Ptr == NULL) { 1487 TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",1488 opName[opCode], O2S(namePtr), i),1489 Tcl_GetObjResult(interp));1490 1156 Tcl_DecrRefCount(namePtr); 1491 1157 Tcl_DecrRefCount(valuePtr); … … 1494 1160 } 1495 1161 PUSH_OBJECT(value2Ptr); 1496 TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",1497 opName[opCode], O2S(namePtr), i), value2Ptr);1498 1162 Tcl_DecrRefCount(namePtr); 1499 1163 Tcl_DecrRefCount(valuePtr); … … 1510 1174 result = tclIntType.setFromAnyProc(interp, valuePtr); 1511 1175 if (result != TCL_OK) { 1512 TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",1513 opnd, O2S(elemPtr), O2S(valuePtr)),1514 Tcl_GetObjResult(interp));1515 1176 Tcl_DecrRefCount(elemPtr); 1516 1177 Tcl_DecrRefCount(valuePtr); … … 1524 1185 CACHE_STACK_INFO(); 1525 1186 if (value2Ptr == NULL) { 1526 TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ",1527 opnd, O2S(elemPtr), i),1528 Tcl_GetObjResult(interp));1529 1187 Tcl_DecrRefCount(elemPtr); 1530 1188 Tcl_DecrRefCount(valuePtr); … … 1533 1191 } 1534 1192 PUSH_OBJECT(value2Ptr); 1535 TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ",1536 opnd, O2S(elemPtr), i), value2Ptr);1537 1193 Tcl_DecrRefCount(elemPtr); 1538 1194 Tcl_DecrRefCount(valuePtr); … … 1550 1206 result = tclIntType.setFromAnyProc(interp, valuePtr); 1551 1207 if (result != TCL_OK) { 1552 TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",1553 O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),1554 Tcl_GetObjResult(interp));1555 1208 Tcl_DecrRefCount(namePtr); 1556 1209 Tcl_DecrRefCount(elemPtr); … … 1565 1218 CACHE_STACK_INFO(); 1566 1219 if (value2Ptr == NULL) { 1567 TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",1568 O2S(namePtr), O2S(elemPtr), i),1569 Tcl_GetObjResult(interp));1570 1220 Tcl_DecrRefCount(namePtr); 1571 1221 Tcl_DecrRefCount(elemPtr); … … 1575 1225 } 1576 1226 PUSH_OBJECT(value2Ptr); 1577 TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",1578 O2S(namePtr), O2S(elemPtr), i), value2Ptr);1579 1227 Tcl_DecrRefCount(namePtr); 1580 1228 Tcl_DecrRefCount(elemPtr); … … 1590 1238 CACHE_STACK_INFO(); 1591 1239 if (value2Ptr == NULL) { 1592 TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ",1593 opnd, i), Tcl_GetObjResult(interp));1594 1240 result = TCL_ERROR; 1595 1241 goto checkForCatch; 1596 1242 } 1597 1243 PUSH_OBJECT(value2Ptr); 1598 TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i),1599 value2Ptr);1600 1244 ADJUST_PC(3); 1601 1245 … … 1609 1253 CACHE_STACK_INFO(); 1610 1254 if (value2Ptr == NULL) { 1611 TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ",1612 opName[opCode], O2S(namePtr), i),1613 Tcl_GetObjResult(interp));1614 1255 result = TCL_ERROR; 1615 1256 Tcl_DecrRefCount(namePtr); … … 1617 1258 } 1618 1259 PUSH_OBJECT(value2Ptr); 1619 TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",1620 opName[opCode], O2S(namePtr), i), value2Ptr);1621 1260 TclDecrRefCount(namePtr); 1622 1261 ADJUST_PC(2); … … 1634 1273 CACHE_STACK_INFO(); 1635 1274 if (value2Ptr == NULL) { 1636 TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ",1637 opnd, O2S(elemPtr), i),1638 Tcl_GetObjResult(interp));1639 1275 Tcl_DecrRefCount(elemPtr); 1640 1276 result = TCL_ERROR; … … 1642 1278 } 1643 1279 PUSH_OBJECT(value2Ptr); 1644 TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ",1645 opnd, O2S(elemPtr), i), value2Ptr);1646 1280 Tcl_DecrRefCount(elemPtr); 1647 1281 } … … 1660 1294 CACHE_STACK_INFO(); 1661 1295 if (value2Ptr == NULL) { 1662 TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",1663 O2S(namePtr), O2S(elemPtr), i),1664 Tcl_GetObjResult(interp));1665 1296 Tcl_DecrRefCount(namePtr); 1666 1297 Tcl_DecrRefCount(elemPtr); … … 1669 1300 } 1670 1301 PUSH_OBJECT(value2Ptr); 1671 TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",1672 O2S(namePtr), O2S(elemPtr), i), value2Ptr);1673 1302 Tcl_DecrRefCount(namePtr); 1674 1303 Tcl_DecrRefCount(elemPtr); … … 1678 1307 case INST_JUMP1: 1679 1308 opnd = TclGetInt1AtPtr(pc+1); 1680 TRACE(("jump1 %d => new pc %u\n", opnd,1681 (unsigned int)(pc + opnd - codePtr->codeStart)));1682 1309 ADJUST_PC(opnd); 1683 1310 1684 1311 case INST_JUMP4: 1685 1312 opnd = TclGetInt4AtPtr(pc+1); 1686 TRACE(("jump4 %d => new pc %u\n", opnd,1687 (unsigned int)(pc + opnd - codePtr->codeStart)));1688 1313 ADJUST_PC(opnd); 1689 1314 … … 1709 1334 result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); 1710 1335 if (result != TCL_OK) { 1711 TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],1712 opnd), Tcl_GetObjResult(interp));1713 1336 Tcl_DecrRefCount(valuePtr); 1714 1337 goto checkForCatch; … … 1716 1339 } 1717 1340 if (b) { 1718 TRACE(("%s %d => %.20s true, new pc %u\n",1719 opName[opCode], opnd, O2S(valuePtr),1720 (unsigned int)(pc+opnd - codePtr->codeStart)));1721 1341 TclDecrRefCount(valuePtr); 1722 1342 ADJUST_PC(opnd); 1723 1343 } else { 1724 TRACE(("%s %d => %.20s false\n", opName[opCode], opnd,1725 O2S(valuePtr)));1726 1344 TclDecrRefCount(valuePtr); 1727 1345 ADJUST_PC(pcAdjustment); … … 1750 1368 result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); 1751 1369 if (result != TCL_OK) { 1752 TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],1753 opnd), Tcl_GetObjResult(interp));1754 1370 Tcl_DecrRefCount(valuePtr); 1755 1371 goto checkForCatch; … … 1757 1373 } 1758 1374 if (b) { 1759 TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,1760 O2S(valuePtr)));1761 1375 TclDecrRefCount(valuePtr); 1762 1376 ADJUST_PC(pcAdjustment); 1763 1377 } else { 1764 TRACE(("%s %d => %.20s false, new pc %u\n",1765 opName[opCode], opnd, O2S(valuePtr),1766 (unsigned int)(pc + opnd - codePtr->codeStart)));1767 1378 TclDecrRefCount(valuePtr); 1768 1379 ADJUST_PC(opnd); … … 1804 1415 } 1805 1416 if (result != TCL_OK) { 1806 TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",1807 opName[opCode], O2S(valuePtr),1808 (t1Ptr? t1Ptr->name : "null")));1809 1417 IllegalExprOperandType(interp, opCode, valuePtr); 1810 1418 Tcl_DecrRefCount(valuePtr); … … 1830 1438 } 1831 1439 if (result != TCL_OK) { 1832 TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",1833 opName[opCode], O2S(value2Ptr),1834 (t2Ptr? t2Ptr->name : "null")));1835 1440 IllegalExprOperandType(interp, opCode, value2Ptr); 1836 1441 Tcl_DecrRefCount(valuePtr); … … 1851 1456 if (Tcl_IsShared(valuePtr)) { 1852 1457 PUSH_OBJECT(Tcl_NewLongObj(iResult)); 1853 TRACE(("%s %.20s %.20s => %d\n", opName[opCode],1854 O2S(valuePtr), O2S(value2Ptr), iResult));1855 1458 TclDecrRefCount(valuePtr); 1856 1459 } else { /* reuse the valuePtr object */ 1857 TRACE(("%s %.20s %.20s => %d\n",1858 opName[opCode], /* NB: stack top is off by 1 */1859 O2S(valuePtr), O2S(value2Ptr), iResult));1860 1460 Tcl_SetLongObj(valuePtr, iResult); 1861 1461 ++stackTop; /* valuePtr now on stk top has right r.c. */ … … 2013 1613 if (Tcl_IsShared(valuePtr)) { 2014 1614 PUSH_OBJECT(Tcl_NewLongObj(iResult)); 2015 TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],2016 O2S(valuePtr), O2S(value2Ptr), iResult));2017 1615 TclDecrRefCount(valuePtr); 2018 1616 } else { /* reuse the valuePtr object */ 2019 TRACE(("%s %.20s %.20s => %ld\n",2020 opName[opCode], /* NB: stack top is off by 1 */2021 O2S(valuePtr), O2S(value2Ptr), iResult));2022 1617 Tcl_SetLongObj(valuePtr, iResult); 2023 1618 ++stackTop; /* valuePtr now on stk top has right r.c. */ … … 2049 1644 valuePtr, &i); 2050 1645 if (result != TCL_OK) { 2051 TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",2052 opName[opCode], O2S(valuePtr), O2S(value2Ptr),2053 (valuePtr->typePtr?2054 valuePtr->typePtr->name : "null")));2055 1646 IllegalExprOperandType(interp, opCode, valuePtr); 2056 1647 Tcl_DecrRefCount(valuePtr); … … 2065 1656 value2Ptr, &i2); 2066 1657 if (result != TCL_OK) { 2067 TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",2068 opName[opCode], O2S(valuePtr), O2S(value2Ptr),2069 (value2Ptr->typePtr?2070 value2Ptr->typePtr->name : "null")));2071 1658 IllegalExprOperandType(interp, opCode, value2Ptr); 2072 1659 Tcl_DecrRefCount(valuePtr); … … 2085 1672 */ 2086 1673 if (i2 == 0) { 2087 TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2));2088 1674 Tcl_DecrRefCount(valuePtr); 2089 1675 Tcl_DecrRefCount(value2Ptr); … … 2137 1723 if (Tcl_IsShared(valuePtr)) { 2138 1724 PUSH_OBJECT(Tcl_NewLongObj(iResult)); 2139 TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,2140 iResult));2141 1725 TclDecrRefCount(valuePtr); 2142 1726 } else { /* reuse the valuePtr object */ 2143 TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,2144 iResult)); /* NB: stack top is off by 1 */2145 1727 Tcl_SetLongObj(valuePtr, iResult); 2146 1728 ++stackTop; /* valuePtr now on stk top has right r.c. */ … … 2186 1768 } 2187 1769 if (result != TCL_OK) { 2188 TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",2189 opName[opCode], s, O2S(value2Ptr),2190 (valuePtr->typePtr?2191 valuePtr->typePtr->name : "null")));2192 1770 IllegalExprOperandType(interp, opCode, valuePtr); 2193 1771 Tcl_DecrRefCount(valuePtr); … … 2212 1790 } 2213 1791 if (result != TCL_OK) { 2214 TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",2215 opName[opCode], O2S(valuePtr), s,2216 (value2Ptr->typePtr?2217 value2Ptr->typePtr->name : "null")));2218 1792 IllegalExprOperandType(interp, opCode, value2Ptr); 2219 1793 Tcl_DecrRefCount(valuePtr); … … 2246 1820 case INST_DIV: 2247 1821 if (d2 == 0.0) { 2248 TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n",2249 d1, d2));2250 1822 Tcl_DecrRefCount(valuePtr); 2251 1823 Tcl_DecrRefCount(value2Ptr); … … 2261 1833 2262 1834 if (IS_NAN(dResult) || IS_INF(dResult)) { 2263 TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n",2264 opName[opCode], O2S(valuePtr), O2S(value2Ptr)));2265 1835 TclExprFloatError(interp, dResult); 2266 1836 result = TCL_ERROR; … … 2291 1861 */ 2292 1862 if (i2 == 0) { 2293 TRACE(("div %ld %ld => DIVIDE BY ZERO\n",2294 i, i2));2295 1863 Tcl_DecrRefCount(valuePtr); 2296 1864 Tcl_DecrRefCount(value2Ptr); … … 2318 1886 if (doDouble) { 2319 1887 PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); 2320 TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],2321 d1, d2, dResult));2322 1888 } else { 2323 1889 PUSH_OBJECT(Tcl_NewLongObj(iResult)); 2324 TRACE(("%s %ld %ld => %ld\n", opName[opCode],2325 i, i2, iResult));2326 1890 } 2327 1891 TclDecrRefCount(valuePtr); 2328 1892 } else { /* reuse the valuePtr object */ 2329 1893 if (doDouble) { /* NB: stack top is off by 1 */ 2330 TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],2331 d1, d2, dResult));2332 1894 Tcl_SetDoubleObj(valuePtr, dResult); 2333 1895 } else { 2334 TRACE(("%s %ld %ld => %ld\n", opName[opCode],2335 i, i2, iResult));2336 1896 Tcl_SetLongObj(valuePtr, iResult); 2337 1897 } … … 2363 1923 } 2364 1924 if (result != TCL_OK) { 2365 TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",2366 opName[opCode], s,2367 (tPtr? tPtr->name : "null")));2368 1925 IllegalExprOperandType(interp, opCode, valuePtr); 2369 1926 goto checkForCatch; 2370 1927 } 2371 1928 } 2372 TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr);2373 1929 } 2374 1930 ADJUST_PC(1); … … 2399 1955 } 2400 1956 if (result != TCL_OK) { 2401 TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n",2402 opName[opCode], s,2403 (tPtr? tPtr->name : "null")));2404 1957 IllegalExprOperandType(interp, opCode, valuePtr); 2405 1958 Tcl_DecrRefCount(valuePtr); … … 2417 1970 objPtr = Tcl_NewLongObj( 2418 1971 (opCode == INST_UMINUS)? -i : !i); 2419 TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),2420 objPtr); /* NB: stack top is off by 1 */2421 1972 } else { 2422 1973 d = valuePtr->internalRep.doubleValue; … … 2430 1981 objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); 2431 1982 } 2432 TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),2433 objPtr); /* NB: stack top is off by 1 */2434 1983 } 2435 1984 PUSH_OBJECT(objPtr); … … 2443 1992 Tcl_SetLongObj(valuePtr, 2444 1993 (opCode == INST_UMINUS)? -i : !i); 2445 TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),2446 valuePtr); /* NB: stack top is off by 1 */2447 1994 } else { 2448 1995 d = valuePtr->internalRep.doubleValue; … … 2456 2003 Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); 2457 2004 } 2458 TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),2459 valuePtr); /* NB: stack top is off by 1 */2460 2005 } 2461 2006 ++stackTop; /* valuePtr now on stk top has right r.c. */ … … 2481 2026 valuePtr, &i); 2482 2027 if (result != TCL_OK) { /* try to convert to double */ 2483 TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",2484 O2S(valuePtr), (tPtr? tPtr->name : "null")));2485 2028 IllegalExprOperandType(interp, opCode, valuePtr); 2486 2029 Tcl_DecrRefCount(valuePtr); … … 2492 2035 if (Tcl_IsShared(valuePtr)) { 2493 2036 PUSH_OBJECT(Tcl_NewLongObj(~i)); 2494 TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));2495 2037 TclDecrRefCount(valuePtr); 2496 2038 } else { … … 2500 2042 Tcl_SetLongObj(valuePtr, ~i); 2501 2043 ++stackTop; /* valuePtr now on stk top has right r.c. */ 2502 TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));2503 2044 } 2504 2045 } … … 2515 2056 2516 2057 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { 2517 TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));2518 2058 panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); 2519 2059 } … … 2528 2068 goto checkForCatch; 2529 2069 } 2530 TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd),2531 stackPtr[stackTop].o);2532 2070 } 2533 2071 ADJUST_PC(2); … … 2555 2093 goto checkForCatch; 2556 2094 } 2557 TRACE_WITH_OBJ(("callFunc1 %d => ", objc),2558 stackPtr[stackTop].o);2559 2095 ADJUST_PC(2); 2560 2096 } … … 2627 2163 d = valuePtr->internalRep.doubleValue; 2628 2164 if (IS_NAN(d) || IS_INF(d)) { 2629 TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n",2630 O2S(valuePtr)));2631 2165 TclExprFloatError(interp, d); 2632 2166 result = TCL_ERROR; … … 2636 2170 shared = shared; /* lint, shared not used. */ 2637 2171 converted = converted; /* lint, converted not used. */ 2638 TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",2639 O2S(valuePtr),2640 (converted? "converted" : "not converted"),2641 (shared? "shared" : "not shared")));2642 } else {2643 TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n",2644 O2S(valuePtr)));2645 2172 } 2646 2173 } … … 2660 2187 codePtr); 2661 2188 if (rangePtr == NULL) { 2662 TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n"));2663 2189 result = TCL_BREAK; 2664 2190 goto abnormalReturn; /* no catch exists to check */ … … 2667 2193 case LOOP_EXCEPTION_RANGE: 2668 2194 result = TCL_OK; 2669 TRACE(("break => range at %d, new pc %d\n",2670 rangePtr->codeOffset, rangePtr->breakOffset));2671 2195 break; 2672 2196 case CATCH_EXCEPTION_RANGE: 2673 2197 result = TCL_BREAK; 2674 TRACE(("break => ...\n"));2675 2198 goto processCatch; /* it will use rangePtr */ 2676 2199 default: … … 2693 2216 codePtr); 2694 2217 if (rangePtr == NULL) { 2695 TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n"));2696 2218 result = TCL_CONTINUE; 2697 2219 goto abnormalReturn; … … 2700 2222 case LOOP_EXCEPTION_RANGE: 2701 2223 if (rangePtr->continueOffset == -1) { 2702 TRACE(("continue => loop w/o continue, checking for catch\n"));2703 2224 goto checkForCatch; 2704 2225 } else { 2705 2226 result = TCL_OK; 2706 TRACE(("continue => range at %d, new pc %d\n",2707 rangePtr->codeOffset, rangePtr->continueOffset));2708 2227 } 2709 2228 break; 2710 2229 case CATCH_EXCEPTION_RANGE: 2711 2230 result = TCL_CONTINUE; 2712 TRACE(("continue => ...\n"));2713 2231 goto processCatch; /* it will use rangePtr */ 2714 2232 default: … … 2744 2262 TclSetVarScalar(iterVarPtr); 2745 2263 TclClearVarUndefined(iterVarPtr); 2746 TRACE(("foreach_start4 %u => loop iter count temp %d\n",2747 opnd, iterTmpIndex));2748 2264 } 2749 2265 ADJUST_PC(5); … … 2794 2310 result = Tcl_ListObjLength(interp, listPtr, &listLen); 2795 2311 if (result != TCL_OK) { 2796 TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ",2797 opnd, i, O2S(listPtr)),2798 Tcl_GetObjResult(interp));2799 2312 goto checkForCatch; 2800 2313 } … … 2840 2353 CACHE_STACK_INFO(); 2841 2354 if (value2Ptr == NULL) { 2842 TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ",2843 opnd, varIndex),2844 Tcl_GetObjResult(interp));2845 2355 if (setEmptyStr) { 2846 2356 Tcl_DecrRefCount(elemPtr); /* unneeded */ … … 2862 2372 2863 2373 PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); 2864 TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n",2865 opnd, numLists, iterNum,2866 (continueLoop? "continue" : "exit")));2867 2374 } 2868 2375 ADJUST_PC(5); … … 2875 2382 */ 2876 2383 catchStackPtr[++catchTop] = stackTop; 2877 TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",2878 TclGetUInt4AtPtr(pc+1), catchTop, stackTop));2879 2384 ADJUST_PC(5); 2880 2385 … … 2882 2387 catchTop--; 2883 2388 result = TCL_OK; 2884 TRACE(("endCatch => catchTop=%d\n", catchTop));2885 2389 ADJUST_PC(1); 2886 2390 2887 2391 case INST_PUSH_RESULT: 2888 2392 PUSH_OBJECT(Tcl_GetObjResult(interp)); 2889 TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp));2890 2393 ADJUST_PC(1); 2891 2394 2892 2395 case INST_PUSH_RETURN_CODE: 2893 2396 PUSH_OBJECT(Tcl_NewLongObj(result)); 2894 TRACE(("pushReturnCode => %u\n", result));2895 2397 ADJUST_PC(1); 2896 2398 2897 2399 default: 2898 TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode));2899 2400 panic("TclExecuteByteCode: unrecognized opCode %u", opCode); 2900 2401 } /* end of switch on opCode */ … … 2926 2427 rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); 2927 2428 if (rangePtr == NULL) { 2928 TRACE((" ... no enclosing catch, returning %s\n",2929 StringForResultCode(result)));2930 2429 goto abnormalReturn; 2931 2430 } … … 2945 2444 TclDecrRefCount(valuePtr); 2946 2445 } 2947 TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",2948 rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],2949 (unsigned int)(rangePtr->catchOffset)));2950 2446 pc = (codePtr->codeStart + rangePtr->catchOffset); 2951 2447 continue; /* restart the execution loop at pc */ … … 2975 2471 #undef STATIC_CATCH_STACK_SIZE 2976 2472 } 2977 2978 2979 /*2980 *----------------------------------------------------------------------2981 *2982 * PrintByteCodeInfo --2983 *2984 * This procedure prints a summary about a bytecode object to stdout.2985 * It is called by TclExecuteByteCode when starting to execute the2986 * bytecode object if tclTraceExec has the value 2 or more.2987 *2988 * Results:2989 * None.2990 *2991 * Side effects:2992 * None.2993 *2994 *----------------------------------------------------------------------2995 */2996 2997 static void2998 PrintByteCodeInfo(codePtr)2999 register ByteCode *codePtr; /* The bytecode whose summary is printed3000 * to stdout. */3001 {3002 Proc *procPtr = codePtr->procPtr;3003 int numCmds = codePtr->numCommands;3004 int numObjs = codePtr->numObjects;3005 int objBytes, i;3006 3007 objBytes = (numObjs * sizeof(Tcl_Obj));3008 for (i = 0; i < numObjs; i++) {3009 Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];3010 if (litObjPtr->bytes != NULL) {3011 objBytes += litObjPtr->length;3012 }3013 }3014 3015 fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",3016 (unsigned int) codePtr, codePtr->refCount,3017 codePtr->compileEpoch, (unsigned int) codePtr->iPtr,3018 codePtr->iPtr->compileEpoch);3019 3020 fprintf(stdout, " Source: ");3021 TclPrintSource(stdout, codePtr->source, 70);3022 3023 fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",3024 numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,3025 codePtr->numAuxDataItems, codePtr->maxStackDepth,3026 (codePtr->numSrcChars?3027 ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));3028 3029 fprintf(stdout, " Code %zu = %u(header)+%d(inst)+%d(objs)+%u(exc)+%u(aux)+%d(cmd map)\n",3030 codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,3031 objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),3032 (codePtr->numAuxDataItems * sizeof(AuxData)),3033 codePtr->numCmdLocBytes);3034 3035 if (procPtr != NULL) {3036 fprintf(stdout,3037 " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",3038 (unsigned int) procPtr, procPtr->refCount,3039 procPtr->numArgs, procPtr->numCompiledLocals);3040 }3041 }3042 3043 3044 /*3045 *----------------------------------------------------------------------3046 *3047 * ValidatePcAndStackTop --3048 *3049 * This procedure is called by TclExecuteByteCode when debugging to3050 * verify that the program counter and stack top are valid during3051 * execution.3052 *3053 * Results:3054 * None.3055 *3056 * Side effects:3057 * Prints a message to stderr and panics if either the pc or stack3058 * top are invalid.3059 *3060 *----------------------------------------------------------------------3061 */3062 3063 #ifdef TCL_COMPILE_DEBUG3064 static void3065 ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)3066 register ByteCode *codePtr; /* The bytecode whose summary is printed3067 * to stdout. */3068 unsigned char *pc; /* Points to first byte of a bytecode3069 * instruction. The program counter. */3070 int stackTop; /* Current stack top. Must be between3071 * stackLowerBound and stackUpperBound3072 * (inclusive). */3073 int stackLowerBound; /* Smallest legal value for stackTop. */3074 int stackUpperBound; /* Greatest legal value for stackTop. */3075 {3076 unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);3077 unsigned int codeStart = (unsigned int) codePtr->codeStart;3078 unsigned int codeEnd = (unsigned int)3079 (codePtr->codeStart + codePtr->numCodeBytes);3080 unsigned char opCode = *pc;3081 3082 if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {3083 fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",3084 (unsigned int) pc);3085 panic("TclExecuteByteCode execution failure: bad pc");3086 }3087 if ((unsigned int) opCode > LAST_INST_OPCODE) {3088 fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",3089 (unsigned int) opCode, relativePc);3090 panic("TclExecuteByteCode execution failure: bad opcode");3091 }3092 if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {3093 int numChars;3094 char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);3095 char *ellipsis = "";3096 3097 fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",3098 stackTop, relativePc);3099 if (cmd != NULL) {3100 if (numChars > 100) {3101 numChars = 100;3102 ellipsis = "...";3103 }3104 fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,3105 ellipsis);3106 } else {3107 fprintf(stderr, "\n");3108 }3109 panic("TclExecuteByteCode execution failure: bad stack top");3110 }3111 }3112 #endif /* TCL_COMPILE_DEBUG */3113 2473 3114 2474 … … 4271 3631 4272 3632 4273 #ifdef TCL_COMPILE_STATS4274 /*4275 *----------------------------------------------------------------------4276 *4277 * TclLog2 --4278 *4279 * Procedure used while collecting compilation statistics to determine4280 * the log base 2 of an integer.4281 *4282 * Results:4283 * Returns the log base 2 of the operand. If the argument is less4284 * than or equal to zero, a zero is returned.4285 *4286 * Side effects:4287 * None.4288 *4289 *----------------------------------------------------------------------4290 */4291 4292 int4293 TclLog2(value)4294 register int value; /* The integer for which to compute the4295 * log base 2. */4296 {4297 register int n = value;4298 register int result = 0;4299 4300 while (n > 1) {4301 n = n >> 1;4302 result++;4303 }4304 return result;4305 }4306 4307 4308 /*4309 *----------------------------------------------------------------------4310 *4311 * EvalStatsCmd --4312 *4313 * Implements the "evalstats" command that prints instruction execution4314 * counts to stdout.4315 *4316 * Results:4317 * Standard Tcl results.4318 *4319 * Side effects:4320 * None.4321 *4322 *----------------------------------------------------------------------4323 */4324 4325 static int4326 EvalStatsCmd(unused, interp, argc, argv)4327 ClientData unused; /* Unused. */4328 Tcl_Interp *interp; /* The current interpreter. */4329 int argc; /* The number of arguments. */4330 char **argv; /* The argument strings. */4331 {4332 register double total = 0.0;4333 register int i;4334 int maxSizeDecade = 0;4335 double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));4336 4337 for (i = 0; i < 256; i++) {4338 if (instructionCount[i] != 0) {4339 total += instructionCount[i];4340 }4341 }4342 4343 for (i = 31; i >= 0; i--) {4344 if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {4345 maxSizeDecade = i;4346 break;4347 }4348 }4349 4350 fprintf(stdout, "\nNumber of compilations %ld\n",4351 tclNumCompilations);4352 fprintf(stdout, "Number of executions %ld\n",4353 numExecutions);4354 fprintf(stdout, "Average executions/compilation %.0f\n",4355 ((float) numExecutions/tclNumCompilations));4356 4357 fprintf(stdout, "\nInstructions executed %.0f\n",4358 total);4359 fprintf(stdout, "Average instructions/compile %.0f\n",4360 total/tclNumCompilations);4361 fprintf(stdout, "Average instructions/execution %.0f\n",4362 total/numExecutions);4363 4364 fprintf(stdout, "\nTotal source bytes %.6g\n",4365 tclTotalSourceBytes);4366 fprintf(stdout, "Total code bytes %.6g\n",4367 tclTotalCodeBytes);4368 fprintf(stdout, "Average code/compilation %.0f\n",4369 tclTotalCodeBytes/tclNumCompilations);4370 fprintf(stdout, "Average code/source %.2f\n",4371 tclTotalCodeBytes/tclTotalSourceBytes);4372 fprintf(stdout, "Current source bytes %.6g\n",4373 tclCurrentSourceBytes);4374 fprintf(stdout, "Current code bytes %.6g\n",4375 tclCurrentCodeBytes);4376 fprintf(stdout, "Current code/source %.2f\n",4377 tclCurrentCodeBytes/tclCurrentSourceBytes);4378 4379 fprintf(stdout, "\nTotal objects allocated %ld\n",4380 tclObjsAlloced);4381 fprintf(stdout, "Total objects freed %ld\n",4382 tclObjsFreed);4383 fprintf(stdout, "Current objects: %ld\n",4384 (tclObjsAlloced - tclObjsFreed));4385 4386 fprintf(stdout, "\nBreakdown of code byte requirements:\n");4387 fprintf(stdout, " Total bytes Pct of Avg per\n");4388 fprintf(stdout, " all code compile\n");4389 fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",4390 tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);4391 fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",4392 totalHeaderBytes,4393 ((totalHeaderBytes * 100.0) / tclTotalCodeBytes),4394 totalHeaderBytes/tclNumCompilations);4395 fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",4396 tclTotalInstBytes,4397 ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),4398 tclTotalInstBytes/tclNumCompilations);4399 fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",4400 tclTotalObjBytes,4401 ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),4402 tclTotalObjBytes/tclNumCompilations);4403 fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",4404 tclTotalExceptBytes,4405 ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),4406 tclTotalExceptBytes/tclNumCompilations);4407 fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",4408 tclTotalAuxBytes,4409 ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),4410 tclTotalAuxBytes/tclNumCompilations);4411 fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",4412 tclTotalCmdMapBytes,4413 ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),4414 tclTotalCmdMapBytes/tclNumCompilations);4415 4416 fprintf(stdout, "\nSource and ByteCode size distributions:\n");4417 fprintf(stdout, " binary decade source code\n");4418 for (i = 0; i <= maxSizeDecade; i++) {4419 int decadeLow, decadeHigh;4420 4421 if (i == 0) {4422 decadeLow = 0;4423 } else {4424 decadeLow = 1 << i;4425 }4426 decadeHigh = (1 << (i+1)) - 1;4427 fprintf(stdout, " %6d -%6d %6d %6d\n",4428 decadeLow, decadeHigh,4429 tclSourceCount[i], tclByteCodeCount[i]);4430 }4431 4432 fprintf(stdout, "\nInstruction counts:\n");4433 for (i = 0; i < 256; i++) {4434 if (instructionCount[i]) {4435 fprintf(stdout, "%20s %8d %6.2f%%\n",4436 opName[i], instructionCount[i],4437 (instructionCount[i] * 100.0)/total);4438 }4439 }4440 4441 #ifdef TCL_MEM_DEBUG4442 fprintf(stdout, "\nHeap Statistics:\n");4443 TclDumpMemoryInfo(stdout);4444 #endif /* TCL_MEM_DEBUG */4445 4446 return TCL_OK;4447 }4448 #endif /* TCL_COMPILE_STATS */4449 4450 4451 3633 /* 4452 3634 *---------------------------------------------------------------------- … … 4758 3940 panic("UpdateStringOfCmdName should never be invoked"); 4759 3941 } 4760 4761 4762 #ifdef TCL_COMPILE_DEBUG4763 /*4764 *----------------------------------------------------------------------4765 *4766 * StringForResultCode --4767 *4768 * Procedure that returns a human-readable string representing a4769 * Tcl result code such as TCL_ERROR.4770 *4771 * Results:4772 * If the result code is one of the standard Tcl return codes, the4773 * result is a string representing that code such as "TCL_ERROR".4774 * Otherwise, the result string is that code formatted as a4775 * sequence of decimal digit characters. Note that the resulting4776 * string must not be modified by the caller.4777 *4778 * Side effects:4779 * None.4780 *4781 *----------------------------------------------------------------------4782 */4783 4784 static char *4785 StringForResultCode(result)4786 int result; /* The Tcl result code for which to4787 * generate a string. */4788 {4789 static char buf[20];4790 4791 if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {4792 return resultStrings[result];4793 }4794 TclFormatInt(buf, result);4795 return buf;4796 }4797 #endif /* TCL_COMPILE_DEBUG */ -
external/tcl/tclInt.h
re15936c radeddd8 1326 1326 1327 1327 extern Tcl_Obj * tclFreeObjList; 1328 1329 #ifdef TCL_COMPILE_STATS1330 extern long tclObjsAlloced;1331 extern long tclObjsFreed;1332 #endif /* TCL_COMPILE_STATS */1333 1328 1334 1329 /* … … 1445 1440 int objc, Tcl_Obj *CONST objv[], int flags)); 1446 1441 EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); 1447 1442 EXTERN void TclpFree(char *cp); 1448 1443 EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, 1449 1444 unsigned int size)); … … 1472 1467 EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, 1473 1468 Tcl_Interp *cmdInterp, Tcl_Command cmd)); 1474 EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,1475 Tcl_Obj *objPtr));1476 1469 EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); 1477 1470 EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, … … 1688 1681 */ 1689 1682 1690 #ifdef TCL_COMPILE_STATS1691 # define TclIncrObjsAllocated() \1692 tclObjsAlloced++1693 # define TclIncrObjsFreed() \1694 tclObjsFreed++1695 #else1696 # define TclIncrObjsAllocated()1697 # define TclIncrObjsFreed()1698 #endif /* TCL_COMPILE_STATS */1699 1700 #ifdef TCL_MEM_DEBUG1701 # define TclNewObj(objPtr) \1702 (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \1703 (objPtr)->refCount = 0; \1704 (objPtr)->bytes = tclEmptyStringRep; \1705 (objPtr)->length = 0; \1706 (objPtr)->typePtr = NULL; \1707 TclIncrObjsAllocated()1708 # define TclDbNewObj(objPtr, file, line) \1709 (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \1710 (objPtr)->refCount = 0; \1711 (objPtr)->bytes = tclEmptyStringRep; \1712 (objPtr)->length = 0; \1713 (objPtr)->typePtr = NULL; \1714 TclIncrObjsAllocated()1715 # define TclDecrRefCount(objPtr) \1716 if (--(objPtr)->refCount <= 0) { \1717 if ((objPtr)->refCount < -1) \1718 panic("Reference count for %lx was negative: %s line %d", \1719 (objPtr), __FILE__, __LINE__); \1720 if (((objPtr)->bytes != NULL) \1721 && ((objPtr)->bytes != tclEmptyStringRep)) { \1722 ckfree((char *) (objPtr)->bytes); \1723 } \1724 if (((objPtr)->typePtr != NULL) \1725 && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \1726 (objPtr)->typePtr->freeIntRepProc(objPtr); \1727 } \1728 ckfree((char *) (objPtr)); \1729 TclIncrObjsFreed(); \1730 }1731 #else /* not TCL_MEM_DEBUG */1732 1683 # define TclNewObj(objPtr) \ 1733 1684 if (tclFreeObjList == NULL) { \ … … 1740 1691 (objPtr)->bytes = tclEmptyStringRep; \ 1741 1692 (objPtr)->length = 0; \ 1742 (objPtr)->typePtr = NULL; \ 1743 TclIncrObjsAllocated() 1693 (objPtr)->typePtr = NULL; 1744 1694 # define TclDecrRefCount(objPtr) \ 1745 1695 if (--(objPtr)->refCount <= 0) { \ … … 1754 1704 (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ 1755 1705 tclFreeObjList = (objPtr); \ 1756 TclIncrObjsFreed(); \1757 1706 } 1758 #endif /* TCL_MEM_DEBUG */1759 1707 1760 1708 /* -
external/tcl/tclListObj.c
re15936c radeddd8 46 46 * Tcl_NewListObj -- 47 47 * 48 * This procedure is normally called when not debugging: i.e., when 49 * TCL_MEM_DEBUG is not defined. It creates a new list object from an 50 * (objc,objv) array: that is, each of the objc elements of the array 51 * referenced by objv is inserted as an element into a new Tcl object. 52 * 53 * When TCL_MEM_DEBUG is defined, this procedure just returns the 54 * result of calling the debugging version Tcl_DbNewListObj. 48 * This procedure creates a new list object from an (objc,objv) array: 49 * that is, each of the objc elements of the array referenced by objv 50 * is inserted as an element into a new Tcl object. 55 51 * 56 52 * Results: … … 66 62 *---------------------------------------------------------------------- 67 63 */ 68 69 #ifdef TCL_MEM_DEBUG70 #undef Tcl_NewListObj71 72 Tcl_Obj *73 Tcl_NewListObj(objc, objv)74 int objc; /* Count of objects referenced by objv. */75 Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */76 {77 return Tcl_DbNewListObj(objc, objv, "unknown", 0);78 }79 80 #else /* if not TCL_MEM_DEBUG */81 64 82 65 Tcl_Obj * … … 112 95 return listPtr; 113 96 } 114 #endif /* if TCL_MEM_DEBUG */115 116 117 /*118 *----------------------------------------------------------------------119 *120 * Tcl_DbNewListObj --121 *122 * This procedure is normally called when debugging: i.e., when123 * TCL_MEM_DEBUG is defined. It creates new list objects. It is the124 * same as the Tcl_NewListObj procedure above except that it calls125 * Tcl_DbCkalloc directly with the file name and line number from its126 * caller. This simplifies debugging since then the checkmem command127 * will report the correct file name and line number when reporting128 * objects that haven't been freed.129 *130 * When TCL_MEM_DEBUG is not defined, this procedure just returns the131 * result of calling Tcl_NewListObj.132 *133 * Results:134 * A new list object is returned that is initialized from the object135 * pointers in objv. If objc is less than or equal to zero, an empty136 * object is returned. The new object's string representation137 * is left NULL. The new list object has ref count 0.138 *139 * Side effects:140 * The ref counts of the elements in objv are incremented since the141 * resulting list now refers to them.142 *143 *----------------------------------------------------------------------144 */145 146 #ifdef TCL_MEM_DEBUG147 148 Tcl_Obj *149 Tcl_DbNewListObj(objc, objv, file, line)150 int objc; /* Count of objects referenced by objv. */151 Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */152 char *file; /* The name of the source file calling this153 * procedure; used for debugging. */154 int line; /* Line number in the source file; used155 * for debugging. */156 {157 register Tcl_Obj *listPtr;158 register Tcl_Obj **elemPtrs;159 register List *listRepPtr;160 int i;161 162 TclDbNewObj(listPtr, file, line);163 164 if (objc > 0) {165 Tcl_InvalidateStringRep(listPtr);166 167 elemPtrs = (Tcl_Obj **)168 ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));169 for (i = 0; i < objc; i++) {170 elemPtrs[i] = objv[i];171 Tcl_IncrRefCount(elemPtrs[i]);172 }173 174 listRepPtr = (List *) ckalloc(sizeof(List));175 listRepPtr->maxElemCount = objc;176 listRepPtr->elemCount = objc;177 listRepPtr->elements = elemPtrs;178 179 listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;180 listPtr->typePtr = &tclListType;181 }182 return listPtr;183 }184 185 #else /* if not TCL_MEM_DEBUG */186 187 Tcl_Obj *188 Tcl_DbNewListObj(objc, objv, file, line)189 int objc; /* Count of objects referenced by objv. */190 Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */191 char *file; /* The name of the source file calling this192 * procedure; used for debugging. */193 int line; /* Line number in the source file; used194 * for debugging. */195 {196 return Tcl_NewListObj(objc, objv);197 }198 #endif /* TCL_MEM_DEBUG */199 97 200 98 -
external/tcl/tclObj.c
re15936c radeddd8 36 36 37 37 char *tclEmptyStringRep = NULL; 38 39 /*40 * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and41 * freed (by TclFreeObj).42 */43 44 #ifdef TCL_COMPILE_STATS45 long tclObjsAlloced = 0;46 long tclObjsFreed = 0;47 #endif /* TCL_COMPILE_STATS */48 38 49 39 /* … … 417 407 * Tcl_NewObj -- 418 408 * 419 * This procedure is normally called when not debugging: i.e., when 420 * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote 421 * the empty string. These objects have a NULL object type and NULL 422 * string representation byte pointer. Type managers call this routine 423 * to allocate new objects that they further initialize. 424 * 425 * When TCL_MEM_DEBUG is defined, this procedure just returns the 426 * result of calling the debugging version Tcl_DbNewObj. 409 * This procedure creates new Tcl objects that denote the empty string. 410 * These objects have a NULL object type and NULL string representation 411 * byte pointer. Type managers call this routine to allocate new objects 412 * that they further initialize. 427 413 * 428 414 * Results: … … 431 417 * is set to 0. 432 418 * 433 * Side effects: 434 * If compiling with TCL_COMPILE_STATS, this procedure increments 435 * the global count of allocated objects (tclObjsAlloced). 436 * 437 *---------------------------------------------------------------------- 438 */ 439 440 #ifdef TCL_MEM_DEBUG 441 #undef Tcl_NewObj 442 443 Tcl_Obj * 444 Tcl_NewObj() 445 { 446 return Tcl_DbNewObj("unknown", 0); 447 } 448 449 #else /* if not TCL_MEM_DEBUG */ 419 *---------------------------------------------------------------------- 420 */ 450 421 451 422 Tcl_Obj * … … 468 439 objPtr->length = 0; 469 440 objPtr->typePtr = NULL; 470 #ifdef TCL_COMPILE_STATS471 tclObjsAlloced++;472 #endif /* TCL_COMPILE_STATS */473 441 return objPtr; 474 442 } 475 #endif /* TCL_MEM_DEBUG */476 477 478 /*479 *----------------------------------------------------------------------480 *481 * Tcl_DbNewObj --482 *483 * This procedure is normally called when debugging: i.e., when484 * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the485 * empty string. It is the same as the Tcl_NewObj procedure above486 * except that it calls Tcl_DbCkalloc directly with the file name and487 * line number from its caller. This simplifies debugging since then488 * the checkmem command will report the correct file name and line489 * number when reporting objects that haven't been freed.490 *491 * When TCL_MEM_DEBUG is not defined, this procedure just returns the492 * result of calling Tcl_NewObj.493 *494 * Results:495 * The result is a newly allocated that represents the empty string.496 * The new object's typePtr is set NULL and its ref count is set to 0.497 *498 * Side effects:499 * If compiling with TCL_COMPILE_STATS, this procedure increments500 * the global count of allocated objects (tclObjsAlloced).501 *502 *----------------------------------------------------------------------503 */504 505 #ifdef TCL_MEM_DEBUG506 507 Tcl_Obj *508 Tcl_DbNewObj(file, line)509 register char *file; /* The name of the source file calling this510 * procedure; used for debugging. */511 register int line; /* Line number in the source file; used512 * for debugging. */513 {514 register Tcl_Obj *objPtr;515 516 /*517 * If debugging Tcl's memory usage, allocate the object using ckalloc.518 * Otherwise, allocate it using the list of free Tcl_Objs we maintain.519 */520 521 objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);522 objPtr->refCount = 0;523 objPtr->bytes = tclEmptyStringRep;524 objPtr->length = 0;525 objPtr->typePtr = NULL;526 #ifdef TCL_COMPILE_STATS527 tclObjsAlloced++;528 #endif /* TCL_COMPILE_STATS */529 return objPtr;530 }531 532 #else /* if not TCL_MEM_DEBUG */533 534 Tcl_Obj *535 Tcl_DbNewObj(file, line)536 char *file; /* The name of the source file calling this537 * procedure; used for debugging. */538 int line; /* Line number in the source file; used539 * for debugging. */540 {541 return Tcl_NewObj();542 }543 #endif /* TCL_MEM_DEBUG */544 443 545 444 … … 609 508 * after deallocating the string representation and calling the 610 509 * type-specific Tcl_FreeInternalRepProc to deallocate the object's 611 * internal representation. If compiling with TCL_COMPILE_STATS, 612 * this procedure increments the global count of freed objects 613 * (tclObjsFreed). 510 * internal representation. 614 511 * 615 512 *---------------------------------------------------------------------- … … 622 519 register Tcl_ObjType *typePtr = objPtr->typePtr; 623 520 624 #ifdef TCL_MEM_DEBUG625 if ((objPtr)->refCount < -1) {626 panic("Reference count for %lx was negative", objPtr);627 }628 #endif /* TCL_MEM_DEBUG */629 630 521 Tcl_InvalidateStringRep(objPtr); 631 522 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { … … 634 525 635 526 /* 636 * If debugging Tcl's memory usage, deallocate the object using ckfree. 637 * Otherwise, deallocate it by adding it onto the list of free 527 * Deallocate the object by adding it onto the list of free 638 528 * Tcl_Objs we maintain. 639 529 */ 640 530 641 #ifdef TCL_MEM_DEBUG642 ckfree((char *) objPtr);643 #else644 531 objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; 645 532 tclFreeObjList = objPtr; 646 #endif /* TCL_MEM_DEBUG */647 648 #ifdef TCL_COMPILE_STATS649 tclObjsFreed++;650 #endif /* TCL_COMPILE_STATS */651 533 } 652 534 … … 794 676 * Tcl_NewBooleanObj -- 795 677 * 796 * This procedure is normally called when not debugging: i.e., when 797 * TCL_MEM_DEBUG is not defined. It creates a new boolean object and 798 * initializes it from the argument boolean value. A nonzero 799 * "boolValue" is coerced to 1. 800 * 801 * When TCL_MEM_DEBUG is defined, this procedure just returns the 802 * result of calling the debugging version Tcl_DbNewBooleanObj. 678 * This procedure creates a new boolean object and initializes it from 679 * the argument boolean value. A nonzero "boolValue" is coerced to 1. 803 680 * 804 681 * Results: … … 811 688 *---------------------------------------------------------------------- 812 689 */ 813 814 #ifdef TCL_MEM_DEBUG815 #undef Tcl_NewBooleanObj816 690 817 691 Tcl_Obj * … … 819 693 register int boolValue; /* Boolean used to initialize new object. */ 820 694 { 821 return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);822 }823 824 #else /* if not TCL_MEM_DEBUG */825 826 Tcl_Obj *827 Tcl_NewBooleanObj(boolValue)828 register int boolValue; /* Boolean used to initialize new object. */829 {830 695 register Tcl_Obj *objPtr; 831 696 … … 837 702 return objPtr; 838 703 } 839 #endif /* TCL_MEM_DEBUG */840 841 842 /*843 *----------------------------------------------------------------------844 *845 * Tcl_DbNewBooleanObj --846 *847 * This procedure is normally called when debugging: i.e., when848 * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the849 * same as the Tcl_NewBooleanObj procedure above except that it calls850 * Tcl_DbCkalloc directly with the file name and line number from its851 * caller. This simplifies debugging since then the checkmem command852 * will report the correct file name and line number when reporting853 * objects that haven't been freed.854 *855 * When TCL_MEM_DEBUG is not defined, this procedure just returns the856 * result of calling Tcl_NewBooleanObj.857 *858 * Results:859 * The newly created object is returned. This object will have an860 * invalid string representation. The returned object has ref count 0.861 *862 * Side effects:863 * None.864 *865 *----------------------------------------------------------------------866 */867 868 #ifdef TCL_MEM_DEBUG869 870 Tcl_Obj *871 Tcl_DbNewBooleanObj(boolValue, file, line)872 register int boolValue; /* Boolean used to initialize new object. */873 char *file; /* The name of the source file calling this874 * procedure; used for debugging. */875 int line; /* Line number in the source file; used876 * for debugging. */877 {878 register Tcl_Obj *objPtr;879 880 TclDbNewObj(objPtr, file, line);881 objPtr->bytes = NULL;882 883 objPtr->internalRep.longValue = (boolValue? 1 : 0);884 objPtr->typePtr = &tclBooleanType;885 return objPtr;886 }887 888 #else /* if not TCL_MEM_DEBUG */889 890 Tcl_Obj *891 Tcl_DbNewBooleanObj(boolValue, file, line)892 register int boolValue; /* Boolean used to initialize new object. */893 char *file; /* The name of the source file calling this894 * procedure; used for debugging. */895 int line; /* Line number in the source file; used896 * for debugging. */897 {898 return Tcl_NewBooleanObj(boolValue);899 }900 #endif /* TCL_MEM_DEBUG */901 704 902 705 … … 1178 981 * Tcl_NewDoubleObj -- 1179 982 * 1180 * This procedure is normally called when not debugging: i.e., when 1181 * TCL_MEM_DEBUG is not defined. It creates a new double object and 1182 * initializes it from the argument double value. 1183 * 1184 * When TCL_MEM_DEBUG is defined, this procedure just returns the 1185 * result of calling the debugging version Tcl_DbNewDoubleObj. 983 * This procedure creates a new double object and initializes it from 984 * the argument double value. 1186 985 * 1187 986 * Results: … … 1194 993 *---------------------------------------------------------------------- 1195 994 */ 1196 1197 #ifdef TCL_MEM_DEBUG1198 #undef Tcl_NewDoubleObj1199 995 1200 996 Tcl_Obj * … … 1202 998 register double dblValue; /* Double used to initialize the object. */ 1203 999 { 1204 return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);1205 }1206 1207 #else /* if not TCL_MEM_DEBUG */1208 1209 Tcl_Obj *1210 Tcl_NewDoubleObj(dblValue)1211 register double dblValue; /* Double used to initialize the object. */1212 {1213 1000 register Tcl_Obj *objPtr; 1214 1001 … … 1220 1007 return objPtr; 1221 1008 } 1222 #endif /* if TCL_MEM_DEBUG */1223 1224 1225 /*1226 *----------------------------------------------------------------------1227 *1228 * Tcl_DbNewDoubleObj --1229 *1230 * This procedure is normally called when debugging: i.e., when1231 * TCL_MEM_DEBUG is defined. It creates new double objects. It is the1232 * same as the Tcl_NewDoubleObj procedure above except that it calls1233 * Tcl_DbCkalloc directly with the file name and line number from its1234 * caller. This simplifies debugging since then the checkmem command1235 * will report the correct file name and line number when reporting1236 * objects that haven't been freed.1237 *1238 * When TCL_MEM_DEBUG is not defined, this procedure just returns the1239 * result of calling Tcl_NewDoubleObj.1240 *1241 * Results:1242 * The newly created object is returned. This object will have an1243 * invalid string representation. The returned object has ref count 0.1244 *1245 * Side effects:1246 * None.1247 *1248 *----------------------------------------------------------------------1249 */1250 1251 #ifdef TCL_MEM_DEBUG1252 1253 Tcl_Obj *1254 Tcl_DbNewDoubleObj(dblValue, file, line)1255 register double dblValue; /* Double used to initialize the object. */1256 char *file; /* The name of the source file calling this1257 * procedure; used for debugging. */1258 int line; /* Line number in the source file; used1259 * for debugging. */1260 {1261 register Tcl_Obj *objPtr;1262 1263 TclDbNewObj(objPtr, file, line);1264 objPtr->bytes = NULL;1265 1266 objPtr->internalRep.doubleValue = dblValue;1267 objPtr->typePtr = &tclDoubleType;1268 return objPtr;1269 }1270 1271 #else /* if not TCL_MEM_DEBUG */1272 1273 Tcl_Obj *1274 Tcl_DbNewDoubleObj(dblValue, file, line)1275 register double dblValue; /* Double used to initialize the object. */1276 char *file; /* The name of the source file calling this1277 * procedure; used for debugging. */1278 int line; /* Line number in the source file; used1279 * for debugging. */1280 {1281 return Tcl_NewDoubleObj(dblValue);1282 }1283 #endif /* TCL_MEM_DEBUG */1284 1009 1285 1010 … … 1531 1256 * Tcl_NewIntObj -- 1532 1257 * 1533 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 1534 * Tcl_NewIntObj to create a new integer object end up calling the 1535 * debugging procedure Tcl_DbNewLongObj instead. 1536 * 1537 * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, 1538 * calls to Tcl_NewIntObj result in a call to one of the two 1258 * Calls to Tcl_NewIntObj result in a call to one of the two 1539 1259 * Tcl_NewIntObj implementations below. We provide two implementations 1540 1260 * so that the Tcl core can be compiled to do memory debugging of the … … 1556 1276 */ 1557 1277 1558 #ifdef TCL_MEM_DEBUG1559 #undef Tcl_NewIntObj1560 1561 1278 Tcl_Obj * 1562 1279 Tcl_NewIntObj(intValue) 1563 1280 register int intValue; /* Int used to initialize the new object. */ 1564 1281 { 1565 return Tcl_DbNewLongObj((long)intValue, "unknown", 0);1566 }1567 1568 #else /* if not TCL_MEM_DEBUG */1569 1570 Tcl_Obj *1571 Tcl_NewIntObj(intValue)1572 register int intValue; /* Int used to initialize the new object. */1573 {1574 1282 register Tcl_Obj *objPtr; 1575 1283 … … 1581 1289 return objPtr; 1582 1290 } 1583 #endif /* if TCL_MEM_DEBUG */1584 1291 1585 1292 … … 1856 1563 * Tcl_NewLongObj -- 1857 1564 * 1858 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 1859 * Tcl_NewLongObj to create a new long integer object end up calling 1860 * the debugging procedure Tcl_DbNewLongObj instead. 1861 * 1862 * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, 1863 * calls to Tcl_NewLongObj result in a call to one of the two 1565 * Calls to Tcl_NewLongObj result in a call to one of the two 1864 1566 * Tcl_NewLongObj implementations below. We provide two implementations 1865 1567 * so that the Tcl core can be compiled to do memory debugging of the … … 1881 1583 */ 1882 1584 1883 #ifdef TCL_MEM_DEBUG1884 #undef Tcl_NewLongObj1885 1886 1585 Tcl_Obj * 1887 1586 Tcl_NewLongObj(longValue) … … 1889 1588 * new object. */ 1890 1589 { 1891 return Tcl_DbNewLongObj(longValue, "unknown", 0);1892 }1893 1894 #else /* if not TCL_MEM_DEBUG */1895 1896 Tcl_Obj *1897 Tcl_NewLongObj(longValue)1898 register long longValue; /* Long integer used to initialize the1899 * new object. */1900 {1901 1590 register Tcl_Obj *objPtr; 1902 1591 … … 1908 1597 return objPtr; 1909 1598 } 1910 #endif /* if TCL_MEM_DEBUG */1911 1599 1912 1600 … … 1916 1604 * Tcl_DbNewLongObj -- 1917 1605 * 1918 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 1919 * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or 1920 * long integer objects end up calling the debugging procedure 1921 * Tcl_DbNewLongObj instead. We provide two implementations of 1922 * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do 1923 * memory debugging of the core is independent of whether a client 1924 * requests debugging for itself. 1925 * 1926 * When the core is compiled with TCL_MEM_DEBUG defined, 1927 * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and 1928 * line number from its caller. This simplifies debugging since then 1929 * the checkmem command will report the caller's file name and line 1930 * number when reporting objects that haven't been freed. 1931 * 1932 * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, 1933 * this procedure just returns the result of calling Tcl_NewLongObj. 1606 * This procedure just returns the result of calling Tcl_NewLongObj. 1934 1607 * 1935 1608 * Results: … … 1943 1616 *---------------------------------------------------------------------- 1944 1617 */ 1945 1946 #ifdef TCL_MEM_DEBUG1947 1618 1948 1619 Tcl_Obj * … … 1955 1626 * for debugging. */ 1956 1627 { 1957 register Tcl_Obj *objPtr;1958 1959 TclDbNewObj(objPtr, file, line);1960 objPtr->bytes = NULL;1961 1962 objPtr->internalRep.longValue = longValue;1963 objPtr->typePtr = &tclIntType;1964 return objPtr;1965 }1966 1967 #else /* if not TCL_MEM_DEBUG */1968 1969 Tcl_Obj *1970 Tcl_DbNewLongObj(longValue, file, line)1971 register long longValue; /* Long integer used to initialize the1972 * new object. */1973 char *file; /* The name of the source file calling this1974 * procedure; used for debugging. */1975 int line; /* Line number in the source file; used1976 * for debugging. */1977 {1978 1628 return Tcl_NewLongObj(longValue); 1979 1629 } 1980 #endif /* TCL_MEM_DEBUG */1981 1630 1982 1631 … … 2060 1709 return result; 2061 1710 } 2062 2063 2064 /*2065 *----------------------------------------------------------------------2066 *2067 * Tcl_DbIncrRefCount --2068 *2069 * This procedure is normally called when debugging: i.e., when2070 * TCL_MEM_DEBUG is defined. This checks to see whether or not2071 * the memory has been freed before incrementing the ref count.2072 *2073 * When TCL_MEM_DEBUG is not defined, this procedure just increments2074 * the reference count of the object.2075 *2076 * Results:2077 * None.2078 *2079 * Side effects:2080 * The object's ref count is incremented.2081 *2082 *----------------------------------------------------------------------2083 */2084 2085 void2086 Tcl_DbIncrRefCount(objPtr, file, line)2087 register Tcl_Obj *objPtr; /* The object we are adding a reference to. */2088 char *file; /* The name of the source file calling this2089 * procedure; used for debugging. */2090 int line; /* Line number in the source file; used2091 * for debugging. */2092 {2093 #ifdef TCL_MEM_DEBUG2094 if (objPtr->refCount == 0x61616161) {2095 fprintf(stderr, "file = %s, line = %d\n", file, line);2096 fflush(stderr);2097 panic("Trying to increment refCount of previously disposed object.");2098 }2099 #endif2100 ++(objPtr)->refCount;2101 }2102 2103 2104 /*2105 *----------------------------------------------------------------------2106 *2107 * Tcl_DbDecrRefCount --2108 *2109 * This procedure is normally called when debugging: i.e., when2110 * TCL_MEM_DEBUG is defined. This checks to see whether or not2111 * the memory has been freed before incrementing the ref count.2112 *2113 * When TCL_MEM_DEBUG is not defined, this procedure just increments2114 * the reference count of the object.2115 *2116 * Results:2117 * None.2118 *2119 * Side effects:2120 * The object's ref count is incremented.2121 *2122 *----------------------------------------------------------------------2123 */2124 2125 void2126 Tcl_DbDecrRefCount(objPtr, file, line)2127 register Tcl_Obj *objPtr; /* The object we are adding a reference to. */2128 char *file; /* The name of the source file calling this2129 * procedure; used for debugging. */2130 int line; /* Line number in the source file; used2131 * for debugging. */2132 {2133 #ifdef TCL_MEM_DEBUG2134 if (objPtr->refCount == 0x61616161) {2135 fprintf(stderr, "file = %s, line = %d\n", file, line);2136 fflush(stderr);2137 panic("Trying to decrement refCount of previously disposed object.");2138 }2139 #endif2140 if (--(objPtr)->refCount <= 0) {2141 TclFreeObj(objPtr);2142 }2143 }2144 2145 2146 /*2147 *----------------------------------------------------------------------2148 *2149 * Tcl_DbIsShared --2150 *2151 * This procedure is normally called when debugging: i.e., when2152 * TCL_MEM_DEBUG is defined. This checks to see whether or not2153 * the memory has been freed before incrementing the ref count.2154 *2155 * When TCL_MEM_DEBUG is not defined, this procedure just decrements2156 * the reference count of the object and throws it away if the count2157 * is 0 or less.2158 *2159 * Results:2160 * None.2161 *2162 * Side effects:2163 * The object's ref count is incremented.2164 *2165 *----------------------------------------------------------------------2166 */2167 2168 int2169 Tcl_DbIsShared(objPtr, file, line)2170 register Tcl_Obj *objPtr; /* The object we are adding a reference to. */2171 char *file; /* The name of the source file calling this2172 * procedure; used for debugging. */2173 int line; /* Line number in the source file; used2174 * for debugging. */2175 {2176 #ifdef TCL_MEM_DEBUG2177 if (objPtr->refCount == 0x61616161) {2178 fprintf(stderr, "file = %s, line = %d\n", file, line);2179 fflush(stderr);2180 panic("Trying to check whether previously disposed object is shared.");2181 }2182 #endif2183 return ((objPtr)->refCount > 1);2184 } -
external/tcl/tclProc.c
re15936c radeddd8 985 985 */ 986 986 987 if (tclTraceExec >= 1) {988 fprintf(stdout, "Calling proc ");989 for (i = 0; i < objc; i++) {990 bytes = Tcl_GetStringFromObj(objv[i], &length);991 TclPrintSource(stdout, bytes, TclMin(length, 15));992 fprintf(stdout, " ");993 }994 fprintf(stdout, "\n");995 fflush(stdout);996 }997 998 987 iPtr->returnCode = TCL_OK; 999 988 procPtr->refCount++; … … 1119 1108 int numChars; 1120 1109 char *ellipsis; 1121 1122 if (tclTraceCompile >= 1) {1123 /*1124 * Display a line summarizing the top level command we1125 * are about to compile.1126 */1127 1128 numChars = strlen(procName);1129 ellipsis = "";1130 if (numChars > 50) {1131 numChars = 50;1132 ellipsis = "...";1133 }1134 fprintf(stdout, "Compiling %s \"%.*s%s\"\n",1135 description, numChars, procName, ellipsis);1136 }1137 1110 1138 1111 /* -
external/tcl/tclStringObj.c
re15936c radeddd8 50 50 * Tcl_NewStringObj -- 51 51 * 52 * This procedure is normally called when not debugging: i.e., when 53 * TCL_MEM_DEBUG is not defined. It creates a new string object and 54 * initializes it from the byte pointer and length arguments. 55 * 56 * When TCL_MEM_DEBUG is defined, this procedure just returns the 57 * result of calling the debugging version Tcl_DbNewStringObj. 52 * This procedure creates a new string object and initializes it from 53 * the byte pointer and length arguments. 58 54 * 59 55 * Results: … … 70 66 *---------------------------------------------------------------------- 71 67 */ 72 73 #ifdef TCL_MEM_DEBUG74 #undef Tcl_NewStringObj75 68 76 69 Tcl_Obj * … … 83 76 * NULL byte. */ 84 77 { 85 return Tcl_DbNewStringObj(bytes, length, "unknown", 0);86 }87 88 #else /* if not TCL_MEM_DEBUG */89 90 Tcl_Obj *91 Tcl_NewStringObj(bytes, length)92 register char *bytes; /* Points to the first of the length bytes93 * used to initialize the new object. */94 register int length; /* The number of bytes to copy from "bytes"95 * when initializing the new object. If96 * negative, use bytes up to the first97 * NULL byte. */98 {99 78 register Tcl_Obj *objPtr; 100 79 … … 106 85 return objPtr; 107 86 } 108 #endif /* TCL_MEM_DEBUG */109 110 111 /*112 *----------------------------------------------------------------------113 *114 * Tcl_DbNewStringObj --115 *116 * This procedure is normally called when debugging: i.e., when117 * TCL_MEM_DEBUG is defined. It creates new string objects. It is the118 * same as the Tcl_NewStringObj procedure above except that it calls119 * Tcl_DbCkalloc directly with the file name and line number from its120 * caller. This simplifies debugging since then the checkmem command121 * will report the correct file name and line number when reporting122 * objects that haven't been freed.123 *124 * When TCL_MEM_DEBUG is not defined, this procedure just returns the125 * result of calling Tcl_NewStringObj.126 *127 * Results:128 * A newly created string object is returned that has ref count zero.129 *130 * Side effects:131 * The new object's internal string representation will be set to a132 * copy of the length bytes starting at "bytes". If "length" is133 * negative, use bytes up to the first NULL byte; i.e., assume "bytes"134 * points to a C-style NULL-terminated string. The object's type is set135 * to NULL. An extra NULL is added to the end of the new object's byte136 * array.137 *138 *----------------------------------------------------------------------139 */140 141 #ifdef TCL_MEM_DEBUG142 143 Tcl_Obj *144 Tcl_DbNewStringObj(bytes, length, file, line)145 register char *bytes; /* Points to the first of the length bytes146 * used to initialize the new object. */147 register int length; /* The number of bytes to copy from "bytes"148 * when initializing the new object. If149 * negative, use bytes up to the first150 * NULL byte. */151 char *file; /* The name of the source file calling this152 * procedure; used for debugging. */153 int line; /* Line number in the source file; used154 * for debugging. */155 {156 register Tcl_Obj *objPtr;157 158 if (length < 0) {159 length = (bytes? strlen(bytes) : 0);160 }161 TclDbNewObj(objPtr, file, line);162 TclInitStringRep(objPtr, bytes, length);163 return objPtr;164 }165 166 #else /* if not TCL_MEM_DEBUG */167 168 Tcl_Obj *169 Tcl_DbNewStringObj(bytes, length, file, line)170 register char *bytes; /* Points to the first of the length bytes171 * used to initialize the new object. */172 register int length; /* The number of bytes to copy from "bytes"173 * when initializing the new object. If174 * negative, use bytes up to the first175 * NULL byte. */176 char *file; /* The name of the source file calling this177 * procedure; used for debugging. */178 int line; /* Line number in the source file; used179 * for debugging. */180 {181 return Tcl_NewStringObj(bytes, length);182 }183 #endif /* TCL_MEM_DEBUG */184 87 185 88 -
external/tcl/tclVar.c
re15936c radeddd8 711 711 char *msg; 712 712 713 #ifdef TCL_COMPILE_DEBUG714 Proc *procPtr = varFramePtr->procPtr;715 int localCt = procPtr->numCompiledLocals;716 717 if (compiledLocals == NULL) {718 fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n",719 localIndex, (unsigned int) varFramePtr);720 panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",721 (unsigned int) varFramePtr);722 }723 if ((localIndex < 0) || (localIndex >= localCt)) {724 fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n",725 localIndex, (unsigned int) varFramePtr, localCt);726 panic("TclGetIndexedScalar: bad local index %i in frame 0x%x",727 localIndex, (unsigned int) varFramePtr);728 }729 #endif /* TCL_COMPILE_DEBUG */730 731 713 varPtr = &(compiledLocals[localIndex]); 732 714 varName = varPtr->name; … … 832 814 int new; 833 815 834 #ifdef TCL_COMPILE_DEBUG835 Proc *procPtr = varFramePtr->procPtr;836 int localCt = procPtr->numCompiledLocals;837 838 if (compiledLocals == NULL) {839 fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n",840 localIndex, (unsigned int) varFramePtr);841 panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",842 (unsigned int) varFramePtr);843 }844 if ((localIndex < 0) || (localIndex >= localCt)) {845 fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n",846 localIndex, (unsigned int) varFramePtr, localCt);847 panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x",848 localIndex, (unsigned int) varFramePtr);849 }850 #endif /* TCL_COMPILE_DEBUG */851 852 816 /* 853 817 * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. … … 1449 1413 Tcl_Obj *resultPtr = NULL; 1450 1414 1451 #ifdef TCL_COMPILE_DEBUG1452 Proc *procPtr = varFramePtr->procPtr;1453 int localCt = procPtr->numCompiledLocals;1454 1455 if (compiledLocals == NULL) {1456 fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n",1457 localIndex, (unsigned int) varFramePtr);1458 panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",1459 (unsigned int) varFramePtr);1460 }1461 if ((localIndex < 0) || (localIndex >= localCt)) {1462 fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n",1463 localIndex, (unsigned int) varFramePtr, localCt);1464 panic("TclSetIndexedScalar: bad local index %i in frame 0x%x",1465 localIndex, (unsigned int) varFramePtr);1466 }1467 #endif /* TCL_COMPILE_DEBUG */1468 1469 1415 varPtr = &(compiledLocals[localIndex]); 1470 1416 varName = varPtr->name; … … 1635 1581 int new; 1636 1582 1637 #ifdef TCL_COMPILE_DEBUG1638 Proc *procPtr = varFramePtr->procPtr;1639 int localCt = procPtr->numCompiledLocals;1640 1641 if (compiledLocals == NULL) {1642 fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n",1643 localIndex, (unsigned int) varFramePtr);1644 panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",1645 (unsigned int) varFramePtr);1646 }1647 if ((localIndex < 0) || (localIndex >= localCt)) {1648 fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n",1649 localIndex, (unsigned int) varFramePtr, localCt);1650 panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",1651 localIndex, (unsigned int) varFramePtr);1652 }1653 #endif /* TCL_COMPILE_DEBUG */1654 1655 1583 /* 1656 1584 * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE.
Note:
See TracChangeset
for help on using the changeset viewer.