1/* 2 * tclObj.c -- 3 * 4 * This file contains Tcl object-related functions that are used by many 5 * Tcl commands. 6 * 7 * Copyright (c) 1995-1997 Sun Microsystems, Inc. 8 * Copyright (c) 1999 by Scriptics Corporation. 9 * Copyright (c) 2001 by ActiveState Corporation. 10 * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. 11 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 12 * 13 * See the file "license.terms" for information on usage and redistribution of 14 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 * 16 * RCS: @(#) $Id: tclObj.c,v 1.139.2.8 2010/03/30 16:30:13 dgp Exp $ 17 */ 18 19#include "tclInt.h" 20#include "tommath.h" 21#include <float.h> 22#include <math.h> 23 24/* 25 * Table of all object types. 26 */ 27 28static Tcl_HashTable typeTable; 29static int typeTableInitialized = 0; /* 0 means not yet initialized. */ 30TCL_DECLARE_MUTEX(tableMutex) 31 32/* 33 * Head of the list of free Tcl_Obj structs we maintain. 34 */ 35 36Tcl_Obj *tclFreeObjList = NULL; 37 38/* 39 * The object allocator is single threaded. This mutex is referenced by the 40 * TclNewObj macro, however, so must be visible. 41 */ 42 43#ifdef TCL_THREADS 44MODULE_SCOPE Tcl_Mutex tclObjMutex; 45Tcl_Mutex tclObjMutex; 46#endif 47 48/* 49 * Pointer to a heap-allocated string of length zero that the Tcl core uses as 50 * the value of an empty string representation for an object. This value is 51 * shared by all new objects allocated by Tcl_NewObj. 52 */ 53 54char tclEmptyString = '\0'; 55char *tclEmptyStringRep = &tclEmptyString; 56 57#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) 58/* 59 * Structure for tracking the source file and line number where a given Tcl_Obj 60 * was allocated. We also track the pointer to the Tcl_Obj itself, for sanity 61 * checking purposes. 62 */ 63 64typedef struct ObjData { 65 Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ 66 CONST char *file; /* The name of the source file calling this 67 * function; used for debugging. */ 68 int line; /* Line number in the source file; used for 69 * debugging. */ 70} ObjData; 71#endif /* TCL_MEM_DEBUG && TCL_THREADS */ 72 73/* 74 * All static variables used in this file are collected into a single instance 75 * of the following structure. For multi-threaded implementations, there is 76 * one instance of this structure for each thread. 77 * 78 * Notice that different structures with the same name appear in other files. 79 * The structure defined below is used in this file only. 80 */ 81 82typedef struct ThreadSpecificData { 83 Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj 84 * generated by a call to the function 85 * EvalTokensStandard() from a literal text 86 * where bs+nl sequences occured in it, if 87 * any. I.e. this table keeps track of 88 * invisible/stripped continuation lines. Its 89 * keys are Tcl_Obj pointers, the values are 90 * ContLineLoc pointers. See the file 91 * tclCompile.h for the definition of this 92 * structure, and for references to all related 93 * places in the core. 94 */ 95#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) 96 /* 97 * Thread local table that is used to check that a Tcl_Obj was not 98 * allocated by some other thread. 99 */ 100 101 Tcl_HashTable *objThreadMap; 102#endif /* TCL_MEM_DEBUG && TCL_THREADS */ 103} ThreadSpecificData; 104 105static Tcl_ThreadDataKey dataKey; 106 107static void ContLineLocFree (char* clientData); 108static void TclThreadFinalizeContLines (ClientData clientData); 109static ThreadSpecificData* TclGetContLineTable (void); 110 111/* 112 * Nested Tcl_Obj deletion management support 113 * 114 * All context references used in the object freeing code are pointers to this 115 * structure; every thread will have its own structure instance. The purpose 116 * of this structure is to allow deeply nested collections of Tcl_Objs to be 117 * freed without taking a vast depth of C stack (which could cause all sorts 118 * of breakage.) 119 */ 120 121typedef struct PendingObjData { 122 int deletionCount; /* Count of the number of invokations of 123 * TclFreeObj() are on the stack (at least 124 * conceptually; many are actually expanded 125 * macros). */ 126 Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() 127 * invoked upon them but which can't be 128 * deleted yet because they are in a nested 129 * invokation of TclFreeObj(). By postponing 130 * this way, we limit the maximum overall C 131 * stack depth when deleting a complex object. 132 * The down-side is that we alter the overall 133 * behaviour by altering the order in which 134 * objects are deleted, and we change the 135 * order in which the string rep and the 136 * internal rep of an object are deleted. Note 137 * that code which assumes the previous 138 * behaviour in either of these respects is 139 * unsafe anyway; it was never documented as 140 * to exactly what would happen in these 141 * cases, and the overall contract of a 142 * user-level Tcl_DecrRefCount() is still 143 * preserved (assuming that a particular T_DRC 144 * would delete an object is not very 145 * safe). */ 146} PendingObjData; 147 148/* 149 * These are separated out so that some semantic content is attached 150 * to them. 151 */ 152#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) 153#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) 154#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) 155#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) 156#define PushObjToDelete(contextPtr,objPtr) \ 157 /* The string rep is already invalidated so we can use the bytes value \ 158 * for our pointer chain: push onto the head of the stack. */ \ 159 (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ 160 (contextPtr)->deletionStack = (objPtr) 161#define PopObjToDelete(contextPtr,objPtrVar) \ 162 (objPtrVar) = (contextPtr)->deletionStack; \ 163 (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes 164 165/* 166 * Macro to set up the local reference to the deletion context. 167 */ 168#ifndef TCL_THREADS 169static PendingObjData pendingObjData; 170#define ObjInitDeletionContext(contextPtr) \ 171 PendingObjData *CONST contextPtr = &pendingObjData 172#else 173static Tcl_ThreadDataKey pendingObjDataKey; 174#define ObjInitDeletionContext(contextPtr) \ 175 PendingObjData *CONST contextPtr = (PendingObjData *) \ 176 Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) 177#endif 178 179/* 180 * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep 181 */ 182 183#define PACK_BIGNUM(bignum, objPtr) \ 184 if ((bignum).used > 0x7fff) { \ 185 mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ 186 *temp = bignum; \ 187 (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \ 188 (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \ 189 } else { \ 190 if ((bignum).alloc > 0x7fff) { \ 191 mp_shrink(&(bignum)); \ 192 } \ 193 (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ 194 (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ 195 | ((bignum).alloc << 15) | ((bignum).used)); \ 196 } 197 198#define UNPACK_BIGNUM(objPtr, bignum) \ 199 if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ 200 (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ 201 } else { \ 202 (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \ 203 (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ 204 (bignum).alloc = \ 205 ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ 206 (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ 207 } 208 209/* 210 * Prototypes for functions defined later in this file: 211 */ 212 213static int ParseBoolean(Tcl_Obj *objPtr); 214static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 215static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 216static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 217static void UpdateStringOfDouble(Tcl_Obj *objPtr); 218static void UpdateStringOfInt(Tcl_Obj *objPtr); 219#ifndef NO_WIDE_TYPE 220static void UpdateStringOfWideInt(Tcl_Obj *objPtr); 221static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 222#endif 223static void FreeBignum(Tcl_Obj *objPtr); 224static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); 225static void UpdateStringOfBignum(Tcl_Obj *objPtr); 226static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, 227 int copy, mp_int *bignumValue); 228 229/* 230 * Prototypes for the array hash key methods. 231 */ 232 233static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); 234 235/* 236 * Prototypes for the CommandName object type. 237 */ 238 239static void DupCmdNameInternalRep(Tcl_Obj *objPtr, 240 Tcl_Obj *copyPtr); 241static void FreeCmdNameInternalRep(Tcl_Obj *objPtr); 242static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 243 244/* 245 * The structures below defines the Tcl object types defined in this file by 246 * means of functions that can be invoked by generic object code. See also 247 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager 248 * implementations. 249 */ 250 251static Tcl_ObjType oldBooleanType = { 252 "boolean", /* name */ 253 NULL, /* freeIntRepProc */ 254 NULL, /* dupIntRepProc */ 255 NULL, /* updateStringProc */ 256 SetBooleanFromAny /* setFromAnyProc */ 257}; 258Tcl_ObjType tclBooleanType = { 259 "booleanString", /* name */ 260 NULL, /* freeIntRepProc */ 261 NULL, /* dupIntRepProc */ 262 NULL, /* updateStringProc */ 263 SetBooleanFromAny /* setFromAnyProc */ 264}; 265Tcl_ObjType tclDoubleType = { 266 "double", /* name */ 267 NULL, /* freeIntRepProc */ 268 NULL, /* dupIntRepProc */ 269 UpdateStringOfDouble, /* updateStringProc */ 270 SetDoubleFromAny /* setFromAnyProc */ 271}; 272Tcl_ObjType tclIntType = { 273 "int", /* name */ 274 NULL, /* freeIntRepProc */ 275 NULL, /* dupIntRepProc */ 276 UpdateStringOfInt, /* updateStringProc */ 277 SetIntFromAny /* setFromAnyProc */ 278}; 279#ifndef NO_WIDE_TYPE 280Tcl_ObjType tclWideIntType = { 281 "wideInt", /* name */ 282 NULL, /* freeIntRepProc */ 283 NULL, /* dupIntRepProc */ 284 UpdateStringOfWideInt, /* updateStringProc */ 285 SetWideIntFromAny /* setFromAnyProc */ 286}; 287#endif 288Tcl_ObjType tclBignumType = { 289 "bignum", /* name */ 290 FreeBignum, /* freeIntRepProc */ 291 DupBignum, /* dupIntRepProc */ 292 UpdateStringOfBignum, /* updateStringProc */ 293 NULL /* setFromAnyProc */ 294}; 295 296/* 297 * The structure below defines the Tcl obj hash key type. 298 */ 299 300Tcl_HashKeyType tclObjHashKeyType = { 301 TCL_HASH_KEY_TYPE_VERSION, /* version */ 302 0, /* flags */ 303 TclHashObjKey, /* hashKeyProc */ 304 TclCompareObjKeys, /* compareKeysProc */ 305 AllocObjEntry, /* allocEntryProc */ 306 TclFreeObjEntry /* freeEntryProc */ 307}; 308 309/* 310 * The structure below defines the command name Tcl object type by means of 311 * functions that can be invoked by generic object code. Objects of this type 312 * cache the Command pointer that results from looking up command names in the 313 * command hashtable. Such objects appear as the zeroth ("command name") 314 * argument in a Tcl command. 315 * 316 * NOTE: the ResolvedCmdName that gets cached is stored in the 317 * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might 318 * think you could use the simpler otherValuePtr field to store the single 319 * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions 320 * use the second internal pointer field of the twoPtrValue field for their 321 * own purposes. 322 */ 323 324static Tcl_ObjType tclCmdNameType = { 325 "cmdName", /* name */ 326 FreeCmdNameInternalRep, /* freeIntRepProc */ 327 DupCmdNameInternalRep, /* dupIntRepProc */ 328 NULL, /* updateStringProc */ 329 SetCmdNameFromAny /* setFromAnyProc */ 330}; 331 332/* 333 * Structure containing a cached pointer to a command that is the result of 334 * resolving the command's name in some namespace. It is the internal 335 * representation for a cmdName object. It contains the pointer along with 336 * some information that is used to check the pointer's validity. 337 */ 338 339typedef struct ResolvedCmdName { 340 Command *cmdPtr; /* A cached Command pointer. */ 341 Namespace *refNsPtr; /* Points to the namespace containing the 342 * reference (not the namespace that contains 343 * the referenced command). NULL if the name 344 * is fully qualified.*/ 345 long refNsId; /* refNsPtr's unique namespace id. Used to 346 * verify that refNsPtr is still valid (e.g., 347 * it's possible that the cmd's containing 348 * namespace was deleted and a new one created 349 * at the same address). */ 350 int refNsCmdEpoch; /* Value of the referencing namespace's 351 * cmdRefEpoch when the pointer was cached. 352 * Before using the cached pointer, we check 353 * if the namespace's epoch was incremented; 354 * if so, this cached pointer is invalid. */ 355 int cmdEpoch; /* Value of the command's cmdEpoch when this 356 * pointer was cached. Before using the cached 357 * pointer, we check if the cmd's epoch was 358 * incremented; if so, the cmd was renamed, 359 * deleted, hidden, or exposed, and so the 360 * pointer is invalid. */ 361 int refCount; /* Reference count: 1 for each cmdName object 362 * that has a pointer to this ResolvedCmdName 363 * structure as its internal rep. This 364 * structure can be freed when refCount 365 * becomes zero. */ 366} ResolvedCmdName; 367 368/* 369 *------------------------------------------------------------------------- 370 * 371 * TclInitObjectSubsystem -- 372 * 373 * This function is invoked to perform once-only initialization of the 374 * type table. It also registers the object types defined in this file. 375 * 376 * Results: 377 * None. 378 * 379 * Side effects: 380 * Initializes the table of defined object types "typeTable" with builtin 381 * object types defined in this file. 382 * 383 *------------------------------------------------------------------------- 384 */ 385 386void 387TclInitObjSubsystem(void) 388{ 389 Tcl_MutexLock(&tableMutex); 390 typeTableInitialized = 1; 391 Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); 392 Tcl_MutexUnlock(&tableMutex); 393 394 Tcl_RegisterObjType(&tclByteArrayType); 395 Tcl_RegisterObjType(&tclDoubleType); 396 Tcl_RegisterObjType(&tclEndOffsetType); 397 Tcl_RegisterObjType(&tclIntType); 398 Tcl_RegisterObjType(&tclStringType); 399 Tcl_RegisterObjType(&tclListType); 400 Tcl_RegisterObjType(&tclDictType); 401 Tcl_RegisterObjType(&tclByteCodeType); 402 Tcl_RegisterObjType(&tclArraySearchType); 403 Tcl_RegisterObjType(&tclCmdNameType); 404 Tcl_RegisterObjType(&tclRegexpType); 405 Tcl_RegisterObjType(&tclProcBodyType); 406 407 /* For backward compatibility only ... */ 408 Tcl_RegisterObjType(&oldBooleanType); 409#ifndef NO_WIDE_TYPE 410 Tcl_RegisterObjType(&tclWideIntType); 411#endif 412 413#ifdef TCL_COMPILE_STATS 414 Tcl_MutexLock(&tclObjMutex); 415 tclObjsAlloced = 0; 416 tclObjsFreed = 0; 417 { 418 int i; 419 for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { 420 tclObjsShared[i] = 0; 421 } 422 } 423 Tcl_MutexUnlock(&tclObjMutex); 424#endif 425} 426 427/* 428 *---------------------------------------------------------------------- 429 * 430 * TclFinalizeThreadObjects -- 431 * 432 * This function is called by Tcl_FinalizeThread to clean up thread 433 * specific Tcl_Obj information. 434 * 435 * Results: 436 * None. 437 * 438 * Side effects: 439 * None. 440 * 441 *---------------------------------------------------------------------- 442 */ 443 444void 445TclFinalizeThreadObjects(void) 446{ 447#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) 448 Tcl_HashEntry *hPtr; 449 Tcl_HashSearch hSearch; 450 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 451 Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; 452 453 if (tablePtr != NULL) { 454 for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); 455 hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { 456 ObjData *objData = Tcl_GetHashValue(hPtr); 457 458 if (objData != NULL) { 459 ckfree((char *) objData); 460 } 461 } 462 463 Tcl_DeleteHashTable(tablePtr); 464 ckfree((char *) tablePtr); 465 tsdPtr->objThreadMap = NULL; 466 } 467#endif 468} 469 470/* 471 *---------------------------------------------------------------------- 472 * 473 * TclFinalizeObjects -- 474 * 475 * This function is called by Tcl_Finalize to clean up all registered 476 * Tcl_ObjType's and to reset the tclFreeObjList. 477 * 478 * Results: 479 * None. 480 * 481 * Side effects: 482 * None. 483 * 484 *---------------------------------------------------------------------- 485 */ 486 487void 488TclFinalizeObjects(void) 489{ 490 Tcl_MutexLock(&tableMutex); 491 if (typeTableInitialized) { 492 Tcl_DeleteHashTable(&typeTable); 493 typeTableInitialized = 0; 494 } 495 Tcl_MutexUnlock(&tableMutex); 496 497 /* 498 * All we do here is reset the head pointer of the linked list of free 499 * Tcl_Obj's to NULL; the memory finalization will take care of releasing 500 * memory for us. 501 */ 502 Tcl_MutexLock(&tclObjMutex); 503 tclFreeObjList = NULL; 504 Tcl_MutexUnlock(&tclObjMutex); 505} 506 507/* 508 *---------------------------------------------------------------------- 509 * 510 * TclGetContLineTable -- 511 * 512 * This procedure is a helper which returns the thread-specific 513 * hash-table used to track continuation line information associated with 514 * Tcl_Obj*, and the objThreadMap, etc. 515 * 516 * Results: 517 * A reference to the thread-data. 518 * 519 * Side effects: 520 * May allocate memory for the thread-data. 521 * 522 * TIP #280 523 *---------------------------------------------------------------------- 524 */ 525 526static ThreadSpecificData* 527TclGetContLineTable() 528{ 529 /* 530 * Initialize the hashtable tracking invisible continuation lines. For 531 * the release we use a thread exit handler to ensure that this is done 532 * before TSD blocks are made invalid. The TclFinalizeObjects() which 533 * would be the natural place for this is invoked afterwards, meaning that 534 * we try to operate on a data structure already gone. 535 */ 536 537 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 538 if (!tsdPtr->lineCLPtr) { 539 tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 540 Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); 541 Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); 542 } 543 return tsdPtr; 544} 545 546/* 547 *---------------------------------------------------------------------- 548 * 549 * TclContinuationsEnter -- 550 * 551 * This procedure is a helper which saves the continuation line 552 * information associated with a Tcl_Obj*. 553 * 554 * Results: 555 * A reference to the newly created continuation line location table. 556 * 557 * Side effects: 558 * Allocates memory for the table of continuation line locations. 559 * 560 * TIP #280 561 *---------------------------------------------------------------------- 562 */ 563 564ContLineLoc* 565TclContinuationsEnter(Tcl_Obj* objPtr, 566 int num, 567 int* loc) 568{ 569 int newEntry; 570 ThreadSpecificData *tsdPtr = TclGetContLineTable(); 571 Tcl_HashEntry* hPtr = 572 Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); 573 574 ContLineLoc* clLocPtr = 575 (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); 576 577 if (!newEntry) { 578 /* 579 * We're entering ContLineLoc data for the same value more than one 580 * time. Taking care not to leak the old entry. 581 * 582 * This can happen when literals in a proc body are shared. See for 583 * example test info-30.19 where the action (code) for all branches of 584 * the switch command is identical, mapping them all to the same 585 * literal. An interesting result of this is that the number and 586 * locations (offset) of invisible continuation lines in the literal 587 * are the same for all occurences. 588 * 589 * Note that while reusing the existing entry is possible it requires 590 * the same actions as for a new entry because we have to copy the 591 * incoming num/loc data even so. Because we are called from 592 * TclContinuationsEnterDerived for this case, which modified the 593 * stored locations (Rebased to the proper relative offset). Just 594 * returning the stored entry and data would rebase them a second 595 * time, or more, hosing the data. It is easier to simply replace, as 596 * we are doing. 597 */ 598 599 ckfree((char *) Tcl_GetHashValue(hPtr)); 600 } 601 602 clLocPtr->num = num; 603 memcpy (&clLocPtr->loc, loc, num*sizeof(int)); 604 clLocPtr->loc[num] = CLL_END; /* Sentinel */ 605 Tcl_SetHashValue (hPtr, clLocPtr); 606 607 return clLocPtr; 608} 609 610/* 611 *---------------------------------------------------------------------- 612 * 613 * TclContinuationsEnterDerived -- 614 * 615 * This procedure is a helper which computes the continuation line 616 * information associated with a Tcl_Obj* cut from the middle of a 617 * script. 618 * 619 * Results: 620 * None. 621 * 622 * Side effects: 623 * Allocates memory for the table of continuation line locations. 624 * 625 * TIP #280 626 *---------------------------------------------------------------------- 627 */ 628 629void 630TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) 631{ 632 /* 633 * We have to handle invisible continuations lines here as well, despite 634 * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If 635 * our script is the sole argument to an 'eval' command, for example, the 636 * scriptCLLocPtr we are using was generated by a previous call to TST, 637 * and while the words we have here may contain continuation lines they 638 * are invisible already, and the inner call to TST had no bs+nl sequences 639 * to trigger its code. 640 * 641 * Luckily for us, the table we have to create here for the current word 642 * has to be a slice of the table currently in use, with the locations 643 * suitably modified to be relative to the start of the word instead of 644 * relative to the script. 645 * 646 * That is what we are doing now. Determine the slice we need, and if not 647 * empty, wrap it into a new table, and save the result into our 648 * thread-global hashtable, as usual. 649 */ 650 651 /* 652 * First compute the range of the word within the script. 653 */ 654 655 int length, end, num; 656 int* wordCLLast = clNext; 657 658 Tcl_GetStringFromObj(objPtr, &length); 659 /* Is there a better way which doesn't shimmer ? */ 660 661 end = start + length; /* first char after the word */ 662 663 /* 664 * Then compute the table slice covering the range of 665 * the word. 666 */ 667 668 while (*wordCLLast >= 0 && *wordCLLast < end) { 669 wordCLLast++; 670 } 671 672 /* 673 * And generate the table from the slice, if it was 674 * not empty. 675 */ 676 677 num = wordCLLast - clNext; 678 if (num) { 679 int i; 680 ContLineLoc* clLocPtr = 681 TclContinuationsEnter(objPtr, num, clNext); 682 683 /* 684 * Re-base the locations. 685 */ 686 687 for (i=0;i<num;i++) { 688 clLocPtr->loc[i] -= start; 689 690 /* 691 * Continuation lines coming before the string and affecting us 692 * should not happen, due to the proper maintenance of clNext 693 * during compilation. 694 */ 695 696 if (clLocPtr->loc[i] < 0) { 697 Tcl_Panic("Derived ICL data for object using offsets from before the script"); 698 } 699 } 700 } 701} 702 703/* 704 *---------------------------------------------------------------------- 705 * 706 * TclContinuationsCopy -- 707 * 708 * This procedure is a helper which copies the continuation line 709 * information associated with a Tcl_Obj* to another Tcl_Obj*. 710 * It is assumed that both contain the same string/script. Use 711 * this when a script is duplicated because it was shared. 712 * 713 * Results: 714 * None. 715 * 716 * Side effects: 717 * Allocates memory for the table of continuation line locations. 718 * 719 * TIP #280 720 *---------------------------------------------------------------------- 721 */ 722 723void 724TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) 725{ 726 ThreadSpecificData *tsdPtr = TclGetContLineTable(); 727 Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); 728 729 if (hPtr) { 730 ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); 731 732 TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); 733 } 734} 735 736/* 737 *---------------------------------------------------------------------- 738 * 739 * TclContinuationsGet -- 740 * 741 * This procedure is a helper which retrieves the continuation line 742 * information associated with a Tcl_Obj*, if it has any. 743 * 744 * Results: 745 * A reference to the continuation line location table, or NULL 746 * if the Tcl_Obj* has no such information associated with it. 747 * 748 * Side effects: 749 * None. 750 * 751 * TIP #280 752 *---------------------------------------------------------------------- 753 */ 754 755ContLineLoc* 756TclContinuationsGet(Tcl_Obj* objPtr) 757{ 758 ThreadSpecificData *tsdPtr = TclGetContLineTable(); 759 Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); 760 761 if (hPtr) { 762 return (ContLineLoc*) Tcl_GetHashValue (hPtr); 763 } else { 764 return NULL; 765 } 766} 767 768/* 769 *---------------------------------------------------------------------- 770 * 771 * TclThreadFinalizeContLines -- 772 * 773 * This procedure is a helper which releases all continuation line 774 * information currently known. It is run as a thread exit handler. 775 * 776 * Results: 777 * None. 778 * 779 * Side effects: 780 * Releases memory. 781 * 782 * TIP #280 783 *---------------------------------------------------------------------- 784 */ 785 786static void 787TclThreadFinalizeContLines (ClientData clientData) 788{ 789 /* 790 * Release the hashtable tracking invisible continuation lines. 791 */ 792 793 ThreadSpecificData *tsdPtr = TclGetContLineTable(); 794 Tcl_HashEntry *hPtr; 795 Tcl_HashSearch hSearch; 796 797 for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); 798 hPtr != NULL; 799 hPtr = Tcl_NextHashEntry(&hSearch)) { 800 /* 801 * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because 802 * here we can be sure that the compiler will not hold references to 803 * the data in the hashtable, and using TEF might bork the 804 * finalization sequence. 805 */ 806 ContLineLocFree (Tcl_GetHashValue (hPtr)); 807 Tcl_DeleteHashEntry (hPtr); 808 } 809 Tcl_DeleteHashTable (tsdPtr->lineCLPtr); 810 ckfree((char *) tsdPtr->lineCLPtr); 811 tsdPtr->lineCLPtr = NULL; 812} 813 814/* 815 *---------------------------------------------------------------------- 816 * 817 * ContLineLocFree -- 818 * 819 * The freProc for continuation line location tables. 820 * 821 * Results: 822 * None. 823 * 824 * Side effects: 825 * Releases memory. 826 * 827 * TIP #280 828 *---------------------------------------------------------------------- 829 */ 830 831static void 832ContLineLocFree (char* clientData) 833{ 834 ckfree (clientData); 835} 836 837/* 838 *-------------------------------------------------------------- 839 * 840 * Tcl_RegisterObjType -- 841 * 842 * This function is called to register a new Tcl object type in the table 843 * of all object types supported by Tcl. 844 * 845 * Results: 846 * None. 847 * 848 * Side effects: 849 * The type is registered in the Tcl type table. If there was already a 850 * type with the same name as in typePtr, it is replaced with the new 851 * type. 852 * 853 *-------------------------------------------------------------- 854 */ 855 856void 857Tcl_RegisterObjType( 858 Tcl_ObjType *typePtr) /* Information about object type; storage must 859 * be statically allocated (must live 860 * forever). */ 861{ 862 int isNew; 863 864 Tcl_MutexLock(&tableMutex); 865 Tcl_SetHashValue( 866 Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr); 867 Tcl_MutexUnlock(&tableMutex); 868} 869 870/* 871 *---------------------------------------------------------------------- 872 * 873 * Tcl_AppendAllObjTypes -- 874 * 875 * This function appends onto the argument object the name of each object 876 * type as a list element. This includes the builtin object types (e.g. 877 * int, list) as well as those added using Tcl_NewObj. These names can be 878 * used, for example, with Tcl_GetObjType to get pointers to the 879 * corresponding Tcl_ObjType structures. 880 * 881 * Results: 882 * The return value is normally TCL_OK; in this case the object 883 * referenced by objPtr has each type name appended to it. If an error 884 * occurs, TCL_ERROR is returned and the interpreter's result holds an 885 * error message. 886 * 887 * Side effects: 888 * If necessary, the object referenced by objPtr is converted into a list 889 * object. 890 * 891 *---------------------------------------------------------------------- 892 */ 893 894int 895Tcl_AppendAllObjTypes( 896 Tcl_Interp *interp, /* Interpreter used for error reporting. */ 897 Tcl_Obj *objPtr) /* Points to the Tcl object onto which the 898 * name of each registered type is appended as 899 * a list element. */ 900{ 901 register Tcl_HashEntry *hPtr; 902 Tcl_HashSearch search; 903 int numElems; 904 905 /* 906 * Get the test for a valid list out of the way first. 907 */ 908 909 if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) { 910 return TCL_ERROR; 911 } 912 913 /* 914 * Type names are NUL-terminated, not counted strings. This code relies on 915 * that. 916 */ 917 918 Tcl_MutexLock(&tableMutex); 919 for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); 920 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { 921 Tcl_ListObjAppendElement(NULL, objPtr, 922 Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); 923 } 924 Tcl_MutexUnlock(&tableMutex); 925 return TCL_OK; 926} 927 928/* 929 *---------------------------------------------------------------------- 930 * 931 * Tcl_GetObjType -- 932 * 933 * This function looks up an object type by name. 934 * 935 * Results: 936 * If an object type with name matching "typeName" is found, a pointer to 937 * its Tcl_ObjType structure is returned; otherwise, NULL is returned. 938 * 939 * Side effects: 940 * None. 941 * 942 *---------------------------------------------------------------------- 943 */ 944 945Tcl_ObjType * 946Tcl_GetObjType( 947 CONST char *typeName) /* Name of Tcl object type to look up. */ 948{ 949 register Tcl_HashEntry *hPtr; 950 Tcl_ObjType *typePtr = NULL; 951 952 Tcl_MutexLock(&tableMutex); 953 hPtr = Tcl_FindHashEntry(&typeTable, typeName); 954 if (hPtr != NULL) { 955 typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); 956 } 957 Tcl_MutexUnlock(&tableMutex); 958 return typePtr; 959} 960 961/* 962 *---------------------------------------------------------------------- 963 * 964 * Tcl_ConvertToType -- 965 * 966 * Convert the Tcl object "objPtr" to have type "typePtr" if possible. 967 * 968 * Results: 969 * The return value is TCL_OK on success and TCL_ERROR on failure. If 970 * TCL_ERROR is returned, then the interpreter's result contains an error 971 * message unless "interp" is NULL. Passing a NULL "interp" allows this 972 * function to be used as a test whether the conversion could be done 973 * (and in fact was done). 974 * 975 * Side effects: 976 * Any internal representation for the old type is freed. 977 * 978 *---------------------------------------------------------------------- 979 */ 980 981int 982Tcl_ConvertToType( 983 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 984 Tcl_Obj *objPtr, /* The object to convert. */ 985 Tcl_ObjType *typePtr) /* The target type. */ 986{ 987 if (objPtr->typePtr == typePtr) { 988 return TCL_OK; 989 } 990 991 /* 992 * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form 993 * as appropriate for the target type. This frees the old internal 994 * representation. 995 */ 996 997 if (typePtr->setFromAnyProc == NULL) { 998 Tcl_Panic("may not convert object to type %s", typePtr->name); 999 } 1000 1001 return typePtr->setFromAnyProc(interp, objPtr); 1002} 1003 1004/* 1005 *-------------------------------------------------------------- 1006 * 1007 * TclDbDumpActiveObjects -- 1008 * 1009 * This function is called to dump all of the active Tcl_Obj structs this 1010 * allocator knows about. 1011 * 1012 * Results: 1013 * None. 1014 * 1015 * Side effects: 1016 * None. 1017 * 1018 *-------------------------------------------------------------- 1019 */ 1020 1021void 1022TclDbDumpActiveObjects( 1023 FILE *outFile) 1024{ 1025#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) 1026 Tcl_HashSearch hSearch; 1027 Tcl_HashEntry *hPtr; 1028 Tcl_HashTable *tablePtr; 1029 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1030 1031 tablePtr = tsdPtr->objThreadMap; 1032 1033 if (tablePtr != NULL) { 1034 fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); 1035 for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; 1036 hPtr = Tcl_NextHashEntry(&hSearch)) { 1037 ObjData *objData = Tcl_GetHashValue(hPtr); 1038 1039 if (objData != NULL) { 1040 fprintf(outFile, 1041 "key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n", 1042 Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr, 1043 objData->file, objData->line); 1044 } else { 1045 fprintf(outFile, "key = 0x%p\n", 1046 Tcl_GetHashKey(tablePtr, hPtr)); 1047 } 1048 } 1049 } 1050#endif 1051} 1052 1053/* 1054 *---------------------------------------------------------------------- 1055 * 1056 * TclDbInitNewObj -- 1057 * 1058 * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is 1059 * enabled. This function will initialize the members of a Tcl_Obj 1060 * struct. Initilization would be done inline via the TclNewObj macro 1061 * when compiling without TCL_MEM_DEBUG. 1062 * 1063 * Results: 1064 * The Tcl_Obj struct members are initialized. 1065 * 1066 * Side effects: 1067 * None. 1068 *---------------------------------------------------------------------- 1069 */ 1070 1071#ifdef TCL_MEM_DEBUG 1072void 1073TclDbInitNewObj( 1074 register Tcl_Obj *objPtr, 1075 register CONST char *file, /* The name of the source file calling this 1076 * function; used for debugging. */ 1077 register int line) /* Line number in the source file; used for 1078 * debugging. */ 1079{ 1080 objPtr->refCount = 0; 1081 objPtr->bytes = tclEmptyStringRep; 1082 objPtr->length = 0; 1083 objPtr->typePtr = NULL; 1084 1085#ifdef TCL_THREADS 1086 /* 1087 * Add entry to a thread local map used to check if a Tcl_Obj was 1088 * allocated by the currently executing thread. 1089 */ 1090 1091 if (!TclInExit()) { 1092 Tcl_HashEntry *hPtr; 1093 Tcl_HashTable *tablePtr; 1094 int isNew; 1095 ObjData *objData; 1096 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1097 1098 if (tsdPtr->objThreadMap == NULL) { 1099 tsdPtr->objThreadMap = (Tcl_HashTable *) 1100 ckalloc(sizeof(Tcl_HashTable)); 1101 Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); 1102 } 1103 tablePtr = tsdPtr->objThreadMap; 1104 hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); 1105 if (!isNew) { 1106 Tcl_Panic("expected to create new entry for object map"); 1107 } 1108 1109 /* 1110 * Record the debugging information. 1111 */ 1112 1113 objData = (ObjData *) ckalloc(sizeof(ObjData)); 1114 objData->objPtr = objPtr; 1115 objData->file = file; 1116 objData->line = line; 1117 Tcl_SetHashValue(hPtr, objData); 1118 } 1119#endif /* TCL_THREADS */ 1120} 1121#endif /* TCL_MEM_DEBUG */ 1122 1123/* 1124 *---------------------------------------------------------------------- 1125 * 1126 * Tcl_NewObj -- 1127 * 1128 * This function is normally called when not debugging: i.e., when 1129 * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote 1130 * the empty string. These objects have a NULL object type and NULL 1131 * string representation byte pointer. Type managers call this routine to 1132 * allocate new objects that they further initialize. 1133 * 1134 * When TCL_MEM_DEBUG is defined, this function just returns the result 1135 * of calling the debugging version Tcl_DbNewObj. 1136 * 1137 * Results: 1138 * The result is a newly allocated object that represents the empty 1139 * string. The new object's typePtr is set NULL and its ref count is set 1140 * to 0. 1141 * 1142 * Side effects: 1143 * If compiling with TCL_COMPILE_STATS, this function increments the 1144 * global count of allocated objects (tclObjsAlloced). 1145 * 1146 *---------------------------------------------------------------------- 1147 */ 1148 1149#ifdef TCL_MEM_DEBUG 1150#undef Tcl_NewObj 1151 1152Tcl_Obj * 1153Tcl_NewObj(void) 1154{ 1155 return Tcl_DbNewObj("unknown", 0); 1156} 1157 1158#else /* if not TCL_MEM_DEBUG */ 1159 1160Tcl_Obj * 1161Tcl_NewObj(void) 1162{ 1163 register Tcl_Obj *objPtr; 1164 1165 /* 1166 * Use the macro defined in tclInt.h - it will use the correct allocator. 1167 */ 1168 1169 TclNewObj(objPtr); 1170 return objPtr; 1171} 1172#endif /* TCL_MEM_DEBUG */ 1173 1174/* 1175 *---------------------------------------------------------------------- 1176 * 1177 * Tcl_DbNewObj -- 1178 * 1179 * This function is normally called when debugging: i.e., when 1180 * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the 1181 * empty string. It is the same as the Tcl_NewObj function above except 1182 * that it calls Tcl_DbCkalloc directly with the file name and line 1183 * number from its caller. This simplifies debugging since then the 1184 * [memory active] command will report the correct file name and line 1185 * number when reporting objects that haven't been freed. 1186 * 1187 * When TCL_MEM_DEBUG is not defined, this function just returns the 1188 * result of calling Tcl_NewObj. 1189 * 1190 * Results: 1191 * The result is a newly allocated that represents the empty string. The 1192 * new object's typePtr is set NULL and its ref count is set to 0. 1193 * 1194 * Side effects: 1195 * If compiling with TCL_COMPILE_STATS, this function increments the 1196 * global count of allocated objects (tclObjsAlloced). 1197 * 1198 *---------------------------------------------------------------------- 1199 */ 1200 1201#ifdef TCL_MEM_DEBUG 1202 1203Tcl_Obj * 1204Tcl_DbNewObj( 1205 register CONST char *file, /* The name of the source file calling this 1206 * function; used for debugging. */ 1207 register int line) /* Line number in the source file; used for 1208 * debugging. */ 1209{ 1210 register Tcl_Obj *objPtr; 1211 1212 /* 1213 * Use the macro defined in tclInt.h - it will use the correct allocator. 1214 */ 1215 1216 TclDbNewObj(objPtr, file, line); 1217 return objPtr; 1218} 1219#else /* if not TCL_MEM_DEBUG */ 1220 1221Tcl_Obj * 1222Tcl_DbNewObj( 1223 CONST char *file, /* The name of the source file calling this 1224 * function; used for debugging. */ 1225 int line) /* Line number in the source file; used for 1226 * debugging. */ 1227{ 1228 return Tcl_NewObj(); 1229} 1230#endif /* TCL_MEM_DEBUG */ 1231 1232/* 1233 *---------------------------------------------------------------------- 1234 * 1235 * TclAllocateFreeObjects -- 1236 * 1237 * Function to allocate a number of free Tcl_Objs. This is done using a 1238 * single ckalloc to reduce the overhead for Tcl_Obj allocation. 1239 * 1240 * Assumes mutex is held. 1241 * 1242 * Results: 1243 * None. 1244 * 1245 * Side effects: 1246 * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the 1247 * first of a number of free Tcl_Obj's linked together by their 1248 * internalRep.otherValuePtrs. 1249 * 1250 *---------------------------------------------------------------------- 1251 */ 1252 1253#define OBJS_TO_ALLOC_EACH_TIME 100 1254 1255void 1256TclAllocateFreeObjects(void) 1257{ 1258 size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); 1259 char *basePtr; 1260 register Tcl_Obj *prevPtr, *objPtr; 1261 register int i; 1262 1263 /* 1264 * This has been noted by Purify to be a potential leak. The problem is 1265 * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated 1266 * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually 1267 * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, 1268 * but leaves it to Tcl's memory subsystem finalization to release it. 1269 * Purify apparently can't figure that out, and fires a false alarm. 1270 */ 1271 1272 basePtr = (char *) ckalloc(bytesToAlloc); 1273 1274 prevPtr = NULL; 1275 objPtr = (Tcl_Obj *) basePtr; 1276 for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { 1277 objPtr->internalRep.otherValuePtr = (void *) prevPtr; 1278 prevPtr = objPtr; 1279 objPtr++; 1280 } 1281 tclFreeObjList = prevPtr; 1282} 1283#undef OBJS_TO_ALLOC_EACH_TIME 1284 1285/* 1286 *---------------------------------------------------------------------- 1287 * 1288 * TclFreeObj -- 1289 * 1290 * This function frees the memory associated with the argument object. 1291 * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref 1292 * count is zero. It is only "public" since it must be callable by that 1293 * macro wherever the macro is used. It should not be directly called by 1294 * clients. 1295 * 1296 * Results: 1297 * None. 1298 * 1299 * Side effects: 1300 * Deallocates the storage for the object's Tcl_Obj structure after 1301 * deallocating the string representation and calling the type-specific 1302 * Tcl_FreeInternalRepProc to deallocate the object's internal 1303 * representation. If compiling with TCL_COMPILE_STATS, this function 1304 * increments the global count of freed objects (tclObjsFreed). 1305 * 1306 *---------------------------------------------------------------------- 1307 */ 1308 1309#ifdef TCL_MEM_DEBUG 1310void 1311TclFreeObj( 1312 register Tcl_Obj *objPtr) /* The object to be freed. */ 1313{ 1314 register Tcl_ObjType *typePtr = objPtr->typePtr; 1315 1316 /* 1317 * This macro declares a variable, so must come here... 1318 */ 1319 1320 ObjInitDeletionContext(context); 1321 1322 if (objPtr->refCount < -1) { 1323 Tcl_Panic("Reference count for %lx was negative", objPtr); 1324 } 1325 1326 /* Invalidate the string rep first so we can use the bytes value 1327 * for our pointer chain, and signal an obj deletion (as opposed 1328 * to shimmering) with 'length == -1' */ 1329 1330 TclInvalidateStringRep(objPtr); 1331 objPtr->length = -1; 1332 1333 if (ObjDeletePending(context)) { 1334 PushObjToDelete(context, objPtr); 1335 } else { 1336 TCL_DTRACE_OBJ_FREE(objPtr); 1337 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { 1338 ObjDeletionLock(context); 1339 typePtr->freeIntRepProc(objPtr); 1340 ObjDeletionUnlock(context); 1341 } 1342 1343 Tcl_MutexLock(&tclObjMutex); 1344 ckfree((char *) objPtr); 1345 Tcl_MutexUnlock(&tclObjMutex); 1346 TclIncrObjsFreed(); 1347 ObjDeletionLock(context); 1348 while (ObjOnStack(context)) { 1349 Tcl_Obj *objToFree; 1350 1351 PopObjToDelete(context,objToFree); 1352 TCL_DTRACE_OBJ_FREE(objToFree); 1353 TclFreeIntRep(objToFree); 1354 1355 Tcl_MutexLock(&tclObjMutex); 1356 ckfree((char *) objToFree); 1357 Tcl_MutexUnlock(&tclObjMutex); 1358 TclIncrObjsFreed(); 1359 } 1360 ObjDeletionUnlock(context); 1361 } 1362 1363 /* 1364 * We cannot use TclGetContinuationTable() here, because that may 1365 * re-initialize the thread-data for calls coming after the 1366 * finalization. We have to access it using the low-level call and then 1367 * check for validity. This function can be called after 1368 * TclFinalizeThreadData() has already killed the thread-global data 1369 * structures. Performing TCL_TSD_INIT will leave us with an 1370 * un-initialized memory block upon which we crash (if we where to access 1371 * the uninitialized hashtable). 1372 */ 1373 1374 { 1375 ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); 1376 if (tsdPtr->lineCLPtr) { 1377 Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); 1378 if (hPtr) { 1379 Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); 1380 Tcl_DeleteHashEntry (hPtr); 1381 } 1382 } 1383 } 1384} 1385#else /* TCL_MEM_DEBUG */ 1386 1387void 1388TclFreeObj( 1389 register Tcl_Obj *objPtr) /* The object to be freed. */ 1390{ 1391 /* Invalidate the string rep first so we can use the bytes value 1392 * for our pointer chain, and signal an obj deletion (as opposed 1393 * to shimmering) with 'length == -1' */ 1394 1395 TclInvalidateStringRep(objPtr); 1396 objPtr->length = -1; 1397 1398 if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { 1399 /* 1400 * objPtr can be freed safely, as it will not attempt to free any 1401 * other objects: it will not cause recursive calls to this function. 1402 */ 1403 1404 TCL_DTRACE_OBJ_FREE(objPtr); 1405 TclFreeObjStorage(objPtr); 1406 TclIncrObjsFreed(); 1407 } else { 1408 /* 1409 * This macro declares a variable, so must come here... 1410 */ 1411 1412 ObjInitDeletionContext(context); 1413 1414 if (ObjDeletePending(context)) { 1415 PushObjToDelete(context, objPtr); 1416 } else { 1417 /* 1418 * Note that the contents of the while loop assume that the string 1419 * rep has already been freed and we don't want to do anything 1420 * fancy with adding to the queue inside ourselves. Must take care 1421 * to unstack the object first since freeing the internal rep can 1422 * add further objects to the stack. The code assumes that it is 1423 * the first thing in a block; all current usages in the core 1424 * satisfy this. 1425 */ 1426 1427 TCL_DTRACE_OBJ_FREE(objPtr); 1428 ObjDeletionLock(context); 1429 objPtr->typePtr->freeIntRepProc(objPtr); 1430 ObjDeletionUnlock(context); 1431 1432 TclFreeObjStorage(objPtr); 1433 TclIncrObjsFreed(); 1434 ObjDeletionLock(context); 1435 while (ObjOnStack(context)) { 1436 Tcl_Obj *objToFree; 1437 PopObjToDelete(context,objToFree); 1438 TCL_DTRACE_OBJ_FREE(objToFree); 1439 if ((objToFree->typePtr != NULL) 1440 && (objToFree->typePtr->freeIntRepProc != NULL)) { 1441 objToFree->typePtr->freeIntRepProc(objToFree); 1442 } 1443 TclFreeObjStorage(objToFree); 1444 TclIncrObjsFreed(); 1445 } 1446 ObjDeletionUnlock(context); 1447 } 1448 } 1449 1450 /* 1451 * We cannot use TclGetContinuationTable() here, because that may 1452 * re-initialize the thread-data for calls coming after the 1453 * finalization. We have to access it using the low-level call and then 1454 * check for validity. This function can be called after 1455 * TclFinalizeThreadData() has already killed the thread-global data 1456 * structures. Performing TCL_TSD_INIT will leave us with an 1457 * un-initialized memory block upon which we crash (if we where to access 1458 * the uninitialized hashtable). 1459 */ 1460 1461 { 1462 ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); 1463 if (tsdPtr->lineCLPtr) { 1464 Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); 1465 if (hPtr) { 1466 Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); 1467 Tcl_DeleteHashEntry (hPtr); 1468 } 1469 } 1470 } 1471} 1472#endif 1473 1474/* 1475 *---------------------------------------------------------------------- 1476 * 1477 * TclObjBeingDeleted -- 1478 * 1479 * This function returns 1 when the Tcl_Obj is being deleted. It is 1480 * provided for the rare cases where the reason for the loss of an 1481 * internal rep might be relevant. [FR 1512138] 1482 * 1483 * Results: 1484 * 1 if being deleted, 0 otherwise. 1485 * 1486 * Side effects: 1487 * None. 1488 * 1489 *---------------------------------------------------------------------- 1490 */ 1491 1492int 1493TclObjBeingDeleted( 1494 Tcl_Obj *objPtr) 1495{ 1496 return (objPtr->length == -1); 1497} 1498 1499 1500/* 1501 *---------------------------------------------------------------------- 1502 * 1503 * Tcl_DuplicateObj -- 1504 * 1505 * Create and return a new object that is a duplicate of the argument 1506 * object. 1507 * 1508 * Results: 1509 * The return value is a pointer to a newly created Tcl_Obj. This object 1510 * has reference count 0 and the same type, if any, as the source object 1511 * objPtr. Also: 1512 * 1) If the source object has a valid string rep, we copy it; 1513 * otherwise, the duplicate's string rep is set NULL to mark it 1514 * invalid. 1515 * 2) If the source object has an internal representation (i.e. its 1516 * typePtr is non-NULL), the new object's internal rep is set to a 1517 * copy; otherwise the new internal rep is marked invalid. 1518 * 1519 * Side effects: 1520 * What constitutes "copying" the internal representation depends on the 1521 * type. For example, if the argument object is a list, the element 1522 * objects it points to will not actually be copied but will be shared 1523 * with the duplicate list. That is, the ref counts of the element 1524 * objects will be incremented. 1525 * 1526 *---------------------------------------------------------------------- 1527 */ 1528 1529Tcl_Obj * 1530Tcl_DuplicateObj( 1531 register Tcl_Obj *objPtr) /* The object to duplicate. */ 1532{ 1533 register Tcl_ObjType *typePtr = objPtr->typePtr; 1534 register Tcl_Obj *dupPtr; 1535 1536 TclNewObj(dupPtr); 1537 1538 if (objPtr->bytes == NULL) { 1539 dupPtr->bytes = NULL; 1540 } else if (objPtr->bytes != tclEmptyStringRep) { 1541 TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); 1542 } 1543 1544 if (typePtr != NULL) { 1545 if (typePtr->dupIntRepProc == NULL) { 1546 dupPtr->internalRep = objPtr->internalRep; 1547 dupPtr->typePtr = typePtr; 1548 } else { 1549 (*typePtr->dupIntRepProc)(objPtr, dupPtr); 1550 } 1551 } 1552 return dupPtr; 1553} 1554 1555/* 1556 *---------------------------------------------------------------------- 1557 * 1558 * Tcl_GetString -- 1559 * 1560 * Returns the string representation byte array pointer for an object. 1561 * 1562 * Results: 1563 * Returns a pointer to the string representation of objPtr. The byte 1564 * array referenced by the returned pointer must not be modified by the 1565 * caller. Furthermore, the caller must copy the bytes if they need to 1566 * retain them since the object's string rep can change as a result of 1567 * other operations. 1568 * 1569 * Side effects: 1570 * May call the object's updateStringProc to update the string 1571 * representation from the internal representation. 1572 * 1573 *---------------------------------------------------------------------- 1574 */ 1575 1576char * 1577Tcl_GetString( 1578 register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should 1579 * be returned. */ 1580{ 1581 if (objPtr->bytes != NULL) { 1582 return objPtr->bytes; 1583 } 1584 1585 if (objPtr->typePtr->updateStringProc == NULL) { 1586 Tcl_Panic("UpdateStringProc should not be invoked for type %s", 1587 objPtr->typePtr->name); 1588 } 1589 (*objPtr->typePtr->updateStringProc)(objPtr); 1590 return objPtr->bytes; 1591} 1592 1593/* 1594 *---------------------------------------------------------------------- 1595 * 1596 * Tcl_GetStringFromObj -- 1597 * 1598 * Returns the string representation's byte array pointer and length for 1599 * an object. 1600 * 1601 * Results: 1602 * Returns a pointer to the string representation of objPtr. If lengthPtr 1603 * isn't NULL, the length of the string representation is stored at 1604 * *lengthPtr. The byte array referenced by the returned pointer must not 1605 * be modified by the caller. Furthermore, the caller must copy the bytes 1606 * if they need to retain them since the object's string rep can change 1607 * as a result of other operations. 1608 * 1609 * Side effects: 1610 * May call the object's updateStringProc to update the string 1611 * representation from the internal representation. 1612 * 1613 *---------------------------------------------------------------------- 1614 */ 1615 1616char * 1617Tcl_GetStringFromObj( 1618 register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should 1619 * be returned. */ 1620 register int *lengthPtr) /* If non-NULL, the location where the string 1621 * rep's byte array length should * be stored. 1622 * If NULL, no length is stored. */ 1623{ 1624 if (objPtr->bytes == NULL) { 1625 if (objPtr->typePtr->updateStringProc == NULL) { 1626 Tcl_Panic("UpdateStringProc should not be invoked for type %s", 1627 objPtr->typePtr->name); 1628 } 1629 (*objPtr->typePtr->updateStringProc)(objPtr); 1630 } 1631 1632 if (lengthPtr != NULL) { 1633 *lengthPtr = objPtr->length; 1634 } 1635 return objPtr->bytes; 1636} 1637 1638/* 1639 *---------------------------------------------------------------------- 1640 * 1641 * Tcl_InvalidateStringRep -- 1642 * 1643 * This function is called to invalidate an object's string 1644 * representation. 1645 * 1646 * Results: 1647 * None. 1648 * 1649 * Side effects: 1650 * Deallocates the storage for any old string representation, then sets 1651 * the string representation NULL to mark it invalid. 1652 * 1653 *---------------------------------------------------------------------- 1654 */ 1655 1656void 1657Tcl_InvalidateStringRep( 1658 register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should 1659 * be freed. */ 1660{ 1661 TclInvalidateStringRep(objPtr); 1662} 1663 1664 1665/* 1666 *---------------------------------------------------------------------- 1667 * 1668 * Tcl_NewBooleanObj -- 1669 * 1670 * This function is normally called when not debugging: i.e., when 1671 * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and 1672 * initializes it from the argument boolean value. A nonzero "boolValue" 1673 * is coerced to 1. 1674 * 1675 * When TCL_MEM_DEBUG is defined, this function just returns the result 1676 * of calling the debugging version Tcl_DbNewBooleanObj. 1677 * 1678 * Results: 1679 * The newly created object is returned. This object will have an invalid 1680 * string representation. The returned object has ref count 0. 1681 * 1682 * Side effects: 1683 * None. 1684 * 1685 *---------------------------------------------------------------------- 1686 */ 1687 1688#ifdef TCL_MEM_DEBUG 1689#undef Tcl_NewBooleanObj 1690 1691Tcl_Obj * 1692Tcl_NewBooleanObj( 1693 register int boolValue) /* Boolean used to initialize new object. */ 1694{ 1695 return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); 1696} 1697 1698#else /* if not TCL_MEM_DEBUG */ 1699 1700Tcl_Obj * 1701Tcl_NewBooleanObj( 1702 register int boolValue) /* Boolean used to initialize new object. */ 1703{ 1704 register Tcl_Obj *objPtr; 1705 1706 TclNewBooleanObj(objPtr, boolValue); 1707 return objPtr; 1708} 1709#endif /* TCL_MEM_DEBUG */ 1710 1711/* 1712 *---------------------------------------------------------------------- 1713 * 1714 * Tcl_DbNewBooleanObj -- 1715 * 1716 * This function is normally called when debugging: i.e., when 1717 * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the 1718 * same as the Tcl_NewBooleanObj function above except that it calls 1719 * Tcl_DbCkalloc directly with the file name and line number from its 1720 * caller. This simplifies debugging since then the [memory active] 1721 * command will report the correct file name and line number when 1722 * reporting objects that haven't been freed. 1723 * 1724 * When TCL_MEM_DEBUG is not defined, this function just returns the 1725 * result of calling Tcl_NewBooleanObj. 1726 * 1727 * Results: 1728 * The newly created object is returned. This object will have an invalid 1729 * string representation. The returned object has ref count 0. 1730 * 1731 * Side effects: 1732 * None. 1733 * 1734 *---------------------------------------------------------------------- 1735 */ 1736 1737#ifdef TCL_MEM_DEBUG 1738 1739Tcl_Obj * 1740Tcl_DbNewBooleanObj( 1741 register int boolValue, /* Boolean used to initialize new object. */ 1742 CONST char *file, /* The name of the source file calling this 1743 * function; used for debugging. */ 1744 int line) /* Line number in the source file; used for 1745 * debugging. */ 1746{ 1747 register Tcl_Obj *objPtr; 1748 1749 TclDbNewObj(objPtr, file, line); 1750 objPtr->bytes = NULL; 1751 1752 objPtr->internalRep.longValue = (boolValue? 1 : 0); 1753 objPtr->typePtr = &tclIntType; 1754 return objPtr; 1755} 1756 1757#else /* if not TCL_MEM_DEBUG */ 1758 1759Tcl_Obj * 1760Tcl_DbNewBooleanObj( 1761 register int boolValue, /* Boolean used to initialize new object. */ 1762 CONST char *file, /* The name of the source file calling this 1763 * function; used for debugging. */ 1764 int line) /* Line number in the source file; used for 1765 * debugging. */ 1766{ 1767 return Tcl_NewBooleanObj(boolValue); 1768} 1769#endif /* TCL_MEM_DEBUG */ 1770 1771/* 1772 *---------------------------------------------------------------------- 1773 * 1774 * Tcl_SetBooleanObj -- 1775 * 1776 * Modify an object to be a boolean object and to have the specified 1777 * boolean value. A nonzero "boolValue" is coerced to 1. 1778 * 1779 * Results: 1780 * None. 1781 * 1782 * Side effects: 1783 * The object's old string rep, if any, is freed. Also, any old internal 1784 * rep is freed. 1785 * 1786 *---------------------------------------------------------------------- 1787 */ 1788 1789void 1790Tcl_SetBooleanObj( 1791 register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ 1792 register int boolValue) /* Boolean used to set object's value. */ 1793{ 1794 if (Tcl_IsShared(objPtr)) { 1795 Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); 1796 } 1797 1798 TclSetBooleanObj(objPtr, boolValue); 1799} 1800 1801/* 1802 *---------------------------------------------------------------------- 1803 * 1804 * Tcl_GetBooleanFromObj -- 1805 * 1806 * Attempt to return a boolean from the Tcl object "objPtr". This 1807 * includes conversion from any of Tcl's numeric types. 1808 * 1809 * Results: 1810 * The return value is a standard Tcl object result. If an error occurs 1811 * during conversion, an error message is left in the interpreter's 1812 * result unless "interp" is NULL. 1813 * 1814 * Side effects: 1815 * The intrep of *objPtr may be changed. 1816 * 1817 *---------------------------------------------------------------------- 1818 */ 1819 1820int 1821Tcl_GetBooleanFromObj( 1822 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 1823 register Tcl_Obj *objPtr, /* The object from which to get boolean. */ 1824 register int *boolPtr) /* Place to store resulting boolean. */ 1825{ 1826 do { 1827 if (objPtr->typePtr == &tclIntType) { 1828 *boolPtr = (objPtr->internalRep.longValue != 0); 1829 return TCL_OK; 1830 } 1831 if (objPtr->typePtr == &tclBooleanType) { 1832 *boolPtr = (int) objPtr->internalRep.longValue; 1833 return TCL_OK; 1834 } 1835 if (objPtr->typePtr == &tclDoubleType) { 1836 /* 1837 * Caution: Don't be tempted to check directly for the "double" 1838 * Tcl_ObjType and then compare the intrep to 0.0. This isn't 1839 * reliable because a "double" Tcl_ObjType can hold the NaN value. 1840 * Use the API Tcl_GetDoubleFromObj, which does the checking and 1841 * sets the proper error message for us. 1842 */ 1843 1844 double d; 1845 1846 if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { 1847 return TCL_ERROR; 1848 } 1849 *boolPtr = (d != 0.0); 1850 return TCL_OK; 1851 } 1852 if (objPtr->typePtr == &tclBignumType) { 1853 *boolPtr = 1; 1854 return TCL_OK; 1855 } 1856#ifndef NO_WIDE_TYPE 1857 if (objPtr->typePtr == &tclWideIntType) { 1858 *boolPtr = (objPtr->internalRep.wideValue != 0); 1859 return TCL_OK; 1860 } 1861#endif 1862 } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == 1863 TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); 1864 return TCL_ERROR; 1865} 1866 1867/* 1868 *---------------------------------------------------------------------- 1869 * 1870 * SetBooleanFromAny -- 1871 * 1872 * Attempt to generate a boolean internal form for the Tcl object 1873 * "objPtr". 1874 * 1875 * Results: 1876 * The return value is a standard Tcl result. If an error occurs during 1877 * conversion, an error message is left in the interpreter's result 1878 * unless "interp" is NULL. 1879 * 1880 * Side effects: 1881 * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal 1882 * representation and the type of "objPtr" is set to boolean. 1883 * 1884 *---------------------------------------------------------------------- 1885 */ 1886 1887static int 1888SetBooleanFromAny( 1889 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 1890 register Tcl_Obj *objPtr) /* The object to convert. */ 1891{ 1892 /* 1893 * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine 1894 * whether a boolean conversion is possible without generating the string 1895 * rep. 1896 */ 1897 1898 if (objPtr->bytes == NULL) { 1899 if (objPtr->typePtr == &tclIntType) { 1900 switch (objPtr->internalRep.longValue) { 1901 case 0L: case 1L: 1902 return TCL_OK; 1903 } 1904 goto badBoolean; 1905 } 1906 1907 if (objPtr->typePtr == &tclBignumType) { 1908 goto badBoolean; 1909 } 1910 1911#ifndef NO_WIDE_TYPE 1912 if (objPtr->typePtr == &tclWideIntType) { 1913 goto badBoolean; 1914 } 1915#endif 1916 1917 if (objPtr->typePtr == &tclDoubleType) { 1918 goto badBoolean; 1919 } 1920 } 1921 1922 if (ParseBoolean(objPtr) == TCL_OK) { 1923 return TCL_OK; 1924 } 1925 1926 badBoolean: 1927 if (interp != NULL) { 1928 int length; 1929 char *str = Tcl_GetStringFromObj(objPtr, &length); 1930 Tcl_Obj *msg; 1931 1932 TclNewLiteralStringObj(msg, "expected boolean value but got \""); 1933 Tcl_AppendLimitedToObj(msg, str, length, 50, ""); 1934 Tcl_AppendToObj(msg, "\"", -1); 1935 Tcl_SetObjResult(interp, msg); 1936 } 1937 return TCL_ERROR; 1938} 1939 1940static int 1941ParseBoolean( 1942 register Tcl_Obj *objPtr) /* The object to parse/convert. */ 1943{ 1944 int i, length, newBool; 1945 char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length); 1946 1947 if ((length == 0) || (length > 5)) { 1948 /* longest valid boolean string rep. is "false" */ 1949 return TCL_ERROR; 1950 } 1951 1952 switch (str[0]) { 1953 case '0': 1954 if (length == 1) { 1955 newBool = 0; 1956 goto numericBoolean; 1957 } 1958 return TCL_ERROR; 1959 case '1': 1960 if (length == 1) { 1961 newBool = 1; 1962 goto numericBoolean; 1963 } 1964 return TCL_ERROR; 1965 } 1966 1967 /* 1968 * Force to lower case for case-insensitive detection. Filter out known 1969 * invalid characters at the same time. 1970 */ 1971 1972 for (i=0; i < length; i++) { 1973 char c = str[i]; 1974 switch (c) { 1975 case 'A': case 'E': case 'F': case 'L': case 'N': 1976 case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': 1977 lowerCase[i] = c + (char) ('a' - 'A'); 1978 break; 1979 case 'a': case 'e': case 'f': case 'l': case 'n': 1980 case 'o': case 'r': case 's': case 't': case 'u': case 'y': 1981 lowerCase[i] = c; 1982 break; 1983 default: 1984 return TCL_ERROR; 1985 } 1986 } 1987 lowerCase[length] = 0; 1988 switch (lowerCase[0]) { 1989 case 'y': 1990 /* 1991 * Checking the 'y' is redundant, but makes the code clearer. 1992 */ 1993 if (strncmp(lowerCase, "yes", (size_t) length) == 0) { 1994 newBool = 1; 1995 goto goodBoolean; 1996 } 1997 return TCL_ERROR; 1998 case 'n': 1999 if (strncmp(lowerCase, "no", (size_t) length) == 0) { 2000 newBool = 0; 2001 goto goodBoolean; 2002 } 2003 return TCL_ERROR; 2004 case 't': 2005 if (strncmp(lowerCase, "true", (size_t) length) == 0) { 2006 newBool = 1; 2007 goto goodBoolean; 2008 } 2009 return TCL_ERROR; 2010 case 'f': 2011 if (strncmp(lowerCase, "false", (size_t) length) == 0) { 2012 newBool = 0; 2013 goto goodBoolean; 2014 } 2015 return TCL_ERROR; 2016 case 'o': 2017 if (length < 2) { 2018 return TCL_ERROR; 2019 } 2020 if (strncmp(lowerCase, "on", (size_t) length) == 0) { 2021 newBool = 1; 2022 goto goodBoolean; 2023 } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { 2024 newBool = 0; 2025 goto goodBoolean; 2026 } 2027 return TCL_ERROR; 2028 default: 2029 return TCL_ERROR; 2030 } 2031 2032 /* 2033 * Free the old internalRep before setting the new one. We do this as late 2034 * as possible to allow the conversion code, in particular 2035 * Tcl_GetStringFromObj, to use that old internalRep. 2036 */ 2037 2038 goodBoolean: 2039 TclFreeIntRep(objPtr); 2040 objPtr->internalRep.longValue = newBool; 2041 objPtr->typePtr = &tclBooleanType; 2042 return TCL_OK; 2043 2044 numericBoolean: 2045 TclFreeIntRep(objPtr); 2046 objPtr->internalRep.longValue = newBool; 2047 objPtr->typePtr = &tclIntType; 2048 return TCL_OK; 2049} 2050 2051/* 2052 *---------------------------------------------------------------------- 2053 * 2054 * Tcl_NewDoubleObj -- 2055 * 2056 * This function is normally called when not debugging: i.e., when 2057 * TCL_MEM_DEBUG is not defined. It creates a new double object and 2058 * initializes it from the argument double value. 2059 * 2060 * When TCL_MEM_DEBUG is defined, this function just returns the result 2061 * of calling the debugging version Tcl_DbNewDoubleObj. 2062 * 2063 * Results: 2064 * The newly created object is returned. This object will have an 2065 * invalid string representation. The returned object has ref count 0. 2066 * 2067 * Side effects: 2068 * None. 2069 * 2070 *---------------------------------------------------------------------- 2071 */ 2072 2073#ifdef TCL_MEM_DEBUG 2074#undef Tcl_NewDoubleObj 2075 2076Tcl_Obj * 2077Tcl_NewDoubleObj( 2078 register double dblValue) /* Double used to initialize the object. */ 2079{ 2080 return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); 2081} 2082 2083#else /* if not TCL_MEM_DEBUG */ 2084 2085Tcl_Obj * 2086Tcl_NewDoubleObj( 2087 register double dblValue) /* Double used to initialize the object. */ 2088{ 2089 register Tcl_Obj *objPtr; 2090 2091 TclNewDoubleObj(objPtr, dblValue); 2092 return objPtr; 2093} 2094#endif /* if TCL_MEM_DEBUG */ 2095 2096/* 2097 *---------------------------------------------------------------------- 2098 * 2099 * Tcl_DbNewDoubleObj -- 2100 * 2101 * This function is normally called when debugging: i.e., when 2102 * TCL_MEM_DEBUG is defined. It creates new double objects. It is the 2103 * same as the Tcl_NewDoubleObj function above except that it calls 2104 * Tcl_DbCkalloc directly with the file name and line number from its 2105 * caller. This simplifies debugging since then the [memory active] 2106 * command will report the correct file name and line number when 2107 * reporting objects that haven't been freed. 2108 * 2109 * When TCL_MEM_DEBUG is not defined, this function just returns the 2110 * result of calling Tcl_NewDoubleObj. 2111 * 2112 * Results: 2113 * The newly created object is returned. This object will have an invalid 2114 * string representation. The returned object has ref count 0. 2115 * 2116 * Side effects: 2117 * None. 2118 * 2119 *---------------------------------------------------------------------- 2120 */ 2121 2122#ifdef TCL_MEM_DEBUG 2123 2124Tcl_Obj * 2125Tcl_DbNewDoubleObj( 2126 register double dblValue, /* Double used to initialize the object. */ 2127 CONST char *file, /* The name of the source file calling this 2128 * function; used for debugging. */ 2129 int line) /* Line number in the source file; used for 2130 * debugging. */ 2131{ 2132 register Tcl_Obj *objPtr; 2133 2134 TclDbNewObj(objPtr, file, line); 2135 objPtr->bytes = NULL; 2136 2137 objPtr->internalRep.doubleValue = dblValue; 2138 objPtr->typePtr = &tclDoubleType; 2139 return objPtr; 2140} 2141 2142#else /* if not TCL_MEM_DEBUG */ 2143 2144Tcl_Obj * 2145Tcl_DbNewDoubleObj( 2146 register double dblValue, /* Double used to initialize the object. */ 2147 CONST char *file, /* The name of the source file calling this 2148 * function; used for debugging. */ 2149 int line) /* Line number in the source file; used for 2150 * debugging. */ 2151{ 2152 return Tcl_NewDoubleObj(dblValue); 2153} 2154#endif /* TCL_MEM_DEBUG */ 2155 2156/* 2157 *---------------------------------------------------------------------- 2158 * 2159 * Tcl_SetDoubleObj -- 2160 * 2161 * Modify an object to be a double object and to have the specified 2162 * double value. 2163 * 2164 * Results: 2165 * None. 2166 * 2167 * Side effects: 2168 * The object's old string rep, if any, is freed. Also, any old internal 2169 * rep is freed. 2170 * 2171 *---------------------------------------------------------------------- 2172 */ 2173 2174void 2175Tcl_SetDoubleObj( 2176 register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ 2177 register double dblValue) /* Double used to set the object's value. */ 2178{ 2179 if (Tcl_IsShared(objPtr)) { 2180 Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); 2181 } 2182 2183 TclSetDoubleObj(objPtr, dblValue); 2184} 2185 2186/* 2187 *---------------------------------------------------------------------- 2188 * 2189 * Tcl_GetDoubleFromObj -- 2190 * 2191 * Attempt to return a double from the Tcl object "objPtr". If the object 2192 * is not already a double, an attempt will be made to convert it to one. 2193 * 2194 * Results: 2195 * The return value is a standard Tcl object result. If an error occurs 2196 * during conversion, an error message is left in the interpreter's 2197 * result unless "interp" is NULL. 2198 * 2199 * Side effects: 2200 * If the object is not already a double, the conversion will free any 2201 * old internal representation. 2202 * 2203 *---------------------------------------------------------------------- 2204 */ 2205 2206int 2207Tcl_GetDoubleFromObj( 2208 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2209 register Tcl_Obj *objPtr, /* The object from which to get a double. */ 2210 register double *dblPtr) /* Place to store resulting double. */ 2211{ 2212 do { 2213 if (objPtr->typePtr == &tclDoubleType) { 2214 if (TclIsNaN(objPtr->internalRep.doubleValue)) { 2215 if (interp != NULL) { 2216 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2217 "floating point value is Not a Number", -1)); 2218 } 2219 return TCL_ERROR; 2220 } 2221 *dblPtr = (double) objPtr->internalRep.doubleValue; 2222 return TCL_OK; 2223 } 2224 if (objPtr->typePtr == &tclIntType) { 2225 *dblPtr = objPtr->internalRep.longValue; 2226 return TCL_OK; 2227 } 2228 if (objPtr->typePtr == &tclBignumType) { 2229 mp_int big; 2230 UNPACK_BIGNUM( objPtr, big ); 2231 *dblPtr = TclBignumToDouble( &big ); 2232 return TCL_OK; 2233 } 2234#ifndef NO_WIDE_TYPE 2235 if (objPtr->typePtr == &tclWideIntType) { 2236 *dblPtr = (double) objPtr->internalRep.wideValue; 2237 return TCL_OK; 2238 } 2239#endif 2240 } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); 2241 return TCL_ERROR; 2242} 2243 2244/* 2245 *---------------------------------------------------------------------- 2246 * 2247 * SetDoubleFromAny -- 2248 * 2249 * Attempt to generate an double-precision floating point internal form 2250 * for the Tcl object "objPtr". 2251 * 2252 * Results: 2253 * The return value is a standard Tcl object result. If an error occurs 2254 * during conversion, an error message is left in the interpreter's 2255 * result unless "interp" is NULL. 2256 * 2257 * Side effects: 2258 * If no error occurs, a double is stored as "objPtr"s internal 2259 * representation. 2260 * 2261 *---------------------------------------------------------------------- 2262 */ 2263 2264static int 2265SetDoubleFromAny( 2266 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2267 register Tcl_Obj *objPtr) /* The object to convert. */ 2268{ 2269 return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, 2270 NULL, 0); 2271} 2272 2273/* 2274 *---------------------------------------------------------------------- 2275 * 2276 * UpdateStringOfDouble -- 2277 * 2278 * Update the string representation for a double-precision floating point 2279 * object. This must obey the current tcl_precision value for 2280 * double-to-string conversions. Note: This function does not free an 2281 * existing old string rep so storage will be lost if this has not 2282 * already been done. 2283 * 2284 * Results: 2285 * None. 2286 * 2287 * Side effects: 2288 * The object's string is set to a valid string that results from the 2289 * double-to-string conversion. 2290 * 2291 *---------------------------------------------------------------------- 2292 */ 2293 2294static void 2295UpdateStringOfDouble( 2296 register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ 2297{ 2298 char buffer[TCL_DOUBLE_SPACE]; 2299 register int len; 2300 2301 Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); 2302 len = strlen(buffer); 2303 2304 objPtr->bytes = (char *) ckalloc((unsigned) len + 1); 2305 strcpy(objPtr->bytes, buffer); 2306 objPtr->length = len; 2307} 2308 2309/* 2310 *---------------------------------------------------------------------- 2311 * 2312 * Tcl_NewIntObj -- 2313 * 2314 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 2315 * Tcl_NewIntObj to create a new integer object end up calling the 2316 * debugging function Tcl_DbNewLongObj instead. 2317 * 2318 * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, 2319 * calls to Tcl_NewIntObj result in a call to one of the two 2320 * Tcl_NewIntObj implementations below. We provide two implementations so 2321 * that the Tcl core can be compiled to do memory debugging of the core 2322 * even if a client does not request it for itself. 2323 * 2324 * Integer and long integer objects share the same "integer" type 2325 * implementation. We store all integers as longs and Tcl_GetIntFromObj 2326 * checks whether the current value of the long can be represented by an 2327 * int. 2328 * 2329 * Results: 2330 * The newly created object is returned. This object will have an invalid 2331 * string representation. The returned object has ref count 0. 2332 * 2333 * Side effects: 2334 * None. 2335 * 2336 *---------------------------------------------------------------------- 2337 */ 2338 2339#ifdef TCL_MEM_DEBUG 2340#undef Tcl_NewIntObj 2341 2342Tcl_Obj * 2343Tcl_NewIntObj( 2344 register int intValue) /* Int used to initialize the new object. */ 2345{ 2346 return Tcl_DbNewLongObj((long)intValue, "unknown", 0); 2347} 2348 2349#else /* if not TCL_MEM_DEBUG */ 2350 2351Tcl_Obj * 2352Tcl_NewIntObj( 2353 register int intValue) /* Int used to initialize the new object. */ 2354{ 2355 register Tcl_Obj *objPtr; 2356 2357 TclNewIntObj(objPtr, intValue); 2358 return objPtr; 2359} 2360#endif /* if TCL_MEM_DEBUG */ 2361 2362/* 2363 *---------------------------------------------------------------------- 2364 * 2365 * Tcl_SetIntObj -- 2366 * 2367 * Modify an object to be an integer and to have the specified integer 2368 * value. 2369 * 2370 * Results: 2371 * None. 2372 * 2373 * Side effects: 2374 * The object's old string rep, if any, is freed. Also, any old internal 2375 * rep is freed. 2376 * 2377 *---------------------------------------------------------------------- 2378 */ 2379 2380void 2381Tcl_SetIntObj( 2382 register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ 2383 register int intValue) /* Integer used to set object's value. */ 2384{ 2385 if (Tcl_IsShared(objPtr)) { 2386 Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); 2387 } 2388 2389 TclSetIntObj(objPtr, intValue); 2390} 2391 2392/* 2393 *---------------------------------------------------------------------- 2394 * 2395 * Tcl_GetIntFromObj -- 2396 * 2397 * Attempt to return an int from the Tcl object "objPtr". If the object 2398 * is not already an int, an attempt will be made to convert it to one. 2399 * 2400 * Integer and long integer objects share the same "integer" type 2401 * implementation. We store all integers as longs and Tcl_GetIntFromObj 2402 * checks whether the current value of the long can be represented by an 2403 * int. 2404 * 2405 * Results: 2406 * The return value is a standard Tcl object result. If an error occurs 2407 * during conversion or if the long integer held by the object can not be 2408 * represented by an int, an error message is left in the interpreter's 2409 * result unless "interp" is NULL. 2410 * 2411 * Side effects: 2412 * If the object is not already an int, the conversion will free any old 2413 * internal representation. 2414 * 2415 *---------------------------------------------------------------------- 2416 */ 2417 2418int 2419Tcl_GetIntFromObj( 2420 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2421 register Tcl_Obj *objPtr, /* The object from which to get a int. */ 2422 register int *intPtr) /* Place to store resulting int. */ 2423{ 2424#if (LONG_MAX == INT_MAX) 2425 return TclGetLongFromObj(interp, objPtr, (long *) intPtr); 2426#else 2427 long l; 2428 2429 if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { 2430 return TCL_ERROR; 2431 } 2432 if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { 2433 if (interp != NULL) { 2434 CONST char *s = 2435 "integer value too large to represent as non-long integer"; 2436 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); 2437 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); 2438 } 2439 return TCL_ERROR; 2440 } 2441 *intPtr = (int) l; 2442 return TCL_OK; 2443#endif 2444} 2445 2446/* 2447 *---------------------------------------------------------------------- 2448 * 2449 * SetIntFromAny -- 2450 * 2451 * Attempts to force the internal representation for a Tcl object to 2452 * tclIntType, specifically. 2453 * 2454 * Results: 2455 * The return value is a standard object Tcl result. If an error occurs 2456 * during conversion, an error message is left in the interpreter's 2457 * result unless "interp" is NULL. 2458 * 2459 *---------------------------------------------------------------------- 2460 */ 2461 2462static int 2463SetIntFromAny( 2464 Tcl_Interp *interp, /* Tcl interpreter */ 2465 Tcl_Obj *objPtr) /* Pointer to the object to convert */ 2466{ 2467 long l; 2468 return TclGetLongFromObj(interp, objPtr, &l); 2469} 2470 2471/* 2472 *---------------------------------------------------------------------- 2473 * 2474 * UpdateStringOfInt -- 2475 * 2476 * Update the string representation for an integer object. Note: This 2477 * function does not free an existing old string rep so storage will be 2478 * lost if this has not already been done. 2479 * 2480 * Results: 2481 * None. 2482 * 2483 * Side effects: 2484 * The object's string is set to a valid string that results from the 2485 * int-to-string conversion. 2486 * 2487 *---------------------------------------------------------------------- 2488 */ 2489 2490static void 2491UpdateStringOfInt( 2492 register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ 2493{ 2494 char buffer[TCL_INTEGER_SPACE]; 2495 register int len; 2496 2497 len = TclFormatInt(buffer, objPtr->internalRep.longValue); 2498 2499 objPtr->bytes = ckalloc((unsigned) len + 1); 2500 strcpy(objPtr->bytes, buffer); 2501 objPtr->length = len; 2502} 2503 2504/* 2505 *---------------------------------------------------------------------- 2506 * 2507 * Tcl_NewLongObj -- 2508 * 2509 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 2510 * Tcl_NewLongObj to create a new long integer object end up calling the 2511 * debugging function Tcl_DbNewLongObj instead. 2512 * 2513 * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, 2514 * calls to Tcl_NewLongObj result in a call to one of the two 2515 * Tcl_NewLongObj implementations below. We provide two implementations 2516 * so that the Tcl core can be compiled to do memory debugging of the 2517 * core even if a client does not request it for itself. 2518 * 2519 * Integer and long integer objects share the same "integer" type 2520 * implementation. We store all integers as longs and Tcl_GetIntFromObj 2521 * checks whether the current value of the long can be represented by an 2522 * int. 2523 * 2524 * Results: 2525 * The newly created object is returned. This object will have an invalid 2526 * string representation. The returned object has ref count 0. 2527 * 2528 * Side effects: 2529 * None. 2530 * 2531 *---------------------------------------------------------------------- 2532 */ 2533 2534#ifdef TCL_MEM_DEBUG 2535#undef Tcl_NewLongObj 2536 2537Tcl_Obj * 2538Tcl_NewLongObj( 2539 register long longValue) /* Long integer used to initialize the 2540 * new object. */ 2541{ 2542 return Tcl_DbNewLongObj(longValue, "unknown", 0); 2543} 2544 2545#else /* if not TCL_MEM_DEBUG */ 2546 2547Tcl_Obj * 2548Tcl_NewLongObj( 2549 register long longValue) /* Long integer used to initialize the 2550 * new object. */ 2551{ 2552 register Tcl_Obj *objPtr; 2553 2554 TclNewLongObj(objPtr, longValue); 2555 return objPtr; 2556} 2557#endif /* if TCL_MEM_DEBUG */ 2558 2559/* 2560 *---------------------------------------------------------------------- 2561 * 2562 * Tcl_DbNewLongObj -- 2563 * 2564 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 2565 * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer 2566 * objects end up calling the debugging function Tcl_DbNewLongObj 2567 * instead. We provide two implementations of Tcl_DbNewLongObj so that 2568 * whether the Tcl core is compiled to do memory debugging of the core is 2569 * independent of whether a client requests debugging for itself. 2570 * 2571 * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj 2572 * calls Tcl_DbCkalloc directly with the file name and line number from 2573 * its caller. This simplifies debugging since then the [memory active] 2574 * command will report the caller's file name and line number when 2575 * reporting objects that haven't been freed. 2576 * 2577 * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, 2578 * this function just returns the result of calling Tcl_NewLongObj. 2579 * 2580 * Results: 2581 * The newly created long integer object is returned. This object will 2582 * have an invalid string representation. The returned object has ref 2583 * count 0. 2584 * 2585 * Side effects: 2586 * Allocates memory. 2587 * 2588 *---------------------------------------------------------------------- 2589 */ 2590 2591#ifdef TCL_MEM_DEBUG 2592 2593Tcl_Obj * 2594Tcl_DbNewLongObj( 2595 register long longValue, /* Long integer used to initialize the new 2596 * object. */ 2597 CONST char *file, /* The name of the source file calling this 2598 * function; used for debugging. */ 2599 int line) /* Line number in the source file; used for 2600 * debugging. */ 2601{ 2602 register Tcl_Obj *objPtr; 2603 2604 TclDbNewObj(objPtr, file, line); 2605 objPtr->bytes = NULL; 2606 2607 objPtr->internalRep.longValue = longValue; 2608 objPtr->typePtr = &tclIntType; 2609 return objPtr; 2610} 2611 2612#else /* if not TCL_MEM_DEBUG */ 2613 2614Tcl_Obj * 2615Tcl_DbNewLongObj( 2616 register long longValue, /* Long integer used to initialize the new 2617 * object. */ 2618 CONST char *file, /* The name of the source file calling this 2619 * function; used for debugging. */ 2620 int line) /* Line number in the source file; used for 2621 * debugging. */ 2622{ 2623 return Tcl_NewLongObj(longValue); 2624} 2625#endif /* TCL_MEM_DEBUG */ 2626 2627/* 2628 *---------------------------------------------------------------------- 2629 * 2630 * Tcl_SetLongObj -- 2631 * 2632 * Modify an object to be an integer object and to have the specified 2633 * long integer value. 2634 * 2635 * Results: 2636 * None. 2637 * 2638 * Side effects: 2639 * The object's old string rep, if any, is freed. Also, any old internal 2640 * rep is freed. 2641 * 2642 *---------------------------------------------------------------------- 2643 */ 2644 2645void 2646Tcl_SetLongObj( 2647 register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ 2648 register long longValue) /* Long integer used to initialize the 2649 * object's value. */ 2650{ 2651 if (Tcl_IsShared(objPtr)) { 2652 Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); 2653 } 2654 2655 TclSetLongObj(objPtr, longValue); 2656} 2657 2658/* 2659 *---------------------------------------------------------------------- 2660 * 2661 * Tcl_GetLongFromObj -- 2662 * 2663 * Attempt to return an long integer from the Tcl object "objPtr". If the 2664 * object is not already an int object, an attempt will be made to 2665 * convert it to one. 2666 * 2667 * Results: 2668 * The return value is a standard Tcl object result. If an error occurs 2669 * during conversion, an error message is left in the interpreter's 2670 * result unless "interp" is NULL. 2671 * 2672 * Side effects: 2673 * If the object is not already an int object, the conversion will free 2674 * any old internal representation. 2675 * 2676 *---------------------------------------------------------------------- 2677 */ 2678 2679int 2680Tcl_GetLongFromObj( 2681 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2682 register Tcl_Obj *objPtr, /* The object from which to get a long. */ 2683 register long *longPtr) /* Place to store resulting long. */ 2684{ 2685 do { 2686 if (objPtr->typePtr == &tclIntType) { 2687 *longPtr = objPtr->internalRep.longValue; 2688 return TCL_OK; 2689 } 2690#ifndef NO_WIDE_TYPE 2691 if (objPtr->typePtr == &tclWideIntType) { 2692 /* 2693 * We return any integer in the range -ULONG_MAX to ULONG_MAX 2694 * converted to a long, ignoring overflow. The rule preserves 2695 * existing semantics for conversion of integers on input, but 2696 * avoids inadvertent demotion of wide integers to 32-bit ones in 2697 * the internal rep. 2698 */ 2699 2700 Tcl_WideInt w = objPtr->internalRep.wideValue; 2701 if (w >= -(Tcl_WideInt)(ULONG_MAX) 2702 && w <= (Tcl_WideInt)(ULONG_MAX)) { 2703 *longPtr = Tcl_WideAsLong(w); 2704 return TCL_OK; 2705 } 2706 goto tooLarge; 2707 } 2708#endif 2709 if (objPtr->typePtr == &tclDoubleType) { 2710 if (interp != NULL) { 2711 Tcl_Obj *msg; 2712 2713 TclNewLiteralStringObj(msg, "expected integer but got \""); 2714 Tcl_AppendObjToObj(msg, objPtr); 2715 Tcl_AppendToObj(msg, "\"", -1); 2716 Tcl_SetObjResult(interp, msg); 2717 } 2718 return TCL_ERROR; 2719 } 2720 if (objPtr->typePtr == &tclBignumType) { 2721 /* 2722 * Must check for those bignum values that can fit in a long, even 2723 * when auto-narrowing is enabled. Only those values in the signed 2724 * long range get auto-narrowed to tclIntType, while all the 2725 * values in the unsigned long range will fit in a long. 2726 */ 2727 2728 mp_int big; 2729 2730 UNPACK_BIGNUM(objPtr, big); 2731 if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) 2732 / DIGIT_BIT) { 2733 unsigned long value = 0, numBytes = sizeof(long); 2734 long scratch; 2735 unsigned char *bytes = (unsigned char *)&scratch; 2736 if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { 2737 while (numBytes-- > 0) { 2738 value = (value << CHAR_BIT) | *bytes++; 2739 } 2740 if (big.sign) { 2741 *longPtr = - (long) value; 2742 } else { 2743 *longPtr = (long) value; 2744 } 2745 return TCL_OK; 2746 } 2747 } 2748#ifndef NO_WIDE_TYPE 2749 tooLarge: 2750#endif 2751 if (interp != NULL) { 2752 char *s = "integer value too large to represent"; 2753 Tcl_Obj *msg = Tcl_NewStringObj(s, -1); 2754 2755 Tcl_SetObjResult(interp, msg); 2756 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); 2757 } 2758 return TCL_ERROR; 2759 } 2760 } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, 2761 TCL_PARSE_INTEGER_ONLY)==TCL_OK); 2762 return TCL_ERROR; 2763} 2764#ifndef NO_WIDE_TYPE 2765 2766/* 2767 *---------------------------------------------------------------------- 2768 * 2769 * UpdateStringOfWideInt -- 2770 * 2771 * Update the string representation for a wide integer object. Note: this 2772 * function does not free an existing old string rep so storage will be 2773 * lost if this has not already been done. 2774 * 2775 * Results: 2776 * None. 2777 * 2778 * Side effects: 2779 * The object's string is set to a valid string that results from the 2780 * wideInt-to-string conversion. 2781 * 2782 *---------------------------------------------------------------------- 2783 */ 2784 2785static void 2786UpdateStringOfWideInt( 2787 register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ 2788{ 2789 char buffer[TCL_INTEGER_SPACE+2]; 2790 register unsigned len; 2791 register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; 2792 2793 /* 2794 * Note that sprintf will generate a compiler warning under Mingw claiming 2795 * %I64 is an unknown format specifier. Just ignore this warning. We can't 2796 * use %L as the format specifier since that gets printed as a 32 bit 2797 * value. 2798 */ 2799 2800 sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); 2801 len = strlen(buffer); 2802 objPtr->bytes = ckalloc((unsigned) len + 1); 2803 memcpy(objPtr->bytes, buffer, len + 1); 2804 objPtr->length = len; 2805} 2806#endif /* !NO_WIDE_TYPE */ 2807 2808/* 2809 *---------------------------------------------------------------------- 2810 * 2811 * Tcl_NewWideIntObj -- 2812 * 2813 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 2814 * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling 2815 * the debugging function Tcl_DbNewWideIntObj instead. 2816 * 2817 * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, 2818 * calls to Tcl_NewWideIntObj result in a call to one of the two 2819 * Tcl_NewWideIntObj implementations below. We provide two 2820 * implementations so that the Tcl core can be compiled to do memory 2821 * debugging of the core even if a client does not request it for itself. 2822 * 2823 * Results: 2824 * The newly created object is returned. This object will have an invalid 2825 * string representation. The returned object has ref count 0. 2826 * 2827 * Side effects: 2828 * None. 2829 * 2830 *---------------------------------------------------------------------- 2831 */ 2832 2833#ifdef TCL_MEM_DEBUG 2834#undef Tcl_NewWideIntObj 2835 2836Tcl_Obj * 2837Tcl_NewWideIntObj( 2838 register Tcl_WideInt wideValue) 2839 /* Wide integer used to initialize the new 2840 * object. */ 2841{ 2842 return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); 2843} 2844 2845#else /* if not TCL_MEM_DEBUG */ 2846 2847Tcl_Obj * 2848Tcl_NewWideIntObj( 2849 register Tcl_WideInt wideValue) 2850 /* Wide integer used to initialize the new 2851 * object. */ 2852{ 2853 register Tcl_Obj *objPtr; 2854 2855 TclNewObj(objPtr); 2856 Tcl_SetWideIntObj(objPtr, wideValue); 2857 return objPtr; 2858} 2859#endif /* if TCL_MEM_DEBUG */ 2860 2861/* 2862 *---------------------------------------------------------------------- 2863 * 2864 * Tcl_DbNewWideIntObj -- 2865 * 2866 * If a client is compiled with TCL_MEM_DEBUG defined, calls to 2867 * Tcl_NewWideIntObj to create new wide integer end up calling the 2868 * debugging function Tcl_DbNewWideIntObj instead. We provide two 2869 * implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is 2870 * compiled to do memory debugging of the core is independent of whether 2871 * a client requests debugging for itself. 2872 * 2873 * When the core is compiled with TCL_MEM_DEBUG defined, 2874 * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name 2875 * and line number from its caller. This simplifies debugging since then 2876 * the checkmem command will report the caller's file name and line 2877 * number when reporting objects that haven't been freed. 2878 * 2879 * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, 2880 * this function just returns the result of calling Tcl_NewWideIntObj. 2881 * 2882 * Results: 2883 * The newly created wide integer object is returned. This object will 2884 * have an invalid string representation. The returned object has ref 2885 * count 0. 2886 * 2887 * Side effects: 2888 * Allocates memory. 2889 * 2890 *---------------------------------------------------------------------- 2891 */ 2892 2893#ifdef TCL_MEM_DEBUG 2894 2895Tcl_Obj * 2896Tcl_DbNewWideIntObj( 2897 register Tcl_WideInt wideValue, 2898 /* Wide integer used to initialize the new 2899 * object. */ 2900 CONST char *file, /* The name of the source file calling this 2901 * function; used for debugging. */ 2902 int line) /* Line number in the source file; used for 2903 * debugging. */ 2904{ 2905 register Tcl_Obj *objPtr; 2906 2907 TclDbNewObj(objPtr, file, line); 2908 Tcl_SetWideIntObj(objPtr, wideValue); 2909 return objPtr; 2910} 2911 2912#else /* if not TCL_MEM_DEBUG */ 2913 2914Tcl_Obj * 2915Tcl_DbNewWideIntObj( 2916 register Tcl_WideInt wideValue, 2917 /* Long integer used to initialize the new 2918 * object. */ 2919 CONST char *file, /* The name of the source file calling this 2920 * function; used for debugging. */ 2921 int line) /* Line number in the source file; used for 2922 * debugging. */ 2923{ 2924 return Tcl_NewWideIntObj(wideValue); 2925} 2926#endif /* TCL_MEM_DEBUG */ 2927 2928/* 2929 *---------------------------------------------------------------------- 2930 * 2931 * Tcl_SetWideIntObj -- 2932 * 2933 * Modify an object to be a wide integer object and to have the specified 2934 * wide integer value. 2935 * 2936 * Results: 2937 * None. 2938 * 2939 * Side effects: 2940 * The object's old string rep, if any, is freed. Also, any old internal 2941 * rep is freed. 2942 * 2943 *---------------------------------------------------------------------- 2944 */ 2945 2946void 2947Tcl_SetWideIntObj( 2948 register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ 2949 register Tcl_WideInt wideValue) 2950 /* Wide integer used to initialize the 2951 * object's value. */ 2952{ 2953 if (Tcl_IsShared(objPtr)) { 2954 Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); 2955 } 2956 2957 if ((wideValue >= (Tcl_WideInt) LONG_MIN) 2958 && (wideValue <= (Tcl_WideInt) LONG_MAX)) { 2959 TclSetLongObj(objPtr, (long) wideValue); 2960 } else { 2961#ifndef NO_WIDE_TYPE 2962 TclSetWideIntObj(objPtr, wideValue); 2963#else 2964 mp_int big; 2965 2966 TclBNInitBignumFromWideInt(&big, wideValue); 2967 Tcl_SetBignumObj(objPtr, &big); 2968#endif 2969 } 2970} 2971 2972/* 2973 *---------------------------------------------------------------------- 2974 * 2975 * Tcl_GetWideIntFromObj -- 2976 * 2977 * Attempt to return a wide integer from the Tcl object "objPtr". If the 2978 * object is not already a wide int object, an attempt will be made to 2979 * convert it to one. 2980 * 2981 * Results: 2982 * The return value is a standard Tcl object result. If an error occurs 2983 * during conversion, an error message is left in the interpreter's 2984 * result unless "interp" is NULL. 2985 * 2986 * Side effects: 2987 * If the object is not already an int object, the conversion will free 2988 * any old internal representation. 2989 * 2990 *---------------------------------------------------------------------- 2991 */ 2992 2993int 2994Tcl_GetWideIntFromObj( 2995 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2996 register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ 2997 register Tcl_WideInt *wideIntPtr) 2998 /* Place to store resulting long. */ 2999{ 3000 do { 3001#ifndef NO_WIDE_TYPE 3002 if (objPtr->typePtr == &tclWideIntType) { 3003 *wideIntPtr = objPtr->internalRep.wideValue; 3004 return TCL_OK; 3005 } 3006#endif 3007 if (objPtr->typePtr == &tclIntType) { 3008 *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; 3009 return TCL_OK; 3010 } 3011 if (objPtr->typePtr == &tclDoubleType) { 3012 if (interp != NULL) { 3013 Tcl_Obj *msg; 3014 3015 TclNewLiteralStringObj(msg, "expected integer but got \""); 3016 Tcl_AppendObjToObj(msg, objPtr); 3017 Tcl_AppendToObj(msg, "\"", -1); 3018 Tcl_SetObjResult(interp, msg); 3019 } 3020 return TCL_ERROR; 3021 } 3022 if (objPtr->typePtr == &tclBignumType) { 3023 /* 3024 * Must check for those bignum values that can fit in a 3025 * Tcl_WideInt, even when auto-narrowing is enabled. 3026 */ 3027 3028 mp_int big; 3029 3030 UNPACK_BIGNUM(objPtr, big); 3031 if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt) 3032 + DIGIT_BIT - 1) / DIGIT_BIT) { 3033 Tcl_WideUInt value = 0; 3034 unsigned long numBytes = sizeof(Tcl_WideInt); 3035 Tcl_WideInt scratch; 3036 unsigned char *bytes = (unsigned char *) &scratch; 3037 3038 if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { 3039 while (numBytes-- > 0) { 3040 value = (value << CHAR_BIT) | *bytes++; 3041 } 3042 if (big.sign) { 3043 *wideIntPtr = - (Tcl_WideInt) value; 3044 } else { 3045 *wideIntPtr = (Tcl_WideInt) value; 3046 } 3047 return TCL_OK; 3048 } 3049 } 3050 if (interp != NULL) { 3051 char *s = "integer value too large to represent"; 3052 Tcl_Obj* msg = Tcl_NewStringObj(s, -1); 3053 3054 Tcl_SetObjResult(interp, msg); 3055 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); 3056 } 3057 return TCL_ERROR; 3058 } 3059 } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, 3060 TCL_PARSE_INTEGER_ONLY)==TCL_OK); 3061 return TCL_ERROR; 3062} 3063#ifndef NO_WIDE_TYPE 3064 3065/* 3066 *---------------------------------------------------------------------- 3067 * 3068 * SetWideIntFromAny -- 3069 * 3070 * Attempts to force the internal representation for a Tcl object to 3071 * tclWideIntType, specifically. 3072 * 3073 * Results: 3074 * The return value is a standard object Tcl result. If an error occurs 3075 * during conversion, an error message is left in the interpreter's 3076 * result unless "interp" is NULL. 3077 * 3078 *---------------------------------------------------------------------- 3079 */ 3080 3081static int 3082SetWideIntFromAny( 3083 Tcl_Interp *interp, /* Tcl interpreter */ 3084 Tcl_Obj *objPtr) /* Pointer to the object to convert */ 3085{ 3086 Tcl_WideInt w; 3087 return Tcl_GetWideIntFromObj(interp, objPtr, &w); 3088} 3089#endif /* !NO_WIDE_TYPE */ 3090 3091/* 3092 *---------------------------------------------------------------------- 3093 * 3094 * FreeBignum -- 3095 * 3096 * This function frees the internal rep of a bignum. 3097 * 3098 * Results: 3099 * None. 3100 * 3101 *---------------------------------------------------------------------- 3102 */ 3103 3104static void 3105FreeBignum( 3106 Tcl_Obj *objPtr) 3107{ 3108 mp_int toFree; /* Bignum to free */ 3109 3110 UNPACK_BIGNUM(objPtr, toFree); 3111 mp_clear(&toFree); 3112 if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { 3113 ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); 3114 } 3115} 3116 3117/* 3118 *---------------------------------------------------------------------- 3119 * 3120 * DupBignum -- 3121 * 3122 * This function duplicates the internal rep of a bignum. 3123 * 3124 * Results: 3125 * None. 3126 * 3127 * Side effects: 3128 * The destination object receies a copy of the source object 3129 * 3130 *---------------------------------------------------------------------- 3131 */ 3132 3133static void 3134DupBignum( 3135 Tcl_Obj *srcPtr, 3136 Tcl_Obj *copyPtr) 3137{ 3138 mp_int bignumVal; 3139 mp_int bignumCopy; 3140 3141 copyPtr->typePtr = &tclBignumType; 3142 UNPACK_BIGNUM(srcPtr, bignumVal); 3143 if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { 3144 Tcl_Panic("initialization failure in DupBignum"); 3145 } 3146 PACK_BIGNUM(bignumCopy, copyPtr); 3147} 3148 3149/* 3150 *---------------------------------------------------------------------- 3151 * 3152 * UpdateStringOfBignum -- 3153 * 3154 * This function updates the string representation of a bignum object. 3155 * 3156 * Results: 3157 * None. 3158 * 3159 * Side effects: 3160 * The object's string is set to whatever results from the bignum- 3161 * to-string conversion. 3162 * 3163 * The object's existing string representation is NOT freed; memory will leak 3164 * if the string rep is still valid at the time this function is called. 3165 * 3166 *---------------------------------------------------------------------- 3167 */ 3168 3169static void 3170UpdateStringOfBignum( 3171 Tcl_Obj *objPtr) 3172{ 3173 mp_int bignumVal; 3174 int size; 3175 int status; 3176 char* stringVal; 3177 3178 UNPACK_BIGNUM(objPtr, bignumVal); 3179 status = mp_radix_size(&bignumVal, 10, &size); 3180 if (status != MP_OKAY) { 3181 Tcl_Panic("radix size failure in UpdateStringOfBignum"); 3182 } 3183 if (size == 3) { 3184 /* 3185 * mp_radix_size() returns 3 when more than INT_MAX bytes would be 3186 * needed to hold the string rep (because mp_radix_size ignores 3187 * integer overflow issues). When we know the string rep will be more 3188 * than 3, we can conclude the string rep would overflow our string 3189 * length limits. 3190 * 3191 * Note that so long as we enforce our bignums to the size that fits 3192 * in a packed bignum, this branch will never be taken. 3193 */ 3194 3195 Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); 3196 } 3197 stringVal = ckalloc((size_t) size); 3198 status = mp_toradix_n(&bignumVal, stringVal, 10, size); 3199 if (status != MP_OKAY) { 3200 Tcl_Panic("conversion failure in UpdateStringOfBignum"); 3201 } 3202 objPtr->bytes = stringVal; 3203 objPtr->length = size - 1; /* size includes a trailing null byte */ 3204} 3205 3206/* 3207 *---------------------------------------------------------------------- 3208 * 3209 * Tcl_NewBignumObj -- 3210 * 3211 * Creates an initializes a bignum object. 3212 * 3213 * Results: 3214 * Returns the newly created object. 3215 * 3216 * Side effects: 3217 * The bignum value is cleared, since ownership has transferred to Tcl. 3218 * 3219 *---------------------------------------------------------------------- 3220 */ 3221 3222#ifdef TCL_MEM_DEBUG 3223#undef Tcl_NewBignumObj 3224 3225Tcl_Obj * 3226Tcl_NewBignumObj( 3227 mp_int *bignumValue) 3228{ 3229 return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); 3230} 3231#else 3232Tcl_Obj * 3233Tcl_NewBignumObj( 3234 mp_int *bignumValue) 3235{ 3236 Tcl_Obj* objPtr; 3237 3238 TclNewObj(objPtr); 3239 Tcl_SetBignumObj(objPtr, bignumValue); 3240 return objPtr; 3241} 3242#endif 3243 3244/* 3245 *---------------------------------------------------------------------- 3246 * 3247 * Tcl_DbNewBignumObj -- 3248 * 3249 * This function is normally called when debugging: that is, when 3250 * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording the 3251 * creation point so that [memory active] can report it. 3252 * 3253 * Results: 3254 * Returns the newly created object. 3255 * 3256 * Side effects: 3257 * The bignum value is cleared, since ownership has transferred to Tcl. 3258 * 3259 *---------------------------------------------------------------------- 3260 */ 3261 3262#ifdef TCL_MEM_DEBUG 3263Tcl_Obj * 3264Tcl_DbNewBignumObj( 3265 mp_int *bignumValue, 3266 CONST char *file, 3267 int line) 3268{ 3269 Tcl_Obj *objPtr; 3270 3271 TclDbNewObj(objPtr, file, line); 3272 Tcl_SetBignumObj(objPtr, bignumValue); 3273 return objPtr; 3274} 3275#else 3276Tcl_Obj * 3277Tcl_DbNewBignumObj( 3278 mp_int *bignumValue, 3279 CONST char *file, 3280 int line) 3281{ 3282 return Tcl_NewBignumObj(bignumValue); 3283} 3284#endif 3285 3286/* 3287 *---------------------------------------------------------------------- 3288 * 3289 * GetBignumFromObj -- 3290 * 3291 * This function retrieves a 'bignum' value from a Tcl object, converting 3292 * the object if necessary. Either copies or transfers the mp_int value 3293 * depending on the copy flag value passed in. 3294 * 3295 * Results: 3296 * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. 3297 * 3298 * Side effects: 3299 * A copy of bignum is stored in *bignumValue, which is expected to be 3300 * uninitialized or cleared. If conversion fails, and the 'interp' 3301 * argument is not NULL, an error message is stored in the interpreter 3302 * result. 3303 * 3304 *---------------------------------------------------------------------- 3305 */ 3306 3307static int 3308GetBignumFromObj( 3309 Tcl_Interp *interp, /* Tcl interpreter for error reporting */ 3310 Tcl_Obj *objPtr, /* Object to read */ 3311 int copy, /* Whether to copy the returned bignum value */ 3312 mp_int *bignumValue) /* Returned bignum value. */ 3313{ 3314 do { 3315 if (objPtr->typePtr == &tclBignumType) { 3316 if (copy || Tcl_IsShared(objPtr)) { 3317 mp_int temp; 3318 UNPACK_BIGNUM(objPtr, temp); 3319 mp_init_copy(bignumValue, &temp); 3320 } else { 3321 UNPACK_BIGNUM(objPtr, *bignumValue); 3322 objPtr->internalRep.ptrAndLongRep.ptr = NULL; 3323 objPtr->internalRep.ptrAndLongRep.value = 0; 3324 objPtr->typePtr = NULL; 3325 if (objPtr->bytes == NULL) { 3326 TclInitStringRep(objPtr, tclEmptyStringRep, 0); 3327 } 3328 } 3329 return TCL_OK; 3330 } 3331 if (objPtr->typePtr == &tclIntType) { 3332 TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); 3333 return TCL_OK; 3334 } 3335#ifndef NO_WIDE_TYPE 3336 if (objPtr->typePtr == &tclWideIntType) { 3337 TclBNInitBignumFromWideInt(bignumValue, 3338 objPtr->internalRep.wideValue); 3339 return TCL_OK; 3340 } 3341#endif 3342 if (objPtr->typePtr == &tclDoubleType) { 3343 if (interp != NULL) { 3344 Tcl_Obj *msg; 3345 3346 TclNewLiteralStringObj(msg, "expected integer but got \""); 3347 Tcl_AppendObjToObj(msg, objPtr); 3348 Tcl_AppendToObj(msg, "\"", -1); 3349 Tcl_SetObjResult(interp, msg); 3350 } 3351 return TCL_ERROR; 3352 } 3353 } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, 3354 TCL_PARSE_INTEGER_ONLY)==TCL_OK); 3355 return TCL_ERROR; 3356} 3357 3358/* 3359 *---------------------------------------------------------------------- 3360 * 3361 * Tcl_GetBignumFromObj -- 3362 * 3363 * This function retrieves a 'bignum' value from a Tcl object, converting 3364 * the object if necessary. 3365 * 3366 * Results: 3367 * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. 3368 * 3369 * Side effects: 3370 * A copy of bignum is stored in *bignumValue, which is expected to be 3371 * uninitialized or cleared. If conversion fails, an the 'interp' 3372 * argument is not NULL, an error message is stored in the interpreter 3373 * result. 3374 * 3375 * It is expected that the caller will NOT have invoked mp_init on the 3376 * bignum value before passing it in. Tcl will initialize the mp_int as 3377 * it sets the value. The value is a copy of the value in objPtr, so it 3378 * becomes the responsibility of the caller to call mp_clear on it. 3379 * 3380 *---------------------------------------------------------------------- 3381 */ 3382 3383int 3384Tcl_GetBignumFromObj( 3385 Tcl_Interp *interp, /* Tcl interpreter for error reporting */ 3386 Tcl_Obj *objPtr, /* Object to read */ 3387 mp_int *bignumValue) /* Returned bignum value. */ 3388{ 3389 return GetBignumFromObj(interp, objPtr, 1, bignumValue); 3390} 3391 3392/* 3393 *---------------------------------------------------------------------- 3394 * 3395 * Tcl_TakeBignumFromObj -- 3396 * 3397 * This function retrieves a 'bignum' value from a Tcl object, converting 3398 * the object if necessary. 3399 * 3400 * Results: 3401 * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. 3402 * 3403 * Side effects: 3404 * A copy of bignum is stored in *bignumValue, which is expected to be 3405 * uninitialized or cleared. If conversion fails, an the 'interp' 3406 * argument is not NULL, an error message is stored in the interpreter 3407 * result. 3408 * 3409 * It is expected that the caller will NOT have invoked mp_init on the 3410 * bignum value before passing it in. Tcl will initialize the mp_int as 3411 * it sets the value. The value is transferred from the internals of 3412 * objPtr to the caller, passing responsibility of the caller to call 3413 * mp_clear on it. The objPtr is cleared to hold an empty value. 3414 * 3415 *---------------------------------------------------------------------- 3416 */ 3417 3418int 3419Tcl_TakeBignumFromObj( 3420 Tcl_Interp *interp, /* Tcl interpreter for error reporting */ 3421 Tcl_Obj *objPtr, /* Object to read */ 3422 mp_int *bignumValue) /* Returned bignum value. */ 3423{ 3424 return GetBignumFromObj(interp, objPtr, 0, bignumValue); 3425} 3426 3427/* 3428 *---------------------------------------------------------------------- 3429 * 3430 * Tcl_SetBignumObj -- 3431 * 3432 * This function sets the value of a Tcl_Obj to a large integer. 3433 * 3434 * Results: 3435 * None. 3436 * 3437 * Side effects: 3438 * Object value is stored. The bignum value is cleared, since ownership 3439 * has transferred to Tcl. 3440 * 3441 *---------------------------------------------------------------------- 3442 */ 3443 3444void 3445Tcl_SetBignumObj( 3446 Tcl_Obj *objPtr, /* Object to set */ 3447 mp_int *bignumValue) /* Value to store */ 3448{ 3449 if (Tcl_IsShared(objPtr)) { 3450 Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); 3451 } 3452 if ((size_t)(bignumValue->used) 3453 <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { 3454 unsigned long value = 0, numBytes = sizeof(long); 3455 long scratch; 3456 unsigned char *bytes = (unsigned char *)&scratch; 3457 if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { 3458 goto tooLargeForLong; 3459 } 3460 while (numBytes-- > 0) { 3461 value = (value << CHAR_BIT) | *bytes++; 3462 } 3463 if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { 3464 goto tooLargeForLong; 3465 } 3466 if (bignumValue->sign) { 3467 TclSetLongObj(objPtr, -(long)value); 3468 } else { 3469 TclSetLongObj(objPtr, (long)value); 3470 } 3471 mp_clear(bignumValue); 3472 return; 3473 } 3474 tooLargeForLong: 3475#ifndef NO_WIDE_TYPE 3476 if ((size_t)(bignumValue->used) 3477 <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { 3478 Tcl_WideUInt value = 0; 3479 unsigned long numBytes = sizeof(Tcl_WideInt); 3480 Tcl_WideInt scratch; 3481 unsigned char *bytes = (unsigned char *)&scratch; 3482 if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { 3483 goto tooLargeForWide; 3484 } 3485 while (numBytes-- > 0) { 3486 value = (value << CHAR_BIT) | *bytes++; 3487 } 3488 if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { 3489 goto tooLargeForWide; 3490 } 3491 if (bignumValue->sign) { 3492 TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); 3493 } else { 3494 TclSetWideIntObj(objPtr, (Tcl_WideInt)value); 3495 } 3496 mp_clear(bignumValue); 3497 return; 3498 } 3499 tooLargeForWide: 3500#endif 3501 TclInvalidateStringRep(objPtr); 3502 TclFreeIntRep(objPtr); 3503 TclSetBignumIntRep(objPtr, bignumValue); 3504} 3505 3506void 3507TclSetBignumIntRep( 3508 Tcl_Obj *objPtr, 3509 mp_int *bignumValue) 3510{ 3511 objPtr->typePtr = &tclBignumType; 3512 PACK_BIGNUM(*bignumValue, objPtr); 3513 3514 /* 3515 * Clear the mp_int value. 3516 * Don't call mp_clear() because it would free the digit array 3517 * we just packed into the Tcl_Obj. 3518 */ 3519 3520 bignumValue->dp = NULL; 3521 bignumValue->alloc = bignumValue->used = 0; 3522 bignumValue->sign = MP_NEG; 3523} 3524 3525/* 3526 *---------------------------------------------------------------------- 3527 * 3528 * TclGetNumberFromObj -- 3529 * 3530 * Results: 3531 * 3532 * Side effects: 3533 * 3534 *---------------------------------------------------------------------- 3535 */ 3536 3537int TclGetNumberFromObj( 3538 Tcl_Interp *interp, 3539 Tcl_Obj *objPtr, 3540 ClientData *clientDataPtr, 3541 int *typePtr) 3542{ 3543 do { 3544 if (objPtr->typePtr == &tclDoubleType) { 3545 if (TclIsNaN(objPtr->internalRep.doubleValue)) { 3546 *typePtr = TCL_NUMBER_NAN; 3547 } else { 3548 *typePtr = TCL_NUMBER_DOUBLE; 3549 } 3550 *clientDataPtr = &(objPtr->internalRep.doubleValue); 3551 return TCL_OK; 3552 } 3553 if (objPtr->typePtr == &tclIntType) { 3554 *typePtr = TCL_NUMBER_LONG; 3555 *clientDataPtr = &(objPtr->internalRep.longValue); 3556 return TCL_OK; 3557 } 3558#ifndef NO_WIDE_TYPE 3559 if (objPtr->typePtr == &tclWideIntType) { 3560 *typePtr = TCL_NUMBER_WIDE; 3561 *clientDataPtr = &(objPtr->internalRep.wideValue); 3562 return TCL_OK; 3563 } 3564#endif 3565 if (objPtr->typePtr == &tclBignumType) { 3566 static Tcl_ThreadDataKey bignumKey; 3567 mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, 3568 (int) sizeof(mp_int)); 3569 UNPACK_BIGNUM( objPtr, *bigPtr ); 3570 *typePtr = TCL_NUMBER_BIG; 3571 *clientDataPtr = bigPtr; 3572 return TCL_OK; 3573 } 3574 } while (TCL_OK == 3575 TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); 3576 return TCL_ERROR; 3577} 3578 3579/* 3580 *---------------------------------------------------------------------- 3581 * 3582 * Tcl_DbIncrRefCount -- 3583 * 3584 * This function is normally called when debugging: i.e., when 3585 * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory 3586 * has been freed before incrementing the ref count. 3587 * 3588 * When TCL_MEM_DEBUG is not defined, this function just increments the 3589 * reference count of the object. 3590 * 3591 * Results: 3592 * None. 3593 * 3594 * Side effects: 3595 * The object's ref count is incremented. 3596 * 3597 *---------------------------------------------------------------------- 3598 */ 3599 3600void 3601Tcl_DbIncrRefCount( 3602 register Tcl_Obj *objPtr, /* The object we are registering a reference 3603 * to. */ 3604 CONST char *file, /* The name of the source file calling this 3605 * function; used for debugging. */ 3606 int line) /* Line number in the source file; used for 3607 * debugging. */ 3608{ 3609#ifdef TCL_MEM_DEBUG 3610 if (objPtr->refCount == 0x61616161) { 3611 fprintf(stderr, "file = %s, line = %d\n", file, line); 3612 fflush(stderr); 3613 Tcl_Panic("incrementing refCount of previously disposed object"); 3614 } 3615 3616# ifdef TCL_THREADS 3617 /* 3618 * Check to make sure that the Tcl_Obj was allocated by the current 3619 * thread. Don't do this check when shutting down since thread local 3620 * storage can be finalized before the last Tcl_Obj is freed. 3621 */ 3622 3623 if (!TclInExit()) { 3624 Tcl_HashTable *tablePtr; 3625 Tcl_HashEntry *hPtr; 3626 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 3627 3628 tablePtr = tsdPtr->objThreadMap; 3629 if (!tablePtr) { 3630 Tcl_Panic("object table not initialized"); 3631 } 3632 hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); 3633 if (!hPtr) { 3634 Tcl_Panic("%s%s", 3635 "Trying to incr ref count of " 3636 "Tcl_Obj allocated in another thread"); 3637 } 3638 } 3639# endif 3640#endif 3641 ++(objPtr)->refCount; 3642} 3643 3644/* 3645 *---------------------------------------------------------------------- 3646 * 3647 * Tcl_DbDecrRefCount -- 3648 * 3649 * This function is normally called when debugging: i.e., when 3650 * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory 3651 * has been freed before decrementing the ref count. 3652 * 3653 * When TCL_MEM_DEBUG is not defined, this function just decrements the 3654 * reference count of the object. 3655 * 3656 * Results: 3657 * None. 3658 * 3659 * Side effects: 3660 * The object's ref count is incremented. 3661 * 3662 *---------------------------------------------------------------------- 3663 */ 3664 3665void 3666Tcl_DbDecrRefCount( 3667 register Tcl_Obj *objPtr, /* The object we are releasing a reference 3668 * to. */ 3669 CONST char *file, /* The name of the source file calling this 3670 * function; used for debugging. */ 3671 int line) /* Line number in the source file; used for 3672 * debugging. */ 3673{ 3674#ifdef TCL_MEM_DEBUG 3675 if (objPtr->refCount == 0x61616161) { 3676 fprintf(stderr, "file = %s, line = %d\n", file, line); 3677 fflush(stderr); 3678 Tcl_Panic("decrementing refCount of previously disposed object"); 3679 } 3680 3681# ifdef TCL_THREADS 3682 /* 3683 * Check to make sure that the Tcl_Obj was allocated by the current 3684 * thread. Don't do this check when shutting down since thread local 3685 * storage can be finalized before the last Tcl_Obj is freed. 3686 */ 3687 3688 if (!TclInExit()) { 3689 Tcl_HashTable *tablePtr; 3690 Tcl_HashEntry *hPtr; 3691 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 3692 3693 tablePtr = tsdPtr->objThreadMap; 3694 if (!tablePtr) { 3695 Tcl_Panic("object table not initialized"); 3696 } 3697 hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); 3698 if (!hPtr) { 3699 Tcl_Panic("%s%s", 3700 "Trying to decr ref count of " 3701 "Tcl_Obj allocated in another thread"); 3702 } 3703 3704 /* 3705 * If the Tcl_Obj is going to be deleted, remove the entry. 3706 */ 3707 3708 if ((objPtr->refCount - 1) <= 0) { 3709 ObjData *objData = Tcl_GetHashValue(hPtr); 3710 3711 if (objData != NULL) { 3712 ckfree((char *) objData); 3713 } 3714 3715 Tcl_DeleteHashEntry(hPtr); 3716 } 3717 } 3718# endif 3719#endif 3720 if (--(objPtr)->refCount <= 0) { 3721 TclFreeObj(objPtr); 3722 } 3723} 3724 3725/* 3726 *---------------------------------------------------------------------- 3727 * 3728 * Tcl_DbIsShared -- 3729 * 3730 * This function is normally called when debugging: i.e., when 3731 * TCL_MEM_DEBUG is defined. It tests whether the object has a ref count 3732 * greater than one. 3733 * 3734 * When TCL_MEM_DEBUG is not defined, this function just tests if the 3735 * object has a ref count greater than one. 3736 * 3737 * Results: 3738 * None. 3739 * 3740 * Side effects: 3741 * None. 3742 * 3743 *---------------------------------------------------------------------- 3744 */ 3745 3746int 3747Tcl_DbIsShared( 3748 register Tcl_Obj *objPtr, /* The object to test for being shared. */ 3749 CONST char *file, /* The name of the source file calling this 3750 * function; used for debugging. */ 3751 int line) /* Line number in the source file; used for 3752 * debugging. */ 3753{ 3754#ifdef TCL_MEM_DEBUG 3755 if (objPtr->refCount == 0x61616161) { 3756 fprintf(stderr, "file = %s, line = %d\n", file, line); 3757 fflush(stderr); 3758 Tcl_Panic("checking whether previously disposed object is shared"); 3759 } 3760 3761# ifdef TCL_THREADS 3762 /* 3763 * Check to make sure that the Tcl_Obj was allocated by the current 3764 * thread. Don't do this check when shutting down since thread local 3765 * storage can be finalized before the last Tcl_Obj is freed. 3766 */ 3767 3768 if (!TclInExit()) { 3769 Tcl_HashTable *tablePtr; 3770 Tcl_HashEntry *hPtr; 3771 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 3772 tablePtr = tsdPtr->objThreadMap; 3773 if (!tablePtr) { 3774 Tcl_Panic("object table not initialized"); 3775 } 3776 hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); 3777 if (!hPtr) { 3778 Tcl_Panic("%s%s", 3779 "Trying to check shared status of" 3780 "Tcl_Obj allocated in another thread"); 3781 } 3782 } 3783# endif 3784#endif 3785 3786#ifdef TCL_COMPILE_STATS 3787 Tcl_MutexLock(&tclObjMutex); 3788 if ((objPtr)->refCount <= 1) { 3789 tclObjsShared[1]++; 3790 } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { 3791 tclObjsShared[(objPtr)->refCount]++; 3792 } else { 3793 tclObjsShared[0]++; 3794 } 3795 Tcl_MutexUnlock(&tclObjMutex); 3796#endif 3797 3798 return ((objPtr)->refCount > 1); 3799} 3800 3801/* 3802 *---------------------------------------------------------------------- 3803 * 3804 * Tcl_InitObjHashTable -- 3805 * 3806 * Given storage for a hash table, set up the fields to prepare the hash 3807 * table for use, the keys are Tcl_Obj *. 3808 * 3809 * Results: 3810 * None. 3811 * 3812 * Side effects: 3813 * TablePtr is now ready to be passed to Tcl_FindHashEntry and 3814 * Tcl_CreateHashEntry. 3815 * 3816 *---------------------------------------------------------------------- 3817 */ 3818 3819void 3820Tcl_InitObjHashTable( 3821 register Tcl_HashTable *tablePtr) 3822 /* Pointer to table record, which is supplied 3823 * by the caller. */ 3824{ 3825 Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, 3826 &tclObjHashKeyType); 3827} 3828 3829/* 3830 *---------------------------------------------------------------------- 3831 * 3832 * AllocObjEntry -- 3833 * 3834 * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key. 3835 * 3836 * Results: 3837 * The return value is a pointer to the created entry. 3838 * 3839 * Side effects: 3840 * Increments the reference count on the object. 3841 * 3842 *---------------------------------------------------------------------- 3843 */ 3844 3845static Tcl_HashEntry * 3846AllocObjEntry( 3847 Tcl_HashTable *tablePtr, /* Hash table. */ 3848 void *keyPtr) /* Key to store in the hash table entry. */ 3849{ 3850 Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; 3851 Tcl_HashEntry *hPtr; 3852 3853 hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); 3854 hPtr->key.oneWordValue = (char *) objPtr; 3855 Tcl_IncrRefCount(objPtr); 3856 hPtr->clientData = NULL; 3857 3858 return hPtr; 3859} 3860 3861/* 3862 *---------------------------------------------------------------------- 3863 * 3864 * TclCompareObjKeys -- 3865 * 3866 * Compares two Tcl_Obj * keys. 3867 * 3868 * Results: 3869 * The return value is 0 if they are different and 1 if they are the 3870 * same. 3871 * 3872 * Side effects: 3873 * None. 3874 * 3875 *---------------------------------------------------------------------- 3876 */ 3877 3878int 3879TclCompareObjKeys( 3880 void *keyPtr, /* New key to compare. */ 3881 Tcl_HashEntry *hPtr) /* Existing key to compare. */ 3882{ 3883 Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; 3884 Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; 3885 register CONST char *p1, *p2; 3886 register int l1, l2; 3887 3888 /* 3889 * If the object pointers are the same then they match. 3890 */ 3891 3892 if (objPtr1 == objPtr2) { 3893 return 1; 3894 } 3895 3896 /* 3897 * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being 3898 * in a register. 3899 */ 3900 3901 p1 = TclGetString(objPtr1); 3902 l1 = objPtr1->length; 3903 p2 = TclGetString(objPtr2); 3904 l2 = objPtr2->length; 3905 3906 /* 3907 * Only compare if the string representations are of the same length. 3908 */ 3909 3910 if (l1 == l2) { 3911 for (;; p1++, p2++, l1--) { 3912 if (*p1 != *p2) { 3913 break; 3914 } 3915 if (l1 == 0) { 3916 return 1; 3917 } 3918 } 3919 } 3920 3921 return 0; 3922} 3923 3924/* 3925 *---------------------------------------------------------------------- 3926 * 3927 * TclFreeObjEntry -- 3928 * 3929 * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. 3930 * 3931 * Results: 3932 * The return value is a pointer to the created entry. 3933 * 3934 * Side effects: 3935 * Decrements the reference count of the object. 3936 * 3937 *---------------------------------------------------------------------- 3938 */ 3939 3940void 3941TclFreeObjEntry( 3942 Tcl_HashEntry *hPtr) /* Hash entry to free. */ 3943{ 3944 Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; 3945 3946 Tcl_DecrRefCount(objPtr); 3947 ckfree((char *) hPtr); 3948} 3949 3950/* 3951 *---------------------------------------------------------------------- 3952 * 3953 * TclHashObjKey -- 3954 * 3955 * Compute a one-word summary of the string representation of the 3956 * Tcl_Obj, which can be used to generate a hash index. 3957 * 3958 * Results: 3959 * The return value is a one-word summary of the information in the 3960 * string representation of the Tcl_Obj. 3961 * 3962 * Side effects: 3963 * None. 3964 * 3965 *---------------------------------------------------------------------- 3966 */ 3967 3968unsigned int 3969TclHashObjKey( 3970 Tcl_HashTable *tablePtr, /* Hash table. */ 3971 void *keyPtr) /* Key from which to compute hash value. */ 3972{ 3973 Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; 3974 CONST char *string = TclGetString(objPtr); 3975 int length = objPtr->length; 3976 unsigned int result = 0; 3977 int i; 3978 3979 /* 3980 * I tried a zillion different hash functions and asked many other people 3981 * for advice. Many people had their own favorite functions, all 3982 * different, but no-one had much idea why they were good ones. I chose 3983 * the one below (multiply by 9 and add new character) because of the 3984 * following reasons: 3985 * 3986 * 1. Multiplying by 10 is perfect for keys that are decimal strings, and 3987 * multiplying by 9 is just about as good. 3988 * 2. Times-9 is (shift-left-3) plus (old). This means that each 3989 * character's bits hang around in the low-order bits of the hash value 3990 * for ever, plus they spread fairly rapidly up to the high-order bits 3991 * to fill out the hash value. This seems works well both for decimal 3992 * and *non-decimal strings. 3993 */ 3994 3995 for (i=0 ; i<length ; i++) { 3996 result += (result << 3) + string[i]; 3997 } 3998 return result; 3999} 4000 4001/* 4002 *---------------------------------------------------------------------- 4003 * 4004 * Tcl_GetCommandFromObj -- 4005 * 4006 * Returns the command specified by the name in a Tcl_Obj. 4007 * 4008 * Results: 4009 * Returns a token for the command if it is found. Otherwise, if it can't 4010 * be found or there is an error, returns NULL. 4011 * 4012 * Side effects: 4013 * May update the internal representation for the object, caching the 4014 * command reference so that the next time this function is called with 4015 * the same object, the command can be found quickly. 4016 * 4017 *---------------------------------------------------------------------- 4018 */ 4019 4020Tcl_Command 4021Tcl_GetCommandFromObj( 4022 Tcl_Interp *interp, /* The interpreter in which to resolve the 4023 * command and to report errors. */ 4024 register Tcl_Obj *objPtr) /* The object containing the command's name. 4025 * If the name starts with "::", will be 4026 * looked up in global namespace. Else, looked 4027 * up first in the current namespace, then in 4028 * global namespace. */ 4029{ 4030 register ResolvedCmdName *resPtr; 4031 register Command *cmdPtr; 4032 Namespace *refNsPtr; 4033 int result; 4034 4035 /* 4036 * Get the internal representation, converting to a command type if 4037 * needed. The internal representation is a ResolvedCmdName that points to 4038 * the actual command. 4039 * 4040 * Check the context namespace and the namespace epoch of the resolved 4041 * symbol to make sure that it is fresh. Note that we verify that the 4042 * namespace id of the context namespace is the same as the one we cached; 4043 * this insures that the namespace wasn't deleted and a new one created at 4044 * the same address with the same command epoch. Note that fully qualified 4045 * names have a NULL refNsPtr, these checks needn't be made. 4046 * 4047 * Check also that the command's epoch is up to date, and that the command 4048 * is not deleted. 4049 * 4050 * If any check fails, then force another conversion to the command type, 4051 * to discard the old rep and create a new one. 4052 */ 4053 4054 resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; 4055 if ((objPtr->typePtr != &tclCmdNameType) 4056 || (resPtr == NULL) 4057 || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) 4058 || (cmdPtr->flags & CMD_IS_DELETED) 4059 || (interp != cmdPtr->nsPtr->interp) 4060 || (cmdPtr->nsPtr->flags & NS_DYING) 4061 || ((resPtr->refNsPtr != NULL) && 4062 (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp)) 4063 != resPtr->refNsPtr) 4064 || (resPtr->refNsId != refNsPtr->nsId) 4065 || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch))) 4066 ) { 4067 4068 result = tclCmdNameType.setFromAnyProc(interp, objPtr); 4069 4070 resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; 4071 if ((result == TCL_OK) && resPtr) { 4072 cmdPtr = resPtr->cmdPtr; 4073 } else { 4074 cmdPtr = NULL; 4075 } 4076 } 4077 4078 return (Tcl_Command) cmdPtr; 4079} 4080 4081/* 4082 *---------------------------------------------------------------------- 4083 * 4084 * TclSetCmdNameObj -- 4085 * 4086 * Modify an object to be an CmdName object that refers to the argument 4087 * Command structure. 4088 * 4089 * Results: 4090 * None. 4091 * 4092 * Side effects: 4093 * The object's old internal rep is freed. It's string rep is not 4094 * changed. The refcount in the Command structure is incremented to keep 4095 * it from being freed if the command is later deleted until 4096 * TclExecuteByteCode has a chance to recognize that it was deleted. 4097 * 4098 *---------------------------------------------------------------------- 4099 */ 4100 4101void 4102TclSetCmdNameObj( 4103 Tcl_Interp *interp, /* Points to interpreter containing command 4104 * that should be cached in objPtr. */ 4105 register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a 4106 * CmdName object. */ 4107 Command *cmdPtr) /* Points to Command structure that the 4108 * CmdName object should refer to. */ 4109{ 4110 Interp *iPtr = (Interp *) interp; 4111 register ResolvedCmdName *resPtr; 4112 register Namespace *currNsPtr; 4113 char *name; 4114 4115 if (objPtr->typePtr == &tclCmdNameType) { 4116 return; 4117 } 4118 4119 cmdPtr->refCount++; 4120 resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); 4121 resPtr->cmdPtr = cmdPtr; 4122 resPtr->cmdEpoch = cmdPtr->cmdEpoch; 4123 resPtr->refCount = 1; 4124 4125 name = TclGetString(objPtr); 4126 if ((*name++ == ':') && (*name == ':')) { 4127 /* 4128 * The name is fully qualified: set the referring namespace to 4129 * NULL. 4130 */ 4131 4132 resPtr->refNsPtr = NULL; 4133 } else { 4134 /* 4135 * Get the current namespace. 4136 */ 4137 4138 currNsPtr = iPtr->varFramePtr->nsPtr; 4139 4140 resPtr->refNsPtr = currNsPtr; 4141 resPtr->refNsId = currNsPtr->nsId; 4142 resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; 4143 } 4144 4145 TclFreeIntRep(objPtr); 4146 objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; 4147 objPtr->internalRep.twoPtrValue.ptr2 = NULL; 4148 objPtr->typePtr = &tclCmdNameType; 4149} 4150 4151/* 4152 *---------------------------------------------------------------------- 4153 * 4154 * FreeCmdNameInternalRep -- 4155 * 4156 * Frees the resources associated with a cmdName object's internal 4157 * representation. 4158 * 4159 * Results: 4160 * None. 4161 * 4162 * Side effects: 4163 * Decrements the ref count of any cached ResolvedCmdName structure 4164 * pointed to by the cmdName's internal representation. If this is the 4165 * last use of the ResolvedCmdName, it is freed. This in turn decrements 4166 * the ref count of the Command structure pointed to by the 4167 * ResolvedSymbol, which may free the Command structure. 4168 * 4169 *---------------------------------------------------------------------- 4170 */ 4171 4172static void 4173FreeCmdNameInternalRep( 4174 register Tcl_Obj *objPtr) /* CmdName object with internal 4175 * representation to free. */ 4176{ 4177 register ResolvedCmdName *resPtr = 4178 (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; 4179 4180 if (resPtr != NULL) { 4181 /* 4182 * Decrement the reference count of the ResolvedCmdName structure. If 4183 * there are no more uses, free the ResolvedCmdName structure. 4184 */ 4185 4186 resPtr->refCount--; 4187 if (resPtr->refCount == 0) { 4188 /* 4189 * Now free the cached command, unless it is still in its hash 4190 * table or if there are other references to it from other cmdName 4191 * objects. 4192 */ 4193 4194 Command *cmdPtr = resPtr->cmdPtr; 4195 TclCleanupCommandMacro(cmdPtr); 4196 ckfree((char *) resPtr); 4197 } 4198 } 4199} 4200 4201/* 4202 *---------------------------------------------------------------------- 4203 * 4204 * DupCmdNameInternalRep -- 4205 * 4206 * Initialize the internal representation of an cmdName Tcl_Obj to a copy 4207 * of the internal representation of an existing cmdName object. 4208 * 4209 * Results: 4210 * None. 4211 * 4212 * Side effects: 4213 * "copyPtr"s internal rep is set to point to the ResolvedCmdName 4214 * structure corresponding to "srcPtr"s internal rep. Increments the ref 4215 * count of the ResolvedCmdName structure pointed to by the cmdName's 4216 * internal representation. 4217 * 4218 *---------------------------------------------------------------------- 4219 */ 4220 4221static void 4222DupCmdNameInternalRep( 4223 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ 4224 register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ 4225{ 4226 register ResolvedCmdName *resPtr = (ResolvedCmdName *) 4227 srcPtr->internalRep.twoPtrValue.ptr1; 4228 4229 copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; 4230 copyPtr->internalRep.twoPtrValue.ptr2 = NULL; 4231 if (resPtr != NULL) { 4232 resPtr->refCount++; 4233 } 4234 copyPtr->typePtr = &tclCmdNameType; 4235} 4236 4237/* 4238 *---------------------------------------------------------------------- 4239 * 4240 * SetCmdNameFromAny -- 4241 * 4242 * Generate an cmdName internal form for the Tcl object "objPtr". 4243 * 4244 * Results: 4245 * The return value is a standard Tcl result. The conversion always 4246 * succeeds and TCL_OK is returned. 4247 * 4248 * Side effects: 4249 * A pointer to a ResolvedCmdName structure that holds a cached pointer 4250 * to the command with a name that matches objPtr's string rep is stored 4251 * as objPtr's internal representation. This ResolvedCmdName pointer will 4252 * be NULL if no matching command was found. The ref count of the cached 4253 * Command's structure (if any) is also incremented. 4254 * 4255 *---------------------------------------------------------------------- 4256 */ 4257 4258static int 4259SetCmdNameFromAny( 4260 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 4261 register Tcl_Obj *objPtr) /* The object to convert. */ 4262{ 4263 Interp *iPtr = (Interp *) interp; 4264 char *name; 4265 register Command *cmdPtr; 4266 Namespace *currNsPtr; 4267 register ResolvedCmdName *resPtr; 4268 4269 /* 4270 * Find the Command structure, if any, that describes the command called 4271 * "name". Build a ResolvedCmdName that holds a cached pointer to this 4272 * Command, and bump the reference count in the referenced Command 4273 * structure. A Command structure will not be deleted as long as it is 4274 * referenced from a CmdName object. 4275 */ 4276 4277 name = TclGetString(objPtr); 4278 cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); 4279 4280 /* 4281 * Free the old internalRep before setting the new one. Do this after 4282 * getting the string rep to allow the conversion code (in particular, 4283 * Tcl_GetStringFromObj) to use that old internalRep. 4284 */ 4285 4286 if (cmdPtr) { 4287 cmdPtr->refCount++; 4288 resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; 4289 if ((objPtr->typePtr == &tclCmdNameType) 4290 && resPtr && (resPtr->refCount == 1)) { 4291 /* 4292 * Reuse the old ResolvedCmdName struct instead of freeing it 4293 */ 4294 4295 Command *oldCmdPtr = resPtr->cmdPtr; 4296 if (--oldCmdPtr->refCount == 0) { 4297 TclCleanupCommandMacro(oldCmdPtr); 4298 } 4299 } else { 4300 TclFreeIntRep(objPtr); 4301 resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); 4302 resPtr->refCount = 1; 4303 objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; 4304 objPtr->internalRep.twoPtrValue.ptr2 = NULL; 4305 objPtr->typePtr = &tclCmdNameType; 4306 } 4307 resPtr->cmdPtr = cmdPtr; 4308 resPtr->cmdEpoch = cmdPtr->cmdEpoch; 4309 if ((*name++ == ':') && (*name == ':')) { 4310 /* 4311 * The name is fully qualified: set the referring namespace to 4312 * NULL. 4313 */ 4314 4315 resPtr->refNsPtr = NULL; 4316 } else { 4317 /* 4318 * Get the current namespace. 4319 */ 4320 4321 currNsPtr = iPtr->varFramePtr->nsPtr; 4322 4323 resPtr->refNsPtr = currNsPtr; 4324 resPtr->refNsId = currNsPtr->nsId; 4325 resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; 4326 } 4327 } else { 4328 TclFreeIntRep(objPtr); 4329 objPtr->internalRep.twoPtrValue.ptr1 = NULL; 4330 objPtr->internalRep.twoPtrValue.ptr2 = NULL; 4331 objPtr->typePtr = &tclCmdNameType; 4332 } 4333 return TCL_OK; 4334} 4335 4336/* 4337 * Local Variables: 4338 * mode: c 4339 * c-basic-offset: 4 4340 * fill-column: 78 4341 * End: 4342 */ 4343