Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclObj.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

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