Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclObj.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclObj.c --
sl@0	3	*
sl@0	4	* This file contains Tcl object-related procedures that are used by
sl@0	5	* many Tcl commands.
sl@0	6	*
sl@0	7	* Copyright (c) 1995-1997 Sun Microsystems, Inc.
sl@0	8	* Copyright (c) 1999 by Scriptics Corporation.
sl@0	9	* Copyright (c) 2001 by ActiveState Corporation.
sl@0	10	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	11	*
sl@0	12	* See the file "license.terms" for information on usage and redistribution
sl@0	13	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	14	*
sl@0	15	* RCS: @(#) $Id: tclObj.c,v 1.42.2.14 2005/11/29 14:02:04 dkf Exp $
sl@0	16	*/
sl@0	17
sl@0	18	#include "tclInt.h"
sl@0	19	#include "tclCompile.h"
sl@0	20	#include "tclPort.h"
sl@0	21	#if defined(__SYMBIAN32__)
sl@0	22	#include "tclSymbianGlobals.h"
sl@0	23	#endif
sl@0	24
sl@0	25	/*
sl@0	26	* Table of all object types.
sl@0	27	*/
sl@0	28	#if !defined(__SYMBIAN32__) \|\| !defined(__WINSCW__)
sl@0	29	static Tcl_HashTable typeTable;
sl@0	30	static int typeTableInitialized = 0; /* 0 means not yet initialized. */
sl@0	31	#endif
sl@0	32	TCL_DECLARE_MUTEX(tableMutex)
sl@0	33
sl@0	34	/*
sl@0	35	* Head of the list of free Tcl_Obj structs we maintain.
sl@0	36	*/
sl@0	37
sl@0	38	Tcl_Obj *tclFreeObjList = NULL;
sl@0	39
sl@0	40	/*
sl@0	41	* The object allocator is single threaded. This mutex is referenced
sl@0	42	* by the TclNewObj macro, however, so must be visible.
sl@0	43	*/
sl@0	44
sl@0	45	#ifdef TCL_THREADS
sl@0	46	Tcl_Mutex tclObjMutex;
sl@0	47	#endif
sl@0	48
sl@0	49	/*
sl@0	50	* Pointer to a heap-allocated string of length zero that the Tcl core uses
sl@0	51	* as the value of an empty string representation for an object. This value
sl@0	52	* is shared by all new objects allocated by Tcl_NewObj.
sl@0	53	*/
sl@0	54
sl@0	55	char tclEmptyString = '\0';
sl@0	56	char *tclEmptyStringRep = &tclEmptyString;
sl@0	57
sl@0	58	/*
sl@0	59	* Prototypes for procedures defined later in this file:
sl@0	60	*/
sl@0	61
sl@0	62	static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	63	Tcl_Obj *objPtr));
sl@0	64	static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	65	Tcl_Obj *objPtr));
sl@0	66	static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	67	Tcl_Obj *objPtr));
sl@0	68	static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
sl@0	69	Tcl_Obj *objPtr));
sl@0	70	static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	71	static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	72	static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	73	static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	74	Tcl_Obj *objPtr));
sl@0	75
sl@0	76	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	77	static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	78	#endif
sl@0	79
sl@0	80	/*
sl@0	81	* Prototypes for the array hash key methods.
sl@0	82	*/
sl@0	83
sl@0	84	static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_((
sl@0	85	Tcl_HashTable tablePtr, VOID keyPtr));
sl@0	86	static int CompareObjKeys _ANSI_ARGS_((
sl@0	87	VOID keyPtr, Tcl_HashEntry hPtr));
sl@0	88	static void FreeObjEntry _ANSI_ARGS_((
sl@0	89	Tcl_HashEntry *hPtr));
sl@0	90	static unsigned int HashObjKey _ANSI_ARGS_((
sl@0	91	Tcl_HashTable *tablePtr,
sl@0	92	VOID *keyPtr));
sl@0	93
sl@0	94	/*
sl@0	95	* Prototypes for the CommandName object type.
sl@0	96	*/
sl@0	97
sl@0	98	static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
sl@0	99	Tcl_Obj *copyPtr));
sl@0	100	static void FreeCmdNameInternalRep _ANSI_ARGS_((
sl@0	101	Tcl_Obj *objPtr));
sl@0	102	static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	103	Tcl_Obj *objPtr));
sl@0	104
sl@0	105
sl@0	106	/*
sl@0	107	* The structures below defines the Tcl object types defined in this file by
sl@0	108	* means of procedures that can be invoked by generic object code. See also
sl@0	109	* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
sl@0	110	* implementations.
sl@0	111	*/
sl@0	112
sl@0	113	Tcl_ObjType tclBooleanType = {
sl@0	114	"boolean", /* name */
sl@0	115	(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
sl@0	116	(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
sl@0	117	UpdateStringOfBoolean, /* updateStringProc */
sl@0	118	SetBooleanFromAny /* setFromAnyProc */
sl@0	119	};
sl@0	120
sl@0	121	Tcl_ObjType tclDoubleType = {
sl@0	122	"double", /* name */
sl@0	123	(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
sl@0	124	(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
sl@0	125	UpdateStringOfDouble, /* updateStringProc */
sl@0	126	SetDoubleFromAny /* setFromAnyProc */
sl@0	127	};
sl@0	128
sl@0	129	Tcl_ObjType tclIntType = {
sl@0	130	"int", /* name */
sl@0	131	(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
sl@0	132	(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
sl@0	133	UpdateStringOfInt, /* updateStringProc */
sl@0	134	SetIntFromAny /* setFromAnyProc */
sl@0	135	};
sl@0	136
sl@0	137	Tcl_ObjType tclWideIntType = {
sl@0	138	"wideInt", /* name */
sl@0	139	(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
sl@0	140	(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
sl@0	141	#ifdef TCL_WIDE_INT_IS_LONG
sl@0	142	UpdateStringOfInt, /* updateStringProc */
sl@0	143	#else /* !TCL_WIDE_INT_IS_LONG */
sl@0	144	UpdateStringOfWideInt, /* updateStringProc */
sl@0	145	#endif
sl@0	146	SetWideIntFromAny /* setFromAnyProc */
sl@0	147	};
sl@0	148
sl@0	149	/*
sl@0	150	* The structure below defines the Tcl obj hash key type.
sl@0	151	*/
sl@0	152	Tcl_HashKeyType tclObjHashKeyType = {
sl@0	153	TCL_HASH_KEY_TYPE_VERSION, /* version */
sl@0	154	0, /* flags */
sl@0	155	HashObjKey, /* hashKeyProc */
sl@0	156	CompareObjKeys, /* compareKeysProc */
sl@0	157	AllocObjEntry, /* allocEntryProc */
sl@0	158	FreeObjEntry /* freeEntryProc */
sl@0	159	};
sl@0	160
sl@0	161	/*
sl@0	162	* The structure below defines the command name Tcl object type by means of
sl@0	163	* procedures that can be invoked by generic object code. Objects of this
sl@0	164	* type cache the Command pointer that results from looking up command names
sl@0	165	* in the command hashtable. Such objects appear as the zeroth ("command
sl@0	166	* name") argument in a Tcl command.
sl@0	167	*
sl@0	168	* NOTE: the ResolvedCmdName that gets cached is stored in the
sl@0	169	* twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.
sl@0	170	* You might think you could use the simpler otherValuePtr field to
sl@0	171	* store the single ResolvedCmdName pointer, but DO NOT DO THIS. It
sl@0	172	* seems that some extensions use the second internal pointer field
sl@0	173	* of the twoPtrValue field for their own purposes.
sl@0	174	*/
sl@0	175
sl@0	176	static Tcl_ObjType tclCmdNameType = {
sl@0	177	"cmdName", /* name */
sl@0	178	FreeCmdNameInternalRep, /* freeIntRepProc */
sl@0	179	DupCmdNameInternalRep, /* dupIntRepProc */
sl@0	180	(Tcl_UpdateStringProc ) NULL, / updateStringProc */
sl@0	181	SetCmdNameFromAny /* setFromAnyProc */
sl@0	182	};
sl@0	183
sl@0	184
sl@0	185	/*
sl@0	186	* Structure containing a cached pointer to a command that is the result
sl@0	187	* of resolving the command's name in some namespace. It is the internal
sl@0	188	* representation for a cmdName object. It contains the pointer along
sl@0	189	* with some information that is used to check the pointer's validity.
sl@0	190	*/
sl@0	191
sl@0	192	typedef struct ResolvedCmdName {
sl@0	193	Command cmdPtr; / A cached Command pointer. */
sl@0	194	Namespace refNsPtr; / Points to the namespace containing the
sl@0	195	* reference (not the namespace that
sl@0	196	* contains the referenced command). */
sl@0	197	long refNsId; /* refNsPtr's unique namespace id. Used to
sl@0	198	* verify that refNsPtr is still valid
sl@0	199	* (e.g., it's possible that the cmd's
sl@0	200	* containing namespace was deleted and a
sl@0	201	* new one created at the same address). */
sl@0	202	int refNsCmdEpoch; /* Value of the referencing namespace's
sl@0	203	* cmdRefEpoch when the pointer was cached.
sl@0	204	* Before using the cached pointer, we check
sl@0	205	* if the namespace's epoch was incremented;
sl@0	206	* if so, this cached pointer is invalid. */
sl@0	207	int cmdEpoch; /* Value of the command's cmdEpoch when this
sl@0	208	* pointer was cached. Before using the
sl@0	209	* cached pointer, we check if the cmd's
sl@0	210	* epoch was incremented; if so, the cmd was
sl@0	211	* renamed, deleted, hidden, or exposed, and
sl@0	212	* so the pointer is invalid. */
sl@0	213	int refCount; /* Reference count: 1 for each cmdName
sl@0	214	* object that has a pointer to this
sl@0	215	* ResolvedCmdName structure as its internal
sl@0	216	* rep. This structure can be freed when
sl@0	217	* refCount becomes zero. */
sl@0	218	} ResolvedCmdName;
sl@0	219
sl@0	220
sl@0	221	/*
sl@0	222	*-------------------------------------------------------------------------
sl@0	223	*
sl@0	224	* TclInitObjectSubsystem --
sl@0	225	*
sl@0	226	* This procedure is invoked to perform once-only initialization of
sl@0	227	* the type table. It also registers the object types defined in
sl@0	228	* this file.
sl@0	229	*
sl@0	230	* Results:
sl@0	231	* None.
sl@0	232	*
sl@0	233	* Side effects:
sl@0	234	* Initializes the table of defined object types "typeTable" with
sl@0	235	* builtin object types defined in this file.
sl@0	236	*
sl@0	237	*-------------------------------------------------------------------------
sl@0	238	*/
sl@0	239
sl@0	240	void
sl@0	241	TclInitObjSubsystem()
sl@0	242	{
sl@0	243	Tcl_MutexLock(&tableMutex);
sl@0	244	typeTableInitialized = 1;
sl@0	245	Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
sl@0	246	Tcl_MutexUnlock(&tableMutex);
sl@0	247
sl@0	248	Tcl_RegisterObjType(&tclBooleanType);
sl@0	249	Tcl_RegisterObjType(&tclByteArrayType);
sl@0	250	Tcl_RegisterObjType(&tclDoubleType);
sl@0	251	Tcl_RegisterObjType(&tclEndOffsetType);
sl@0	252	Tcl_RegisterObjType(&tclIntType);
sl@0	253	Tcl_RegisterObjType(&tclWideIntType);
sl@0	254	Tcl_RegisterObjType(&tclStringType);
sl@0	255	Tcl_RegisterObjType(&tclListType);
sl@0	256	Tcl_RegisterObjType(&tclByteCodeType);
sl@0	257	Tcl_RegisterObjType(&tclProcBodyType);
sl@0	258	Tcl_RegisterObjType(&tclArraySearchType);
sl@0	259	Tcl_RegisterObjType(&tclIndexType);
sl@0	260	Tcl_RegisterObjType(&tclNsNameType);
sl@0	261	Tcl_RegisterObjType(&tclCmdNameType);
sl@0	262
sl@0	263	#ifdef TCL_COMPILE_STATS
sl@0	264	Tcl_MutexLock(&tclObjMutex);
sl@0	265	tclObjsAlloced = 0;
sl@0	266	tclObjsFreed = 0;
sl@0	267	{
sl@0	268	int i;
sl@0	269	for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
sl@0	270	tclObjsShared[i] = 0;
sl@0	271	}
sl@0	272	}
sl@0	273	Tcl_MutexUnlock(&tclObjMutex);
sl@0	274	#endif
sl@0	275	}
sl@0	276
sl@0	277	/*
sl@0	278	*----------------------------------------------------------------------
sl@0	279	*
sl@0	280	* TclFinalizeObjects --
sl@0	281	*
sl@0	282	* This procedure is called by Tcl_Finalize to clean up all
sl@0	283	* registered Tcl_ObjType's and to reset the tclFreeObjList.
sl@0	284	*
sl@0	285	* Results:
sl@0	286	* None.
sl@0	287	*
sl@0	288	* Side effects:
sl@0	289	* None.
sl@0	290	*
sl@0	291	*----------------------------------------------------------------------
sl@0	292	*/
sl@0	293
sl@0	294	void
sl@0	295	TclFinalizeObjects()
sl@0	296	{
sl@0	297	Tcl_MutexLock(&tableMutex);
sl@0	298	if (typeTableInitialized) {
sl@0	299	Tcl_DeleteHashTable(&typeTable);
sl@0	300	typeTableInitialized = 0;
sl@0	301	}
sl@0	302	Tcl_MutexUnlock(&tableMutex);
sl@0	303
sl@0	304	/*
sl@0	305	* All we do here is reset the head pointer of the linked list of
sl@0	306	* free Tcl_Obj's to NULL; the memory finalization will take care
sl@0	307	* of releasing memory for us.
sl@0	308	*/
sl@0	309	Tcl_MutexLock(&tclObjMutex);
sl@0	310	tclFreeObjList = NULL;
sl@0	311	Tcl_MutexUnlock(&tclObjMutex);
sl@0	312	}
sl@0	313
sl@0	314	/*
sl@0	315	*--------------------------------------------------------------
sl@0	316	*
sl@0	317	* Tcl_RegisterObjType --
sl@0	318	*
sl@0	319	* This procedure is called to register a new Tcl object type
sl@0	320	* in the table of all object types supported by Tcl.
sl@0	321	*
sl@0	322	* Results:
sl@0	323	* None.
sl@0	324	*
sl@0	325	* Side effects:
sl@0	326	* The type is registered in the Tcl type table. If there was already
sl@0	327	* a type with the same name as in typePtr, it is replaced with the
sl@0	328	* new type.
sl@0	329	*
sl@0	330	*--------------------------------------------------------------
sl@0	331	*/
sl@0	332
sl@0	333	EXPORT_C void
sl@0	334	Tcl_RegisterObjType(typePtr)
sl@0	335	Tcl_ObjType typePtr; / Information about object type;
sl@0	336	* storage must be statically
sl@0	337	* allocated (must live forever). */
sl@0	338	{
sl@0	339	int new;
sl@0	340	Tcl_MutexLock(&tableMutex);
sl@0	341	Tcl_SetHashValue(
sl@0	342	Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
sl@0	343	Tcl_MutexUnlock(&tableMutex);
sl@0	344	}
sl@0	345
sl@0	346	/*
sl@0	347	*----------------------------------------------------------------------
sl@0	348	*
sl@0	349	* Tcl_AppendAllObjTypes --
sl@0	350	*
sl@0	351	* This procedure appends onto the argument object the name of each
sl@0	352	* object type as a list element. This includes the builtin object
sl@0	353	* types (e.g. int, list) as well as those added using
sl@0	354	* Tcl_NewObj. These names can be used, for example, with
sl@0	355	* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
sl@0	356	* structures.
sl@0	357	*
sl@0	358	* Results:
sl@0	359	* The return value is normally TCL_OK; in this case the object
sl@0	360	* referenced by objPtr has each type name appended to it. If an
sl@0	361	* error occurs, TCL_ERROR is returned and the interpreter's result
sl@0	362	* holds an error message.
sl@0	363	*
sl@0	364	* Side effects:
sl@0	365	* If necessary, the object referenced by objPtr is converted into
sl@0	366	* a list object.
sl@0	367	*
sl@0	368	*----------------------------------------------------------------------
sl@0	369	*/
sl@0	370
sl@0	371	EXPORT_C int
sl@0	372	Tcl_AppendAllObjTypes(interp, objPtr)
sl@0	373	Tcl_Interp interp; / Interpreter used for error reporting. */
sl@0	374	Tcl_Obj objPtr; / Points to the Tcl object onto which the
sl@0	375	* name of each registered type is appended
sl@0	376	* as a list element. */
sl@0	377	{
sl@0	378	register Tcl_HashEntry *hPtr;
sl@0	379	Tcl_HashSearch search;
sl@0	380	int objc;
sl@0	381	Tcl_Obj **objv;
sl@0	382
sl@0	383	/*
sl@0	384	* Get the test for a valid list out of the way first.
sl@0	385	*/
sl@0	386
sl@0	387	if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
sl@0	388	return TCL_ERROR;
sl@0	389	}
sl@0	390
sl@0	391	/*
sl@0	392	* Type names are NUL-terminated, not counted strings.
sl@0	393	* This code relies on that.
sl@0	394	*/
sl@0	395
sl@0	396	Tcl_MutexLock(&tableMutex);
sl@0	397	for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
sl@0	398	hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
sl@0	399	Tcl_ListObjAppendElement(NULL, objPtr,
sl@0	400	Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
sl@0	401	}
sl@0	402	Tcl_MutexUnlock(&tableMutex);
sl@0	403	return TCL_OK;
sl@0	404	}
sl@0	405
sl@0	406	/*
sl@0	407	*----------------------------------------------------------------------
sl@0	408	*
sl@0	409	* Tcl_GetObjType --
sl@0	410	*
sl@0	411	* This procedure looks up an object type by name.
sl@0	412	*
sl@0	413	* Results:
sl@0	414	* If an object type with name matching "typeName" is found, a pointer
sl@0	415	* to its Tcl_ObjType structure is returned; otherwise, NULL is
sl@0	416	* returned.
sl@0	417	*
sl@0	418	* Side effects:
sl@0	419	* None.
sl@0	420	*
sl@0	421	*----------------------------------------------------------------------
sl@0	422	*/
sl@0	423
sl@0	424	EXPORT_C Tcl_ObjType *
sl@0	425	Tcl_GetObjType(typeName)
sl@0	426	CONST char typeName; / Name of Tcl object type to look up. */
sl@0	427	{
sl@0	428	register Tcl_HashEntry *hPtr;
sl@0	429	Tcl_ObjType *typePtr = NULL;
sl@0	430
sl@0	431	Tcl_MutexLock(&tableMutex);
sl@0	432	hPtr = Tcl_FindHashEntry(&typeTable, typeName);
sl@0	433	if (hPtr != (Tcl_HashEntry *) NULL) {
sl@0	434	typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
sl@0	435	}
sl@0	436	Tcl_MutexUnlock(&tableMutex);
sl@0	437	return typePtr;
sl@0	438	}
sl@0	439
sl@0	440	/*
sl@0	441	*----------------------------------------------------------------------
sl@0	442	*
sl@0	443	* Tcl_ConvertToType --
sl@0	444	*
sl@0	445	* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
sl@0	446	*
sl@0	447	* Results:
sl@0	448	* The return value is TCL_OK on success and TCL_ERROR on failure. If
sl@0	449	* TCL_ERROR is returned, then the interpreter's result contains an
sl@0	450	* error message unless "interp" is NULL. Passing a NULL "interp"
sl@0	451	* allows this procedure to be used as a test whether the conversion
sl@0	452	* could be done (and in fact was done).
sl@0	453	*
sl@0	454	* Side effects:
sl@0	455	* Any internal representation for the old type is freed.
sl@0	456	*
sl@0	457	*----------------------------------------------------------------------
sl@0	458	*/
sl@0	459
sl@0	460	EXPORT_C int
sl@0	461	Tcl_ConvertToType(interp, objPtr, typePtr)
sl@0	462	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	463	Tcl_Obj objPtr; / The object to convert. */
sl@0	464	Tcl_ObjType typePtr; / The target type. */
sl@0	465	{
sl@0	466	if (objPtr->typePtr == typePtr) {
sl@0	467	return TCL_OK;
sl@0	468	}
sl@0	469
sl@0	470	/*
sl@0	471	* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
sl@0	472	* form as appropriate for the target type. This frees the old internal
sl@0	473	* representation.
sl@0	474	*/
sl@0	475
sl@0	476	return typePtr->setFromAnyProc(interp, objPtr);
sl@0	477	}
sl@0	478
sl@0	479	/*
sl@0	480	*----------------------------------------------------------------------
sl@0	481	*
sl@0	482	* Tcl_NewObj --
sl@0	483	*
sl@0	484	* This procedure is normally called when not debugging: i.e., when
sl@0	485	* TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
sl@0	486	* the empty string. These objects have a NULL object type and NULL
sl@0	487	* string representation byte pointer. Type managers call this routine
sl@0	488	* to allocate new objects that they further initialize.
sl@0	489	*
sl@0	490	* When TCL_MEM_DEBUG is defined, this procedure just returns the
sl@0	491	* result of calling the debugging version Tcl_DbNewObj.
sl@0	492	*
sl@0	493	* Results:
sl@0	494	* The result is a newly allocated object that represents the empty
sl@0	495	* string. The new object's typePtr is set NULL and its ref count
sl@0	496	* is set to 0.
sl@0	497	*
sl@0	498	* Side effects:
sl@0	499	* If compiling with TCL_COMPILE_STATS, this procedure increments
sl@0	500	* the global count of allocated objects (tclObjsAlloced).
sl@0	501	*
sl@0	502	*----------------------------------------------------------------------
sl@0	503	*/
sl@0	504
sl@0	505	#ifdef TCL_MEM_DEBUG
sl@0	506	#undef Tcl_NewObj
sl@0	507
sl@0	508	EXPORT_C Tcl_Obj *
sl@0	509	Tcl_NewObj()
sl@0	510	{
sl@0	511	return Tcl_DbNewObj("unknown", 0);
sl@0	512	}
sl@0	513
sl@0	514	#else /* if not TCL_MEM_DEBUG */
sl@0	515
sl@0	516	EXPORT_C Tcl_Obj *
sl@0	517	Tcl_NewObj()
sl@0	518	{
sl@0	519	register Tcl_Obj *objPtr;
sl@0	520
sl@0	521	/*
sl@0	522	* Use the macro defined in tclInt.h - it will use the
sl@0	523	* correct allocator.
sl@0	524	*/
sl@0	525
sl@0	526	TclNewObj(objPtr);
sl@0	527	return objPtr;
sl@0	528	}
sl@0	529	#endif /* TCL_MEM_DEBUG */
sl@0	530
sl@0	531	/*
sl@0	532	*----------------------------------------------------------------------
sl@0	533	*
sl@0	534	* Tcl_DbNewObj --
sl@0	535	*
sl@0	536	* This procedure is normally called when debugging: i.e., when
sl@0	537	* TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
sl@0	538	* empty string. It is the same as the Tcl_NewObj procedure above
sl@0	539	* except that it calls Tcl_DbCkalloc directly with the file name and
sl@0	540	* line number from its caller. This simplifies debugging since then
sl@0	541	* the [memory active] command will report the correct file name and line
sl@0	542	* number when reporting objects that haven't been freed.
sl@0	543	*
sl@0	544	* When TCL_MEM_DEBUG is not defined, this procedure just returns the
sl@0	545	* result of calling Tcl_NewObj.
sl@0	546	*
sl@0	547	* Results:
sl@0	548	* The result is a newly allocated that represents the empty string.
sl@0	549	* The new object's typePtr is set NULL and its ref count is set to 0.
sl@0	550	*
sl@0	551	* Side effects:
sl@0	552	* If compiling with TCL_COMPILE_STATS, this procedure increments
sl@0	553	* the global count of allocated objects (tclObjsAlloced).
sl@0	554	*
sl@0	555	*----------------------------------------------------------------------
sl@0	556	*/
sl@0	557
sl@0	558	#ifdef TCL_MEM_DEBUG
sl@0	559
sl@0	560	EXPORT_C Tcl_Obj *
sl@0	561	Tcl_DbNewObj(file, line)
sl@0	562	register CONST char file; / The name of the source file calling this
sl@0	563	* procedure; used for debugging. */
sl@0	564	register int line; /* Line number in the source file; used
sl@0	565	* for debugging. */
sl@0	566	{
sl@0	567	register Tcl_Obj *objPtr;
sl@0	568
sl@0	569	/*
sl@0	570	* Use the macro defined in tclInt.h - it will use the
sl@0	571	* correct allocator.
sl@0	572	*/
sl@0	573
sl@0	574	TclDbNewObj(objPtr, file, line);
sl@0	575	return objPtr;
sl@0	576	}
sl@0	577	#else /* if not TCL_MEM_DEBUG */
sl@0	578
sl@0	579	EXPORT_C Tcl_Obj *
sl@0	580	Tcl_DbNewObj(file, line)
sl@0	581	CONST char file; / The name of the source file calling this
sl@0	582	* procedure; used for debugging. */
sl@0	583	int line; /* Line number in the source file; used
sl@0	584	* for debugging. */
sl@0	585	{
sl@0	586	return Tcl_NewObj();
sl@0	587	}
sl@0	588	#endif /* TCL_MEM_DEBUG */
sl@0	589
sl@0	590	/*
sl@0	591	*----------------------------------------------------------------------
sl@0	592	*
sl@0	593	* TclAllocateFreeObjects --
sl@0	594	*
sl@0	595	* Procedure to allocate a number of free Tcl_Objs. This is done using
sl@0	596	* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
sl@0	597	*
sl@0	598	* Assumes mutex is held.
sl@0	599	*
sl@0	600	* Results:
sl@0	601	* None.
sl@0	602	*
sl@0	603	* Side effects:
sl@0	604	* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
sl@0	605	* first of a number of free Tcl_Obj's linked together by their
sl@0	606	* internalRep.otherValuePtrs.
sl@0	607	*
sl@0	608	*----------------------------------------------------------------------
sl@0	609	*/
sl@0	610
sl@0	611	#define OBJS_TO_ALLOC_EACH_TIME 100
sl@0	612
sl@0	613	void
sl@0	614	TclAllocateFreeObjects()
sl@0	615	{
sl@0	616	size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
sl@0	617	char *basePtr;
sl@0	618	register Tcl_Obj prevPtr, objPtr;
sl@0	619	register int i;
sl@0	620
sl@0	621	/*
sl@0	622	* This has been noted by Purify to be a potential leak. The problem is
sl@0	623	* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
sl@0	624	* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
sl@0	625	* actually freeing the memory. TclFinalizeObjects() does not ckfree()
sl@0	626	* this memory, but leaves it to Tcl's memory subsystem finalziation to
sl@0	627	* release it. Purify apparently can't figure that out, and fires a
sl@0	628	* false alarm.
sl@0	629	*/
sl@0	630
sl@0	631	basePtr = (char *) ckalloc(bytesToAlloc);
sl@0	632	memset(basePtr, 0, bytesToAlloc);
sl@0	633
sl@0	634	prevPtr = NULL;
sl@0	635	objPtr = (Tcl_Obj *) basePtr;
sl@0	636	for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
sl@0	637	objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
sl@0	638	prevPtr = objPtr;
sl@0	639	objPtr++;
sl@0	640	}
sl@0	641	tclFreeObjList = prevPtr;
sl@0	642	}
sl@0	643	#undef OBJS_TO_ALLOC_EACH_TIME
sl@0	644
sl@0	645	/*
sl@0	646	*----------------------------------------------------------------------
sl@0	647	*
sl@0	648	* TclFreeObj --
sl@0	649	*
sl@0	650	* This procedure frees the memory associated with the argument
sl@0	651	* object. It is called by the tcl.h macro Tcl_DecrRefCount when an
sl@0	652	* object's ref count is zero. It is only "public" since it must
sl@0	653	* be callable by that macro wherever the macro is used. It should not
sl@0	654	* be directly called by clients.
sl@0	655	*
sl@0	656	* Results:
sl@0	657	* None.
sl@0	658	*
sl@0	659	* Side effects:
sl@0	660	* Deallocates the storage for the object's Tcl_Obj structure
sl@0	661	* after deallocating the string representation and calling the
sl@0	662	* type-specific Tcl_FreeInternalRepProc to deallocate the object's
sl@0	663	* internal representation. If compiling with TCL_COMPILE_STATS,
sl@0	664	* this procedure increments the global count of freed objects
sl@0	665	* (tclObjsFreed).
sl@0	666	*
sl@0	667	*----------------------------------------------------------------------
sl@0	668	*/
sl@0	669
sl@0	670	EXPORT_C void
sl@0	671	TclFreeObj(objPtr)
sl@0	672	register Tcl_Obj objPtr; / The object to be freed. */
sl@0	673	{
sl@0	674	register Tcl_ObjType *typePtr = objPtr->typePtr;
sl@0	675
sl@0	676	#ifdef TCL_MEM_DEBUG
sl@0	677	if ((objPtr)->refCount < -1) {
sl@0	678	panic("Reference count for %lx was negative", objPtr);
sl@0	679	}
sl@0	680	#endif /* TCL_MEM_DEBUG */
sl@0	681
sl@0	682	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
sl@0	683	typePtr->freeIntRepProc(objPtr);
sl@0	684	}
sl@0	685	Tcl_InvalidateStringRep(objPtr);
sl@0	686
sl@0	687	/*
sl@0	688	* If debugging Tcl's memory usage, deallocate the object using ckfree.
sl@0	689	* Otherwise, deallocate it by adding it onto the list of free
sl@0	690	* Tcl_Obj structs we maintain.
sl@0	691	*/
sl@0	692
sl@0	693	#if defined(TCL_MEM_DEBUG) \|\| defined(PURIFY)
sl@0	694	Tcl_MutexLock(&tclObjMutex);
sl@0	695	ckfree((char *) objPtr);
sl@0	696	Tcl_MutexUnlock(&tclObjMutex);
sl@0	697	#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
sl@0	698	TclThreadFreeObj(objPtr);
sl@0	699	#else
sl@0	700	Tcl_MutexLock(&tclObjMutex);
sl@0	701	objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
sl@0	702	tclFreeObjList = objPtr;
sl@0	703	Tcl_MutexUnlock(&tclObjMutex);
sl@0	704	#endif /* TCL_MEM_DEBUG */
sl@0	705
sl@0	706	#ifdef TCL_COMPILE_STATS
sl@0	707	tclObjsFreed++;
sl@0	708	#endif /* TCL_COMPILE_STATS */
sl@0	709	}
sl@0	710
sl@0	711	/*
sl@0	712	*----------------------------------------------------------------------
sl@0	713	*
sl@0	714	* Tcl_DuplicateObj --
sl@0	715	*
sl@0	716	* Create and return a new object that is a duplicate of the argument
sl@0	717	* object.
sl@0	718	*
sl@0	719	* Results:
sl@0	720	* The return value is a pointer to a newly created Tcl_Obj. This
sl@0	721	* object has reference count 0 and the same type, if any, as the
sl@0	722	* source object objPtr. Also:
sl@0	723	* 1) If the source object has a valid string rep, we copy it;
sl@0	724	* otherwise, the duplicate's string rep is set NULL to mark
sl@0	725	* it invalid.
sl@0	726	* 2) If the source object has an internal representation (i.e. its
sl@0	727	* typePtr is non-NULL), the new object's internal rep is set to
sl@0	728	* a copy; otherwise the new internal rep is marked invalid.
sl@0	729	*
sl@0	730	* Side effects:
sl@0	731	* What constitutes "copying" the internal representation depends on
sl@0	732	* the type. For example, if the argument object is a list,
sl@0	733	* the element objects it points to will not actually be copied but
sl@0	734	* will be shared with the duplicate list. That is, the ref counts of
sl@0	735	* the element objects will be incremented.
sl@0	736	*
sl@0	737	*----------------------------------------------------------------------
sl@0	738	*/
sl@0	739
sl@0	740	EXPORT_C Tcl_Obj *
sl@0	741	Tcl_DuplicateObj(objPtr)
sl@0	742	register Tcl_Obj objPtr; / The object to duplicate. */
sl@0	743	{
sl@0	744	register Tcl_ObjType *typePtr = objPtr->typePtr;
sl@0	745	register Tcl_Obj *dupPtr;
sl@0	746
sl@0	747	TclNewObj(dupPtr);
sl@0	748
sl@0	749	if (objPtr->bytes == NULL) {
sl@0	750	dupPtr->bytes = NULL;
sl@0	751	} else if (objPtr->bytes != tclEmptyStringRep) {
sl@0	752	TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
sl@0	753	}
sl@0	754
sl@0	755	if (typePtr != NULL) {
sl@0	756	if (typePtr->dupIntRepProc == NULL) {
sl@0	757	dupPtr->internalRep = objPtr->internalRep;
sl@0	758	dupPtr->typePtr = typePtr;
sl@0	759	} else {
sl@0	760	(*typePtr->dupIntRepProc)(objPtr, dupPtr);
sl@0	761	}
sl@0	762	}
sl@0	763	return dupPtr;
sl@0	764	}
sl@0	765
sl@0	766	/*
sl@0	767	*----------------------------------------------------------------------
sl@0	768	*
sl@0	769	* Tcl_GetString --
sl@0	770	*
sl@0	771	* Returns the string representation byte array pointer for an object.
sl@0	772	*
sl@0	773	* Results:
sl@0	774	* Returns a pointer to the string representation of objPtr. The byte
sl@0	775	* array referenced by the returned pointer must not be modified by the
sl@0	776	* caller. Furthermore, the caller must copy the bytes if they need to
sl@0	777	* retain them since the object's string rep can change as a result of
sl@0	778	* other operations.
sl@0	779	*
sl@0	780	* Side effects:
sl@0	781	* May call the object's updateStringProc to update the string
sl@0	782	* representation from the internal representation.
sl@0	783	*
sl@0	784	*----------------------------------------------------------------------
sl@0	785	*/
sl@0	786
sl@0	787	EXPORT_C char *
sl@0	788	Tcl_GetString(objPtr)
sl@0	789	register Tcl_Obj objPtr; / Object whose string rep byte pointer
sl@0	790	* should be returned. */
sl@0	791	{
sl@0	792	if (objPtr->bytes != NULL) {
sl@0	793	return objPtr->bytes;
sl@0	794	}
sl@0	795
sl@0	796	if (objPtr->typePtr->updateStringProc == NULL) {
sl@0	797	panic("UpdateStringProc should not be invoked for type %s",
sl@0	798	objPtr->typePtr->name);
sl@0	799	}
sl@0	800	(*objPtr->typePtr->updateStringProc)(objPtr);
sl@0	801	return objPtr->bytes;
sl@0	802	}
sl@0	803
sl@0	804	/*
sl@0	805	*----------------------------------------------------------------------
sl@0	806	*
sl@0	807	* Tcl_GetStringFromObj --
sl@0	808	*
sl@0	809	* Returns the string representation's byte array pointer and length
sl@0	810	* for an object.
sl@0	811	*
sl@0	812	* Results:
sl@0	813	* Returns a pointer to the string representation of objPtr. If
sl@0	814	* lengthPtr isn't NULL, the length of the string representation is
sl@0	815	* stored at *lengthPtr. The byte array referenced by the returned
sl@0	816	* pointer must not be modified by the caller. Furthermore, the
sl@0	817	* caller must copy the bytes if they need to retain them since the
sl@0	818	* object's string rep can change as a result of other operations.
sl@0	819	*
sl@0	820	* Side effects:
sl@0	821	* May call the object's updateStringProc to update the string
sl@0	822	* representation from the internal representation.
sl@0	823	*
sl@0	824	*----------------------------------------------------------------------
sl@0	825	*/
sl@0	826
sl@0	827	EXPORT_C char *
sl@0	828	Tcl_GetStringFromObj(objPtr, lengthPtr)
sl@0	829	register Tcl_Obj objPtr; / Object whose string rep byte pointer should
sl@0	830	* be returned. */
sl@0	831	register int lengthPtr; / If non-NULL, the location where the string
sl@0	832	* rep's byte array length should * be stored.
sl@0	833	* If NULL, no length is stored. */
sl@0	834	{
sl@0	835	if (objPtr->bytes == NULL) {
sl@0	836	if (objPtr->typePtr->updateStringProc == NULL) {
sl@0	837	panic("UpdateStringProc should not be invoked for type %s",
sl@0	838	objPtr->typePtr->name);
sl@0	839	}
sl@0	840	(*objPtr->typePtr->updateStringProc)(objPtr);
sl@0	841	}
sl@0	842
sl@0	843	if (lengthPtr != NULL) {
sl@0	844	*lengthPtr = objPtr->length;
sl@0	845	}
sl@0	846	return objPtr->bytes;
sl@0	847	}
sl@0	848
sl@0	849	/*
sl@0	850	*----------------------------------------------------------------------
sl@0	851	*
sl@0	852	* Tcl_InvalidateStringRep --
sl@0	853	*
sl@0	854	* This procedure is called to invalidate an object's string
sl@0	855	* representation.
sl@0	856	*
sl@0	857	* Results:
sl@0	858	* None.
sl@0	859	*
sl@0	860	* Side effects:
sl@0	861	* Deallocates the storage for any old string representation, then
sl@0	862	* sets the string representation NULL to mark it invalid.
sl@0	863	*
sl@0	864	*----------------------------------------------------------------------
sl@0	865	*/
sl@0	866
sl@0	867	EXPORT_C void
sl@0	868	Tcl_InvalidateStringRep(objPtr)
sl@0	869	register Tcl_Obj objPtr; / Object whose string rep byte pointer
sl@0	870	* should be freed. */
sl@0	871	{
sl@0	872	if (objPtr->bytes != NULL) {
sl@0	873	if (objPtr->bytes != tclEmptyStringRep) {
sl@0	874	ckfree((char *) objPtr->bytes);
sl@0	875	}
sl@0	876	objPtr->bytes = NULL;
sl@0	877	}
sl@0	878	}
sl@0	879
sl@0	880	/*
sl@0	881	*----------------------------------------------------------------------
sl@0	882	*
sl@0	883	* Tcl_NewBooleanObj --
sl@0	884	*
sl@0	885	* This procedure is normally called when not debugging: i.e., when
sl@0	886	* TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
sl@0	887	* initializes it from the argument boolean value. A nonzero
sl@0	888	* "boolValue" is coerced to 1.
sl@0	889	*
sl@0	890	* When TCL_MEM_DEBUG is defined, this procedure just returns the
sl@0	891	* result of calling the debugging version Tcl_DbNewBooleanObj.
sl@0	892	*
sl@0	893	* Results:
sl@0	894	* The newly created object is returned. This object will have an
sl@0	895	* invalid string representation. The returned object has ref count 0.
sl@0	896	*
sl@0	897	* Side effects:
sl@0	898	* None.
sl@0	899	*
sl@0	900	*----------------------------------------------------------------------
sl@0	901	*/
sl@0	902
sl@0	903	#ifdef TCL_MEM_DEBUG
sl@0	904	#undef Tcl_NewBooleanObj
sl@0	905
sl@0	906	EXPORT_C Tcl_Obj *
sl@0	907	Tcl_NewBooleanObj(boolValue)
sl@0	908	register int boolValue; /* Boolean used to initialize new object. */
sl@0	909	{
sl@0	910	return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
sl@0	911	}
sl@0	912
sl@0	913	#else /* if not TCL_MEM_DEBUG */
sl@0	914
sl@0	915	EXPORT_C Tcl_Obj *
sl@0	916	Tcl_NewBooleanObj(boolValue)
sl@0	917	register int boolValue; /* Boolean used to initialize new object. */
sl@0	918	{
sl@0	919	register Tcl_Obj *objPtr;
sl@0	920
sl@0	921	TclNewObj(objPtr);
sl@0	922	objPtr->bytes = NULL;
sl@0	923
sl@0	924	objPtr->internalRep.longValue = (boolValue? 1 : 0);
sl@0	925	objPtr->typePtr = &tclBooleanType;
sl@0	926	return objPtr;
sl@0	927	}
sl@0	928	#endif /* TCL_MEM_DEBUG */
sl@0	929
sl@0	930	/*
sl@0	931	*----------------------------------------------------------------------
sl@0	932	*
sl@0	933	* Tcl_DbNewBooleanObj --
sl@0	934	*
sl@0	935	* This procedure is normally called when debugging: i.e., when
sl@0	936	* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
sl@0	937	* same as the Tcl_NewBooleanObj procedure above except that it calls
sl@0	938	* Tcl_DbCkalloc directly with the file name and line number from its
sl@0	939	* caller. This simplifies debugging since then the [memory active]
sl@0	940	* command will report the correct file name and line number when
sl@0	941	* reporting objects that haven't been freed.
sl@0	942	*
sl@0	943	* When TCL_MEM_DEBUG is not defined, this procedure just returns the
sl@0	944	* result of calling Tcl_NewBooleanObj.
sl@0	945	*
sl@0	946	* Results:
sl@0	947	* The newly created object is returned. This object will have an
sl@0	948	* invalid string representation. The returned object has ref count 0.
sl@0	949	*
sl@0	950	* Side effects:
sl@0	951	* None.
sl@0	952	*
sl@0	953	*----------------------------------------------------------------------
sl@0	954	*/
sl@0	955
sl@0	956	#ifdef TCL_MEM_DEBUG
sl@0	957
sl@0	958	EXPORT_C Tcl_Obj *
sl@0	959	Tcl_DbNewBooleanObj(boolValue, file, line)
sl@0	960	register int boolValue; /* Boolean used to initialize new object. */
sl@0	961	CONST char file; / The name of the source file calling this
sl@0	962	* procedure; used for debugging. */
sl@0	963	int line; /* Line number in the source file; used
sl@0	964	* for debugging. */
sl@0	965	{
sl@0	966	register Tcl_Obj *objPtr;
sl@0	967
sl@0	968	TclDbNewObj(objPtr, file, line);
sl@0	969	objPtr->bytes = NULL;
sl@0	970
sl@0	971	objPtr->internalRep.longValue = (boolValue? 1 : 0);
sl@0	972	objPtr->typePtr = &tclBooleanType;
sl@0	973	return objPtr;
sl@0	974	}
sl@0	975
sl@0	976	#else /* if not TCL_MEM_DEBUG */
sl@0	977
sl@0	978	EXPORT_C Tcl_Obj *
sl@0	979	Tcl_DbNewBooleanObj(boolValue, file, line)
sl@0	980	register int boolValue; /* Boolean used to initialize new object. */
sl@0	981	CONST char file; / The name of the source file calling this
sl@0	982	* procedure; used for debugging. */
sl@0	983	int line; /* Line number in the source file; used
sl@0	984	* for debugging. */
sl@0	985	{
sl@0	986	return Tcl_NewBooleanObj(boolValue);
sl@0	987	}
sl@0	988	#endif /* TCL_MEM_DEBUG */
sl@0	989
sl@0	990	/*
sl@0	991	*----------------------------------------------------------------------
sl@0	992	*
sl@0	993	* Tcl_SetBooleanObj --
sl@0	994	*
sl@0	995	* Modify an object to be a boolean object and to have the specified
sl@0	996	* boolean value. A nonzero "boolValue" is coerced to 1.
sl@0	997	*
sl@0	998	* Results:
sl@0	999	* None.
sl@0	1000	*
sl@0	1001	* Side effects:
sl@0	1002	* The object's old string rep, if any, is freed. Also, any old
sl@0	1003	* internal rep is freed.
sl@0	1004	*
sl@0	1005	*----------------------------------------------------------------------
sl@0	1006	*/
sl@0	1007
sl@0	1008	EXPORT_C void
sl@0	1009	Tcl_SetBooleanObj(objPtr, boolValue)
sl@0	1010	register Tcl_Obj objPtr; / Object whose internal rep to init. */
sl@0	1011	register int boolValue; /* Boolean used to set object's value. */
sl@0	1012	{
sl@0	1013	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1014
sl@0	1015	if (Tcl_IsShared(objPtr)) {
sl@0	1016	panic("Tcl_SetBooleanObj called with shared object");
sl@0	1017	}
sl@0	1018
sl@0	1019	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1020	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1021	}
sl@0	1022
sl@0	1023	objPtr->internalRep.longValue = (boolValue? 1 : 0);
sl@0	1024	objPtr->typePtr = &tclBooleanType;
sl@0	1025	Tcl_InvalidateStringRep(objPtr);
sl@0	1026	}
sl@0	1027
sl@0	1028	/*
sl@0	1029	*----------------------------------------------------------------------
sl@0	1030	*
sl@0	1031	* Tcl_GetBooleanFromObj --
sl@0	1032	*
sl@0	1033	* Attempt to return a boolean from the Tcl object "objPtr". If the
sl@0	1034	* object is not already a boolean, an attempt will be made to convert
sl@0	1035	* it to one.
sl@0	1036	*
sl@0	1037	* Results:
sl@0	1038	* The return value is a standard Tcl object result. If an error occurs
sl@0	1039	* during conversion, an error message is left in the interpreter's
sl@0	1040	* result unless "interp" is NULL.
sl@0	1041	*
sl@0	1042	* Side effects:
sl@0	1043	* If the object is not already a boolean, the conversion will free
sl@0	1044	* any old internal representation.
sl@0	1045	*
sl@0	1046	*----------------------------------------------------------------------
sl@0	1047	*/
sl@0	1048
sl@0	1049	EXPORT_C int
sl@0	1050	Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
sl@0	1051	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1052	register Tcl_Obj objPtr; / The object from which to get boolean. */
sl@0	1053	register int boolPtr; / Place to store resulting boolean. */
sl@0	1054	{
sl@0	1055	register int result;
sl@0	1056
sl@0	1057	if (objPtr->typePtr == &tclBooleanType) {
sl@0	1058	result = TCL_OK;
sl@0	1059	} else {
sl@0	1060	result = SetBooleanFromAny(interp, objPtr);
sl@0	1061	}
sl@0	1062
sl@0	1063	if (result == TCL_OK) {
sl@0	1064	*boolPtr = (int) objPtr->internalRep.longValue;
sl@0	1065	}
sl@0	1066	return result;
sl@0	1067	}
sl@0	1068
sl@0	1069	/*
sl@0	1070	*----------------------------------------------------------------------
sl@0	1071	*
sl@0	1072	* SetBooleanFromAny --
sl@0	1073	*
sl@0	1074	* Attempt to generate a boolean internal form for the Tcl object
sl@0	1075	* "objPtr".
sl@0	1076	*
sl@0	1077	* Results:
sl@0	1078	* The return value is a standard Tcl result. If an error occurs during
sl@0	1079	* conversion, an error message is left in the interpreter's result
sl@0	1080	* unless "interp" is NULL.
sl@0	1081	*
sl@0	1082	* Side effects:
sl@0	1083	* If no error occurs, an integer 1 or 0 is stored as "objPtr"s
sl@0	1084	* internal representation and the type of "objPtr" is set to boolean.
sl@0	1085	*
sl@0	1086	*----------------------------------------------------------------------
sl@0	1087	*/
sl@0	1088
sl@0	1089	static int
sl@0	1090	SetBooleanFromAny(interp, objPtr)
sl@0	1091	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1092	register Tcl_Obj objPtr; / The object to convert. */
sl@0	1093	{
sl@0	1094	Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1095	char string, end;
sl@0	1096	register char c;
sl@0	1097	char lowerCase[10];
sl@0	1098	int newBool, length;
sl@0	1099	register int i;
sl@0	1100
sl@0	1101	/*
sl@0	1102	* Get the string representation. Make it up-to-date if necessary.
sl@0	1103	*/
sl@0	1104
sl@0	1105	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1106
sl@0	1107	/*
sl@0	1108	* Use the obvious shortcuts for numerical values; if objPtr is not
sl@0	1109	* of numerical type, parse its string rep.
sl@0	1110	*/
sl@0	1111
sl@0	1112	if (objPtr->typePtr == &tclIntType) {
sl@0	1113	newBool = (objPtr->internalRep.longValue != 0);
sl@0	1114	} else if (objPtr->typePtr == &tclDoubleType) {
sl@0	1115	newBool = (objPtr->internalRep.doubleValue != 0.0);
sl@0	1116	} else if (objPtr->typePtr == &tclWideIntType) {
sl@0	1117	newBool = (objPtr->internalRep.wideValue != 0);
sl@0	1118	} else {
sl@0	1119	/*
sl@0	1120	* Copy the string converting its characters to lower case.
sl@0	1121	*/
sl@0	1122
sl@0	1123	for (i = 0; (i < 9) && (i < length); i++) {
sl@0	1124	c = string[i];
sl@0	1125	/*
sl@0	1126	* Weed out international characters so we can safely operate
sl@0	1127	* on single bytes.
sl@0	1128	*/
sl@0	1129
sl@0	1130	if (c & 0x80) {
sl@0	1131	goto badBoolean;
sl@0	1132	}
sl@0	1133	if (Tcl_UniCharIsUpper(UCHAR(c))) {
sl@0	1134	c = (char) Tcl_UniCharToLower(UCHAR(c));
sl@0	1135	}
sl@0	1136	lowerCase[i] = c;
sl@0	1137	}
sl@0	1138	lowerCase[i] = 0;
sl@0	1139
sl@0	1140	/*
sl@0	1141	* Parse the string as a boolean. We use an implementation here that
sl@0	1142	* doesn't report errors in interp if interp is NULL.
sl@0	1143	*/
sl@0	1144
sl@0	1145	c = lowerCase[0];
sl@0	1146	if ((c == '0') && (lowerCase[1] == '\0')) {
sl@0	1147	newBool = 0;
sl@0	1148	} else if ((c == '1') && (lowerCase[1] == '\0')) {
sl@0	1149	newBool = 1;
sl@0	1150	} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
sl@0	1151	newBool = 1;
sl@0	1152	} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
sl@0	1153	newBool = 0;
sl@0	1154	} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
sl@0	1155	newBool = 1;
sl@0	1156	} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
sl@0	1157	newBool = 0;
sl@0	1158	} else if ((c == 'o') && (length >= 2)) {
sl@0	1159	if (strncmp(lowerCase, "on", (size_t) length) == 0) {
sl@0	1160	newBool = 1;
sl@0	1161	} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
sl@0	1162	newBool = 0;
sl@0	1163	} else {
sl@0	1164	goto badBoolean;
sl@0	1165	}
sl@0	1166	} else {
sl@0	1167	double dbl;
sl@0	1168	/*
sl@0	1169	* Boolean values can be extracted from ints or doubles. Note
sl@0	1170	* that we don't use strtoul or strtoull here because we don't
sl@0	1171	* care about what the value is, just whether it is equal to
sl@0	1172	* zero or not.
sl@0	1173	*/
sl@0	1174	#ifdef TCL_WIDE_INT_IS_LONG
sl@0	1175	newBool = strtol(string, &end, 0);
sl@0	1176	if (end != string) {
sl@0	1177	/*
sl@0	1178	* Make sure the string has no garbage after the end of
sl@0	1179	* the int.
sl@0	1180	*/
sl@0	1181	while ((end < (string+length))
sl@0	1182	&& isspace(UCHAR(end))) { / INTL: ISO only */
sl@0	1183	end++;
sl@0	1184	}
sl@0	1185	if (end == (string+length)) {
sl@0	1186	newBool = (newBool != 0);
sl@0	1187	goto goodBoolean;
sl@0	1188	}
sl@0	1189	}
sl@0	1190	#else /* !TCL_WIDE_INT_IS_LONG */
sl@0	1191	Tcl_WideInt wide = strtoll(string, &end, 0);
sl@0	1192	if (end != string) {
sl@0	1193	/*
sl@0	1194	* Make sure the string has no garbage after the end of
sl@0	1195	* the wide int.
sl@0	1196	*/
sl@0	1197	while ((end < (string+length))
sl@0	1198	&& isspace(UCHAR(end))) { / INTL: ISO only */
sl@0	1199	end++;
sl@0	1200	}
sl@0	1201	if (end == (string+length)) {
sl@0	1202	newBool = (wide != Tcl_LongAsWide(0));
sl@0	1203	goto goodBoolean;
sl@0	1204	}
sl@0	1205	}
sl@0	1206	#endif /* TCL_WIDE_INT_IS_LONG */
sl@0	1207	/*
sl@0	1208	* Still might be a string containing the characters representing an
sl@0	1209	* int or double that wasn't handled above. This would be a string
sl@0	1210	* like "27" or "1.0" that is non-zero and not "1". Such a string
sl@0	1211	* would result in the boolean value true. We try converting to
sl@0	1212	* double. If that succeeds and the resulting double is non-zero, we
sl@0	1213	* have a "true". Note that numbers can't have embedded NULLs.
sl@0	1214	*/
sl@0	1215
sl@0	1216	dbl = strtod(string, &end);
sl@0	1217	if (end == string) {
sl@0	1218	goto badBoolean;
sl@0	1219	}
sl@0	1220
sl@0	1221	/*
sl@0	1222	* Make sure the string has no garbage after the end of the double.
sl@0	1223	*/
sl@0	1224
sl@0	1225	while ((end < (string+length))
sl@0	1226	&& isspace(UCHAR(end))) { / INTL: ISO only */
sl@0	1227	end++;
sl@0	1228	}
sl@0	1229	if (end != (string+length)) {
sl@0	1230	goto badBoolean;
sl@0	1231	}
sl@0	1232	newBool = (dbl != 0.0);
sl@0	1233	}
sl@0	1234	}
sl@0	1235
sl@0	1236	/*
sl@0	1237	* Free the old internalRep before setting the new one. We do this as
sl@0	1238	* late as possible to allow the conversion code, in particular
sl@0	1239	* Tcl_GetStringFromObj, to use that old internalRep.
sl@0	1240	*/
sl@0	1241
sl@0	1242	goodBoolean:
sl@0	1243	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1244	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1245	}
sl@0	1246
sl@0	1247	objPtr->internalRep.longValue = newBool;
sl@0	1248	objPtr->typePtr = &tclBooleanType;
sl@0	1249	return TCL_OK;
sl@0	1250
sl@0	1251	badBoolean:
sl@0	1252	if (interp != NULL) {
sl@0	1253	/*
sl@0	1254	* Must copy string before resetting the result in case a caller
sl@0	1255	* is trying to convert the interpreter's result to a boolean.
sl@0	1256	*/
sl@0	1257
sl@0	1258	char buf[100];
sl@0	1259	sprintf(buf, "expected boolean value but got \"%.50s\"", string);
sl@0	1260	Tcl_ResetResult(interp);
sl@0	1261	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0	1262	}
sl@0	1263	return TCL_ERROR;
sl@0	1264	}
sl@0	1265
sl@0	1266	/*
sl@0	1267	*----------------------------------------------------------------------
sl@0	1268	*
sl@0	1269	* UpdateStringOfBoolean --
sl@0	1270	*
sl@0	1271	* Update the string representation for a boolean object.
sl@0	1272	* Note: This procedure does not free an existing old string rep
sl@0	1273	* so storage will be lost if this has not already been done.
sl@0	1274	*
sl@0	1275	* Results:
sl@0	1276	* None.
sl@0	1277	*
sl@0	1278	* Side effects:
sl@0	1279	* The object's string is set to a valid string that results from
sl@0	1280	* the boolean-to-string conversion.
sl@0	1281	*
sl@0	1282	*----------------------------------------------------------------------
sl@0	1283	*/
sl@0	1284
sl@0	1285	static void
sl@0	1286	UpdateStringOfBoolean(objPtr)
sl@0	1287	register Tcl_Obj objPtr; / Int object whose string rep to update. */
sl@0	1288	{
sl@0	1289	char *s = ckalloc((unsigned) 2);
sl@0	1290
sl@0	1291	s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
sl@0	1292	s[1] = '\0';
sl@0	1293	objPtr->bytes = s;
sl@0	1294	objPtr->length = 1;
sl@0	1295	}
sl@0	1296
sl@0	1297	/*
sl@0	1298	*----------------------------------------------------------------------
sl@0	1299	*
sl@0	1300	* Tcl_NewDoubleObj --
sl@0	1301	*
sl@0	1302	* This procedure is normally called when not debugging: i.e., when
sl@0	1303	* TCL_MEM_DEBUG is not defined. It creates a new double object and
sl@0	1304	* initializes it from the argument double value.
sl@0	1305	*
sl@0	1306	* When TCL_MEM_DEBUG is defined, this procedure just returns the
sl@0	1307	* result of calling the debugging version Tcl_DbNewDoubleObj.
sl@0	1308	*
sl@0	1309	* Results:
sl@0	1310	* The newly created object is returned. This object will have an
sl@0	1311	* invalid string representation. The returned object has ref count 0.
sl@0	1312	*
sl@0	1313	* Side effects:
sl@0	1314	* None.
sl@0	1315	*
sl@0	1316	*----------------------------------------------------------------------
sl@0	1317	*/
sl@0	1318
sl@0	1319	#ifdef TCL_MEM_DEBUG
sl@0	1320	#undef Tcl_NewDoubleObj
sl@0	1321
sl@0	1322	EXPORT_C Tcl_Obj *
sl@0	1323	Tcl_NewDoubleObj(dblValue)
sl@0	1324	register double dblValue; /* Double used to initialize the object. */
sl@0	1325	{
sl@0	1326	return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
sl@0	1327	}
sl@0	1328
sl@0	1329	#else /* if not TCL_MEM_DEBUG */
sl@0	1330
sl@0	1331	EXPORT_C Tcl_Obj *
sl@0	1332	Tcl_NewDoubleObj(dblValue)
sl@0	1333	register double dblValue; /* Double used to initialize the object. */
sl@0	1334	{
sl@0	1335	register Tcl_Obj *objPtr;
sl@0	1336
sl@0	1337	TclNewObj(objPtr);
sl@0	1338	objPtr->bytes = NULL;
sl@0	1339
sl@0	1340	objPtr->internalRep.doubleValue = dblValue;
sl@0	1341	objPtr->typePtr = &tclDoubleType;
sl@0	1342	return objPtr;
sl@0	1343	}
sl@0	1344	#endif /* if TCL_MEM_DEBUG */
sl@0	1345
sl@0	1346	/*
sl@0	1347	*----------------------------------------------------------------------
sl@0	1348	*
sl@0	1349	* Tcl_DbNewDoubleObj --
sl@0	1350	*
sl@0	1351	* This procedure is normally called when debugging: i.e., when
sl@0	1352	* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
sl@0	1353	* same as the Tcl_NewDoubleObj procedure above except that it calls
sl@0	1354	* Tcl_DbCkalloc directly with the file name and line number from its
sl@0	1355	* caller. This simplifies debugging since then the [memory active]
sl@0	1356	* command will report the correct file name and line number when
sl@0	1357	* reporting objects that haven't been freed.
sl@0	1358	*
sl@0	1359	* When TCL_MEM_DEBUG is not defined, this procedure just returns the
sl@0	1360	* result of calling Tcl_NewDoubleObj.
sl@0	1361	*
sl@0	1362	* Results:
sl@0	1363	* The newly created object is returned. This object will have an
sl@0	1364	* invalid string representation. The returned object has ref count 0.
sl@0	1365	*
sl@0	1366	* Side effects:
sl@0	1367	* None.
sl@0	1368	*
sl@0	1369	*----------------------------------------------------------------------
sl@0	1370	*/
sl@0	1371
sl@0	1372	#ifdef TCL_MEM_DEBUG
sl@0	1373
sl@0	1374	EXPORT_C Tcl_Obj *
sl@0	1375	Tcl_DbNewDoubleObj(dblValue, file, line)
sl@0	1376	register double dblValue; /* Double used to initialize the object. */
sl@0	1377	CONST char file; / The name of the source file calling this
sl@0	1378	* procedure; used for debugging. */
sl@0	1379	int line; /* Line number in the source file; used
sl@0	1380	* for debugging. */
sl@0	1381	{
sl@0	1382	register Tcl_Obj *objPtr;
sl@0	1383
sl@0	1384	TclDbNewObj(objPtr, file, line);
sl@0	1385	objPtr->bytes = NULL;
sl@0	1386
sl@0	1387	objPtr->internalRep.doubleValue = dblValue;
sl@0	1388	objPtr->typePtr = &tclDoubleType;
sl@0	1389	return objPtr;
sl@0	1390	}
sl@0	1391
sl@0	1392	#else /* if not TCL_MEM_DEBUG */
sl@0	1393
sl@0	1394	EXPORT_C Tcl_Obj *
sl@0	1395	Tcl_DbNewDoubleObj(dblValue, file, line)
sl@0	1396	register double dblValue; /* Double used to initialize the object. */
sl@0	1397	CONST char file; / The name of the source file calling this
sl@0	1398	* procedure; used for debugging. */
sl@0	1399	int line; /* Line number in the source file; used
sl@0	1400	* for debugging. */
sl@0	1401	{
sl@0	1402	return Tcl_NewDoubleObj(dblValue);
sl@0	1403	}
sl@0	1404	#endif /* TCL_MEM_DEBUG */
sl@0	1405
sl@0	1406	/*
sl@0	1407	*----------------------------------------------------------------------
sl@0	1408	*
sl@0	1409	* Tcl_SetDoubleObj --
sl@0	1410	*
sl@0	1411	* Modify an object to be a double object and to have the specified
sl@0	1412	* double value.
sl@0	1413	*
sl@0	1414	* Results:
sl@0	1415	* None.
sl@0	1416	*
sl@0	1417	* Side effects:
sl@0	1418	* The object's old string rep, if any, is freed. Also, any old
sl@0	1419	* internal rep is freed.
sl@0	1420	*
sl@0	1421	*----------------------------------------------------------------------
sl@0	1422	*/
sl@0	1423
sl@0	1424	EXPORT_C void
sl@0	1425	Tcl_SetDoubleObj(objPtr, dblValue)
sl@0	1426	register Tcl_Obj objPtr; / Object whose internal rep to init. */
sl@0	1427	register double dblValue; /* Double used to set the object's value. */
sl@0	1428	{
sl@0	1429	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1430
sl@0	1431	if (Tcl_IsShared(objPtr)) {
sl@0	1432	panic("Tcl_SetDoubleObj called with shared object");
sl@0	1433	}
sl@0	1434
sl@0	1435	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1436	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1437	}
sl@0	1438
sl@0	1439	objPtr->internalRep.doubleValue = dblValue;
sl@0	1440	objPtr->typePtr = &tclDoubleType;
sl@0	1441	Tcl_InvalidateStringRep(objPtr);
sl@0	1442	}
sl@0	1443
sl@0	1444	/*
sl@0	1445	*----------------------------------------------------------------------
sl@0	1446	*
sl@0	1447	* Tcl_GetDoubleFromObj --
sl@0	1448	*
sl@0	1449	* Attempt to return a double from the Tcl object "objPtr". If the
sl@0	1450	* object is not already a double, an attempt will be made to convert
sl@0	1451	* it to one.
sl@0	1452	*
sl@0	1453	* Results:
sl@0	1454	* The return value is a standard Tcl object result. If an error occurs
sl@0	1455	* during conversion, an error message is left in the interpreter's
sl@0	1456	* result unless "interp" is NULL.
sl@0	1457	*
sl@0	1458	* Side effects:
sl@0	1459	* If the object is not already a double, the conversion will free
sl@0	1460	* any old internal representation.
sl@0	1461	*
sl@0	1462	*----------------------------------------------------------------------
sl@0	1463	*/
sl@0	1464
sl@0	1465	EXPORT_C int
sl@0	1466	Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
sl@0	1467	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1468	register Tcl_Obj objPtr; / The object from which to get a double. */
sl@0	1469	register double dblPtr; / Place to store resulting double. */
sl@0	1470	{
sl@0	1471	register int result;
sl@0	1472
sl@0	1473	if (objPtr->typePtr == &tclDoubleType) {
sl@0	1474	*dblPtr = objPtr->internalRep.doubleValue;
sl@0	1475	return TCL_OK;
sl@0	1476	}
sl@0	1477
sl@0	1478	result = SetDoubleFromAny(interp, objPtr);
sl@0	1479	if (result == TCL_OK) {
sl@0	1480	*dblPtr = objPtr->internalRep.doubleValue;
sl@0	1481	}
sl@0	1482	return result;
sl@0	1483	}
sl@0	1484
sl@0	1485	/*
sl@0	1486	*----------------------------------------------------------------------
sl@0	1487	*
sl@0	1488	* SetDoubleFromAny --
sl@0	1489	*
sl@0	1490	* Attempt to generate an double-precision floating point internal form
sl@0	1491	* for the Tcl object "objPtr".
sl@0	1492	*
sl@0	1493	* Results:
sl@0	1494	* The return value is a standard Tcl object result. If an error occurs
sl@0	1495	* during conversion, an error message is left in the interpreter's
sl@0	1496	* result unless "interp" is NULL.
sl@0	1497	*
sl@0	1498	* Side effects:
sl@0	1499	* If no error occurs, a double is stored as "objPtr"s internal
sl@0	1500	* representation.
sl@0	1501	*
sl@0	1502	*----------------------------------------------------------------------
sl@0	1503	*/
sl@0	1504
sl@0	1505	static int
sl@0	1506	SetDoubleFromAny(interp, objPtr)
sl@0	1507	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1508	register Tcl_Obj objPtr; / The object to convert. */
sl@0	1509	{
sl@0	1510	Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1511	char string, end;
sl@0	1512	double newDouble;
sl@0	1513	int length;
sl@0	1514
sl@0	1515	/*
sl@0	1516	* Get the string representation. Make it up-to-date if necessary.
sl@0	1517	*/
sl@0	1518
sl@0	1519	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1520
sl@0	1521	/*
sl@0	1522	* Now parse "objPtr"s string as an double. Numbers can't have embedded
sl@0	1523	* NULLs. We use an implementation here that doesn't report errors in
sl@0	1524	* interp if interp is NULL.
sl@0	1525	*/
sl@0	1526
sl@0	1527	errno = 0;
sl@0	1528	newDouble = strtod(string, &end);
sl@0	1529	if (end == string) {
sl@0	1530	badDouble:
sl@0	1531	if (interp != NULL) {
sl@0	1532	/*
sl@0	1533	* Must copy string before resetting the result in case a caller
sl@0	1534	* is trying to convert the interpreter's result to an int.
sl@0	1535	*/
sl@0	1536
sl@0	1537	char buf[100];
sl@0	1538	sprintf(buf, "expected floating-point number but got \"%.50s\"",
sl@0	1539	string);
sl@0	1540	Tcl_ResetResult(interp);
sl@0	1541	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0	1542	}
sl@0	1543	return TCL_ERROR;
sl@0	1544	}
sl@0	1545	if (errno != 0) {
sl@0	1546	if (interp != NULL) {
sl@0	1547	TclExprFloatError(interp, newDouble);
sl@0	1548	}
sl@0	1549	return TCL_ERROR;
sl@0	1550	}
sl@0	1551
sl@0	1552	/*
sl@0	1553	* Make sure that the string has no garbage after the end of the double.
sl@0	1554	*/
sl@0	1555
sl@0	1556	while ((end < (string+length))
sl@0	1557	&& isspace(UCHAR(end))) { / INTL: ISO space. */
sl@0	1558	end++;
sl@0	1559	}
sl@0	1560	if (end != (string+length)) {
sl@0	1561	goto badDouble;
sl@0	1562	}
sl@0	1563
sl@0	1564	/*
sl@0	1565	* The conversion to double succeeded. Free the old internalRep before
sl@0	1566	* setting the new one. We do this as late as possible to allow the
sl@0	1567	* conversion code, in particular Tcl_GetStringFromObj, to use that old
sl@0	1568	* internalRep.
sl@0	1569	*/
sl@0	1570
sl@0	1571	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1572	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1573	}
sl@0	1574
sl@0	1575	objPtr->internalRep.doubleValue = newDouble;
sl@0	1576	objPtr->typePtr = &tclDoubleType;
sl@0	1577	return TCL_OK;
sl@0	1578	}
sl@0	1579
sl@0	1580	/*
sl@0	1581	*----------------------------------------------------------------------
sl@0	1582	*
sl@0	1583	* UpdateStringOfDouble --
sl@0	1584	*
sl@0	1585	* Update the string representation for a double-precision floating
sl@0	1586	* point object. This must obey the current tcl_precision value for
sl@0	1587	* double-to-string conversions. Note: This procedure does not free an
sl@0	1588	* existing old string rep so storage will be lost if this has not
sl@0	1589	* already been done.
sl@0	1590	*
sl@0	1591	* Results:
sl@0	1592	* None.
sl@0	1593	*
sl@0	1594	* Side effects:
sl@0	1595	* The object's string is set to a valid string that results from
sl@0	1596	* the double-to-string conversion.
sl@0	1597	*
sl@0	1598	*----------------------------------------------------------------------
sl@0	1599	*/
sl@0	1600
sl@0	1601	static void
sl@0	1602	UpdateStringOfDouble(objPtr)
sl@0	1603	register Tcl_Obj objPtr; / Double obj with string rep to update. */
sl@0	1604	{
sl@0	1605	char buffer[TCL_DOUBLE_SPACE];
sl@0	1606	register int len;
sl@0	1607
sl@0	1608	Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
sl@0	1609	buffer);
sl@0	1610	len = strlen(buffer);
sl@0	1611
sl@0	1612	objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
sl@0	1613	strcpy(objPtr->bytes, buffer);
sl@0	1614	objPtr->length = len;
sl@0	1615	}
sl@0	1616
sl@0	1617	/*
sl@0	1618	*----------------------------------------------------------------------
sl@0	1619	*
sl@0	1620	* Tcl_NewIntObj --
sl@0	1621	*
sl@0	1622	* If a client is compiled with TCL_MEM_DEBUG defined, calls to
sl@0	1623	* Tcl_NewIntObj to create a new integer object end up calling the
sl@0	1624	* debugging procedure Tcl_DbNewLongObj instead.
sl@0	1625	*
sl@0	1626	* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
sl@0	1627	* calls to Tcl_NewIntObj result in a call to one of the two
sl@0	1628	* Tcl_NewIntObj implementations below. We provide two implementations
sl@0	1629	* so that the Tcl core can be compiled to do memory debugging of the
sl@0	1630	* core even if a client does not request it for itself.
sl@0	1631	*
sl@0	1632	* Integer and long integer objects share the same "integer" type
sl@0	1633	* implementation. We store all integers as longs and Tcl_GetIntFromObj
sl@0	1634	* checks whether the current value of the long can be represented by
sl@0	1635	* an int.
sl@0	1636	*
sl@0	1637	* Results:
sl@0	1638	* The newly created object is returned. This object will have an
sl@0	1639	* invalid string representation. The returned object has ref count 0.
sl@0	1640	*
sl@0	1641	* Side effects:
sl@0	1642	* None.
sl@0	1643	*
sl@0	1644	*----------------------------------------------------------------------
sl@0	1645	*/
sl@0	1646
sl@0	1647	#ifdef TCL_MEM_DEBUG
sl@0	1648	#undef Tcl_NewIntObj
sl@0	1649
sl@0	1650	EXPORT_C Tcl_Obj *
sl@0	1651	Tcl_NewIntObj(intValue)
sl@0	1652	register int intValue; /* Int used to initialize the new object. */
sl@0	1653	{
sl@0	1654	return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
sl@0	1655	}
sl@0	1656
sl@0	1657	#else /* if not TCL_MEM_DEBUG */
sl@0	1658
sl@0	1659	EXPORT_C Tcl_Obj *
sl@0	1660	Tcl_NewIntObj(intValue)
sl@0	1661	register int intValue; /* Int used to initialize the new object. */
sl@0	1662	{
sl@0	1663	register Tcl_Obj *objPtr;
sl@0	1664
sl@0	1665	TclNewObj(objPtr);
sl@0	1666	objPtr->bytes = NULL;
sl@0	1667
sl@0	1668	objPtr->internalRep.longValue = (long)intValue;
sl@0	1669	objPtr->typePtr = &tclIntType;
sl@0	1670	return objPtr;
sl@0	1671	}
sl@0	1672	#endif /* if TCL_MEM_DEBUG */
sl@0	1673
sl@0	1674	/*
sl@0	1675	*----------------------------------------------------------------------
sl@0	1676	*
sl@0	1677	* Tcl_SetIntObj --
sl@0	1678	*
sl@0	1679	* Modify an object to be an integer and to have the specified integer
sl@0	1680	* value.
sl@0	1681	*
sl@0	1682	* Results:
sl@0	1683	* None.
sl@0	1684	*
sl@0	1685	* Side effects:
sl@0	1686	* The object's old string rep, if any, is freed. Also, any old
sl@0	1687	* internal rep is freed.
sl@0	1688	*
sl@0	1689	*----------------------------------------------------------------------
sl@0	1690	*/
sl@0	1691
sl@0	1692	EXPORT_C void
sl@0	1693	Tcl_SetIntObj(objPtr, intValue)
sl@0	1694	register Tcl_Obj objPtr; / Object whose internal rep to init. */
sl@0	1695	register int intValue; /* Integer used to set object's value. */
sl@0	1696	{
sl@0	1697	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1698
sl@0	1699	if (Tcl_IsShared(objPtr)) {
sl@0	1700	panic("Tcl_SetIntObj called with shared object");
sl@0	1701	}
sl@0	1702
sl@0	1703	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1704	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1705	}
sl@0	1706
sl@0	1707	objPtr->internalRep.longValue = (long) intValue;
sl@0	1708	objPtr->typePtr = &tclIntType;
sl@0	1709	Tcl_InvalidateStringRep(objPtr);
sl@0	1710	}
sl@0	1711
sl@0	1712	/*
sl@0	1713	*----------------------------------------------------------------------
sl@0	1714	*
sl@0	1715	* Tcl_GetIntFromObj --
sl@0	1716	*
sl@0	1717	* Attempt to return an int from the Tcl object "objPtr". If the object
sl@0	1718	* is not already an int, an attempt will be made to convert it to one.
sl@0	1719	*
sl@0	1720	* Integer and long integer objects share the same "integer" type
sl@0	1721	* implementation. We store all integers as longs and Tcl_GetIntFromObj
sl@0	1722	* checks whether the current value of the long can be represented by
sl@0	1723	* an int.
sl@0	1724	*
sl@0	1725	* Results:
sl@0	1726	* The return value is a standard Tcl object result. If an error occurs
sl@0	1727	* during conversion or if the long integer held by the object
sl@0	1728	* can not be represented by an int, an error message is left in
sl@0	1729	* the interpreter's result unless "interp" is NULL.
sl@0	1730	*
sl@0	1731	* Side effects:
sl@0	1732	* If the object is not already an int, the conversion will free
sl@0	1733	* any old internal representation.
sl@0	1734	*
sl@0	1735	*----------------------------------------------------------------------
sl@0	1736	*/
sl@0	1737
sl@0	1738	EXPORT_C int
sl@0	1739	Tcl_GetIntFromObj(interp, objPtr, intPtr)
sl@0	1740	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1741	register Tcl_Obj objPtr; / The object from which to get a int. */
sl@0	1742	register int intPtr; / Place to store resulting int. */
sl@0	1743	{
sl@0	1744	int result;
sl@0	1745	Tcl_WideInt w = 0;
sl@0	1746
sl@0	1747	/*
sl@0	1748	* If the object isn't already an integer of any width, try to
sl@0	1749	* convert it to one.
sl@0	1750	*/
sl@0	1751
sl@0	1752	if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
sl@0	1753	result = SetIntOrWideFromAny(interp, objPtr);
sl@0	1754	if (result != TCL_OK) {
sl@0	1755	return result;
sl@0	1756	}
sl@0	1757	}
sl@0	1758
sl@0	1759	/*
sl@0	1760	* Object should now be either int or wide. Get its value.
sl@0	1761	*/
sl@0	1762
sl@0	1763	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	1764	if (objPtr->typePtr == &tclWideIntType) {
sl@0	1765	w = objPtr->internalRep.wideValue;
sl@0	1766	} else
sl@0	1767	#endif
sl@0	1768	{
sl@0	1769	w = Tcl_LongAsWide(objPtr->internalRep.longValue);
sl@0	1770	}
sl@0	1771
sl@0	1772	if ((LLONG_MAX > UINT_MAX)
sl@0	1773	&& ((w > UINT_MAX) \|\| (w < -(Tcl_WideInt)UINT_MAX))) {
sl@0	1774	if (interp != NULL) {
sl@0	1775	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1776	"integer value too large to represent as non-long integer",
sl@0	1777	-1));
sl@0	1778	}
sl@0	1779	return TCL_ERROR;
sl@0	1780	}
sl@0	1781	*intPtr = (int)w;
sl@0	1782	return TCL_OK;
sl@0	1783	}
sl@0	1784
sl@0	1785	/*
sl@0	1786	*----------------------------------------------------------------------
sl@0	1787	*
sl@0	1788	* SetIntFromAny --
sl@0	1789	*
sl@0	1790	* Attempts to force the internal representation for a Tcl object
sl@0	1791	* to tclIntType, specifically.
sl@0	1792	*
sl@0	1793	* Results:
sl@0	1794	* The return value is a standard object Tcl result. If an
sl@0	1795	* error occurs during conversion, an error message is left in
sl@0	1796	* the interpreter's result unless "interp" is NULL.
sl@0	1797	*
sl@0	1798	*----------------------------------------------------------------------
sl@0	1799	*/
sl@0	1800
sl@0	1801	static int
sl@0	1802	SetIntFromAny( Tcl_Interp* interp,
sl@0	1803	/* Tcl interpreter */
sl@0	1804	Tcl_Obj* objPtr )
sl@0	1805	/* Pointer to the object to convert */
sl@0	1806	{
sl@0	1807	int result;
sl@0	1808
sl@0	1809	result = SetIntOrWideFromAny( interp, objPtr );
sl@0	1810	if ( result != TCL_OK ) {
sl@0	1811	return result;
sl@0	1812	}
sl@0	1813	if ( objPtr->typePtr != &tclIntType ) {
sl@0	1814	if ( interp != NULL ) {
sl@0	1815	char *s = "integer value too large to represent";
sl@0	1816	Tcl_ResetResult(interp);
sl@0	1817	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	1818	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
sl@0	1819	}
sl@0	1820	return TCL_ERROR;
sl@0	1821	}
sl@0	1822	return TCL_OK;
sl@0	1823	}
sl@0	1824
sl@0	1825	/*
sl@0	1826	*----------------------------------------------------------------------
sl@0	1827	*
sl@0	1828	* SetIntOrWideFromAny --
sl@0	1829	*
sl@0	1830	* Attempt to generate an integer internal form for the Tcl object
sl@0	1831	* "objPtr".
sl@0	1832	*
sl@0	1833	* Results:
sl@0	1834	* The return value is a standard object Tcl result. If an error occurs
sl@0	1835	* during conversion, an error message is left in the interpreter's
sl@0	1836	* result unless "interp" is NULL.
sl@0	1837	*
sl@0	1838	* Side effects:
sl@0	1839	* If no error occurs, an int is stored as "objPtr"s internal
sl@0	1840	* representation.
sl@0	1841	*
sl@0	1842	*----------------------------------------------------------------------
sl@0	1843	*/
sl@0	1844
sl@0	1845	static int
sl@0	1846	SetIntOrWideFromAny(interp, objPtr)
sl@0	1847	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	1848	register Tcl_Obj objPtr; / The object to convert. */
sl@0	1849	{
sl@0	1850	Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	1851	char string, end;
sl@0	1852	int length;
sl@0	1853	register char *p;
sl@0	1854	unsigned long newLong;
sl@0	1855	int isNegative = 0;
sl@0	1856	int isWide = 0;
sl@0	1857
sl@0	1858	/*
sl@0	1859	* Get the string representation. Make it up-to-date if necessary.
sl@0	1860	*/
sl@0	1861
sl@0	1862	p = string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1863
sl@0	1864	/*
sl@0	1865	* Now parse "objPtr"s string as an int. We use an implementation here
sl@0	1866	* that doesn't report errors in interp if interp is NULL. Note: use
sl@0	1867	* strtoul instead of strtol for integer conversions to allow full-size
sl@0	1868	* unsigned numbers, but don't depend on strtoul to handle sign
sl@0	1869	* characters; it won't in some implementations.
sl@0	1870	*/
sl@0	1871
sl@0	1872	errno = 0;
sl@0	1873	for ( ; isspace(UCHAR(p)); p++) { / INTL: ISO space. */
sl@0	1874	/* Empty loop body. */
sl@0	1875	}
sl@0	1876	if (*p == '-') {
sl@0	1877	p++;
sl@0	1878	isNegative = 1;
sl@0	1879	} else if (*p == '+') {
sl@0	1880	p++;
sl@0	1881	}
sl@0	1882	if (!isdigit(UCHAR(*p))) {
sl@0	1883	badInteger:
sl@0	1884	if (interp != NULL) {
sl@0	1885	/*
sl@0	1886	* Must copy string before resetting the result in case a caller
sl@0	1887	* is trying to convert the interpreter's result to an int.
sl@0	1888	*/
sl@0	1889
sl@0	1890	char buf[100];
sl@0	1891	sprintf(buf, "expected integer but got \"%.50s\"", string);
sl@0	1892	Tcl_ResetResult(interp);
sl@0	1893	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0	1894	TclCheckBadOctal(interp, string);
sl@0	1895	}
sl@0	1896	return TCL_ERROR;
sl@0	1897	}
sl@0	1898	newLong = strtoul(p, &end, 0);
sl@0	1899	if (end == p) {
sl@0	1900	goto badInteger;
sl@0	1901	}
sl@0	1902	if (errno == ERANGE) {
sl@0	1903	if (interp != NULL) {
sl@0	1904	char *s = "integer value too large to represent";
sl@0	1905	Tcl_ResetResult(interp);
sl@0	1906	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	1907	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
sl@0	1908	}
sl@0	1909	return TCL_ERROR;
sl@0	1910	}
sl@0	1911
sl@0	1912	/*
sl@0	1913	* Make sure that the string has no garbage after the end of the int.
sl@0	1914	*/
sl@0	1915
sl@0	1916	while ((end < (string+length))
sl@0	1917	&& isspace(UCHAR(end))) { / INTL: ISO space. */
sl@0	1918	end++;
sl@0	1919	}
sl@0	1920	if (end != (string+length)) {
sl@0	1921	goto badInteger;
sl@0	1922	}
sl@0	1923
sl@0	1924	/*
sl@0	1925	* If the resulting integer will exceed the range of a long,
sl@0	1926	* put it into a wide instead. (Tcl Bug #868489)
sl@0	1927	*/
sl@0	1928
sl@0	1929	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	1930	if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
sl@0	1931	\|\| (!isNegative && newLong > LONG_MAX)) {
sl@0	1932	isWide = 1;
sl@0	1933	}
sl@0	1934	#endif
sl@0	1935
sl@0	1936	/*
sl@0	1937	* The conversion to int succeeded. Free the old internalRep before
sl@0	1938	* setting the new one. We do this as late as possible to allow the
sl@0	1939	* conversion code, in particular Tcl_GetStringFromObj, to use that old
sl@0	1940	* internalRep.
sl@0	1941	*/
sl@0	1942
sl@0	1943	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	1944	oldTypePtr->freeIntRepProc(objPtr);
sl@0	1945	}
sl@0	1946
sl@0	1947	if (isWide) {
sl@0	1948	objPtr->internalRep.wideValue =
sl@0	1949	(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
sl@0	1950	objPtr->typePtr = &tclWideIntType;
sl@0	1951	} else {
sl@0	1952	objPtr->internalRep.longValue =
sl@0	1953	(isNegative ? -(long)newLong : (long)newLong);
sl@0	1954	objPtr->typePtr = &tclIntType;
sl@0	1955	}
sl@0	1956	return TCL_OK;
sl@0	1957	}
sl@0	1958
sl@0	1959	/*
sl@0	1960	*----------------------------------------------------------------------
sl@0	1961	*
sl@0	1962	* UpdateStringOfInt --
sl@0	1963	*
sl@0	1964	* Update the string representation for an integer object.
sl@0	1965	* Note: This procedure does not free an existing old string rep
sl@0	1966	* so storage will be lost if this has not already been done.
sl@0	1967	*
sl@0	1968	* Results:
sl@0	1969	* None.
sl@0	1970	*
sl@0	1971	* Side effects:
sl@0	1972	* The object's string is set to a valid string that results from
sl@0	1973	* the int-to-string conversion.
sl@0	1974	*
sl@0	1975	*----------------------------------------------------------------------
sl@0	1976	*/
sl@0	1977
sl@0	1978	static void
sl@0	1979	UpdateStringOfInt(objPtr)
sl@0	1980	register Tcl_Obj objPtr; / Int object whose string rep to update. */
sl@0	1981	{
sl@0	1982	char buffer[TCL_INTEGER_SPACE];
sl@0	1983	register int len;
sl@0	1984
sl@0	1985	len = TclFormatInt(buffer, objPtr->internalRep.longValue);
sl@0	1986
sl@0	1987	objPtr->bytes = ckalloc((unsigned) len + 1);
sl@0	1988	strcpy(objPtr->bytes, buffer);
sl@0	1989	objPtr->length = len;
sl@0	1990	}
sl@0	1991
sl@0	1992	/*
sl@0	1993	*----------------------------------------------------------------------
sl@0	1994	*
sl@0	1995	* Tcl_NewLongObj --
sl@0	1996	*
sl@0	1997	* If a client is compiled with TCL_MEM_DEBUG defined, calls to
sl@0	1998	* Tcl_NewLongObj to create a new long integer object end up calling
sl@0	1999	* the debugging procedure Tcl_DbNewLongObj instead.
sl@0	2000	*
sl@0	2001	* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
sl@0	2002	* calls to Tcl_NewLongObj result in a call to one of the two
sl@0	2003	* Tcl_NewLongObj implementations below. We provide two implementations
sl@0	2004	* so that the Tcl core can be compiled to do memory debugging of the
sl@0	2005	* core even if a client does not request it for itself.
sl@0	2006	*
sl@0	2007	* Integer and long integer objects share the same "integer" type
sl@0	2008	* implementation. We store all integers as longs and Tcl_GetIntFromObj
sl@0	2009	* checks whether the current value of the long can be represented by
sl@0	2010	* an int.
sl@0	2011	*
sl@0	2012	* Results:
sl@0	2013	* The newly created object is returned. This object will have an
sl@0	2014	* invalid string representation. The returned object has ref count 0.
sl@0	2015	*
sl@0	2016	* Side effects:
sl@0	2017	* None.
sl@0	2018	*
sl@0	2019	*----------------------------------------------------------------------
sl@0	2020	*/
sl@0	2021
sl@0	2022	#ifdef TCL_MEM_DEBUG
sl@0	2023	#undef Tcl_NewLongObj
sl@0	2024
sl@0	2025	EXPORT_C Tcl_Obj *
sl@0	2026	Tcl_NewLongObj(longValue)
sl@0	2027	register long longValue; /* Long integer used to initialize the
sl@0	2028	* new object. */
sl@0	2029	{
sl@0	2030	return Tcl_DbNewLongObj(longValue, "unknown", 0);
sl@0	2031	}
sl@0	2032
sl@0	2033	#else /* if not TCL_MEM_DEBUG */
sl@0	2034
sl@0	2035	EXPORT_C Tcl_Obj *
sl@0	2036	Tcl_NewLongObj(longValue)
sl@0	2037	register long longValue; /* Long integer used to initialize the
sl@0	2038	* new object. */
sl@0	2039	{
sl@0	2040	register Tcl_Obj *objPtr;
sl@0	2041
sl@0	2042	TclNewObj(objPtr);
sl@0	2043	objPtr->bytes = NULL;
sl@0	2044
sl@0	2045	objPtr->internalRep.longValue = longValue;
sl@0	2046	objPtr->typePtr = &tclIntType;
sl@0	2047	return objPtr;
sl@0	2048	}
sl@0	2049	#endif /* if TCL_MEM_DEBUG */
sl@0	2050
sl@0	2051	/*
sl@0	2052	*----------------------------------------------------------------------
sl@0	2053	*
sl@0	2054	* Tcl_DbNewLongObj --
sl@0	2055	*
sl@0	2056	* If a client is compiled with TCL_MEM_DEBUG defined, calls to
sl@0	2057	* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
sl@0	2058	* long integer objects end up calling the debugging procedure
sl@0	2059	* Tcl_DbNewLongObj instead. We provide two implementations of
sl@0	2060	* Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
sl@0	2061	* memory debugging of the core is independent of whether a client
sl@0	2062	* requests debugging for itself.
sl@0	2063	*
sl@0	2064	* When the core is compiled with TCL_MEM_DEBUG defined,
sl@0	2065	* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
sl@0	2066	* line number from its caller. This simplifies debugging since then
sl@0	2067	* the [memory active] command will report the caller's file name and
sl@0	2068	* line number when reporting objects that haven't been freed.
sl@0	2069	*
sl@0	2070	* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
sl@0	2071	* this procedure just returns the result of calling Tcl_NewLongObj.
sl@0	2072	*
sl@0	2073	* Results:
sl@0	2074	* The newly created long integer object is returned. This object
sl@0	2075	* will have an invalid string representation. The returned object has
sl@0	2076	* ref count 0.
sl@0	2077	*
sl@0	2078	* Side effects:
sl@0	2079	* Allocates memory.
sl@0	2080	*
sl@0	2081	*----------------------------------------------------------------------
sl@0	2082	*/
sl@0	2083
sl@0	2084	#ifdef TCL_MEM_DEBUG
sl@0	2085
sl@0	2086	EXPORT_C Tcl_Obj *
sl@0	2087	Tcl_DbNewLongObj(longValue, file, line)
sl@0	2088	register long longValue; /* Long integer used to initialize the
sl@0	2089	* new object. */
sl@0	2090	CONST char file; / The name of the source file calling this
sl@0	2091	* procedure; used for debugging. */
sl@0	2092	int line; /* Line number in the source file; used
sl@0	2093	* for debugging. */
sl@0	2094	{
sl@0	2095	register Tcl_Obj *objPtr;
sl@0	2096
sl@0	2097	TclDbNewObj(objPtr, file, line);
sl@0	2098	objPtr->bytes = NULL;
sl@0	2099
sl@0	2100	objPtr->internalRep.longValue = longValue;
sl@0	2101	objPtr->typePtr = &tclIntType;
sl@0	2102	return objPtr;
sl@0	2103	}
sl@0	2104
sl@0	2105	#else /* if not TCL_MEM_DEBUG */
sl@0	2106
sl@0	2107	EXPORT_C Tcl_Obj *
sl@0	2108	Tcl_DbNewLongObj(longValue, file, line)
sl@0	2109	register long longValue; /* Long integer used to initialize the
sl@0	2110	* new object. */
sl@0	2111	CONST char file; / The name of the source file calling this
sl@0	2112	* procedure; used for debugging. */
sl@0	2113	int line; /* Line number in the source file; used
sl@0	2114	* for debugging. */
sl@0	2115	{
sl@0	2116	return Tcl_NewLongObj(longValue);
sl@0	2117	}
sl@0	2118	#endif /* TCL_MEM_DEBUG */
sl@0	2119
sl@0	2120	/*
sl@0	2121	*----------------------------------------------------------------------
sl@0	2122	*
sl@0	2123	* Tcl_SetLongObj --
sl@0	2124	*
sl@0	2125	* Modify an object to be an integer object and to have the specified
sl@0	2126	* long integer value.
sl@0	2127	*
sl@0	2128	* Results:
sl@0	2129	* None.
sl@0	2130	*
sl@0	2131	* Side effects:
sl@0	2132	* The object's old string rep, if any, is freed. Also, any old
sl@0	2133	* internal rep is freed.
sl@0	2134	*
sl@0	2135	*----------------------------------------------------------------------
sl@0	2136	*/
sl@0	2137
sl@0	2138	EXPORT_C void
sl@0	2139	Tcl_SetLongObj(objPtr, longValue)
sl@0	2140	register Tcl_Obj objPtr; / Object whose internal rep to init. */
sl@0	2141	register long longValue; /* Long integer used to initialize the
sl@0	2142	* object's value. */
sl@0	2143	{
sl@0	2144	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	2145
sl@0	2146	if (Tcl_IsShared(objPtr)) {
sl@0	2147	panic("Tcl_SetLongObj called with shared object");
sl@0	2148	}
sl@0	2149
sl@0	2150	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	2151	oldTypePtr->freeIntRepProc(objPtr);
sl@0	2152	}
sl@0	2153
sl@0	2154	objPtr->internalRep.longValue = longValue;
sl@0	2155	objPtr->typePtr = &tclIntType;
sl@0	2156	Tcl_InvalidateStringRep(objPtr);
sl@0	2157	}
sl@0	2158
sl@0	2159	/*
sl@0	2160	*----------------------------------------------------------------------
sl@0	2161	*
sl@0	2162	* Tcl_GetLongFromObj --
sl@0	2163	*
sl@0	2164	* Attempt to return an long integer from the Tcl object "objPtr". If
sl@0	2165	* the object is not already an int object, an attempt will be made to
sl@0	2166	* convert it to one.
sl@0	2167	*
sl@0	2168	* Results:
sl@0	2169	* The return value is a standard Tcl object result. If an error occurs
sl@0	2170	* during conversion, an error message is left in the interpreter's
sl@0	2171	* result unless "interp" is NULL.
sl@0	2172	*
sl@0	2173	* Side effects:
sl@0	2174	* If the object is not already an int object, the conversion will free
sl@0	2175	* any old internal representation.
sl@0	2176	*
sl@0	2177	*----------------------------------------------------------------------
sl@0	2178	*/
sl@0	2179
sl@0	2180	EXPORT_C int
sl@0	2181	Tcl_GetLongFromObj(interp, objPtr, longPtr)
sl@0	2182	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	2183	register Tcl_Obj objPtr; / The object from which to get a long. */
sl@0	2184	register long longPtr; / Place to store resulting long. */
sl@0	2185	{
sl@0	2186	register int result;
sl@0	2187
sl@0	2188	if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
sl@0	2189	result = SetIntOrWideFromAny(interp, objPtr);
sl@0	2190	if (result != TCL_OK) {
sl@0	2191	return result;
sl@0	2192	}
sl@0	2193	}
sl@0	2194
sl@0	2195	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	2196	if (objPtr->typePtr == &tclWideIntType) {
sl@0	2197	/*
sl@0	2198	* If the object is already a wide integer, don't convert it.
sl@0	2199	* This code allows for any integer in the range -ULONG_MAX to
sl@0	2200	* ULONG_MAX to be converted to a long, ignoring overflow.
sl@0	2201	* The rule preserves existing semantics for conversion of
sl@0	2202	* integers on input, but avoids inadvertent demotion of
sl@0	2203	* wide integers to 32-bit ones in the internal rep.
sl@0	2204	*/
sl@0	2205
sl@0	2206	Tcl_WideInt w = objPtr->internalRep.wideValue;
sl@0	2207	if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) {
sl@0	2208	*longPtr = Tcl_WideAsLong(w);
sl@0	2209	return TCL_OK;
sl@0	2210	} else {
sl@0	2211	if (interp != NULL) {
sl@0	2212	Tcl_ResetResult(interp);
sl@0	2213	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	2214	"integer value too large to represent", -1);
sl@0	2215	}
sl@0	2216	return TCL_ERROR;
sl@0	2217	}
sl@0	2218	}
sl@0	2219	#endif
sl@0	2220
sl@0	2221	*longPtr = objPtr->internalRep.longValue;
sl@0	2222	return TCL_OK;
sl@0	2223	}
sl@0	2224
sl@0	2225	/*
sl@0	2226	*----------------------------------------------------------------------
sl@0	2227	*
sl@0	2228	* SetWideIntFromAny --
sl@0	2229	*
sl@0	2230	* Attempt to generate an integer internal form for the Tcl object
sl@0	2231	* "objPtr".
sl@0	2232	*
sl@0	2233	* Results:
sl@0	2234	* The return value is a standard object Tcl result. If an error occurs
sl@0	2235	* during conversion, an error message is left in the interpreter's
sl@0	2236	* result unless "interp" is NULL.
sl@0	2237	*
sl@0	2238	* Side effects:
sl@0	2239	* If no error occurs, an int is stored as "objPtr"s internal
sl@0	2240	* representation.
sl@0	2241	*
sl@0	2242	*----------------------------------------------------------------------
sl@0	2243	*/
sl@0	2244
sl@0	2245	static int
sl@0	2246	SetWideIntFromAny(interp, objPtr)
sl@0	2247	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	2248	register Tcl_Obj objPtr; / The object to convert. */
sl@0	2249	{
sl@0	2250	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	2251	Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	2252	char string, end;
sl@0	2253	int length;
sl@0	2254	register char *p;
sl@0	2255	Tcl_WideInt newWide;
sl@0	2256
sl@0	2257	/*
sl@0	2258	* Get the string representation. Make it up-to-date if necessary.
sl@0	2259	*/
sl@0	2260
sl@0	2261	p = string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	2262
sl@0	2263	/*
sl@0	2264	* Now parse "objPtr"s string as an int. We use an implementation here
sl@0	2265	* that doesn't report errors in interp if interp is NULL. Note: use
sl@0	2266	* strtoull instead of strtoll for integer conversions to allow full-size
sl@0	2267	* unsigned numbers, but don't depend on strtoull to handle sign
sl@0	2268	* characters; it won't in some implementations.
sl@0	2269	*/
sl@0	2270
sl@0	2271	errno = 0;
sl@0	2272	#ifdef TCL_STRTOUL_SIGN_CHECK
sl@0	2273	for ( ; isspace(UCHAR(p)); p++) { / INTL: ISO space. */
sl@0	2274	/* Empty loop body. */
sl@0	2275	}
sl@0	2276	if (*p == '-') {
sl@0	2277	p++;
sl@0	2278	newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
sl@0	2279	} else if (*p == '+') {
sl@0	2280	p++;
sl@0	2281	newWide = strtoull(p, &end, 0);
sl@0	2282	} else
sl@0	2283	#else
sl@0	2284	newWide = strtoull(p, &end, 0);
sl@0	2285	#endif
sl@0	2286	if (end == p) {
sl@0	2287	badInteger:
sl@0	2288	if (interp != NULL) {
sl@0	2289	/*
sl@0	2290	* Must copy string before resetting the result in case a caller
sl@0	2291	* is trying to convert the interpreter's result to an int.
sl@0	2292	*/
sl@0	2293
sl@0	2294	char buf[100];
sl@0	2295	sprintf(buf, "expected integer but got \"%.50s\"", string);
sl@0	2296	Tcl_ResetResult(interp);
sl@0	2297	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0	2298	TclCheckBadOctal(interp, string);
sl@0	2299	}
sl@0	2300	return TCL_ERROR;
sl@0	2301	}
sl@0	2302	if (errno == ERANGE) {
sl@0	2303	if (interp != NULL) {
sl@0	2304	char *s = "integer value too large to represent";
sl@0	2305	Tcl_ResetResult(interp);
sl@0	2306	Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
sl@0	2307	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
sl@0	2308	}
sl@0	2309	return TCL_ERROR;
sl@0	2310	}
sl@0	2311
sl@0	2312	/*
sl@0	2313	* Make sure that the string has no garbage after the end of the int.
sl@0	2314	*/
sl@0	2315
sl@0	2316	while ((end < (string+length))
sl@0	2317	&& isspace(UCHAR(end))) { / INTL: ISO space. */
sl@0	2318	end++;
sl@0	2319	}
sl@0	2320	if (end != (string+length)) {
sl@0	2321	goto badInteger;
sl@0	2322	}
sl@0	2323
sl@0	2324	/*
sl@0	2325	* The conversion to int succeeded. Free the old internalRep before
sl@0	2326	* setting the new one. We do this as late as possible to allow the
sl@0	2327	* conversion code, in particular Tcl_GetStringFromObj, to use that old
sl@0	2328	* internalRep.
sl@0	2329	*/
sl@0	2330
sl@0	2331	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	2332	oldTypePtr->freeIntRepProc(objPtr);
sl@0	2333	}
sl@0	2334
sl@0	2335	objPtr->internalRep.wideValue = newWide;
sl@0	2336	#else
sl@0	2337	if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
sl@0	2338	return TCL_ERROR;
sl@0	2339	}
sl@0	2340	#endif
sl@0	2341	objPtr->typePtr = &tclWideIntType;
sl@0	2342	return TCL_OK;
sl@0	2343	}
sl@0	2344
sl@0	2345	/*
sl@0	2346	*----------------------------------------------------------------------
sl@0	2347	*
sl@0	2348	* UpdateStringOfWideInt --
sl@0	2349	*
sl@0	2350	* Update the string representation for a wide integer object.
sl@0	2351	* Note: This procedure does not free an existing old string rep
sl@0	2352	* so storage will be lost if this has not already been done.
sl@0	2353	*
sl@0	2354	* Results:
sl@0	2355	* None.
sl@0	2356	*
sl@0	2357	* Side effects:
sl@0	2358	* The object's string is set to a valid string that results from
sl@0	2359	* the wideInt-to-string conversion.
sl@0	2360	*
sl@0	2361	*----------------------------------------------------------------------
sl@0	2362	*/
sl@0	2363
sl@0	2364	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	2365	static void
sl@0	2366	UpdateStringOfWideInt(objPtr)
sl@0	2367	register Tcl_Obj objPtr; / Int object whose string rep to update. */
sl@0	2368	{
sl@0	2369	char buffer[TCL_INTEGER_SPACE+2];
sl@0	2370	register unsigned len;
sl@0	2371	register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
sl@0	2372
sl@0	2373	/*
sl@0	2374	* Note that sprintf will generate a compiler warning under
sl@0	2375	* Mingw claiming %I64 is an unknown format specifier.
sl@0	2376	* Just ignore this warning. We can't use %L as the format
sl@0	2377	* specifier since that gets printed as a 32 bit value.
sl@0	2378	*/
sl@0	2379	sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
sl@0	2380	len = strlen(buffer);
sl@0	2381	objPtr->bytes = ckalloc((unsigned) len + 1);
sl@0	2382	memcpy(objPtr->bytes, buffer, len + 1);
sl@0	2383	objPtr->length = len;
sl@0	2384	}
sl@0	2385	#endif /* TCL_WIDE_INT_IS_LONG */
sl@0	2386
sl@0	2387	/*
sl@0	2388	*----------------------------------------------------------------------
sl@0	2389	*
sl@0	2390	* Tcl_NewWideIntObj --
sl@0	2391	*
sl@0	2392	* If a client is compiled with TCL_MEM_DEBUG defined, calls to
sl@0	2393	* Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
sl@0	2394	* the debugging procedure Tcl_DbNewWideIntObj instead.
sl@0	2395	*
sl@0	2396	* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
sl@0	2397	* calls to Tcl_NewWideIntObj result in a call to one of the two
sl@0	2398	* Tcl_NewWideIntObj implementations below. We provide two implementations
sl@0	2399	* so that the Tcl core can be compiled to do memory debugging of the
sl@0	2400	* core even if a client does not request it for itself.
sl@0	2401	*
sl@0	2402	* Results:
sl@0	2403	* The newly created object is returned. This object will have an
sl@0	2404	* invalid string representation. The returned object has ref count 0.
sl@0	2405	*
sl@0	2406	* Side effects:
sl@0	2407	* None.
sl@0	2408	*
sl@0	2409	*----------------------------------------------------------------------
sl@0	2410	*/
sl@0	2411
sl@0	2412	#ifdef TCL_MEM_DEBUG
sl@0	2413	#undef Tcl_NewWideIntObj
sl@0	2414
sl@0	2415	EXPORT_C Tcl_Obj *
sl@0	2416	Tcl_NewWideIntObj(wideValue)
sl@0	2417	register Tcl_WideInt wideValue; /* Wide integer used to initialize
sl@0	2418	* the new object. */
sl@0	2419	{
sl@0	2420	return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
sl@0	2421	}
sl@0	2422
sl@0	2423	#else /* if not TCL_MEM_DEBUG */
sl@0	2424
sl@0	2425	EXPORT_C Tcl_Obj *
sl@0	2426	Tcl_NewWideIntObj(wideValue)
sl@0	2427	register Tcl_WideInt wideValue; /* Wide integer used to initialize
sl@0	2428	* the new object. */
sl@0	2429	{
sl@0	2430	register Tcl_Obj *objPtr;
sl@0	2431
sl@0	2432	TclNewObj(objPtr);
sl@0	2433	objPtr->bytes = NULL;
sl@0	2434
sl@0	2435	objPtr->internalRep.wideValue = wideValue;
sl@0	2436	objPtr->typePtr = &tclWideIntType;
sl@0	2437	return objPtr;
sl@0	2438	}
sl@0	2439	#endif /* if TCL_MEM_DEBUG */
sl@0	2440
sl@0	2441	/*
sl@0	2442	*----------------------------------------------------------------------
sl@0	2443	*
sl@0	2444	* Tcl_DbNewWideIntObj --
sl@0	2445	*
sl@0	2446	* If a client is compiled with TCL_MEM_DEBUG defined, calls to
sl@0	2447	* Tcl_NewWideIntObj to create new wide integer end up calling
sl@0	2448	* the debugging procedure Tcl_DbNewWideIntObj instead. We
sl@0	2449	* provide two implementations of Tcl_DbNewWideIntObj so that
sl@0	2450	* whether the Tcl core is compiled to do memory debugging of the
sl@0	2451	* core is independent of whether a client requests debugging for
sl@0	2452	* itself.
sl@0	2453	*
sl@0	2454	* When the core is compiled with TCL_MEM_DEBUG defined,
sl@0	2455	* Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file
sl@0	2456	* name and line number from its caller. This simplifies
sl@0	2457	* debugging since then the checkmem command will report the
sl@0	2458	* caller's file name and line number when reporting objects that
sl@0	2459	* haven't been freed.
sl@0	2460	*
sl@0	2461	* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
sl@0	2462	* this procedure just returns the result of calling Tcl_NewWideIntObj.
sl@0	2463	*
sl@0	2464	* Results:
sl@0	2465	* The newly created wide integer object is returned. This object
sl@0	2466	* will have an invalid string representation. The returned object has
sl@0	2467	* ref count 0.
sl@0	2468	*
sl@0	2469	* Side effects:
sl@0	2470	* Allocates memory.
sl@0	2471	*
sl@0	2472	*----------------------------------------------------------------------
sl@0	2473	*/
sl@0	2474
sl@0	2475	#ifdef TCL_MEM_DEBUG
sl@0	2476
sl@0	2477	EXPORT_C Tcl_Obj *
sl@0	2478	Tcl_DbNewWideIntObj(wideValue, file, line)
sl@0	2479	register Tcl_WideInt wideValue; /* Wide integer used to initialize
sl@0	2480	* the new object. */
sl@0	2481	CONST char file; / The name of the source file
sl@0	2482	* calling this procedure; used for
sl@0	2483	* debugging. */
sl@0	2484	int line; /* Line number in the source file;
sl@0	2485	* used for debugging. */
sl@0	2486	{
sl@0	2487	register Tcl_Obj *objPtr;
sl@0	2488
sl@0	2489	TclDbNewObj(objPtr, file, line);
sl@0	2490	objPtr->bytes = NULL;
sl@0	2491
sl@0	2492	objPtr->internalRep.wideValue = wideValue;
sl@0	2493	objPtr->typePtr = &tclWideIntType;
sl@0	2494	return objPtr;
sl@0	2495	}
sl@0	2496
sl@0	2497	#else /* if not TCL_MEM_DEBUG */
sl@0	2498
sl@0	2499	EXPORT_C Tcl_Obj *
sl@0	2500	Tcl_DbNewWideIntObj(wideValue, file, line)
sl@0	2501	register Tcl_WideInt wideValue; /* Long integer used to initialize
sl@0	2502	* the new object. */
sl@0	2503	CONST char file; / The name of the source file
sl@0	2504	* calling this procedure; used for
sl@0	2505	* debugging. */
sl@0	2506	int line; /* Line number in the source file;
sl@0	2507	* used for debugging. */
sl@0	2508	{
sl@0	2509	return Tcl_NewWideIntObj(wideValue);
sl@0	2510	}
sl@0	2511	#endif /* TCL_MEM_DEBUG */
sl@0	2512
sl@0	2513	/*
sl@0	2514	*----------------------------------------------------------------------
sl@0	2515	*
sl@0	2516	* Tcl_SetWideIntObj --
sl@0	2517	*
sl@0	2518	* Modify an object to be a wide integer object and to have the
sl@0	2519	* specified wide integer value.
sl@0	2520	*
sl@0	2521	* Results:
sl@0	2522	* None.
sl@0	2523	*
sl@0	2524	* Side effects:
sl@0	2525	* The object's old string rep, if any, is freed. Also, any old
sl@0	2526	* internal rep is freed.
sl@0	2527	*
sl@0	2528	*----------------------------------------------------------------------
sl@0	2529	*/
sl@0	2530
sl@0	2531	EXPORT_C void
sl@0	2532	Tcl_SetWideIntObj(objPtr, wideValue)
sl@0	2533	register Tcl_Obj objPtr; / Object w. internal rep to init. */
sl@0	2534	register Tcl_WideInt wideValue; /* Wide integer used to initialize
sl@0	2535	* the object's value. */
sl@0	2536	{
sl@0	2537	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	2538
sl@0	2539	if (Tcl_IsShared(objPtr)) {
sl@0	2540	panic("Tcl_SetWideIntObj called with shared object");
sl@0	2541	}
sl@0	2542
sl@0	2543	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	2544	oldTypePtr->freeIntRepProc(objPtr);
sl@0	2545	}
sl@0	2546
sl@0	2547	objPtr->internalRep.wideValue = wideValue;
sl@0	2548	objPtr->typePtr = &tclWideIntType;
sl@0	2549	Tcl_InvalidateStringRep(objPtr);
sl@0	2550	}
sl@0	2551
sl@0	2552	/*
sl@0	2553	*----------------------------------------------------------------------
sl@0	2554	*
sl@0	2555	* Tcl_GetWideIntFromObj --
sl@0	2556	*
sl@0	2557	* Attempt to return a wide integer from the Tcl object "objPtr". If
sl@0	2558	* the object is not already a wide int object, an attempt will be made
sl@0	2559	* to convert it to one.
sl@0	2560	*
sl@0	2561	* Results:
sl@0	2562	* The return value is a standard Tcl object result. If an error occurs
sl@0	2563	* during conversion, an error message is left in the interpreter's
sl@0	2564	* result unless "interp" is NULL.
sl@0	2565	*
sl@0	2566	* Side effects:
sl@0	2567	* If the object is not already an int object, the conversion will free
sl@0	2568	* any old internal representation.
sl@0	2569	*
sl@0	2570	*----------------------------------------------------------------------
sl@0	2571	*/
sl@0	2572
sl@0	2573	EXPORT_C int
sl@0	2574	Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
sl@0	2575	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	2576	register Tcl_Obj objPtr; / Object from which to get a wide int. */
sl@0	2577	register Tcl_WideInt wideIntPtr; / Place to store resulting long. */
sl@0	2578	{
sl@0	2579	register int result;
sl@0	2580
sl@0	2581	if (objPtr->typePtr == &tclWideIntType) {
sl@0	2582	gotWide:
sl@0	2583	*wideIntPtr = objPtr->internalRep.wideValue;
sl@0	2584	return TCL_OK;
sl@0	2585	}
sl@0	2586	if (objPtr->typePtr == &tclIntType) {
sl@0	2587	/*
sl@0	2588	* This cast is safe; all valid ints/longs are wides.
sl@0	2589	*/
sl@0	2590
sl@0	2591	objPtr->internalRep.wideValue =
sl@0	2592	Tcl_LongAsWide(objPtr->internalRep.longValue);
sl@0	2593	objPtr->typePtr = &tclWideIntType;
sl@0	2594	goto gotWide;
sl@0	2595	}
sl@0	2596	result = SetWideIntFromAny(interp, objPtr);
sl@0	2597	if (result == TCL_OK) {
sl@0	2598	*wideIntPtr = objPtr->internalRep.wideValue;
sl@0	2599	}
sl@0	2600	return result;
sl@0	2601	}
sl@0	2602
sl@0	2603	/*
sl@0	2604	*----------------------------------------------------------------------
sl@0	2605	*
sl@0	2606	* Tcl_DbIncrRefCount --
sl@0	2607	*
sl@0	2608	* This procedure is normally called when debugging: i.e., when
sl@0	2609	* TCL_MEM_DEBUG is defined. This checks to see whether or not
sl@0	2610	* the memory has been freed before incrementing the ref count.
sl@0	2611	*
sl@0	2612	* When TCL_MEM_DEBUG is not defined, this procedure just increments
sl@0	2613	* the reference count of the object.
sl@0	2614	*
sl@0	2615	* Results:
sl@0	2616	* None.
sl@0	2617	*
sl@0	2618	* Side effects:
sl@0	2619	* The object's ref count is incremented.
sl@0	2620	*
sl@0	2621	*----------------------------------------------------------------------
sl@0	2622	*/
sl@0	2623
sl@0	2624	EXPORT_C void
sl@0	2625	Tcl_DbIncrRefCount(objPtr, file, line)
sl@0	2626	register Tcl_Obj objPtr; / The object we are registering a
sl@0	2627	* reference to. */
sl@0	2628	CONST char file; / The name of the source file calling this
sl@0	2629	* procedure; used for debugging. */
sl@0	2630	int line; /* Line number in the source file; used
sl@0	2631	* for debugging. */
sl@0	2632	{
sl@0	2633	#ifdef TCL_MEM_DEBUG
sl@0	2634	if (objPtr->refCount == 0x61616161) {
sl@0	2635	fprintf(stderr, "file = %s, line = %d\n", file, line);
sl@0	2636	fflush(stderr);
sl@0	2637	panic("Trying to increment refCount of previously disposed object.");
sl@0	2638	}
sl@0	2639	#endif
sl@0	2640	++(objPtr)->refCount;
sl@0	2641	}
sl@0	2642
sl@0	2643	/*
sl@0	2644	*----------------------------------------------------------------------
sl@0	2645	*
sl@0	2646	* Tcl_DbDecrRefCount --
sl@0	2647	*
sl@0	2648	* This procedure is normally called when debugging: i.e., when
sl@0	2649	* TCL_MEM_DEBUG is defined. This checks to see whether or not
sl@0	2650	* the memory has been freed before decrementing the ref count.
sl@0	2651	*
sl@0	2652	* When TCL_MEM_DEBUG is not defined, this procedure just decrements
sl@0	2653	* the reference count of the object.
sl@0	2654	*
sl@0	2655	* Results:
sl@0	2656	* None.
sl@0	2657	*
sl@0	2658	* Side effects:
sl@0	2659	* The object's ref count is incremented.
sl@0	2660	*
sl@0	2661	*----------------------------------------------------------------------
sl@0	2662	*/
sl@0	2663
sl@0	2664	EXPORT_C void
sl@0	2665	Tcl_DbDecrRefCount(objPtr, file, line)
sl@0	2666	register Tcl_Obj objPtr; / The object we are releasing a reference
sl@0	2667	* to. */
sl@0	2668	CONST char file; / The name of the source file calling this
sl@0	2669	* procedure; used for debugging. */
sl@0	2670	int line; /* Line number in the source file; used
sl@0	2671	* for debugging. */
sl@0	2672	{
sl@0	2673	#ifdef TCL_MEM_DEBUG
sl@0	2674	if (objPtr->refCount == 0x61616161) {
sl@0	2675	fprintf(stderr, "file = %s, line = %d\n", file, line);
sl@0	2676	fflush(stderr);
sl@0	2677	panic("Trying to decrement refCount of previously disposed object.");
sl@0	2678	}
sl@0	2679	#endif
sl@0	2680	if (--(objPtr)->refCount <= 0) {
sl@0	2681	TclFreeObj(objPtr);
sl@0	2682	}
sl@0	2683	}
sl@0	2684
sl@0	2685	/*
sl@0	2686	*----------------------------------------------------------------------
sl@0	2687	*
sl@0	2688	* Tcl_DbIsShared --
sl@0	2689	*
sl@0	2690	* This procedure is normally called when debugging: i.e., when
sl@0	2691	* TCL_MEM_DEBUG is defined. It tests whether the object has a ref
sl@0	2692	* count greater than one.
sl@0	2693	*
sl@0	2694	* When TCL_MEM_DEBUG is not defined, this procedure just tests
sl@0	2695	* if the object has a ref count greater than one.
sl@0	2696	*
sl@0	2697	* Results:
sl@0	2698	* None.
sl@0	2699	*
sl@0	2700	* Side effects:
sl@0	2701	* None.
sl@0	2702	*
sl@0	2703	*----------------------------------------------------------------------
sl@0	2704	*/
sl@0	2705
sl@0	2706	EXPORT_C int
sl@0	2707	Tcl_DbIsShared(objPtr, file, line)
sl@0	2708	register Tcl_Obj objPtr; / The object to test for being shared. */
sl@0	2709	CONST char file; / The name of the source file calling this
sl@0	2710	* procedure; used for debugging. */
sl@0	2711	int line; /* Line number in the source file; used
sl@0	2712	* for debugging. */
sl@0	2713	{
sl@0	2714	#ifdef TCL_MEM_DEBUG
sl@0	2715	if (objPtr->refCount == 0x61616161) {
sl@0	2716	fprintf(stderr, "file = %s, line = %d\n", file, line);
sl@0	2717	fflush(stderr);
sl@0	2718	panic("Trying to check whether previously disposed object is shared.");
sl@0	2719	}
sl@0	2720	#endif
sl@0	2721	#ifdef TCL_COMPILE_STATS
sl@0	2722	Tcl_MutexLock(&tclObjMutex);
sl@0	2723	if ((objPtr)->refCount <= 1) {
sl@0	2724	tclObjsShared[1]++;
sl@0	2725	} else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
sl@0	2726	tclObjsShared[(objPtr)->refCount]++;
sl@0	2727	} else {
sl@0	2728	tclObjsShared[0]++;
sl@0	2729	}
sl@0	2730	Tcl_MutexUnlock(&tclObjMutex);
sl@0	2731	#endif
sl@0	2732	return ((objPtr)->refCount > 1);
sl@0	2733	}
sl@0	2734
sl@0	2735	/*
sl@0	2736	*----------------------------------------------------------------------
sl@0	2737	*
sl@0	2738	* Tcl_InitObjHashTable --
sl@0	2739	*
sl@0	2740	* Given storage for a hash table, set up the fields to prepare
sl@0	2741	* the hash table for use, the keys are Tcl_Obj *.
sl@0	2742	*
sl@0	2743	* Results:
sl@0	2744	* None.
sl@0	2745	*
sl@0	2746	* Side effects:
sl@0	2747	* TablePtr is now ready to be passed to Tcl_FindHashEntry and
sl@0	2748	* Tcl_CreateHashEntry.
sl@0	2749	*
sl@0	2750	*----------------------------------------------------------------------
sl@0	2751	*/
sl@0	2752
sl@0	2753	EXPORT_C void
sl@0	2754	Tcl_InitObjHashTable(tablePtr)
sl@0	2755	register Tcl_HashTable tablePtr; / Pointer to table record, which
sl@0	2756	* is supplied by the caller. */
sl@0	2757	{
sl@0	2758	Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
sl@0	2759	&tclObjHashKeyType);
sl@0	2760	}
sl@0	2761
sl@0	2762	/*
sl@0	2763	*----------------------------------------------------------------------
sl@0	2764	*
sl@0	2765	* AllocObjEntry --
sl@0	2766	*
sl@0	2767	* Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
sl@0	2768	*
sl@0	2769	* Results:
sl@0	2770	* The return value is a pointer to the created entry.
sl@0	2771	*
sl@0	2772	* Side effects:
sl@0	2773	* Increments the reference count on the object.
sl@0	2774	*
sl@0	2775	*----------------------------------------------------------------------
sl@0	2776	*/
sl@0	2777
sl@0	2778	static Tcl_HashEntry *
sl@0	2779	AllocObjEntry(tablePtr, keyPtr)
sl@0	2780	Tcl_HashTable tablePtr; / Hash table. */
sl@0	2781	VOID keyPtr; / Key to store in the hash table entry. */
sl@0	2782	{
sl@0	2783	Tcl_Obj objPtr = (Tcl_Obj ) keyPtr;
sl@0	2784	Tcl_HashEntry *hPtr;
sl@0	2785
sl@0	2786	hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
sl@0	2787	hPtr->key.oneWordValue = (char *) objPtr;
sl@0	2788	Tcl_IncrRefCount (objPtr);
sl@0	2789
sl@0	2790	return hPtr;
sl@0	2791	}
sl@0	2792
sl@0	2793	/*
sl@0	2794	*----------------------------------------------------------------------
sl@0	2795	*
sl@0	2796	* CompareObjKeys --
sl@0	2797	*
sl@0	2798	* Compares two Tcl_Obj * keys.
sl@0	2799	*
sl@0	2800	* Results:
sl@0	2801	* The return value is 0 if they are different and 1 if they are
sl@0	2802	* the same.
sl@0	2803	*
sl@0	2804	* Side effects:
sl@0	2805	* None.
sl@0	2806	*
sl@0	2807	*----------------------------------------------------------------------
sl@0	2808	*/
sl@0	2809
sl@0	2810	static int
sl@0	2811	CompareObjKeys(keyPtr, hPtr)
sl@0	2812	VOID keyPtr; / New key to compare. */
sl@0	2813	Tcl_HashEntry hPtr; / Existing key to compare. */
sl@0	2814	{
sl@0	2815	Tcl_Obj objPtr1 = (Tcl_Obj ) keyPtr;
sl@0	2816	Tcl_Obj objPtr2 = (Tcl_Obj ) hPtr->key.oneWordValue;
sl@0	2817	register CONST char p1, p2;
sl@0	2818	register int l1, l2;
sl@0	2819
sl@0	2820	/*
sl@0	2821	* If the object pointers are the same then they match.
sl@0	2822	*/
sl@0	2823	if (objPtr1 == objPtr2) {
sl@0	2824	return 1;
sl@0	2825	}
sl@0	2826
sl@0	2827	/*
sl@0	2828	* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
sl@0	2829	* in a register.
sl@0	2830	*/
sl@0	2831	p1 = TclGetString(objPtr1);
sl@0	2832	l1 = objPtr1->length;
sl@0	2833	p2 = TclGetString(objPtr2);
sl@0	2834	l2 = objPtr2->length;
sl@0	2835
sl@0	2836	/*
sl@0	2837	* Only compare if the string representations are of the same length.
sl@0	2838	*/
sl@0	2839	if (l1 == l2) {
sl@0	2840	for (;; p1++, p2++, l1--) {
sl@0	2841	if (p1 != p2) {
sl@0	2842	break;
sl@0	2843	}
sl@0	2844	if (l1 == 0) {
sl@0	2845	return 1;
sl@0	2846	}
sl@0	2847	}
sl@0	2848	}
sl@0	2849
sl@0	2850	return 0;
sl@0	2851	}
sl@0	2852
sl@0	2853	/*
sl@0	2854	*----------------------------------------------------------------------
sl@0	2855	*
sl@0	2856	* FreeObjEntry --
sl@0	2857	*
sl@0	2858	* Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
sl@0	2859	*
sl@0	2860	* Results:
sl@0	2861	* The return value is a pointer to the created entry.
sl@0	2862	*
sl@0	2863	* Side effects:
sl@0	2864	* Decrements the reference count of the object.
sl@0	2865	*
sl@0	2866	*----------------------------------------------------------------------
sl@0	2867	*/
sl@0	2868
sl@0	2869	static void
sl@0	2870	FreeObjEntry(hPtr)
sl@0	2871	Tcl_HashEntry hPtr; / Hash entry to free. */
sl@0	2872	{
sl@0	2873	Tcl_Obj objPtr = (Tcl_Obj ) hPtr->key.oneWordValue;
sl@0	2874
sl@0	2875	Tcl_DecrRefCount (objPtr);
sl@0	2876	ckfree ((char *) hPtr);
sl@0	2877	}
sl@0	2878
sl@0	2879	/*
sl@0	2880	*----------------------------------------------------------------------
sl@0	2881	*
sl@0	2882	* HashObjKey --
sl@0	2883	*
sl@0	2884	* Compute a one-word summary of the string representation of the
sl@0	2885	* Tcl_Obj, which can be used to generate a hash index.
sl@0	2886	*
sl@0	2887	* Results:
sl@0	2888	* The return value is a one-word summary of the information in
sl@0	2889	* the string representation of the Tcl_Obj.
sl@0	2890	*
sl@0	2891	* Side effects:
sl@0	2892	* None.
sl@0	2893	*
sl@0	2894	*----------------------------------------------------------------------
sl@0	2895	*/
sl@0	2896
sl@0	2897	static unsigned int
sl@0	2898	HashObjKey(tablePtr, keyPtr)
sl@0	2899	Tcl_HashTable tablePtr; / Hash table. */
sl@0	2900	VOID keyPtr; / Key from which to compute hash value. */
sl@0	2901	{
sl@0	2902	Tcl_Obj objPtr = (Tcl_Obj ) keyPtr;
sl@0	2903	CONST char *string = TclGetString(objPtr);
sl@0	2904	int length = objPtr->length;
sl@0	2905	unsigned int result;
sl@0	2906	int i;
sl@0	2907
sl@0	2908	/*
sl@0	2909	* I tried a zillion different hash functions and asked many other
sl@0	2910	* people for advice. Many people had their own favorite functions,
sl@0	2911	* all different, but no-one had much idea why they were good ones.
sl@0	2912	* I chose the one below (multiply by 9 and add new character)
sl@0	2913	* because of the following reasons:
sl@0	2914	*
sl@0	2915	* 1. Multiplying by 10 is perfect for keys that are decimal strings,
sl@0	2916	* and multiplying by 9 is just about as good.
sl@0	2917	* 2. Times-9 is (shift-left-3) plus (old). This means that each
sl@0	2918	* character's bits hang around in the low-order bits of the
sl@0	2919	* hash value for ever, plus they spread fairly rapidly up to
sl@0	2920	* the high-order bits to fill out the hash value. This seems
sl@0	2921	* works well both for decimal and non-decimal strings.
sl@0	2922	*/
sl@0	2923
sl@0	2924	result = 0;
sl@0	2925	for (i=0 ; i<length ; i++) {
sl@0	2926	result += (result<<3) + string[i];
sl@0	2927	}
sl@0	2928	return result;
sl@0	2929	}
sl@0	2930
sl@0	2931	/*
sl@0	2932	*----------------------------------------------------------------------
sl@0	2933	*
sl@0	2934	* Tcl_GetCommandFromObj --
sl@0	2935	*
sl@0	2936	* Returns the command specified by the name in a Tcl_Obj.
sl@0	2937	*
sl@0	2938	* Results:
sl@0	2939	* Returns a token for the command if it is found. Otherwise, if it
sl@0	2940	* can't be found or there is an error, returns NULL.
sl@0	2941	*
sl@0	2942	* Side effects:
sl@0	2943	* May update the internal representation for the object, caching
sl@0	2944	* the command reference so that the next time this procedure is
sl@0	2945	* called with the same object, the command can be found quickly.
sl@0	2946	*
sl@0	2947	*----------------------------------------------------------------------
sl@0	2948	*/
sl@0	2949
sl@0	2950	Tcl_Command
sl@0	2951	Tcl_GetCommandFromObj(interp, objPtr)
sl@0	2952	Tcl_Interp interp; / The interpreter in which to resolve the
sl@0	2953	* command and to report errors. */
sl@0	2954	register Tcl_Obj objPtr; / The object containing the command's
sl@0	2955	* name. If the name starts with "::", will
sl@0	2956	* be looked up in global namespace. Else,
sl@0	2957	* looked up first in the current namespace,
sl@0	2958	* then in global namespace. */
sl@0	2959	{
sl@0	2960	Interp iPtr = (Interp ) interp;
sl@0	2961	register ResolvedCmdName *resPtr;
sl@0	2962	register Command *cmdPtr;
sl@0	2963	Namespace *currNsPtr;
sl@0	2964	int result;
sl@0	2965	CallFrame *savedFramePtr;
sl@0	2966	char *name;
sl@0	2967
sl@0	2968	/*
sl@0	2969	* If the variable name is fully qualified, do as if the lookup were
sl@0	2970	* done from the global namespace; this helps avoid repeated lookups
sl@0	2971	* of fully qualified names. It costs close to nothing, and may be very
sl@0	2972	* helpful for OO applications which pass along a command name ("this"),
sl@0	2973	* [Patch 456668]
sl@0	2974	*/
sl@0	2975
sl@0	2976	savedFramePtr = iPtr->varFramePtr;
sl@0	2977	name = Tcl_GetString(objPtr);
sl@0	2978	if ((name++ == ':') && (name == ':')) {
sl@0	2979	iPtr->varFramePtr = NULL;
sl@0	2980	}
sl@0	2981
sl@0	2982	/*
sl@0	2983	* Get the internal representation, converting to a command type if
sl@0	2984	* needed. The internal representation is a ResolvedCmdName that points
sl@0	2985	* to the actual command.
sl@0	2986	*/
sl@0	2987
sl@0	2988	if (objPtr->typePtr != &tclCmdNameType) {
sl@0	2989	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
sl@0	2990	if (result != TCL_OK) {
sl@0	2991	iPtr->varFramePtr = savedFramePtr;
sl@0	2992	return (Tcl_Command) NULL;
sl@0	2993	}
sl@0	2994	}
sl@0	2995	resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
sl@0	2996
sl@0	2997	/*
sl@0	2998	* Get the current namespace.
sl@0	2999	*/
sl@0	3000
sl@0	3001	if (iPtr->varFramePtr != NULL) {
sl@0	3002	currNsPtr = iPtr->varFramePtr->nsPtr;
sl@0	3003	} else {
sl@0	3004	currNsPtr = iPtr->globalNsPtr;
sl@0	3005	}
sl@0	3006
sl@0	3007	/*
sl@0	3008	* Check the context namespace and the namespace epoch of the resolved
sl@0	3009	* symbol to make sure that it is fresh. If not, then force another
sl@0	3010	* conversion to the command type, to discard the old rep and create a
sl@0	3011	* new one. Note that we verify that the namespace id of the context
sl@0	3012	* namespace is the same as the one we cached; this insures that the
sl@0	3013	* namespace wasn't deleted and a new one created at the same address
sl@0	3014	* with the same command epoch.
sl@0	3015	*/
sl@0	3016
sl@0	3017	cmdPtr = NULL;
sl@0	3018	if ((resPtr != NULL)
sl@0	3019	&& (resPtr->refNsPtr == currNsPtr)
sl@0	3020	&& (resPtr->refNsId == currNsPtr->nsId)
sl@0	3021	&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
sl@0	3022	cmdPtr = resPtr->cmdPtr;
sl@0	3023	if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
sl@0	3024	cmdPtr = NULL;
sl@0	3025	}
sl@0	3026	}
sl@0	3027
sl@0	3028	if (cmdPtr == NULL) {
sl@0	3029	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
sl@0	3030	if (result != TCL_OK) {
sl@0	3031	iPtr->varFramePtr = savedFramePtr;
sl@0	3032	return (Tcl_Command) NULL;
sl@0	3033	}
sl@0	3034	resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
sl@0	3035	if (resPtr != NULL) {
sl@0	3036	cmdPtr = resPtr->cmdPtr;
sl@0	3037	}
sl@0	3038	}
sl@0	3039	iPtr->varFramePtr = savedFramePtr;
sl@0	3040	return (Tcl_Command) cmdPtr;
sl@0	3041	}
sl@0	3042
sl@0	3043	/*
sl@0	3044	*----------------------------------------------------------------------
sl@0	3045	*
sl@0	3046	* TclSetCmdNameObj --
sl@0	3047	*
sl@0	3048	* Modify an object to be an CmdName object that refers to the argument
sl@0	3049	* Command structure.
sl@0	3050	*
sl@0	3051	* Results:
sl@0	3052	* None.
sl@0	3053	*
sl@0	3054	* Side effects:
sl@0	3055	* The object's old internal rep is freed. It's string rep is not
sl@0	3056	* changed. The refcount in the Command structure is incremented to
sl@0	3057	* keep it from being freed if the command is later deleted until
sl@0	3058	* TclExecuteByteCode has a chance to recognize that it was deleted.
sl@0	3059	*
sl@0	3060	*----------------------------------------------------------------------
sl@0	3061	*/
sl@0	3062
sl@0	3063	void
sl@0	3064	TclSetCmdNameObj(interp, objPtr, cmdPtr)
sl@0	3065	Tcl_Interp interp; / Points to interpreter containing command
sl@0	3066	* that should be cached in objPtr. */
sl@0	3067	register Tcl_Obj objPtr; / Points to Tcl object to be changed to
sl@0	3068	* a CmdName object. */
sl@0	3069	Command cmdPtr; / Points to Command structure that the
sl@0	3070	* CmdName object should refer to. */
sl@0	3071	{
sl@0	3072	Interp iPtr = (Interp ) interp;
sl@0	3073	register ResolvedCmdName *resPtr;
sl@0	3074	Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	3075	register Namespace *currNsPtr;
sl@0	3076
sl@0	3077	if (oldTypePtr == &tclCmdNameType) {
sl@0	3078	return;
sl@0	3079	}
sl@0	3080
sl@0	3081	/*
sl@0	3082	* Get the current namespace.
sl@0	3083	*/
sl@0	3084
sl@0	3085	if (iPtr->varFramePtr != NULL) {
sl@0	3086	currNsPtr = iPtr->varFramePtr->nsPtr;
sl@0	3087	} else {
sl@0	3088	currNsPtr = iPtr->globalNsPtr;
sl@0	3089	}
sl@0	3090
sl@0	3091	cmdPtr->refCount++;
sl@0	3092	resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
sl@0	3093	resPtr->cmdPtr = cmdPtr;
sl@0	3094	resPtr->refNsPtr = currNsPtr;
sl@0	3095	resPtr->refNsId = currNsPtr->nsId;
sl@0	3096	resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
sl@0	3097	resPtr->cmdEpoch = cmdPtr->cmdEpoch;
sl@0	3098	resPtr->refCount = 1;
sl@0	3099
sl@0	3100	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	3101	oldTypePtr->freeIntRepProc(objPtr);
sl@0	3102	}
sl@0	3103	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
sl@0	3104	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
sl@0	3105	objPtr->typePtr = &tclCmdNameType;
sl@0	3106	}
sl@0	3107
sl@0	3108	/*
sl@0	3109	*----------------------------------------------------------------------
sl@0	3110	*
sl@0	3111	* FreeCmdNameInternalRep --
sl@0	3112	*
sl@0	3113	* Frees the resources associated with a cmdName object's internal
sl@0	3114	* representation.
sl@0	3115	*
sl@0	3116	* Results:
sl@0	3117	* None.
sl@0	3118	*
sl@0	3119	* Side effects:
sl@0	3120	* Decrements the ref count of any cached ResolvedCmdName structure
sl@0	3121	* pointed to by the cmdName's internal representation. If this is
sl@0	3122	* the last use of the ResolvedCmdName, it is freed. This in turn
sl@0	3123	* decrements the ref count of the Command structure pointed to by
sl@0	3124	* the ResolvedSymbol, which may free the Command structure.
sl@0	3125	*
sl@0	3126	*----------------------------------------------------------------------
sl@0	3127	*/
sl@0	3128
sl@0	3129	static void
sl@0	3130	FreeCmdNameInternalRep(objPtr)
sl@0	3131	register Tcl_Obj objPtr; / CmdName object with internal
sl@0	3132	* representation to free. */
sl@0	3133	{
sl@0	3134	register ResolvedCmdName *resPtr =
sl@0	3135	(ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
sl@0	3136
sl@0	3137	if (resPtr != NULL) {
sl@0	3138	/*
sl@0	3139	* Decrement the reference count of the ResolvedCmdName structure.
sl@0	3140	* If there are no more uses, free the ResolvedCmdName structure.
sl@0	3141	*/
sl@0	3142
sl@0	3143	resPtr->refCount--;
sl@0	3144	if (resPtr->refCount == 0) {
sl@0	3145	/*
sl@0	3146	* Now free the cached command, unless it is still in its
sl@0	3147	* hash table or if there are other references to it
sl@0	3148	* from other cmdName objects.
sl@0	3149	*/
sl@0	3150
sl@0	3151	Command *cmdPtr = resPtr->cmdPtr;
sl@0	3152	TclCleanupCommand(cmdPtr);
sl@0	3153	ckfree((char *) resPtr);
sl@0	3154	}
sl@0	3155	}
sl@0	3156	}
sl@0	3157
sl@0	3158	/*
sl@0	3159	*----------------------------------------------------------------------
sl@0	3160	*
sl@0	3161	* DupCmdNameInternalRep --
sl@0	3162	*
sl@0	3163	* Initialize the internal representation of an cmdName Tcl_Obj to a
sl@0	3164	* copy of the internal representation of an existing cmdName object.
sl@0	3165	*
sl@0	3166	* Results:
sl@0	3167	* None.
sl@0	3168	*
sl@0	3169	* Side effects:
sl@0	3170	* "copyPtr"s internal rep is set to point to the ResolvedCmdName
sl@0	3171	* structure corresponding to "srcPtr"s internal rep. Increments the
sl@0	3172	* ref count of the ResolvedCmdName structure pointed to by the
sl@0	3173	* cmdName's internal representation.
sl@0	3174	*
sl@0	3175	*----------------------------------------------------------------------
sl@0	3176	*/
sl@0	3177
sl@0	3178	static void
sl@0	3179	DupCmdNameInternalRep(srcPtr, copyPtr)
sl@0	3180	Tcl_Obj srcPtr; / Object with internal rep to copy. */
sl@0	3181	register Tcl_Obj copyPtr; / Object with internal rep to set. */
sl@0	3182	{
sl@0	3183	register ResolvedCmdName *resPtr =
sl@0	3184	(ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;
sl@0	3185
sl@0	3186	copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
sl@0	3187	copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
sl@0	3188	if (resPtr != NULL) {
sl@0	3189	resPtr->refCount++;
sl@0	3190	}
sl@0	3191	copyPtr->typePtr = &tclCmdNameType;
sl@0	3192	}
sl@0	3193
sl@0	3194	/*
sl@0	3195	*----------------------------------------------------------------------
sl@0	3196	*
sl@0	3197	* SetCmdNameFromAny --
sl@0	3198	*
sl@0	3199	* Generate an cmdName internal form for the Tcl object "objPtr".
sl@0	3200	*
sl@0	3201	* Results:
sl@0	3202	* The return value is a standard Tcl result. The conversion always
sl@0	3203	* succeeds and TCL_OK is returned.
sl@0	3204	*
sl@0	3205	* Side effects:
sl@0	3206	* A pointer to a ResolvedCmdName structure that holds a cached pointer
sl@0	3207	* to the command with a name that matches objPtr's string rep is
sl@0	3208	* stored as objPtr's internal representation. This ResolvedCmdName
sl@0	3209	* pointer will be NULL if no matching command was found. The ref count
sl@0	3210	* of the cached Command's structure (if any) is also incremented.
sl@0	3211	*
sl@0	3212	*----------------------------------------------------------------------
sl@0	3213	*/
sl@0	3214
sl@0	3215	static int
sl@0	3216	SetCmdNameFromAny(interp, objPtr)
sl@0	3217	Tcl_Interp interp; / Used for error reporting if not NULL. */
sl@0	3218	register Tcl_Obj objPtr; / The object to convert. */
sl@0	3219	{
sl@0	3220	Interp iPtr = (Interp ) interp;
sl@0	3221	char *name;
sl@0	3222	Tcl_Command cmd;
sl@0	3223	register Command *cmdPtr;
sl@0	3224	Namespace *currNsPtr;
sl@0	3225	register ResolvedCmdName *resPtr;
sl@0	3226
sl@0	3227	/*
sl@0	3228	* Get "objPtr"s string representation. Make it up-to-date if necessary.
sl@0	3229	*/
sl@0	3230
sl@0	3231	name = objPtr->bytes;
sl@0	3232	if (name == NULL) {
sl@0	3233	name = Tcl_GetString(objPtr);
sl@0	3234	}
sl@0	3235
sl@0	3236	/*
sl@0	3237	* Find the Command structure, if any, that describes the command called
sl@0	3238	* "name". Build a ResolvedCmdName that holds a cached pointer to this
sl@0	3239	* Command, and bump the reference count in the referenced Command
sl@0	3240	* structure. A Command structure will not be deleted as long as it is
sl@0	3241	* referenced from a CmdName object.
sl@0	3242	*/
sl@0	3243
sl@0	3244	cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
sl@0	3245	/flags/ 0);
sl@0	3246	cmdPtr = (Command *) cmd;
sl@0	3247	if (cmdPtr != NULL) {
sl@0	3248	/*
sl@0	3249	* Get the current namespace.
sl@0	3250	*/
sl@0	3251
sl@0	3252	if (iPtr->varFramePtr != NULL) {
sl@0	3253	currNsPtr = iPtr->varFramePtr->nsPtr;
sl@0	3254	} else {
sl@0	3255	currNsPtr = iPtr->globalNsPtr;
sl@0	3256	}
sl@0	3257
sl@0	3258	cmdPtr->refCount++;
sl@0	3259	resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
sl@0	3260	resPtr->cmdPtr = cmdPtr;
sl@0	3261	resPtr->refNsPtr = currNsPtr;
sl@0	3262	resPtr->refNsId = currNsPtr->nsId;
sl@0	3263	resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
sl@0	3264	resPtr->cmdEpoch = cmdPtr->cmdEpoch;
sl@0	3265	resPtr->refCount = 1;
sl@0	3266	} else {
sl@0	3267	resPtr = NULL; /* no command named "name" was found */
sl@0	3268	}
sl@0	3269
sl@0	3270	/*
sl@0	3271	* Free the old internalRep before setting the new one. We do this as
sl@0	3272	* late as possible to allow the conversion code, in particular
sl@0	3273	* GetStringFromObj, to use that old internalRep. If no Command
sl@0	3274	* structure was found, leave NULL as the cached value.
sl@0	3275	*/
sl@0	3276
sl@0	3277	if ((objPtr->typePtr != NULL)
sl@0	3278	&& (objPtr->typePtr->freeIntRepProc != NULL)) {
sl@0	3279	objPtr->typePtr->freeIntRepProc(objPtr);
sl@0	3280	}
sl@0	3281
sl@0	3282	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
sl@0	3283	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
sl@0	3284	objPtr->typePtr = &tclCmdNameType;
sl@0	3285	return TCL_OK;
sl@0	3286	}

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--