os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclObj.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclObj.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,3286 @@
1.4 +/*
1.5 + * tclObj.c --
1.6 + *
1.7 + * This file contains Tcl object-related procedures that are used by
1.8 + * many Tcl commands.
1.9 + *
1.10 + * Copyright (c) 1995-1997 Sun Microsystems, Inc.
1.11 + * Copyright (c) 1999 by Scriptics Corporation.
1.12 + * Copyright (c) 2001 by ActiveState Corporation.
1.13 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclObj.c,v 1.42.2.14 2005/11/29 14:02:04 dkf Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclCompile.h"
1.23 +#include "tclPort.h"
1.24 +#if defined(__SYMBIAN32__)
1.25 +#include "tclSymbianGlobals.h"
1.26 +#endif
1.27 +
1.28 +/*
1.29 + * Table of all object types.
1.30 + */
1.31 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.32 +static Tcl_HashTable typeTable;
1.33 +static int typeTableInitialized = 0; /* 0 means not yet initialized. */
1.34 +#endif
1.35 +TCL_DECLARE_MUTEX(tableMutex)
1.36 +
1.37 +/*
1.38 + * Head of the list of free Tcl_Obj structs we maintain.
1.39 + */
1.40 +
1.41 +Tcl_Obj *tclFreeObjList = NULL;
1.42 +
1.43 +/*
1.44 + * The object allocator is single threaded. This mutex is referenced
1.45 + * by the TclNewObj macro, however, so must be visible.
1.46 + */
1.47 +
1.48 +#ifdef TCL_THREADS
1.49 +Tcl_Mutex tclObjMutex;
1.50 +#endif
1.51 +
1.52 +/*
1.53 + * Pointer to a heap-allocated string of length zero that the Tcl core uses
1.54 + * as the value of an empty string representation for an object. This value
1.55 + * is shared by all new objects allocated by Tcl_NewObj.
1.56 + */
1.57 +
1.58 +char tclEmptyString = '\0';
1.59 +char *tclEmptyStringRep = &tclEmptyString;
1.60 +
1.61 +/*
1.62 + * Prototypes for procedures defined later in this file:
1.63 + */
1.64 +
1.65 +static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.66 + Tcl_Obj *objPtr));
1.67 +static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.68 + Tcl_Obj *objPtr));
1.69 +static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.70 + Tcl_Obj *objPtr));
1.71 +static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
1.72 + Tcl_Obj *objPtr));
1.73 +static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
1.74 +static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
1.75 +static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
1.76 +static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.77 + Tcl_Obj *objPtr));
1.78 +
1.79 +#ifndef TCL_WIDE_INT_IS_LONG
1.80 +static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
1.81 +#endif
1.82 +
1.83 +/*
1.84 + * Prototypes for the array hash key methods.
1.85 + */
1.86 +
1.87 +static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_((
1.88 + Tcl_HashTable *tablePtr, VOID *keyPtr));
1.89 +static int CompareObjKeys _ANSI_ARGS_((
1.90 + VOID *keyPtr, Tcl_HashEntry *hPtr));
1.91 +static void FreeObjEntry _ANSI_ARGS_((
1.92 + Tcl_HashEntry *hPtr));
1.93 +static unsigned int HashObjKey _ANSI_ARGS_((
1.94 + Tcl_HashTable *tablePtr,
1.95 + VOID *keyPtr));
1.96 +
1.97 +/*
1.98 + * Prototypes for the CommandName object type.
1.99 + */
1.100 +
1.101 +static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
1.102 + Tcl_Obj *copyPtr));
1.103 +static void FreeCmdNameInternalRep _ANSI_ARGS_((
1.104 + Tcl_Obj *objPtr));
1.105 +static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.106 + Tcl_Obj *objPtr));
1.107 +
1.108 +
1.109 +/*
1.110 + * The structures below defines the Tcl object types defined in this file by
1.111 + * means of procedures that can be invoked by generic object code. See also
1.112 + * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
1.113 + * implementations.
1.114 + */
1.115 +
1.116 +Tcl_ObjType tclBooleanType = {
1.117 + "boolean", /* name */
1.118 + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
1.119 + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
1.120 + UpdateStringOfBoolean, /* updateStringProc */
1.121 + SetBooleanFromAny /* setFromAnyProc */
1.122 +};
1.123 +
1.124 +Tcl_ObjType tclDoubleType = {
1.125 + "double", /* name */
1.126 + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
1.127 + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
1.128 + UpdateStringOfDouble, /* updateStringProc */
1.129 + SetDoubleFromAny /* setFromAnyProc */
1.130 +};
1.131 +
1.132 +Tcl_ObjType tclIntType = {
1.133 + "int", /* name */
1.134 + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
1.135 + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
1.136 + UpdateStringOfInt, /* updateStringProc */
1.137 + SetIntFromAny /* setFromAnyProc */
1.138 +};
1.139 +
1.140 +Tcl_ObjType tclWideIntType = {
1.141 + "wideInt", /* name */
1.142 + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
1.143 + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
1.144 +#ifdef TCL_WIDE_INT_IS_LONG
1.145 + UpdateStringOfInt, /* updateStringProc */
1.146 +#else /* !TCL_WIDE_INT_IS_LONG */
1.147 + UpdateStringOfWideInt, /* updateStringProc */
1.148 +#endif
1.149 + SetWideIntFromAny /* setFromAnyProc */
1.150 +};
1.151 +
1.152 +/*
1.153 + * The structure below defines the Tcl obj hash key type.
1.154 + */
1.155 +Tcl_HashKeyType tclObjHashKeyType = {
1.156 + TCL_HASH_KEY_TYPE_VERSION, /* version */
1.157 + 0, /* flags */
1.158 + HashObjKey, /* hashKeyProc */
1.159 + CompareObjKeys, /* compareKeysProc */
1.160 + AllocObjEntry, /* allocEntryProc */
1.161 + FreeObjEntry /* freeEntryProc */
1.162 +};
1.163 +
1.164 +/*
1.165 + * The structure below defines the command name Tcl object type by means of
1.166 + * procedures that can be invoked by generic object code. Objects of this
1.167 + * type cache the Command pointer that results from looking up command names
1.168 + * in the command hashtable. Such objects appear as the zeroth ("command
1.169 + * name") argument in a Tcl command.
1.170 + *
1.171 + * NOTE: the ResolvedCmdName that gets cached is stored in the
1.172 + * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.
1.173 + * You might think you could use the simpler otherValuePtr field to
1.174 + * store the single ResolvedCmdName pointer, but DO NOT DO THIS. It
1.175 + * seems that some extensions use the second internal pointer field
1.176 + * of the twoPtrValue field for their own purposes.
1.177 + */
1.178 +
1.179 +static Tcl_ObjType tclCmdNameType = {
1.180 + "cmdName", /* name */
1.181 + FreeCmdNameInternalRep, /* freeIntRepProc */
1.182 + DupCmdNameInternalRep, /* dupIntRepProc */
1.183 + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
1.184 + SetCmdNameFromAny /* setFromAnyProc */
1.185 +};
1.186 +
1.187 +
1.188 +/*
1.189 + * Structure containing a cached pointer to a command that is the result
1.190 + * of resolving the command's name in some namespace. It is the internal
1.191 + * representation for a cmdName object. It contains the pointer along
1.192 + * with some information that is used to check the pointer's validity.
1.193 + */
1.194 +
1.195 +typedef struct ResolvedCmdName {
1.196 + Command *cmdPtr; /* A cached Command pointer. */
1.197 + Namespace *refNsPtr; /* Points to the namespace containing the
1.198 + * reference (not the namespace that
1.199 + * contains the referenced command). */
1.200 + long refNsId; /* refNsPtr's unique namespace id. Used to
1.201 + * verify that refNsPtr is still valid
1.202 + * (e.g., it's possible that the cmd's
1.203 + * containing namespace was deleted and a
1.204 + * new one created at the same address). */
1.205 + int refNsCmdEpoch; /* Value of the referencing namespace's
1.206 + * cmdRefEpoch when the pointer was cached.
1.207 + * Before using the cached pointer, we check
1.208 + * if the namespace's epoch was incremented;
1.209 + * if so, this cached pointer is invalid. */
1.210 + int cmdEpoch; /* Value of the command's cmdEpoch when this
1.211 + * pointer was cached. Before using the
1.212 + * cached pointer, we check if the cmd's
1.213 + * epoch was incremented; if so, the cmd was
1.214 + * renamed, deleted, hidden, or exposed, and
1.215 + * so the pointer is invalid. */
1.216 + int refCount; /* Reference count: 1 for each cmdName
1.217 + * object that has a pointer to this
1.218 + * ResolvedCmdName structure as its internal
1.219 + * rep. This structure can be freed when
1.220 + * refCount becomes zero. */
1.221 +} ResolvedCmdName;
1.222 +
1.223 +
1.224 +/*
1.225 + *-------------------------------------------------------------------------
1.226 + *
1.227 + * TclInitObjectSubsystem --
1.228 + *
1.229 + * This procedure is invoked to perform once-only initialization of
1.230 + * the type table. It also registers the object types defined in
1.231 + * this file.
1.232 + *
1.233 + * Results:
1.234 + * None.
1.235 + *
1.236 + * Side effects:
1.237 + * Initializes the table of defined object types "typeTable" with
1.238 + * builtin object types defined in this file.
1.239 + *
1.240 + *-------------------------------------------------------------------------
1.241 + */
1.242 +
1.243 +void
1.244 +TclInitObjSubsystem()
1.245 +{
1.246 + Tcl_MutexLock(&tableMutex);
1.247 + typeTableInitialized = 1;
1.248 + Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
1.249 + Tcl_MutexUnlock(&tableMutex);
1.250 +
1.251 + Tcl_RegisterObjType(&tclBooleanType);
1.252 + Tcl_RegisterObjType(&tclByteArrayType);
1.253 + Tcl_RegisterObjType(&tclDoubleType);
1.254 + Tcl_RegisterObjType(&tclEndOffsetType);
1.255 + Tcl_RegisterObjType(&tclIntType);
1.256 + Tcl_RegisterObjType(&tclWideIntType);
1.257 + Tcl_RegisterObjType(&tclStringType);
1.258 + Tcl_RegisterObjType(&tclListType);
1.259 + Tcl_RegisterObjType(&tclByteCodeType);
1.260 + Tcl_RegisterObjType(&tclProcBodyType);
1.261 + Tcl_RegisterObjType(&tclArraySearchType);
1.262 + Tcl_RegisterObjType(&tclIndexType);
1.263 + Tcl_RegisterObjType(&tclNsNameType);
1.264 + Tcl_RegisterObjType(&tclCmdNameType);
1.265 +
1.266 +#ifdef TCL_COMPILE_STATS
1.267 + Tcl_MutexLock(&tclObjMutex);
1.268 + tclObjsAlloced = 0;
1.269 + tclObjsFreed = 0;
1.270 + {
1.271 + int i;
1.272 + for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
1.273 + tclObjsShared[i] = 0;
1.274 + }
1.275 + }
1.276 + Tcl_MutexUnlock(&tclObjMutex);
1.277 +#endif
1.278 +}
1.279 +
1.280 +/*
1.281 + *----------------------------------------------------------------------
1.282 + *
1.283 + * TclFinalizeObjects --
1.284 + *
1.285 + * This procedure is called by Tcl_Finalize to clean up all
1.286 + * registered Tcl_ObjType's and to reset the tclFreeObjList.
1.287 + *
1.288 + * Results:
1.289 + * None.
1.290 + *
1.291 + * Side effects:
1.292 + * None.
1.293 + *
1.294 + *----------------------------------------------------------------------
1.295 + */
1.296 +
1.297 +void
1.298 +TclFinalizeObjects()
1.299 +{
1.300 + Tcl_MutexLock(&tableMutex);
1.301 + if (typeTableInitialized) {
1.302 + Tcl_DeleteHashTable(&typeTable);
1.303 + typeTableInitialized = 0;
1.304 + }
1.305 + Tcl_MutexUnlock(&tableMutex);
1.306 +
1.307 + /*
1.308 + * All we do here is reset the head pointer of the linked list of
1.309 + * free Tcl_Obj's to NULL; the memory finalization will take care
1.310 + * of releasing memory for us.
1.311 + */
1.312 + Tcl_MutexLock(&tclObjMutex);
1.313 + tclFreeObjList = NULL;
1.314 + Tcl_MutexUnlock(&tclObjMutex);
1.315 +}
1.316 +
1.317 +/*
1.318 + *--------------------------------------------------------------
1.319 + *
1.320 + * Tcl_RegisterObjType --
1.321 + *
1.322 + * This procedure is called to register a new Tcl object type
1.323 + * in the table of all object types supported by Tcl.
1.324 + *
1.325 + * Results:
1.326 + * None.
1.327 + *
1.328 + * Side effects:
1.329 + * The type is registered in the Tcl type table. If there was already
1.330 + * a type with the same name as in typePtr, it is replaced with the
1.331 + * new type.
1.332 + *
1.333 + *--------------------------------------------------------------
1.334 + */
1.335 +
1.336 +EXPORT_C void
1.337 +Tcl_RegisterObjType(typePtr)
1.338 + Tcl_ObjType *typePtr; /* Information about object type;
1.339 + * storage must be statically
1.340 + * allocated (must live forever). */
1.341 +{
1.342 + int new;
1.343 + Tcl_MutexLock(&tableMutex);
1.344 + Tcl_SetHashValue(
1.345 + Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
1.346 + Tcl_MutexUnlock(&tableMutex);
1.347 +}
1.348 +
1.349 +/*
1.350 + *----------------------------------------------------------------------
1.351 + *
1.352 + * Tcl_AppendAllObjTypes --
1.353 + *
1.354 + * This procedure appends onto the argument object the name of each
1.355 + * object type as a list element. This includes the builtin object
1.356 + * types (e.g. int, list) as well as those added using
1.357 + * Tcl_NewObj. These names can be used, for example, with
1.358 + * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
1.359 + * structures.
1.360 + *
1.361 + * Results:
1.362 + * The return value is normally TCL_OK; in this case the object
1.363 + * referenced by objPtr has each type name appended to it. If an
1.364 + * error occurs, TCL_ERROR is returned and the interpreter's result
1.365 + * holds an error message.
1.366 + *
1.367 + * Side effects:
1.368 + * If necessary, the object referenced by objPtr is converted into
1.369 + * a list object.
1.370 + *
1.371 + *----------------------------------------------------------------------
1.372 + */
1.373 +
1.374 +EXPORT_C int
1.375 +Tcl_AppendAllObjTypes(interp, objPtr)
1.376 + Tcl_Interp *interp; /* Interpreter used for error reporting. */
1.377 + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
1.378 + * name of each registered type is appended
1.379 + * as a list element. */
1.380 +{
1.381 + register Tcl_HashEntry *hPtr;
1.382 + Tcl_HashSearch search;
1.383 + int objc;
1.384 + Tcl_Obj **objv;
1.385 +
1.386 + /*
1.387 + * Get the test for a valid list out of the way first.
1.388 + */
1.389 +
1.390 + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
1.391 + return TCL_ERROR;
1.392 + }
1.393 +
1.394 + /*
1.395 + * Type names are NUL-terminated, not counted strings.
1.396 + * This code relies on that.
1.397 + */
1.398 +
1.399 + Tcl_MutexLock(&tableMutex);
1.400 + for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
1.401 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.402 + Tcl_ListObjAppendElement(NULL, objPtr,
1.403 + Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
1.404 + }
1.405 + Tcl_MutexUnlock(&tableMutex);
1.406 + return TCL_OK;
1.407 +}
1.408 +
1.409 +/*
1.410 + *----------------------------------------------------------------------
1.411 + *
1.412 + * Tcl_GetObjType --
1.413 + *
1.414 + * This procedure looks up an object type by name.
1.415 + *
1.416 + * Results:
1.417 + * If an object type with name matching "typeName" is found, a pointer
1.418 + * to its Tcl_ObjType structure is returned; otherwise, NULL is
1.419 + * returned.
1.420 + *
1.421 + * Side effects:
1.422 + * None.
1.423 + *
1.424 + *----------------------------------------------------------------------
1.425 + */
1.426 +
1.427 +EXPORT_C Tcl_ObjType *
1.428 +Tcl_GetObjType(typeName)
1.429 + CONST char *typeName; /* Name of Tcl object type to look up. */
1.430 +{
1.431 + register Tcl_HashEntry *hPtr;
1.432 + Tcl_ObjType *typePtr = NULL;
1.433 +
1.434 + Tcl_MutexLock(&tableMutex);
1.435 + hPtr = Tcl_FindHashEntry(&typeTable, typeName);
1.436 + if (hPtr != (Tcl_HashEntry *) NULL) {
1.437 + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
1.438 + }
1.439 + Tcl_MutexUnlock(&tableMutex);
1.440 + return typePtr;
1.441 +}
1.442 +
1.443 +/*
1.444 + *----------------------------------------------------------------------
1.445 + *
1.446 + * Tcl_ConvertToType --
1.447 + *
1.448 + * Convert the Tcl object "objPtr" to have type "typePtr" if possible.
1.449 + *
1.450 + * Results:
1.451 + * The return value is TCL_OK on success and TCL_ERROR on failure. If
1.452 + * TCL_ERROR is returned, then the interpreter's result contains an
1.453 + * error message unless "interp" is NULL. Passing a NULL "interp"
1.454 + * allows this procedure to be used as a test whether the conversion
1.455 + * could be done (and in fact was done).
1.456 + *
1.457 + * Side effects:
1.458 + * Any internal representation for the old type is freed.
1.459 + *
1.460 + *----------------------------------------------------------------------
1.461 + */
1.462 +
1.463 +EXPORT_C int
1.464 +Tcl_ConvertToType(interp, objPtr, typePtr)
1.465 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.466 + Tcl_Obj *objPtr; /* The object to convert. */
1.467 + Tcl_ObjType *typePtr; /* The target type. */
1.468 +{
1.469 + if (objPtr->typePtr == typePtr) {
1.470 + return TCL_OK;
1.471 + }
1.472 +
1.473 + /*
1.474 + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
1.475 + * form as appropriate for the target type. This frees the old internal
1.476 + * representation.
1.477 + */
1.478 +
1.479 + return typePtr->setFromAnyProc(interp, objPtr);
1.480 +}
1.481 +
1.482 +/*
1.483 + *----------------------------------------------------------------------
1.484 + *
1.485 + * Tcl_NewObj --
1.486 + *
1.487 + * This procedure is normally called when not debugging: i.e., when
1.488 + * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
1.489 + * the empty string. These objects have a NULL object type and NULL
1.490 + * string representation byte pointer. Type managers call this routine
1.491 + * to allocate new objects that they further initialize.
1.492 + *
1.493 + * When TCL_MEM_DEBUG is defined, this procedure just returns the
1.494 + * result of calling the debugging version Tcl_DbNewObj.
1.495 + *
1.496 + * Results:
1.497 + * The result is a newly allocated object that represents the empty
1.498 + * string. The new object's typePtr is set NULL and its ref count
1.499 + * is set to 0.
1.500 + *
1.501 + * Side effects:
1.502 + * If compiling with TCL_COMPILE_STATS, this procedure increments
1.503 + * the global count of allocated objects (tclObjsAlloced).
1.504 + *
1.505 + *----------------------------------------------------------------------
1.506 + */
1.507 +
1.508 +#ifdef TCL_MEM_DEBUG
1.509 +#undef Tcl_NewObj
1.510 +
1.511 +EXPORT_C Tcl_Obj *
1.512 +Tcl_NewObj()
1.513 +{
1.514 + return Tcl_DbNewObj("unknown", 0);
1.515 +}
1.516 +
1.517 +#else /* if not TCL_MEM_DEBUG */
1.518 +
1.519 +EXPORT_C Tcl_Obj *
1.520 +Tcl_NewObj()
1.521 +{
1.522 + register Tcl_Obj *objPtr;
1.523 +
1.524 + /*
1.525 + * Use the macro defined in tclInt.h - it will use the
1.526 + * correct allocator.
1.527 + */
1.528 +
1.529 + TclNewObj(objPtr);
1.530 + return objPtr;
1.531 +}
1.532 +#endif /* TCL_MEM_DEBUG */
1.533 +
1.534 +/*
1.535 + *----------------------------------------------------------------------
1.536 + *
1.537 + * Tcl_DbNewObj --
1.538 + *
1.539 + * This procedure is normally called when debugging: i.e., when
1.540 + * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
1.541 + * empty string. It is the same as the Tcl_NewObj procedure above
1.542 + * except that it calls Tcl_DbCkalloc directly with the file name and
1.543 + * line number from its caller. This simplifies debugging since then
1.544 + * the [memory active] command will report the correct file name and line
1.545 + * number when reporting objects that haven't been freed.
1.546 + *
1.547 + * When TCL_MEM_DEBUG is not defined, this procedure just returns the
1.548 + * result of calling Tcl_NewObj.
1.549 + *
1.550 + * Results:
1.551 + * The result is a newly allocated that represents the empty string.
1.552 + * The new object's typePtr is set NULL and its ref count is set to 0.
1.553 + *
1.554 + * Side effects:
1.555 + * If compiling with TCL_COMPILE_STATS, this procedure increments
1.556 + * the global count of allocated objects (tclObjsAlloced).
1.557 + *
1.558 + *----------------------------------------------------------------------
1.559 + */
1.560 +
1.561 +#ifdef TCL_MEM_DEBUG
1.562 +
1.563 +EXPORT_C Tcl_Obj *
1.564 +Tcl_DbNewObj(file, line)
1.565 + register CONST char *file; /* The name of the source file calling this
1.566 + * procedure; used for debugging. */
1.567 + register int line; /* Line number in the source file; used
1.568 + * for debugging. */
1.569 +{
1.570 + register Tcl_Obj *objPtr;
1.571 +
1.572 + /*
1.573 + * Use the macro defined in tclInt.h - it will use the
1.574 + * correct allocator.
1.575 + */
1.576 +
1.577 + TclDbNewObj(objPtr, file, line);
1.578 + return objPtr;
1.579 +}
1.580 +#else /* if not TCL_MEM_DEBUG */
1.581 +
1.582 +EXPORT_C Tcl_Obj *
1.583 +Tcl_DbNewObj(file, line)
1.584 + CONST char *file; /* The name of the source file calling this
1.585 + * procedure; used for debugging. */
1.586 + int line; /* Line number in the source file; used
1.587 + * for debugging. */
1.588 +{
1.589 + return Tcl_NewObj();
1.590 +}
1.591 +#endif /* TCL_MEM_DEBUG */
1.592 +
1.593 +/*
1.594 + *----------------------------------------------------------------------
1.595 + *
1.596 + * TclAllocateFreeObjects --
1.597 + *
1.598 + * Procedure to allocate a number of free Tcl_Objs. This is done using
1.599 + * a single ckalloc to reduce the overhead for Tcl_Obj allocation.
1.600 + *
1.601 + * Assumes mutex is held.
1.602 + *
1.603 + * Results:
1.604 + * None.
1.605 + *
1.606 + * Side effects:
1.607 + * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
1.608 + * first of a number of free Tcl_Obj's linked together by their
1.609 + * internalRep.otherValuePtrs.
1.610 + *
1.611 + *----------------------------------------------------------------------
1.612 + */
1.613 +
1.614 +#define OBJS_TO_ALLOC_EACH_TIME 100
1.615 +
1.616 +void
1.617 +TclAllocateFreeObjects()
1.618 +{
1.619 + size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
1.620 + char *basePtr;
1.621 + register Tcl_Obj *prevPtr, *objPtr;
1.622 + register int i;
1.623 +
1.624 + /*
1.625 + * This has been noted by Purify to be a potential leak. The problem is
1.626 + * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
1.627 + * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
1.628 + * actually freeing the memory. TclFinalizeObjects() does not ckfree()
1.629 + * this memory, but leaves it to Tcl's memory subsystem finalziation to
1.630 + * release it. Purify apparently can't figure that out, and fires a
1.631 + * false alarm.
1.632 + */
1.633 +
1.634 + basePtr = (char *) ckalloc(bytesToAlloc);
1.635 + memset(basePtr, 0, bytesToAlloc);
1.636 +
1.637 + prevPtr = NULL;
1.638 + objPtr = (Tcl_Obj *) basePtr;
1.639 + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
1.640 + objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
1.641 + prevPtr = objPtr;
1.642 + objPtr++;
1.643 + }
1.644 + tclFreeObjList = prevPtr;
1.645 +}
1.646 +#undef OBJS_TO_ALLOC_EACH_TIME
1.647 +
1.648 +/*
1.649 + *----------------------------------------------------------------------
1.650 + *
1.651 + * TclFreeObj --
1.652 + *
1.653 + * This procedure frees the memory associated with the argument
1.654 + * object. It is called by the tcl.h macro Tcl_DecrRefCount when an
1.655 + * object's ref count is zero. It is only "public" since it must
1.656 + * be callable by that macro wherever the macro is used. It should not
1.657 + * be directly called by clients.
1.658 + *
1.659 + * Results:
1.660 + * None.
1.661 + *
1.662 + * Side effects:
1.663 + * Deallocates the storage for the object's Tcl_Obj structure
1.664 + * after deallocating the string representation and calling the
1.665 + * type-specific Tcl_FreeInternalRepProc to deallocate the object's
1.666 + * internal representation. If compiling with TCL_COMPILE_STATS,
1.667 + * this procedure increments the global count of freed objects
1.668 + * (tclObjsFreed).
1.669 + *
1.670 + *----------------------------------------------------------------------
1.671 + */
1.672 +
1.673 +EXPORT_C void
1.674 +TclFreeObj(objPtr)
1.675 + register Tcl_Obj *objPtr; /* The object to be freed. */
1.676 +{
1.677 + register Tcl_ObjType *typePtr = objPtr->typePtr;
1.678 +
1.679 +#ifdef TCL_MEM_DEBUG
1.680 + if ((objPtr)->refCount < -1) {
1.681 + panic("Reference count for %lx was negative", objPtr);
1.682 + }
1.683 +#endif /* TCL_MEM_DEBUG */
1.684 +
1.685 + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1.686 + typePtr->freeIntRepProc(objPtr);
1.687 + }
1.688 + Tcl_InvalidateStringRep(objPtr);
1.689 +
1.690 + /*
1.691 + * If debugging Tcl's memory usage, deallocate the object using ckfree.
1.692 + * Otherwise, deallocate it by adding it onto the list of free
1.693 + * Tcl_Obj structs we maintain.
1.694 + */
1.695 +
1.696 +#if defined(TCL_MEM_DEBUG) || defined(PURIFY)
1.697 + Tcl_MutexLock(&tclObjMutex);
1.698 + ckfree((char *) objPtr);
1.699 + Tcl_MutexUnlock(&tclObjMutex);
1.700 +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
1.701 + TclThreadFreeObj(objPtr);
1.702 +#else
1.703 + Tcl_MutexLock(&tclObjMutex);
1.704 + objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
1.705 + tclFreeObjList = objPtr;
1.706 + Tcl_MutexUnlock(&tclObjMutex);
1.707 +#endif /* TCL_MEM_DEBUG */
1.708 +
1.709 +#ifdef TCL_COMPILE_STATS
1.710 + tclObjsFreed++;
1.711 +#endif /* TCL_COMPILE_STATS */
1.712 +}
1.713 +
1.714 +/*
1.715 + *----------------------------------------------------------------------
1.716 + *
1.717 + * Tcl_DuplicateObj --
1.718 + *
1.719 + * Create and return a new object that is a duplicate of the argument
1.720 + * object.
1.721 + *
1.722 + * Results:
1.723 + * The return value is a pointer to a newly created Tcl_Obj. This
1.724 + * object has reference count 0 and the same type, if any, as the
1.725 + * source object objPtr. Also:
1.726 + * 1) If the source object has a valid string rep, we copy it;
1.727 + * otherwise, the duplicate's string rep is set NULL to mark
1.728 + * it invalid.
1.729 + * 2) If the source object has an internal representation (i.e. its
1.730 + * typePtr is non-NULL), the new object's internal rep is set to
1.731 + * a copy; otherwise the new internal rep is marked invalid.
1.732 + *
1.733 + * Side effects:
1.734 + * What constitutes "copying" the internal representation depends on
1.735 + * the type. For example, if the argument object is a list,
1.736 + * the element objects it points to will not actually be copied but
1.737 + * will be shared with the duplicate list. That is, the ref counts of
1.738 + * the element objects will be incremented.
1.739 + *
1.740 + *----------------------------------------------------------------------
1.741 + */
1.742 +
1.743 +EXPORT_C Tcl_Obj *
1.744 +Tcl_DuplicateObj(objPtr)
1.745 + register Tcl_Obj *objPtr; /* The object to duplicate. */
1.746 +{
1.747 + register Tcl_ObjType *typePtr = objPtr->typePtr;
1.748 + register Tcl_Obj *dupPtr;
1.749 +
1.750 + TclNewObj(dupPtr);
1.751 +
1.752 + if (objPtr->bytes == NULL) {
1.753 + dupPtr->bytes = NULL;
1.754 + } else if (objPtr->bytes != tclEmptyStringRep) {
1.755 + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
1.756 + }
1.757 +
1.758 + if (typePtr != NULL) {
1.759 + if (typePtr->dupIntRepProc == NULL) {
1.760 + dupPtr->internalRep = objPtr->internalRep;
1.761 + dupPtr->typePtr = typePtr;
1.762 + } else {
1.763 + (*typePtr->dupIntRepProc)(objPtr, dupPtr);
1.764 + }
1.765 + }
1.766 + return dupPtr;
1.767 +}
1.768 +
1.769 +/*
1.770 + *----------------------------------------------------------------------
1.771 + *
1.772 + * Tcl_GetString --
1.773 + *
1.774 + * Returns the string representation byte array pointer for an object.
1.775 + *
1.776 + * Results:
1.777 + * Returns a pointer to the string representation of objPtr. The byte
1.778 + * array referenced by the returned pointer must not be modified by the
1.779 + * caller. Furthermore, the caller must copy the bytes if they need to
1.780 + * retain them since the object's string rep can change as a result of
1.781 + * other operations.
1.782 + *
1.783 + * Side effects:
1.784 + * May call the object's updateStringProc to update the string
1.785 + * representation from the internal representation.
1.786 + *
1.787 + *----------------------------------------------------------------------
1.788 + */
1.789 +
1.790 +EXPORT_C char *
1.791 +Tcl_GetString(objPtr)
1.792 + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
1.793 + * should be returned. */
1.794 +{
1.795 + if (objPtr->bytes != NULL) {
1.796 + return objPtr->bytes;
1.797 + }
1.798 +
1.799 + if (objPtr->typePtr->updateStringProc == NULL) {
1.800 + panic("UpdateStringProc should not be invoked for type %s",
1.801 + objPtr->typePtr->name);
1.802 + }
1.803 + (*objPtr->typePtr->updateStringProc)(objPtr);
1.804 + return objPtr->bytes;
1.805 +}
1.806 +
1.807 +/*
1.808 + *----------------------------------------------------------------------
1.809 + *
1.810 + * Tcl_GetStringFromObj --
1.811 + *
1.812 + * Returns the string representation's byte array pointer and length
1.813 + * for an object.
1.814 + *
1.815 + * Results:
1.816 + * Returns a pointer to the string representation of objPtr. If
1.817 + * lengthPtr isn't NULL, the length of the string representation is
1.818 + * stored at *lengthPtr. The byte array referenced by the returned
1.819 + * pointer must not be modified by the caller. Furthermore, the
1.820 + * caller must copy the bytes if they need to retain them since the
1.821 + * object's string rep can change as a result of other operations.
1.822 + *
1.823 + * Side effects:
1.824 + * May call the object's updateStringProc to update the string
1.825 + * representation from the internal representation.
1.826 + *
1.827 + *----------------------------------------------------------------------
1.828 + */
1.829 +
1.830 +EXPORT_C char *
1.831 +Tcl_GetStringFromObj(objPtr, lengthPtr)
1.832 + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should
1.833 + * be returned. */
1.834 + register int *lengthPtr; /* If non-NULL, the location where the string
1.835 + * rep's byte array length should * be stored.
1.836 + * If NULL, no length is stored. */
1.837 +{
1.838 + if (objPtr->bytes == NULL) {
1.839 + if (objPtr->typePtr->updateStringProc == NULL) {
1.840 + panic("UpdateStringProc should not be invoked for type %s",
1.841 + objPtr->typePtr->name);
1.842 + }
1.843 + (*objPtr->typePtr->updateStringProc)(objPtr);
1.844 + }
1.845 +
1.846 + if (lengthPtr != NULL) {
1.847 + *lengthPtr = objPtr->length;
1.848 + }
1.849 + return objPtr->bytes;
1.850 +}
1.851 +
1.852 +/*
1.853 + *----------------------------------------------------------------------
1.854 + *
1.855 + * Tcl_InvalidateStringRep --
1.856 + *
1.857 + * This procedure is called to invalidate an object's string
1.858 + * representation.
1.859 + *
1.860 + * Results:
1.861 + * None.
1.862 + *
1.863 + * Side effects:
1.864 + * Deallocates the storage for any old string representation, then
1.865 + * sets the string representation NULL to mark it invalid.
1.866 + *
1.867 + *----------------------------------------------------------------------
1.868 + */
1.869 +
1.870 +EXPORT_C void
1.871 +Tcl_InvalidateStringRep(objPtr)
1.872 + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
1.873 + * should be freed. */
1.874 +{
1.875 + if (objPtr->bytes != NULL) {
1.876 + if (objPtr->bytes != tclEmptyStringRep) {
1.877 + ckfree((char *) objPtr->bytes);
1.878 + }
1.879 + objPtr->bytes = NULL;
1.880 + }
1.881 +}
1.882 +
1.883 +/*
1.884 + *----------------------------------------------------------------------
1.885 + *
1.886 + * Tcl_NewBooleanObj --
1.887 + *
1.888 + * This procedure is normally called when not debugging: i.e., when
1.889 + * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
1.890 + * initializes it from the argument boolean value. A nonzero
1.891 + * "boolValue" is coerced to 1.
1.892 + *
1.893 + * When TCL_MEM_DEBUG is defined, this procedure just returns the
1.894 + * result of calling the debugging version Tcl_DbNewBooleanObj.
1.895 + *
1.896 + * Results:
1.897 + * The newly created object is returned. This object will have an
1.898 + * invalid string representation. The returned object has ref count 0.
1.899 + *
1.900 + * Side effects:
1.901 + * None.
1.902 + *
1.903 + *----------------------------------------------------------------------
1.904 + */
1.905 +
1.906 +#ifdef TCL_MEM_DEBUG
1.907 +#undef Tcl_NewBooleanObj
1.908 +
1.909 +EXPORT_C Tcl_Obj *
1.910 +Tcl_NewBooleanObj(boolValue)
1.911 + register int boolValue; /* Boolean used to initialize new object. */
1.912 +{
1.913 + return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
1.914 +}
1.915 +
1.916 +#else /* if not TCL_MEM_DEBUG */
1.917 +
1.918 +EXPORT_C Tcl_Obj *
1.919 +Tcl_NewBooleanObj(boolValue)
1.920 + register int boolValue; /* Boolean used to initialize new object. */
1.921 +{
1.922 + register Tcl_Obj *objPtr;
1.923 +
1.924 + TclNewObj(objPtr);
1.925 + objPtr->bytes = NULL;
1.926 +
1.927 + objPtr->internalRep.longValue = (boolValue? 1 : 0);
1.928 + objPtr->typePtr = &tclBooleanType;
1.929 + return objPtr;
1.930 +}
1.931 +#endif /* TCL_MEM_DEBUG */
1.932 +
1.933 +/*
1.934 + *----------------------------------------------------------------------
1.935 + *
1.936 + * Tcl_DbNewBooleanObj --
1.937 + *
1.938 + * This procedure is normally called when debugging: i.e., when
1.939 + * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
1.940 + * same as the Tcl_NewBooleanObj procedure above except that it calls
1.941 + * Tcl_DbCkalloc directly with the file name and line number from its
1.942 + * caller. This simplifies debugging since then the [memory active]
1.943 + * command will report the correct file name and line number when
1.944 + * reporting objects that haven't been freed.
1.945 + *
1.946 + * When TCL_MEM_DEBUG is not defined, this procedure just returns the
1.947 + * result of calling Tcl_NewBooleanObj.
1.948 + *
1.949 + * Results:
1.950 + * The newly created object is returned. This object will have an
1.951 + * invalid string representation. The returned object has ref count 0.
1.952 + *
1.953 + * Side effects:
1.954 + * None.
1.955 + *
1.956 + *----------------------------------------------------------------------
1.957 + */
1.958 +
1.959 +#ifdef TCL_MEM_DEBUG
1.960 +
1.961 +EXPORT_C Tcl_Obj *
1.962 +Tcl_DbNewBooleanObj(boolValue, file, line)
1.963 + register int boolValue; /* Boolean used to initialize new object. */
1.964 + CONST char *file; /* The name of the source file calling this
1.965 + * procedure; used for debugging. */
1.966 + int line; /* Line number in the source file; used
1.967 + * for debugging. */
1.968 +{
1.969 + register Tcl_Obj *objPtr;
1.970 +
1.971 + TclDbNewObj(objPtr, file, line);
1.972 + objPtr->bytes = NULL;
1.973 +
1.974 + objPtr->internalRep.longValue = (boolValue? 1 : 0);
1.975 + objPtr->typePtr = &tclBooleanType;
1.976 + return objPtr;
1.977 +}
1.978 +
1.979 +#else /* if not TCL_MEM_DEBUG */
1.980 +
1.981 +EXPORT_C Tcl_Obj *
1.982 +Tcl_DbNewBooleanObj(boolValue, file, line)
1.983 + register int boolValue; /* Boolean used to initialize new object. */
1.984 + CONST char *file; /* The name of the source file calling this
1.985 + * procedure; used for debugging. */
1.986 + int line; /* Line number in the source file; used
1.987 + * for debugging. */
1.988 +{
1.989 + return Tcl_NewBooleanObj(boolValue);
1.990 +}
1.991 +#endif /* TCL_MEM_DEBUG */
1.992 +
1.993 +/*
1.994 + *----------------------------------------------------------------------
1.995 + *
1.996 + * Tcl_SetBooleanObj --
1.997 + *
1.998 + * Modify an object to be a boolean object and to have the specified
1.999 + * boolean value. A nonzero "boolValue" is coerced to 1.
1.1000 + *
1.1001 + * Results:
1.1002 + * None.
1.1003 + *
1.1004 + * Side effects:
1.1005 + * The object's old string rep, if any, is freed. Also, any old
1.1006 + * internal rep is freed.
1.1007 + *
1.1008 + *----------------------------------------------------------------------
1.1009 + */
1.1010 +
1.1011 +EXPORT_C void
1.1012 +Tcl_SetBooleanObj(objPtr, boolValue)
1.1013 + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
1.1014 + register int boolValue; /* Boolean used to set object's value. */
1.1015 +{
1.1016 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1017 +
1.1018 + if (Tcl_IsShared(objPtr)) {
1.1019 + panic("Tcl_SetBooleanObj called with shared object");
1.1020 + }
1.1021 +
1.1022 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1023 + oldTypePtr->freeIntRepProc(objPtr);
1.1024 + }
1.1025 +
1.1026 + objPtr->internalRep.longValue = (boolValue? 1 : 0);
1.1027 + objPtr->typePtr = &tclBooleanType;
1.1028 + Tcl_InvalidateStringRep(objPtr);
1.1029 +}
1.1030 +
1.1031 +/*
1.1032 + *----------------------------------------------------------------------
1.1033 + *
1.1034 + * Tcl_GetBooleanFromObj --
1.1035 + *
1.1036 + * Attempt to return a boolean from the Tcl object "objPtr". If the
1.1037 + * object is not already a boolean, an attempt will be made to convert
1.1038 + * it to one.
1.1039 + *
1.1040 + * Results:
1.1041 + * The return value is a standard Tcl object result. If an error occurs
1.1042 + * during conversion, an error message is left in the interpreter's
1.1043 + * result unless "interp" is NULL.
1.1044 + *
1.1045 + * Side effects:
1.1046 + * If the object is not already a boolean, the conversion will free
1.1047 + * any old internal representation.
1.1048 + *
1.1049 + *----------------------------------------------------------------------
1.1050 + */
1.1051 +
1.1052 +EXPORT_C int
1.1053 +Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
1.1054 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1055 + register Tcl_Obj *objPtr; /* The object from which to get boolean. */
1.1056 + register int *boolPtr; /* Place to store resulting boolean. */
1.1057 +{
1.1058 + register int result;
1.1059 +
1.1060 + if (objPtr->typePtr == &tclBooleanType) {
1.1061 + result = TCL_OK;
1.1062 + } else {
1.1063 + result = SetBooleanFromAny(interp, objPtr);
1.1064 + }
1.1065 +
1.1066 + if (result == TCL_OK) {
1.1067 + *boolPtr = (int) objPtr->internalRep.longValue;
1.1068 + }
1.1069 + return result;
1.1070 +}
1.1071 +
1.1072 +/*
1.1073 + *----------------------------------------------------------------------
1.1074 + *
1.1075 + * SetBooleanFromAny --
1.1076 + *
1.1077 + * Attempt to generate a boolean internal form for the Tcl object
1.1078 + * "objPtr".
1.1079 + *
1.1080 + * Results:
1.1081 + * The return value is a standard Tcl result. If an error occurs during
1.1082 + * conversion, an error message is left in the interpreter's result
1.1083 + * unless "interp" is NULL.
1.1084 + *
1.1085 + * Side effects:
1.1086 + * If no error occurs, an integer 1 or 0 is stored as "objPtr"s
1.1087 + * internal representation and the type of "objPtr" is set to boolean.
1.1088 + *
1.1089 + *----------------------------------------------------------------------
1.1090 + */
1.1091 +
1.1092 +static int
1.1093 +SetBooleanFromAny(interp, objPtr)
1.1094 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1095 + register Tcl_Obj *objPtr; /* The object to convert. */
1.1096 +{
1.1097 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1098 + char *string, *end;
1.1099 + register char c;
1.1100 + char lowerCase[10];
1.1101 + int newBool, length;
1.1102 + register int i;
1.1103 +
1.1104 + /*
1.1105 + * Get the string representation. Make it up-to-date if necessary.
1.1106 + */
1.1107 +
1.1108 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1109 +
1.1110 + /*
1.1111 + * Use the obvious shortcuts for numerical values; if objPtr is not
1.1112 + * of numerical type, parse its string rep.
1.1113 + */
1.1114 +
1.1115 + if (objPtr->typePtr == &tclIntType) {
1.1116 + newBool = (objPtr->internalRep.longValue != 0);
1.1117 + } else if (objPtr->typePtr == &tclDoubleType) {
1.1118 + newBool = (objPtr->internalRep.doubleValue != 0.0);
1.1119 + } else if (objPtr->typePtr == &tclWideIntType) {
1.1120 + newBool = (objPtr->internalRep.wideValue != 0);
1.1121 + } else {
1.1122 + /*
1.1123 + * Copy the string converting its characters to lower case.
1.1124 + */
1.1125 +
1.1126 + for (i = 0; (i < 9) && (i < length); i++) {
1.1127 + c = string[i];
1.1128 + /*
1.1129 + * Weed out international characters so we can safely operate
1.1130 + * on single bytes.
1.1131 + */
1.1132 +
1.1133 + if (c & 0x80) {
1.1134 + goto badBoolean;
1.1135 + }
1.1136 + if (Tcl_UniCharIsUpper(UCHAR(c))) {
1.1137 + c = (char) Tcl_UniCharToLower(UCHAR(c));
1.1138 + }
1.1139 + lowerCase[i] = c;
1.1140 + }
1.1141 + lowerCase[i] = 0;
1.1142 +
1.1143 + /*
1.1144 + * Parse the string as a boolean. We use an implementation here that
1.1145 + * doesn't report errors in interp if interp is NULL.
1.1146 + */
1.1147 +
1.1148 + c = lowerCase[0];
1.1149 + if ((c == '0') && (lowerCase[1] == '\0')) {
1.1150 + newBool = 0;
1.1151 + } else if ((c == '1') && (lowerCase[1] == '\0')) {
1.1152 + newBool = 1;
1.1153 + } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
1.1154 + newBool = 1;
1.1155 + } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
1.1156 + newBool = 0;
1.1157 + } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
1.1158 + newBool = 1;
1.1159 + } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
1.1160 + newBool = 0;
1.1161 + } else if ((c == 'o') && (length >= 2)) {
1.1162 + if (strncmp(lowerCase, "on", (size_t) length) == 0) {
1.1163 + newBool = 1;
1.1164 + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
1.1165 + newBool = 0;
1.1166 + } else {
1.1167 + goto badBoolean;
1.1168 + }
1.1169 + } else {
1.1170 + double dbl;
1.1171 + /*
1.1172 + * Boolean values can be extracted from ints or doubles. Note
1.1173 + * that we don't use strtoul or strtoull here because we don't
1.1174 + * care about what the value is, just whether it is equal to
1.1175 + * zero or not.
1.1176 + */
1.1177 +#ifdef TCL_WIDE_INT_IS_LONG
1.1178 + newBool = strtol(string, &end, 0);
1.1179 + if (end != string) {
1.1180 + /*
1.1181 + * Make sure the string has no garbage after the end of
1.1182 + * the int.
1.1183 + */
1.1184 + while ((end < (string+length))
1.1185 + && isspace(UCHAR(*end))) { /* INTL: ISO only */
1.1186 + end++;
1.1187 + }
1.1188 + if (end == (string+length)) {
1.1189 + newBool = (newBool != 0);
1.1190 + goto goodBoolean;
1.1191 + }
1.1192 + }
1.1193 +#else /* !TCL_WIDE_INT_IS_LONG */
1.1194 + Tcl_WideInt wide = strtoll(string, &end, 0);
1.1195 + if (end != string) {
1.1196 + /*
1.1197 + * Make sure the string has no garbage after the end of
1.1198 + * the wide int.
1.1199 + */
1.1200 + while ((end < (string+length))
1.1201 + && isspace(UCHAR(*end))) { /* INTL: ISO only */
1.1202 + end++;
1.1203 + }
1.1204 + if (end == (string+length)) {
1.1205 + newBool = (wide != Tcl_LongAsWide(0));
1.1206 + goto goodBoolean;
1.1207 + }
1.1208 + }
1.1209 +#endif /* TCL_WIDE_INT_IS_LONG */
1.1210 + /*
1.1211 + * Still might be a string containing the characters representing an
1.1212 + * int or double that wasn't handled above. This would be a string
1.1213 + * like "27" or "1.0" that is non-zero and not "1". Such a string
1.1214 + * would result in the boolean value true. We try converting to
1.1215 + * double. If that succeeds and the resulting double is non-zero, we
1.1216 + * have a "true". Note that numbers can't have embedded NULLs.
1.1217 + */
1.1218 +
1.1219 + dbl = strtod(string, &end);
1.1220 + if (end == string) {
1.1221 + goto badBoolean;
1.1222 + }
1.1223 +
1.1224 + /*
1.1225 + * Make sure the string has no garbage after the end of the double.
1.1226 + */
1.1227 +
1.1228 + while ((end < (string+length))
1.1229 + && isspace(UCHAR(*end))) { /* INTL: ISO only */
1.1230 + end++;
1.1231 + }
1.1232 + if (end != (string+length)) {
1.1233 + goto badBoolean;
1.1234 + }
1.1235 + newBool = (dbl != 0.0);
1.1236 + }
1.1237 + }
1.1238 +
1.1239 + /*
1.1240 + * Free the old internalRep before setting the new one. We do this as
1.1241 + * late as possible to allow the conversion code, in particular
1.1242 + * Tcl_GetStringFromObj, to use that old internalRep.
1.1243 + */
1.1244 +
1.1245 + goodBoolean:
1.1246 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1247 + oldTypePtr->freeIntRepProc(objPtr);
1.1248 + }
1.1249 +
1.1250 + objPtr->internalRep.longValue = newBool;
1.1251 + objPtr->typePtr = &tclBooleanType;
1.1252 + return TCL_OK;
1.1253 +
1.1254 + badBoolean:
1.1255 + if (interp != NULL) {
1.1256 + /*
1.1257 + * Must copy string before resetting the result in case a caller
1.1258 + * is trying to convert the interpreter's result to a boolean.
1.1259 + */
1.1260 +
1.1261 + char buf[100];
1.1262 + sprintf(buf, "expected boolean value but got \"%.50s\"", string);
1.1263 + Tcl_ResetResult(interp);
1.1264 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.1265 + }
1.1266 + return TCL_ERROR;
1.1267 +}
1.1268 +
1.1269 +/*
1.1270 + *----------------------------------------------------------------------
1.1271 + *
1.1272 + * UpdateStringOfBoolean --
1.1273 + *
1.1274 + * Update the string representation for a boolean object.
1.1275 + * Note: This procedure does not free an existing old string rep
1.1276 + * so storage will be lost if this has not already been done.
1.1277 + *
1.1278 + * Results:
1.1279 + * None.
1.1280 + *
1.1281 + * Side effects:
1.1282 + * The object's string is set to a valid string that results from
1.1283 + * the boolean-to-string conversion.
1.1284 + *
1.1285 + *----------------------------------------------------------------------
1.1286 + */
1.1287 +
1.1288 +static void
1.1289 +UpdateStringOfBoolean(objPtr)
1.1290 + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
1.1291 +{
1.1292 + char *s = ckalloc((unsigned) 2);
1.1293 +
1.1294 + s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
1.1295 + s[1] = '\0';
1.1296 + objPtr->bytes = s;
1.1297 + objPtr->length = 1;
1.1298 +}
1.1299 +
1.1300 +/*
1.1301 + *----------------------------------------------------------------------
1.1302 + *
1.1303 + * Tcl_NewDoubleObj --
1.1304 + *
1.1305 + * This procedure is normally called when not debugging: i.e., when
1.1306 + * TCL_MEM_DEBUG is not defined. It creates a new double object and
1.1307 + * initializes it from the argument double value.
1.1308 + *
1.1309 + * When TCL_MEM_DEBUG is defined, this procedure just returns the
1.1310 + * result of calling the debugging version Tcl_DbNewDoubleObj.
1.1311 + *
1.1312 + * Results:
1.1313 + * The newly created object is returned. This object will have an
1.1314 + * invalid string representation. The returned object has ref count 0.
1.1315 + *
1.1316 + * Side effects:
1.1317 + * None.
1.1318 + *
1.1319 + *----------------------------------------------------------------------
1.1320 + */
1.1321 +
1.1322 +#ifdef TCL_MEM_DEBUG
1.1323 +#undef Tcl_NewDoubleObj
1.1324 +
1.1325 +EXPORT_C Tcl_Obj *
1.1326 +Tcl_NewDoubleObj(dblValue)
1.1327 + register double dblValue; /* Double used to initialize the object. */
1.1328 +{
1.1329 + return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
1.1330 +}
1.1331 +
1.1332 +#else /* if not TCL_MEM_DEBUG */
1.1333 +
1.1334 +EXPORT_C Tcl_Obj *
1.1335 +Tcl_NewDoubleObj(dblValue)
1.1336 + register double dblValue; /* Double used to initialize the object. */
1.1337 +{
1.1338 + register Tcl_Obj *objPtr;
1.1339 +
1.1340 + TclNewObj(objPtr);
1.1341 + objPtr->bytes = NULL;
1.1342 +
1.1343 + objPtr->internalRep.doubleValue = dblValue;
1.1344 + objPtr->typePtr = &tclDoubleType;
1.1345 + return objPtr;
1.1346 +}
1.1347 +#endif /* if TCL_MEM_DEBUG */
1.1348 +
1.1349 +/*
1.1350 + *----------------------------------------------------------------------
1.1351 + *
1.1352 + * Tcl_DbNewDoubleObj --
1.1353 + *
1.1354 + * This procedure is normally called when debugging: i.e., when
1.1355 + * TCL_MEM_DEBUG is defined. It creates new double objects. It is the
1.1356 + * same as the Tcl_NewDoubleObj procedure above except that it calls
1.1357 + * Tcl_DbCkalloc directly with the file name and line number from its
1.1358 + * caller. This simplifies debugging since then the [memory active]
1.1359 + * command will report the correct file name and line number when
1.1360 + * reporting objects that haven't been freed.
1.1361 + *
1.1362 + * When TCL_MEM_DEBUG is not defined, this procedure just returns the
1.1363 + * result of calling Tcl_NewDoubleObj.
1.1364 + *
1.1365 + * Results:
1.1366 + * The newly created object is returned. This object will have an
1.1367 + * invalid string representation. The returned object has ref count 0.
1.1368 + *
1.1369 + * Side effects:
1.1370 + * None.
1.1371 + *
1.1372 + *----------------------------------------------------------------------
1.1373 + */
1.1374 +
1.1375 +#ifdef TCL_MEM_DEBUG
1.1376 +
1.1377 +EXPORT_C Tcl_Obj *
1.1378 +Tcl_DbNewDoubleObj(dblValue, file, line)
1.1379 + register double dblValue; /* Double used to initialize the object. */
1.1380 + CONST char *file; /* The name of the source file calling this
1.1381 + * procedure; used for debugging. */
1.1382 + int line; /* Line number in the source file; used
1.1383 + * for debugging. */
1.1384 +{
1.1385 + register Tcl_Obj *objPtr;
1.1386 +
1.1387 + TclDbNewObj(objPtr, file, line);
1.1388 + objPtr->bytes = NULL;
1.1389 +
1.1390 + objPtr->internalRep.doubleValue = dblValue;
1.1391 + objPtr->typePtr = &tclDoubleType;
1.1392 + return objPtr;
1.1393 +}
1.1394 +
1.1395 +#else /* if not TCL_MEM_DEBUG */
1.1396 +
1.1397 +EXPORT_C Tcl_Obj *
1.1398 +Tcl_DbNewDoubleObj(dblValue, file, line)
1.1399 + register double dblValue; /* Double used to initialize the object. */
1.1400 + CONST char *file; /* The name of the source file calling this
1.1401 + * procedure; used for debugging. */
1.1402 + int line; /* Line number in the source file; used
1.1403 + * for debugging. */
1.1404 +{
1.1405 + return Tcl_NewDoubleObj(dblValue);
1.1406 +}
1.1407 +#endif /* TCL_MEM_DEBUG */
1.1408 +
1.1409 +/*
1.1410 + *----------------------------------------------------------------------
1.1411 + *
1.1412 + * Tcl_SetDoubleObj --
1.1413 + *
1.1414 + * Modify an object to be a double object and to have the specified
1.1415 + * double value.
1.1416 + *
1.1417 + * Results:
1.1418 + * None.
1.1419 + *
1.1420 + * Side effects:
1.1421 + * The object's old string rep, if any, is freed. Also, any old
1.1422 + * internal rep is freed.
1.1423 + *
1.1424 + *----------------------------------------------------------------------
1.1425 + */
1.1426 +
1.1427 +EXPORT_C void
1.1428 +Tcl_SetDoubleObj(objPtr, dblValue)
1.1429 + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
1.1430 + register double dblValue; /* Double used to set the object's value. */
1.1431 +{
1.1432 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1433 +
1.1434 + if (Tcl_IsShared(objPtr)) {
1.1435 + panic("Tcl_SetDoubleObj called with shared object");
1.1436 + }
1.1437 +
1.1438 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1439 + oldTypePtr->freeIntRepProc(objPtr);
1.1440 + }
1.1441 +
1.1442 + objPtr->internalRep.doubleValue = dblValue;
1.1443 + objPtr->typePtr = &tclDoubleType;
1.1444 + Tcl_InvalidateStringRep(objPtr);
1.1445 +}
1.1446 +
1.1447 +/*
1.1448 + *----------------------------------------------------------------------
1.1449 + *
1.1450 + * Tcl_GetDoubleFromObj --
1.1451 + *
1.1452 + * Attempt to return a double from the Tcl object "objPtr". If the
1.1453 + * object is not already a double, an attempt will be made to convert
1.1454 + * it to one.
1.1455 + *
1.1456 + * Results:
1.1457 + * The return value is a standard Tcl object result. If an error occurs
1.1458 + * during conversion, an error message is left in the interpreter's
1.1459 + * result unless "interp" is NULL.
1.1460 + *
1.1461 + * Side effects:
1.1462 + * If the object is not already a double, the conversion will free
1.1463 + * any old internal representation.
1.1464 + *
1.1465 + *----------------------------------------------------------------------
1.1466 + */
1.1467 +
1.1468 +EXPORT_C int
1.1469 +Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
1.1470 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1471 + register Tcl_Obj *objPtr; /* The object from which to get a double. */
1.1472 + register double *dblPtr; /* Place to store resulting double. */
1.1473 +{
1.1474 + register int result;
1.1475 +
1.1476 + if (objPtr->typePtr == &tclDoubleType) {
1.1477 + *dblPtr = objPtr->internalRep.doubleValue;
1.1478 + return TCL_OK;
1.1479 + }
1.1480 +
1.1481 + result = SetDoubleFromAny(interp, objPtr);
1.1482 + if (result == TCL_OK) {
1.1483 + *dblPtr = objPtr->internalRep.doubleValue;
1.1484 + }
1.1485 + return result;
1.1486 +}
1.1487 +
1.1488 +/*
1.1489 + *----------------------------------------------------------------------
1.1490 + *
1.1491 + * SetDoubleFromAny --
1.1492 + *
1.1493 + * Attempt to generate an double-precision floating point internal form
1.1494 + * for the Tcl object "objPtr".
1.1495 + *
1.1496 + * Results:
1.1497 + * The return value is a standard Tcl object result. If an error occurs
1.1498 + * during conversion, an error message is left in the interpreter's
1.1499 + * result unless "interp" is NULL.
1.1500 + *
1.1501 + * Side effects:
1.1502 + * If no error occurs, a double is stored as "objPtr"s internal
1.1503 + * representation.
1.1504 + *
1.1505 + *----------------------------------------------------------------------
1.1506 + */
1.1507 +
1.1508 +static int
1.1509 +SetDoubleFromAny(interp, objPtr)
1.1510 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1511 + register Tcl_Obj *objPtr; /* The object to convert. */
1.1512 +{
1.1513 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1514 + char *string, *end;
1.1515 + double newDouble;
1.1516 + int length;
1.1517 +
1.1518 + /*
1.1519 + * Get the string representation. Make it up-to-date if necessary.
1.1520 + */
1.1521 +
1.1522 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1523 +
1.1524 + /*
1.1525 + * Now parse "objPtr"s string as an double. Numbers can't have embedded
1.1526 + * NULLs. We use an implementation here that doesn't report errors in
1.1527 + * interp if interp is NULL.
1.1528 + */
1.1529 +
1.1530 + errno = 0;
1.1531 + newDouble = strtod(string, &end);
1.1532 + if (end == string) {
1.1533 + badDouble:
1.1534 + if (interp != NULL) {
1.1535 + /*
1.1536 + * Must copy string before resetting the result in case a caller
1.1537 + * is trying to convert the interpreter's result to an int.
1.1538 + */
1.1539 +
1.1540 + char buf[100];
1.1541 + sprintf(buf, "expected floating-point number but got \"%.50s\"",
1.1542 + string);
1.1543 + Tcl_ResetResult(interp);
1.1544 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.1545 + }
1.1546 + return TCL_ERROR;
1.1547 + }
1.1548 + if (errno != 0) {
1.1549 + if (interp != NULL) {
1.1550 + TclExprFloatError(interp, newDouble);
1.1551 + }
1.1552 + return TCL_ERROR;
1.1553 + }
1.1554 +
1.1555 + /*
1.1556 + * Make sure that the string has no garbage after the end of the double.
1.1557 + */
1.1558 +
1.1559 + while ((end < (string+length))
1.1560 + && isspace(UCHAR(*end))) { /* INTL: ISO space. */
1.1561 + end++;
1.1562 + }
1.1563 + if (end != (string+length)) {
1.1564 + goto badDouble;
1.1565 + }
1.1566 +
1.1567 + /*
1.1568 + * The conversion to double succeeded. Free the old internalRep before
1.1569 + * setting the new one. We do this as late as possible to allow the
1.1570 + * conversion code, in particular Tcl_GetStringFromObj, to use that old
1.1571 + * internalRep.
1.1572 + */
1.1573 +
1.1574 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1575 + oldTypePtr->freeIntRepProc(objPtr);
1.1576 + }
1.1577 +
1.1578 + objPtr->internalRep.doubleValue = newDouble;
1.1579 + objPtr->typePtr = &tclDoubleType;
1.1580 + return TCL_OK;
1.1581 +}
1.1582 +
1.1583 +/*
1.1584 + *----------------------------------------------------------------------
1.1585 + *
1.1586 + * UpdateStringOfDouble --
1.1587 + *
1.1588 + * Update the string representation for a double-precision floating
1.1589 + * point object. This must obey the current tcl_precision value for
1.1590 + * double-to-string conversions. Note: This procedure does not free an
1.1591 + * existing old string rep so storage will be lost if this has not
1.1592 + * already been done.
1.1593 + *
1.1594 + * Results:
1.1595 + * None.
1.1596 + *
1.1597 + * Side effects:
1.1598 + * The object's string is set to a valid string that results from
1.1599 + * the double-to-string conversion.
1.1600 + *
1.1601 + *----------------------------------------------------------------------
1.1602 + */
1.1603 +
1.1604 +static void
1.1605 +UpdateStringOfDouble(objPtr)
1.1606 + register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
1.1607 +{
1.1608 + char buffer[TCL_DOUBLE_SPACE];
1.1609 + register int len;
1.1610 +
1.1611 + Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
1.1612 + buffer);
1.1613 + len = strlen(buffer);
1.1614 +
1.1615 + objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
1.1616 + strcpy(objPtr->bytes, buffer);
1.1617 + objPtr->length = len;
1.1618 +}
1.1619 +
1.1620 +/*
1.1621 + *----------------------------------------------------------------------
1.1622 + *
1.1623 + * Tcl_NewIntObj --
1.1624 + *
1.1625 + * If a client is compiled with TCL_MEM_DEBUG defined, calls to
1.1626 + * Tcl_NewIntObj to create a new integer object end up calling the
1.1627 + * debugging procedure Tcl_DbNewLongObj instead.
1.1628 + *
1.1629 + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
1.1630 + * calls to Tcl_NewIntObj result in a call to one of the two
1.1631 + * Tcl_NewIntObj implementations below. We provide two implementations
1.1632 + * so that the Tcl core can be compiled to do memory debugging of the
1.1633 + * core even if a client does not request it for itself.
1.1634 + *
1.1635 + * Integer and long integer objects share the same "integer" type
1.1636 + * implementation. We store all integers as longs and Tcl_GetIntFromObj
1.1637 + * checks whether the current value of the long can be represented by
1.1638 + * an int.
1.1639 + *
1.1640 + * Results:
1.1641 + * The newly created object is returned. This object will have an
1.1642 + * invalid string representation. The returned object has ref count 0.
1.1643 + *
1.1644 + * Side effects:
1.1645 + * None.
1.1646 + *
1.1647 + *----------------------------------------------------------------------
1.1648 + */
1.1649 +
1.1650 +#ifdef TCL_MEM_DEBUG
1.1651 +#undef Tcl_NewIntObj
1.1652 +
1.1653 +EXPORT_C Tcl_Obj *
1.1654 +Tcl_NewIntObj(intValue)
1.1655 + register int intValue; /* Int used to initialize the new object. */
1.1656 +{
1.1657 + return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
1.1658 +}
1.1659 +
1.1660 +#else /* if not TCL_MEM_DEBUG */
1.1661 +
1.1662 +EXPORT_C Tcl_Obj *
1.1663 +Tcl_NewIntObj(intValue)
1.1664 + register int intValue; /* Int used to initialize the new object. */
1.1665 +{
1.1666 + register Tcl_Obj *objPtr;
1.1667 +
1.1668 + TclNewObj(objPtr);
1.1669 + objPtr->bytes = NULL;
1.1670 +
1.1671 + objPtr->internalRep.longValue = (long)intValue;
1.1672 + objPtr->typePtr = &tclIntType;
1.1673 + return objPtr;
1.1674 +}
1.1675 +#endif /* if TCL_MEM_DEBUG */
1.1676 +
1.1677 +/*
1.1678 + *----------------------------------------------------------------------
1.1679 + *
1.1680 + * Tcl_SetIntObj --
1.1681 + *
1.1682 + * Modify an object to be an integer and to have the specified integer
1.1683 + * value.
1.1684 + *
1.1685 + * Results:
1.1686 + * None.
1.1687 + *
1.1688 + * Side effects:
1.1689 + * The object's old string rep, if any, is freed. Also, any old
1.1690 + * internal rep is freed.
1.1691 + *
1.1692 + *----------------------------------------------------------------------
1.1693 + */
1.1694 +
1.1695 +EXPORT_C void
1.1696 +Tcl_SetIntObj(objPtr, intValue)
1.1697 + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
1.1698 + register int intValue; /* Integer used to set object's value. */
1.1699 +{
1.1700 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1701 +
1.1702 + if (Tcl_IsShared(objPtr)) {
1.1703 + panic("Tcl_SetIntObj called with shared object");
1.1704 + }
1.1705 +
1.1706 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1707 + oldTypePtr->freeIntRepProc(objPtr);
1.1708 + }
1.1709 +
1.1710 + objPtr->internalRep.longValue = (long) intValue;
1.1711 + objPtr->typePtr = &tclIntType;
1.1712 + Tcl_InvalidateStringRep(objPtr);
1.1713 +}
1.1714 +
1.1715 +/*
1.1716 + *----------------------------------------------------------------------
1.1717 + *
1.1718 + * Tcl_GetIntFromObj --
1.1719 + *
1.1720 + * Attempt to return an int from the Tcl object "objPtr". If the object
1.1721 + * is not already an int, an attempt will be made to convert it to one.
1.1722 + *
1.1723 + * Integer and long integer objects share the same "integer" type
1.1724 + * implementation. We store all integers as longs and Tcl_GetIntFromObj
1.1725 + * checks whether the current value of the long can be represented by
1.1726 + * an int.
1.1727 + *
1.1728 + * Results:
1.1729 + * The return value is a standard Tcl object result. If an error occurs
1.1730 + * during conversion or if the long integer held by the object
1.1731 + * can not be represented by an int, an error message is left in
1.1732 + * the interpreter's result unless "interp" is NULL.
1.1733 + *
1.1734 + * Side effects:
1.1735 + * If the object is not already an int, the conversion will free
1.1736 + * any old internal representation.
1.1737 + *
1.1738 + *----------------------------------------------------------------------
1.1739 + */
1.1740 +
1.1741 +EXPORT_C int
1.1742 +Tcl_GetIntFromObj(interp, objPtr, intPtr)
1.1743 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1744 + register Tcl_Obj *objPtr; /* The object from which to get a int. */
1.1745 + register int *intPtr; /* Place to store resulting int. */
1.1746 +{
1.1747 + int result;
1.1748 + Tcl_WideInt w = 0;
1.1749 +
1.1750 + /*
1.1751 + * If the object isn't already an integer of any width, try to
1.1752 + * convert it to one.
1.1753 + */
1.1754 +
1.1755 + if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
1.1756 + result = SetIntOrWideFromAny(interp, objPtr);
1.1757 + if (result != TCL_OK) {
1.1758 + return result;
1.1759 + }
1.1760 + }
1.1761 +
1.1762 + /*
1.1763 + * Object should now be either int or wide. Get its value.
1.1764 + */
1.1765 +
1.1766 +#ifndef TCL_WIDE_INT_IS_LONG
1.1767 + if (objPtr->typePtr == &tclWideIntType) {
1.1768 + w = objPtr->internalRep.wideValue;
1.1769 + } else
1.1770 +#endif
1.1771 + {
1.1772 + w = Tcl_LongAsWide(objPtr->internalRep.longValue);
1.1773 + }
1.1774 +
1.1775 + if ((LLONG_MAX > UINT_MAX)
1.1776 + && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
1.1777 + if (interp != NULL) {
1.1778 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.1779 + "integer value too large to represent as non-long integer",
1.1780 + -1));
1.1781 + }
1.1782 + return TCL_ERROR;
1.1783 + }
1.1784 + *intPtr = (int)w;
1.1785 + return TCL_OK;
1.1786 +}
1.1787 +
1.1788 +/*
1.1789 + *----------------------------------------------------------------------
1.1790 + *
1.1791 + * SetIntFromAny --
1.1792 + *
1.1793 + * Attempts to force the internal representation for a Tcl object
1.1794 + * to tclIntType, specifically.
1.1795 + *
1.1796 + * Results:
1.1797 + * The return value is a standard object Tcl result. If an
1.1798 + * error occurs during conversion, an error message is left in
1.1799 + * the interpreter's result unless "interp" is NULL.
1.1800 + *
1.1801 + *----------------------------------------------------------------------
1.1802 + */
1.1803 +
1.1804 +static int
1.1805 +SetIntFromAny( Tcl_Interp* interp,
1.1806 + /* Tcl interpreter */
1.1807 + Tcl_Obj* objPtr )
1.1808 + /* Pointer to the object to convert */
1.1809 +{
1.1810 + int result;
1.1811 +
1.1812 + result = SetIntOrWideFromAny( interp, objPtr );
1.1813 + if ( result != TCL_OK ) {
1.1814 + return result;
1.1815 + }
1.1816 + if ( objPtr->typePtr != &tclIntType ) {
1.1817 + if ( interp != NULL ) {
1.1818 + char *s = "integer value too large to represent";
1.1819 + Tcl_ResetResult(interp);
1.1820 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.1821 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
1.1822 + }
1.1823 + return TCL_ERROR;
1.1824 + }
1.1825 + return TCL_OK;
1.1826 +}
1.1827 +
1.1828 +/*
1.1829 + *----------------------------------------------------------------------
1.1830 + *
1.1831 + * SetIntOrWideFromAny --
1.1832 + *
1.1833 + * Attempt to generate an integer internal form for the Tcl object
1.1834 + * "objPtr".
1.1835 + *
1.1836 + * Results:
1.1837 + * The return value is a standard object Tcl result. If an error occurs
1.1838 + * during conversion, an error message is left in the interpreter's
1.1839 + * result unless "interp" is NULL.
1.1840 + *
1.1841 + * Side effects:
1.1842 + * If no error occurs, an int is stored as "objPtr"s internal
1.1843 + * representation.
1.1844 + *
1.1845 + *----------------------------------------------------------------------
1.1846 + */
1.1847 +
1.1848 +static int
1.1849 +SetIntOrWideFromAny(interp, objPtr)
1.1850 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.1851 + register Tcl_Obj *objPtr; /* The object to convert. */
1.1852 +{
1.1853 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1854 + char *string, *end;
1.1855 + int length;
1.1856 + register char *p;
1.1857 + unsigned long newLong;
1.1858 + int isNegative = 0;
1.1859 + int isWide = 0;
1.1860 +
1.1861 + /*
1.1862 + * Get the string representation. Make it up-to-date if necessary.
1.1863 + */
1.1864 +
1.1865 + p = string = Tcl_GetStringFromObj(objPtr, &length);
1.1866 +
1.1867 + /*
1.1868 + * Now parse "objPtr"s string as an int. We use an implementation here
1.1869 + * that doesn't report errors in interp if interp is NULL. Note: use
1.1870 + * strtoul instead of strtol for integer conversions to allow full-size
1.1871 + * unsigned numbers, but don't depend on strtoul to handle sign
1.1872 + * characters; it won't in some implementations.
1.1873 + */
1.1874 +
1.1875 + errno = 0;
1.1876 + for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
1.1877 + /* Empty loop body. */
1.1878 + }
1.1879 + if (*p == '-') {
1.1880 + p++;
1.1881 + isNegative = 1;
1.1882 + } else if (*p == '+') {
1.1883 + p++;
1.1884 + }
1.1885 + if (!isdigit(UCHAR(*p))) {
1.1886 + badInteger:
1.1887 + if (interp != NULL) {
1.1888 + /*
1.1889 + * Must copy string before resetting the result in case a caller
1.1890 + * is trying to convert the interpreter's result to an int.
1.1891 + */
1.1892 +
1.1893 + char buf[100];
1.1894 + sprintf(buf, "expected integer but got \"%.50s\"", string);
1.1895 + Tcl_ResetResult(interp);
1.1896 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.1897 + TclCheckBadOctal(interp, string);
1.1898 + }
1.1899 + return TCL_ERROR;
1.1900 + }
1.1901 + newLong = strtoul(p, &end, 0);
1.1902 + if (end == p) {
1.1903 + goto badInteger;
1.1904 + }
1.1905 + if (errno == ERANGE) {
1.1906 + if (interp != NULL) {
1.1907 + char *s = "integer value too large to represent";
1.1908 + Tcl_ResetResult(interp);
1.1909 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.1910 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
1.1911 + }
1.1912 + return TCL_ERROR;
1.1913 + }
1.1914 +
1.1915 + /*
1.1916 + * Make sure that the string has no garbage after the end of the int.
1.1917 + */
1.1918 +
1.1919 + while ((end < (string+length))
1.1920 + && isspace(UCHAR(*end))) { /* INTL: ISO space. */
1.1921 + end++;
1.1922 + }
1.1923 + if (end != (string+length)) {
1.1924 + goto badInteger;
1.1925 + }
1.1926 +
1.1927 + /*
1.1928 + * If the resulting integer will exceed the range of a long,
1.1929 + * put it into a wide instead. (Tcl Bug #868489)
1.1930 + */
1.1931 +
1.1932 +#ifndef TCL_WIDE_INT_IS_LONG
1.1933 + if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
1.1934 + || (!isNegative && newLong > LONG_MAX)) {
1.1935 + isWide = 1;
1.1936 + }
1.1937 +#endif
1.1938 +
1.1939 + /*
1.1940 + * The conversion to int succeeded. Free the old internalRep before
1.1941 + * setting the new one. We do this as late as possible to allow the
1.1942 + * conversion code, in particular Tcl_GetStringFromObj, to use that old
1.1943 + * internalRep.
1.1944 + */
1.1945 +
1.1946 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1947 + oldTypePtr->freeIntRepProc(objPtr);
1.1948 + }
1.1949 +
1.1950 + if (isWide) {
1.1951 + objPtr->internalRep.wideValue =
1.1952 + (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
1.1953 + objPtr->typePtr = &tclWideIntType;
1.1954 + } else {
1.1955 + objPtr->internalRep.longValue =
1.1956 + (isNegative ? -(long)newLong : (long)newLong);
1.1957 + objPtr->typePtr = &tclIntType;
1.1958 + }
1.1959 + return TCL_OK;
1.1960 +}
1.1961 +
1.1962 +/*
1.1963 + *----------------------------------------------------------------------
1.1964 + *
1.1965 + * UpdateStringOfInt --
1.1966 + *
1.1967 + * Update the string representation for an integer object.
1.1968 + * Note: This procedure does not free an existing old string rep
1.1969 + * so storage will be lost if this has not already been done.
1.1970 + *
1.1971 + * Results:
1.1972 + * None.
1.1973 + *
1.1974 + * Side effects:
1.1975 + * The object's string is set to a valid string that results from
1.1976 + * the int-to-string conversion.
1.1977 + *
1.1978 + *----------------------------------------------------------------------
1.1979 + */
1.1980 +
1.1981 +static void
1.1982 +UpdateStringOfInt(objPtr)
1.1983 + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
1.1984 +{
1.1985 + char buffer[TCL_INTEGER_SPACE];
1.1986 + register int len;
1.1987 +
1.1988 + len = TclFormatInt(buffer, objPtr->internalRep.longValue);
1.1989 +
1.1990 + objPtr->bytes = ckalloc((unsigned) len + 1);
1.1991 + strcpy(objPtr->bytes, buffer);
1.1992 + objPtr->length = len;
1.1993 +}
1.1994 +
1.1995 +/*
1.1996 + *----------------------------------------------------------------------
1.1997 + *
1.1998 + * Tcl_NewLongObj --
1.1999 + *
1.2000 + * If a client is compiled with TCL_MEM_DEBUG defined, calls to
1.2001 + * Tcl_NewLongObj to create a new long integer object end up calling
1.2002 + * the debugging procedure Tcl_DbNewLongObj instead.
1.2003 + *
1.2004 + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
1.2005 + * calls to Tcl_NewLongObj result in a call to one of the two
1.2006 + * Tcl_NewLongObj implementations below. We provide two implementations
1.2007 + * so that the Tcl core can be compiled to do memory debugging of the
1.2008 + * core even if a client does not request it for itself.
1.2009 + *
1.2010 + * Integer and long integer objects share the same "integer" type
1.2011 + * implementation. We store all integers as longs and Tcl_GetIntFromObj
1.2012 + * checks whether the current value of the long can be represented by
1.2013 + * an int.
1.2014 + *
1.2015 + * Results:
1.2016 + * The newly created object is returned. This object will have an
1.2017 + * invalid string representation. The returned object has ref count 0.
1.2018 + *
1.2019 + * Side effects:
1.2020 + * None.
1.2021 + *
1.2022 + *----------------------------------------------------------------------
1.2023 + */
1.2024 +
1.2025 +#ifdef TCL_MEM_DEBUG
1.2026 +#undef Tcl_NewLongObj
1.2027 +
1.2028 +EXPORT_C Tcl_Obj *
1.2029 +Tcl_NewLongObj(longValue)
1.2030 + register long longValue; /* Long integer used to initialize the
1.2031 + * new object. */
1.2032 +{
1.2033 + return Tcl_DbNewLongObj(longValue, "unknown", 0);
1.2034 +}
1.2035 +
1.2036 +#else /* if not TCL_MEM_DEBUG */
1.2037 +
1.2038 +EXPORT_C Tcl_Obj *
1.2039 +Tcl_NewLongObj(longValue)
1.2040 + register long longValue; /* Long integer used to initialize the
1.2041 + * new object. */
1.2042 +{
1.2043 + register Tcl_Obj *objPtr;
1.2044 +
1.2045 + TclNewObj(objPtr);
1.2046 + objPtr->bytes = NULL;
1.2047 +
1.2048 + objPtr->internalRep.longValue = longValue;
1.2049 + objPtr->typePtr = &tclIntType;
1.2050 + return objPtr;
1.2051 +}
1.2052 +#endif /* if TCL_MEM_DEBUG */
1.2053 +
1.2054 +/*
1.2055 + *----------------------------------------------------------------------
1.2056 + *
1.2057 + * Tcl_DbNewLongObj --
1.2058 + *
1.2059 + * If a client is compiled with TCL_MEM_DEBUG defined, calls to
1.2060 + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
1.2061 + * long integer objects end up calling the debugging procedure
1.2062 + * Tcl_DbNewLongObj instead. We provide two implementations of
1.2063 + * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
1.2064 + * memory debugging of the core is independent of whether a client
1.2065 + * requests debugging for itself.
1.2066 + *
1.2067 + * When the core is compiled with TCL_MEM_DEBUG defined,
1.2068 + * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
1.2069 + * line number from its caller. This simplifies debugging since then
1.2070 + * the [memory active] command will report the caller's file name and
1.2071 + * line number when reporting objects that haven't been freed.
1.2072 + *
1.2073 + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
1.2074 + * this procedure just returns the result of calling Tcl_NewLongObj.
1.2075 + *
1.2076 + * Results:
1.2077 + * The newly created long integer object is returned. This object
1.2078 + * will have an invalid string representation. The returned object has
1.2079 + * ref count 0.
1.2080 + *
1.2081 + * Side effects:
1.2082 + * Allocates memory.
1.2083 + *
1.2084 + *----------------------------------------------------------------------
1.2085 + */
1.2086 +
1.2087 +#ifdef TCL_MEM_DEBUG
1.2088 +
1.2089 +EXPORT_C Tcl_Obj *
1.2090 +Tcl_DbNewLongObj(longValue, file, line)
1.2091 + register long longValue; /* Long integer used to initialize the
1.2092 + * new object. */
1.2093 + CONST char *file; /* The name of the source file calling this
1.2094 + * procedure; used for debugging. */
1.2095 + int line; /* Line number in the source file; used
1.2096 + * for debugging. */
1.2097 +{
1.2098 + register Tcl_Obj *objPtr;
1.2099 +
1.2100 + TclDbNewObj(objPtr, file, line);
1.2101 + objPtr->bytes = NULL;
1.2102 +
1.2103 + objPtr->internalRep.longValue = longValue;
1.2104 + objPtr->typePtr = &tclIntType;
1.2105 + return objPtr;
1.2106 +}
1.2107 +
1.2108 +#else /* if not TCL_MEM_DEBUG */
1.2109 +
1.2110 +EXPORT_C Tcl_Obj *
1.2111 +Tcl_DbNewLongObj(longValue, file, line)
1.2112 + register long longValue; /* Long integer used to initialize the
1.2113 + * new object. */
1.2114 + CONST char *file; /* The name of the source file calling this
1.2115 + * procedure; used for debugging. */
1.2116 + int line; /* Line number in the source file; used
1.2117 + * for debugging. */
1.2118 +{
1.2119 + return Tcl_NewLongObj(longValue);
1.2120 +}
1.2121 +#endif /* TCL_MEM_DEBUG */
1.2122 +
1.2123 +/*
1.2124 + *----------------------------------------------------------------------
1.2125 + *
1.2126 + * Tcl_SetLongObj --
1.2127 + *
1.2128 + * Modify an object to be an integer object and to have the specified
1.2129 + * long integer value.
1.2130 + *
1.2131 + * Results:
1.2132 + * None.
1.2133 + *
1.2134 + * Side effects:
1.2135 + * The object's old string rep, if any, is freed. Also, any old
1.2136 + * internal rep is freed.
1.2137 + *
1.2138 + *----------------------------------------------------------------------
1.2139 + */
1.2140 +
1.2141 +EXPORT_C void
1.2142 +Tcl_SetLongObj(objPtr, longValue)
1.2143 + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
1.2144 + register long longValue; /* Long integer used to initialize the
1.2145 + * object's value. */
1.2146 +{
1.2147 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.2148 +
1.2149 + if (Tcl_IsShared(objPtr)) {
1.2150 + panic("Tcl_SetLongObj called with shared object");
1.2151 + }
1.2152 +
1.2153 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.2154 + oldTypePtr->freeIntRepProc(objPtr);
1.2155 + }
1.2156 +
1.2157 + objPtr->internalRep.longValue = longValue;
1.2158 + objPtr->typePtr = &tclIntType;
1.2159 + Tcl_InvalidateStringRep(objPtr);
1.2160 +}
1.2161 +
1.2162 +/*
1.2163 + *----------------------------------------------------------------------
1.2164 + *
1.2165 + * Tcl_GetLongFromObj --
1.2166 + *
1.2167 + * Attempt to return an long integer from the Tcl object "objPtr". If
1.2168 + * the object is not already an int object, an attempt will be made to
1.2169 + * convert it to one.
1.2170 + *
1.2171 + * Results:
1.2172 + * The return value is a standard Tcl object result. If an error occurs
1.2173 + * during conversion, an error message is left in the interpreter's
1.2174 + * result unless "interp" is NULL.
1.2175 + *
1.2176 + * Side effects:
1.2177 + * If the object is not already an int object, the conversion will free
1.2178 + * any old internal representation.
1.2179 + *
1.2180 + *----------------------------------------------------------------------
1.2181 + */
1.2182 +
1.2183 +EXPORT_C int
1.2184 +Tcl_GetLongFromObj(interp, objPtr, longPtr)
1.2185 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.2186 + register Tcl_Obj *objPtr; /* The object from which to get a long. */
1.2187 + register long *longPtr; /* Place to store resulting long. */
1.2188 +{
1.2189 + register int result;
1.2190 +
1.2191 + if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
1.2192 + result = SetIntOrWideFromAny(interp, objPtr);
1.2193 + if (result != TCL_OK) {
1.2194 + return result;
1.2195 + }
1.2196 + }
1.2197 +
1.2198 +#ifndef TCL_WIDE_INT_IS_LONG
1.2199 + if (objPtr->typePtr == &tclWideIntType) {
1.2200 + /*
1.2201 + * If the object is already a wide integer, don't convert it.
1.2202 + * This code allows for any integer in the range -ULONG_MAX to
1.2203 + * ULONG_MAX to be converted to a long, ignoring overflow.
1.2204 + * The rule preserves existing semantics for conversion of
1.2205 + * integers on input, but avoids inadvertent demotion of
1.2206 + * wide integers to 32-bit ones in the internal rep.
1.2207 + */
1.2208 +
1.2209 + Tcl_WideInt w = objPtr->internalRep.wideValue;
1.2210 + if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) {
1.2211 + *longPtr = Tcl_WideAsLong(w);
1.2212 + return TCL_OK;
1.2213 + } else {
1.2214 + if (interp != NULL) {
1.2215 + Tcl_ResetResult(interp);
1.2216 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.2217 + "integer value too large to represent", -1);
1.2218 + }
1.2219 + return TCL_ERROR;
1.2220 + }
1.2221 + }
1.2222 +#endif
1.2223 +
1.2224 + *longPtr = objPtr->internalRep.longValue;
1.2225 + return TCL_OK;
1.2226 +}
1.2227 +
1.2228 +/*
1.2229 + *----------------------------------------------------------------------
1.2230 + *
1.2231 + * SetWideIntFromAny --
1.2232 + *
1.2233 + * Attempt to generate an integer internal form for the Tcl object
1.2234 + * "objPtr".
1.2235 + *
1.2236 + * Results:
1.2237 + * The return value is a standard object Tcl result. If an error occurs
1.2238 + * during conversion, an error message is left in the interpreter's
1.2239 + * result unless "interp" is NULL.
1.2240 + *
1.2241 + * Side effects:
1.2242 + * If no error occurs, an int is stored as "objPtr"s internal
1.2243 + * representation.
1.2244 + *
1.2245 + *----------------------------------------------------------------------
1.2246 + */
1.2247 +
1.2248 +static int
1.2249 +SetWideIntFromAny(interp, objPtr)
1.2250 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.2251 + register Tcl_Obj *objPtr; /* The object to convert. */
1.2252 +{
1.2253 +#ifndef TCL_WIDE_INT_IS_LONG
1.2254 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.2255 + char *string, *end;
1.2256 + int length;
1.2257 + register char *p;
1.2258 + Tcl_WideInt newWide;
1.2259 +
1.2260 + /*
1.2261 + * Get the string representation. Make it up-to-date if necessary.
1.2262 + */
1.2263 +
1.2264 + p = string = Tcl_GetStringFromObj(objPtr, &length);
1.2265 +
1.2266 + /*
1.2267 + * Now parse "objPtr"s string as an int. We use an implementation here
1.2268 + * that doesn't report errors in interp if interp is NULL. Note: use
1.2269 + * strtoull instead of strtoll for integer conversions to allow full-size
1.2270 + * unsigned numbers, but don't depend on strtoull to handle sign
1.2271 + * characters; it won't in some implementations.
1.2272 + */
1.2273 +
1.2274 + errno = 0;
1.2275 +#ifdef TCL_STRTOUL_SIGN_CHECK
1.2276 + for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
1.2277 + /* Empty loop body. */
1.2278 + }
1.2279 + if (*p == '-') {
1.2280 + p++;
1.2281 + newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
1.2282 + } else if (*p == '+') {
1.2283 + p++;
1.2284 + newWide = strtoull(p, &end, 0);
1.2285 + } else
1.2286 +#else
1.2287 + newWide = strtoull(p, &end, 0);
1.2288 +#endif
1.2289 + if (end == p) {
1.2290 + badInteger:
1.2291 + if (interp != NULL) {
1.2292 + /*
1.2293 + * Must copy string before resetting the result in case a caller
1.2294 + * is trying to convert the interpreter's result to an int.
1.2295 + */
1.2296 +
1.2297 + char buf[100];
1.2298 + sprintf(buf, "expected integer but got \"%.50s\"", string);
1.2299 + Tcl_ResetResult(interp);
1.2300 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.2301 + TclCheckBadOctal(interp, string);
1.2302 + }
1.2303 + return TCL_ERROR;
1.2304 + }
1.2305 + if (errno == ERANGE) {
1.2306 + if (interp != NULL) {
1.2307 + char *s = "integer value too large to represent";
1.2308 + Tcl_ResetResult(interp);
1.2309 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.2310 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
1.2311 + }
1.2312 + return TCL_ERROR;
1.2313 + }
1.2314 +
1.2315 + /*
1.2316 + * Make sure that the string has no garbage after the end of the int.
1.2317 + */
1.2318 +
1.2319 + while ((end < (string+length))
1.2320 + && isspace(UCHAR(*end))) { /* INTL: ISO space. */
1.2321 + end++;
1.2322 + }
1.2323 + if (end != (string+length)) {
1.2324 + goto badInteger;
1.2325 + }
1.2326 +
1.2327 + /*
1.2328 + * The conversion to int succeeded. Free the old internalRep before
1.2329 + * setting the new one. We do this as late as possible to allow the
1.2330 + * conversion code, in particular Tcl_GetStringFromObj, to use that old
1.2331 + * internalRep.
1.2332 + */
1.2333 +
1.2334 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.2335 + oldTypePtr->freeIntRepProc(objPtr);
1.2336 + }
1.2337 +
1.2338 + objPtr->internalRep.wideValue = newWide;
1.2339 +#else
1.2340 + if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
1.2341 + return TCL_ERROR;
1.2342 + }
1.2343 +#endif
1.2344 + objPtr->typePtr = &tclWideIntType;
1.2345 + return TCL_OK;
1.2346 +}
1.2347 +
1.2348 +/*
1.2349 + *----------------------------------------------------------------------
1.2350 + *
1.2351 + * UpdateStringOfWideInt --
1.2352 + *
1.2353 + * Update the string representation for a wide integer object.
1.2354 + * Note: This procedure does not free an existing old string rep
1.2355 + * so storage will be lost if this has not already been done.
1.2356 + *
1.2357 + * Results:
1.2358 + * None.
1.2359 + *
1.2360 + * Side effects:
1.2361 + * The object's string is set to a valid string that results from
1.2362 + * the wideInt-to-string conversion.
1.2363 + *
1.2364 + *----------------------------------------------------------------------
1.2365 + */
1.2366 +
1.2367 +#ifndef TCL_WIDE_INT_IS_LONG
1.2368 +static void
1.2369 +UpdateStringOfWideInt(objPtr)
1.2370 + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
1.2371 +{
1.2372 + char buffer[TCL_INTEGER_SPACE+2];
1.2373 + register unsigned len;
1.2374 + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
1.2375 +
1.2376 + /*
1.2377 + * Note that sprintf will generate a compiler warning under
1.2378 + * Mingw claiming %I64 is an unknown format specifier.
1.2379 + * Just ignore this warning. We can't use %L as the format
1.2380 + * specifier since that gets printed as a 32 bit value.
1.2381 + */
1.2382 + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
1.2383 + len = strlen(buffer);
1.2384 + objPtr->bytes = ckalloc((unsigned) len + 1);
1.2385 + memcpy(objPtr->bytes, buffer, len + 1);
1.2386 + objPtr->length = len;
1.2387 +}
1.2388 +#endif /* TCL_WIDE_INT_IS_LONG */
1.2389 +
1.2390 +/*
1.2391 + *----------------------------------------------------------------------
1.2392 + *
1.2393 + * Tcl_NewWideIntObj --
1.2394 + *
1.2395 + * If a client is compiled with TCL_MEM_DEBUG defined, calls to
1.2396 + * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
1.2397 + * the debugging procedure Tcl_DbNewWideIntObj instead.
1.2398 + *
1.2399 + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
1.2400 + * calls to Tcl_NewWideIntObj result in a call to one of the two
1.2401 + * Tcl_NewWideIntObj implementations below. We provide two implementations
1.2402 + * so that the Tcl core can be compiled to do memory debugging of the
1.2403 + * core even if a client does not request it for itself.
1.2404 + *
1.2405 + * Results:
1.2406 + * The newly created object is returned. This object will have an
1.2407 + * invalid string representation. The returned object has ref count 0.
1.2408 + *
1.2409 + * Side effects:
1.2410 + * None.
1.2411 + *
1.2412 + *----------------------------------------------------------------------
1.2413 + */
1.2414 +
1.2415 +#ifdef TCL_MEM_DEBUG
1.2416 +#undef Tcl_NewWideIntObj
1.2417 +
1.2418 +EXPORT_C Tcl_Obj *
1.2419 +Tcl_NewWideIntObj(wideValue)
1.2420 + register Tcl_WideInt wideValue; /* Wide integer used to initialize
1.2421 + * the new object. */
1.2422 +{
1.2423 + return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
1.2424 +}
1.2425 +
1.2426 +#else /* if not TCL_MEM_DEBUG */
1.2427 +
1.2428 +EXPORT_C Tcl_Obj *
1.2429 +Tcl_NewWideIntObj(wideValue)
1.2430 + register Tcl_WideInt wideValue; /* Wide integer used to initialize
1.2431 + * the new object. */
1.2432 +{
1.2433 + register Tcl_Obj *objPtr;
1.2434 +
1.2435 + TclNewObj(objPtr);
1.2436 + objPtr->bytes = NULL;
1.2437 +
1.2438 + objPtr->internalRep.wideValue = wideValue;
1.2439 + objPtr->typePtr = &tclWideIntType;
1.2440 + return objPtr;
1.2441 +}
1.2442 +#endif /* if TCL_MEM_DEBUG */
1.2443 +
1.2444 +/*
1.2445 + *----------------------------------------------------------------------
1.2446 + *
1.2447 + * Tcl_DbNewWideIntObj --
1.2448 + *
1.2449 + * If a client is compiled with TCL_MEM_DEBUG defined, calls to
1.2450 + * Tcl_NewWideIntObj to create new wide integer end up calling
1.2451 + * the debugging procedure Tcl_DbNewWideIntObj instead. We
1.2452 + * provide two implementations of Tcl_DbNewWideIntObj so that
1.2453 + * whether the Tcl core is compiled to do memory debugging of the
1.2454 + * core is independent of whether a client requests debugging for
1.2455 + * itself.
1.2456 + *
1.2457 + * When the core is compiled with TCL_MEM_DEBUG defined,
1.2458 + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file
1.2459 + * name and line number from its caller. This simplifies
1.2460 + * debugging since then the checkmem command will report the
1.2461 + * caller's file name and line number when reporting objects that
1.2462 + * haven't been freed.
1.2463 + *
1.2464 + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
1.2465 + * this procedure just returns the result of calling Tcl_NewWideIntObj.
1.2466 + *
1.2467 + * Results:
1.2468 + * The newly created wide integer object is returned. This object
1.2469 + * will have an invalid string representation. The returned object has
1.2470 + * ref count 0.
1.2471 + *
1.2472 + * Side effects:
1.2473 + * Allocates memory.
1.2474 + *
1.2475 + *----------------------------------------------------------------------
1.2476 + */
1.2477 +
1.2478 +#ifdef TCL_MEM_DEBUG
1.2479 +
1.2480 +EXPORT_C Tcl_Obj *
1.2481 +Tcl_DbNewWideIntObj(wideValue, file, line)
1.2482 + register Tcl_WideInt wideValue; /* Wide integer used to initialize
1.2483 + * the new object. */
1.2484 + CONST char *file; /* The name of the source file
1.2485 + * calling this procedure; used for
1.2486 + * debugging. */
1.2487 + int line; /* Line number in the source file;
1.2488 + * used for debugging. */
1.2489 +{
1.2490 + register Tcl_Obj *objPtr;
1.2491 +
1.2492 + TclDbNewObj(objPtr, file, line);
1.2493 + objPtr->bytes = NULL;
1.2494 +
1.2495 + objPtr->internalRep.wideValue = wideValue;
1.2496 + objPtr->typePtr = &tclWideIntType;
1.2497 + return objPtr;
1.2498 +}
1.2499 +
1.2500 +#else /* if not TCL_MEM_DEBUG */
1.2501 +
1.2502 +EXPORT_C Tcl_Obj *
1.2503 +Tcl_DbNewWideIntObj(wideValue, file, line)
1.2504 + register Tcl_WideInt wideValue; /* Long integer used to initialize
1.2505 + * the new object. */
1.2506 + CONST char *file; /* The name of the source file
1.2507 + * calling this procedure; used for
1.2508 + * debugging. */
1.2509 + int line; /* Line number in the source file;
1.2510 + * used for debugging. */
1.2511 +{
1.2512 + return Tcl_NewWideIntObj(wideValue);
1.2513 +}
1.2514 +#endif /* TCL_MEM_DEBUG */
1.2515 +
1.2516 +/*
1.2517 + *----------------------------------------------------------------------
1.2518 + *
1.2519 + * Tcl_SetWideIntObj --
1.2520 + *
1.2521 + * Modify an object to be a wide integer object and to have the
1.2522 + * specified wide integer value.
1.2523 + *
1.2524 + * Results:
1.2525 + * None.
1.2526 + *
1.2527 + * Side effects:
1.2528 + * The object's old string rep, if any, is freed. Also, any old
1.2529 + * internal rep is freed.
1.2530 + *
1.2531 + *----------------------------------------------------------------------
1.2532 + */
1.2533 +
1.2534 +EXPORT_C void
1.2535 +Tcl_SetWideIntObj(objPtr, wideValue)
1.2536 + register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
1.2537 + register Tcl_WideInt wideValue; /* Wide integer used to initialize
1.2538 + * the object's value. */
1.2539 +{
1.2540 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.2541 +
1.2542 + if (Tcl_IsShared(objPtr)) {
1.2543 + panic("Tcl_SetWideIntObj called with shared object");
1.2544 + }
1.2545 +
1.2546 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.2547 + oldTypePtr->freeIntRepProc(objPtr);
1.2548 + }
1.2549 +
1.2550 + objPtr->internalRep.wideValue = wideValue;
1.2551 + objPtr->typePtr = &tclWideIntType;
1.2552 + Tcl_InvalidateStringRep(objPtr);
1.2553 +}
1.2554 +
1.2555 +/*
1.2556 + *----------------------------------------------------------------------
1.2557 + *
1.2558 + * Tcl_GetWideIntFromObj --
1.2559 + *
1.2560 + * Attempt to return a wide integer from the Tcl object "objPtr". If
1.2561 + * the object is not already a wide int object, an attempt will be made
1.2562 + * to convert it to one.
1.2563 + *
1.2564 + * Results:
1.2565 + * The return value is a standard Tcl object result. If an error occurs
1.2566 + * during conversion, an error message is left in the interpreter's
1.2567 + * result unless "interp" is NULL.
1.2568 + *
1.2569 + * Side effects:
1.2570 + * If the object is not already an int object, the conversion will free
1.2571 + * any old internal representation.
1.2572 + *
1.2573 + *----------------------------------------------------------------------
1.2574 + */
1.2575 +
1.2576 +EXPORT_C int
1.2577 +Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
1.2578 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.2579 + register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
1.2580 + register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
1.2581 +{
1.2582 + register int result;
1.2583 +
1.2584 + if (objPtr->typePtr == &tclWideIntType) {
1.2585 + gotWide:
1.2586 + *wideIntPtr = objPtr->internalRep.wideValue;
1.2587 + return TCL_OK;
1.2588 + }
1.2589 + if (objPtr->typePtr == &tclIntType) {
1.2590 + /*
1.2591 + * This cast is safe; all valid ints/longs are wides.
1.2592 + */
1.2593 +
1.2594 + objPtr->internalRep.wideValue =
1.2595 + Tcl_LongAsWide(objPtr->internalRep.longValue);
1.2596 + objPtr->typePtr = &tclWideIntType;
1.2597 + goto gotWide;
1.2598 + }
1.2599 + result = SetWideIntFromAny(interp, objPtr);
1.2600 + if (result == TCL_OK) {
1.2601 + *wideIntPtr = objPtr->internalRep.wideValue;
1.2602 + }
1.2603 + return result;
1.2604 +}
1.2605 +
1.2606 +/*
1.2607 + *----------------------------------------------------------------------
1.2608 + *
1.2609 + * Tcl_DbIncrRefCount --
1.2610 + *
1.2611 + * This procedure is normally called when debugging: i.e., when
1.2612 + * TCL_MEM_DEBUG is defined. This checks to see whether or not
1.2613 + * the memory has been freed before incrementing the ref count.
1.2614 + *
1.2615 + * When TCL_MEM_DEBUG is not defined, this procedure just increments
1.2616 + * the reference count of the object.
1.2617 + *
1.2618 + * Results:
1.2619 + * None.
1.2620 + *
1.2621 + * Side effects:
1.2622 + * The object's ref count is incremented.
1.2623 + *
1.2624 + *----------------------------------------------------------------------
1.2625 + */
1.2626 +
1.2627 +EXPORT_C void
1.2628 +Tcl_DbIncrRefCount(objPtr, file, line)
1.2629 + register Tcl_Obj *objPtr; /* The object we are registering a
1.2630 + * reference to. */
1.2631 + CONST char *file; /* The name of the source file calling this
1.2632 + * procedure; used for debugging. */
1.2633 + int line; /* Line number in the source file; used
1.2634 + * for debugging. */
1.2635 +{
1.2636 +#ifdef TCL_MEM_DEBUG
1.2637 + if (objPtr->refCount == 0x61616161) {
1.2638 + fprintf(stderr, "file = %s, line = %d\n", file, line);
1.2639 + fflush(stderr);
1.2640 + panic("Trying to increment refCount of previously disposed object.");
1.2641 + }
1.2642 +#endif
1.2643 + ++(objPtr)->refCount;
1.2644 +}
1.2645 +
1.2646 +/*
1.2647 + *----------------------------------------------------------------------
1.2648 + *
1.2649 + * Tcl_DbDecrRefCount --
1.2650 + *
1.2651 + * This procedure is normally called when debugging: i.e., when
1.2652 + * TCL_MEM_DEBUG is defined. This checks to see whether or not
1.2653 + * the memory has been freed before decrementing the ref count.
1.2654 + *
1.2655 + * When TCL_MEM_DEBUG is not defined, this procedure just decrements
1.2656 + * the reference count of the object.
1.2657 + *
1.2658 + * Results:
1.2659 + * None.
1.2660 + *
1.2661 + * Side effects:
1.2662 + * The object's ref count is incremented.
1.2663 + *
1.2664 + *----------------------------------------------------------------------
1.2665 + */
1.2666 +
1.2667 +EXPORT_C void
1.2668 +Tcl_DbDecrRefCount(objPtr, file, line)
1.2669 + register Tcl_Obj *objPtr; /* The object we are releasing a reference
1.2670 + * to. */
1.2671 + CONST char *file; /* The name of the source file calling this
1.2672 + * procedure; used for debugging. */
1.2673 + int line; /* Line number in the source file; used
1.2674 + * for debugging. */
1.2675 +{
1.2676 +#ifdef TCL_MEM_DEBUG
1.2677 + if (objPtr->refCount == 0x61616161) {
1.2678 + fprintf(stderr, "file = %s, line = %d\n", file, line);
1.2679 + fflush(stderr);
1.2680 + panic("Trying to decrement refCount of previously disposed object.");
1.2681 + }
1.2682 +#endif
1.2683 + if (--(objPtr)->refCount <= 0) {
1.2684 + TclFreeObj(objPtr);
1.2685 + }
1.2686 +}
1.2687 +
1.2688 +/*
1.2689 + *----------------------------------------------------------------------
1.2690 + *
1.2691 + * Tcl_DbIsShared --
1.2692 + *
1.2693 + * This procedure is normally called when debugging: i.e., when
1.2694 + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref
1.2695 + * count greater than one.
1.2696 + *
1.2697 + * When TCL_MEM_DEBUG is not defined, this procedure just tests
1.2698 + * if the object has a ref count greater than one.
1.2699 + *
1.2700 + * Results:
1.2701 + * None.
1.2702 + *
1.2703 + * Side effects:
1.2704 + * None.
1.2705 + *
1.2706 + *----------------------------------------------------------------------
1.2707 + */
1.2708 +
1.2709 +EXPORT_C int
1.2710 +Tcl_DbIsShared(objPtr, file, line)
1.2711 + register Tcl_Obj *objPtr; /* The object to test for being shared. */
1.2712 + CONST char *file; /* The name of the source file calling this
1.2713 + * procedure; used for debugging. */
1.2714 + int line; /* Line number in the source file; used
1.2715 + * for debugging. */
1.2716 +{
1.2717 +#ifdef TCL_MEM_DEBUG
1.2718 + if (objPtr->refCount == 0x61616161) {
1.2719 + fprintf(stderr, "file = %s, line = %d\n", file, line);
1.2720 + fflush(stderr);
1.2721 + panic("Trying to check whether previously disposed object is shared.");
1.2722 + }
1.2723 +#endif
1.2724 +#ifdef TCL_COMPILE_STATS
1.2725 + Tcl_MutexLock(&tclObjMutex);
1.2726 + if ((objPtr)->refCount <= 1) {
1.2727 + tclObjsShared[1]++;
1.2728 + } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
1.2729 + tclObjsShared[(objPtr)->refCount]++;
1.2730 + } else {
1.2731 + tclObjsShared[0]++;
1.2732 + }
1.2733 + Tcl_MutexUnlock(&tclObjMutex);
1.2734 +#endif
1.2735 + return ((objPtr)->refCount > 1);
1.2736 +}
1.2737 +
1.2738 +/*
1.2739 + *----------------------------------------------------------------------
1.2740 + *
1.2741 + * Tcl_InitObjHashTable --
1.2742 + *
1.2743 + * Given storage for a hash table, set up the fields to prepare
1.2744 + * the hash table for use, the keys are Tcl_Obj *.
1.2745 + *
1.2746 + * Results:
1.2747 + * None.
1.2748 + *
1.2749 + * Side effects:
1.2750 + * TablePtr is now ready to be passed to Tcl_FindHashEntry and
1.2751 + * Tcl_CreateHashEntry.
1.2752 + *
1.2753 + *----------------------------------------------------------------------
1.2754 + */
1.2755 +
1.2756 +EXPORT_C void
1.2757 +Tcl_InitObjHashTable(tablePtr)
1.2758 + register Tcl_HashTable *tablePtr; /* Pointer to table record, which
1.2759 + * is supplied by the caller. */
1.2760 +{
1.2761 + Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
1.2762 + &tclObjHashKeyType);
1.2763 +}
1.2764 +
1.2765 +/*
1.2766 + *----------------------------------------------------------------------
1.2767 + *
1.2768 + * AllocObjEntry --
1.2769 + *
1.2770 + * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
1.2771 + *
1.2772 + * Results:
1.2773 + * The return value is a pointer to the created entry.
1.2774 + *
1.2775 + * Side effects:
1.2776 + * Increments the reference count on the object.
1.2777 + *
1.2778 + *----------------------------------------------------------------------
1.2779 + */
1.2780 +
1.2781 +static Tcl_HashEntry *
1.2782 +AllocObjEntry(tablePtr, keyPtr)
1.2783 + Tcl_HashTable *tablePtr; /* Hash table. */
1.2784 + VOID *keyPtr; /* Key to store in the hash table entry. */
1.2785 +{
1.2786 + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
1.2787 + Tcl_HashEntry *hPtr;
1.2788 +
1.2789 + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
1.2790 + hPtr->key.oneWordValue = (char *) objPtr;
1.2791 + Tcl_IncrRefCount (objPtr);
1.2792 +
1.2793 + return hPtr;
1.2794 +}
1.2795 +
1.2796 +/*
1.2797 + *----------------------------------------------------------------------
1.2798 + *
1.2799 + * CompareObjKeys --
1.2800 + *
1.2801 + * Compares two Tcl_Obj * keys.
1.2802 + *
1.2803 + * Results:
1.2804 + * The return value is 0 if they are different and 1 if they are
1.2805 + * the same.
1.2806 + *
1.2807 + * Side effects:
1.2808 + * None.
1.2809 + *
1.2810 + *----------------------------------------------------------------------
1.2811 + */
1.2812 +
1.2813 +static int
1.2814 +CompareObjKeys(keyPtr, hPtr)
1.2815 + VOID *keyPtr; /* New key to compare. */
1.2816 + Tcl_HashEntry *hPtr; /* Existing key to compare. */
1.2817 +{
1.2818 + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
1.2819 + Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
1.2820 + register CONST char *p1, *p2;
1.2821 + register int l1, l2;
1.2822 +
1.2823 + /*
1.2824 + * If the object pointers are the same then they match.
1.2825 + */
1.2826 + if (objPtr1 == objPtr2) {
1.2827 + return 1;
1.2828 + }
1.2829 +
1.2830 + /*
1.2831 + * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
1.2832 + * in a register.
1.2833 + */
1.2834 + p1 = TclGetString(objPtr1);
1.2835 + l1 = objPtr1->length;
1.2836 + p2 = TclGetString(objPtr2);
1.2837 + l2 = objPtr2->length;
1.2838 +
1.2839 + /*
1.2840 + * Only compare if the string representations are of the same length.
1.2841 + */
1.2842 + if (l1 == l2) {
1.2843 + for (;; p1++, p2++, l1--) {
1.2844 + if (*p1 != *p2) {
1.2845 + break;
1.2846 + }
1.2847 + if (l1 == 0) {
1.2848 + return 1;
1.2849 + }
1.2850 + }
1.2851 + }
1.2852 +
1.2853 + return 0;
1.2854 +}
1.2855 +
1.2856 +/*
1.2857 + *----------------------------------------------------------------------
1.2858 + *
1.2859 + * FreeObjEntry --
1.2860 + *
1.2861 + * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
1.2862 + *
1.2863 + * Results:
1.2864 + * The return value is a pointer to the created entry.
1.2865 + *
1.2866 + * Side effects:
1.2867 + * Decrements the reference count of the object.
1.2868 + *
1.2869 + *----------------------------------------------------------------------
1.2870 + */
1.2871 +
1.2872 +static void
1.2873 +FreeObjEntry(hPtr)
1.2874 + Tcl_HashEntry *hPtr; /* Hash entry to free. */
1.2875 +{
1.2876 + Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
1.2877 +
1.2878 + Tcl_DecrRefCount (objPtr);
1.2879 + ckfree ((char *) hPtr);
1.2880 +}
1.2881 +
1.2882 +/*
1.2883 + *----------------------------------------------------------------------
1.2884 + *
1.2885 + * HashObjKey --
1.2886 + *
1.2887 + * Compute a one-word summary of the string representation of the
1.2888 + * Tcl_Obj, which can be used to generate a hash index.
1.2889 + *
1.2890 + * Results:
1.2891 + * The return value is a one-word summary of the information in
1.2892 + * the string representation of the Tcl_Obj.
1.2893 + *
1.2894 + * Side effects:
1.2895 + * None.
1.2896 + *
1.2897 + *----------------------------------------------------------------------
1.2898 + */
1.2899 +
1.2900 +static unsigned int
1.2901 +HashObjKey(tablePtr, keyPtr)
1.2902 + Tcl_HashTable *tablePtr; /* Hash table. */
1.2903 + VOID *keyPtr; /* Key from which to compute hash value. */
1.2904 +{
1.2905 + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
1.2906 + CONST char *string = TclGetString(objPtr);
1.2907 + int length = objPtr->length;
1.2908 + unsigned int result;
1.2909 + int i;
1.2910 +
1.2911 + /*
1.2912 + * I tried a zillion different hash functions and asked many other
1.2913 + * people for advice. Many people had their own favorite functions,
1.2914 + * all different, but no-one had much idea why they were good ones.
1.2915 + * I chose the one below (multiply by 9 and add new character)
1.2916 + * because of the following reasons:
1.2917 + *
1.2918 + * 1. Multiplying by 10 is perfect for keys that are decimal strings,
1.2919 + * and multiplying by 9 is just about as good.
1.2920 + * 2. Times-9 is (shift-left-3) plus (old). This means that each
1.2921 + * character's bits hang around in the low-order bits of the
1.2922 + * hash value for ever, plus they spread fairly rapidly up to
1.2923 + * the high-order bits to fill out the hash value. This seems
1.2924 + * works well both for decimal and non-decimal strings.
1.2925 + */
1.2926 +
1.2927 + result = 0;
1.2928 + for (i=0 ; i<length ; i++) {
1.2929 + result += (result<<3) + string[i];
1.2930 + }
1.2931 + return result;
1.2932 +}
1.2933 +
1.2934 +/*
1.2935 + *----------------------------------------------------------------------
1.2936 + *
1.2937 + * Tcl_GetCommandFromObj --
1.2938 + *
1.2939 + * Returns the command specified by the name in a Tcl_Obj.
1.2940 + *
1.2941 + * Results:
1.2942 + * Returns a token for the command if it is found. Otherwise, if it
1.2943 + * can't be found or there is an error, returns NULL.
1.2944 + *
1.2945 + * Side effects:
1.2946 + * May update the internal representation for the object, caching
1.2947 + * the command reference so that the next time this procedure is
1.2948 + * called with the same object, the command can be found quickly.
1.2949 + *
1.2950 + *----------------------------------------------------------------------
1.2951 + */
1.2952 +
1.2953 +Tcl_Command
1.2954 +Tcl_GetCommandFromObj(interp, objPtr)
1.2955 + Tcl_Interp *interp; /* The interpreter in which to resolve the
1.2956 + * command and to report errors. */
1.2957 + register Tcl_Obj *objPtr; /* The object containing the command's
1.2958 + * name. If the name starts with "::", will
1.2959 + * be looked up in global namespace. Else,
1.2960 + * looked up first in the current namespace,
1.2961 + * then in global namespace. */
1.2962 +{
1.2963 + Interp *iPtr = (Interp *) interp;
1.2964 + register ResolvedCmdName *resPtr;
1.2965 + register Command *cmdPtr;
1.2966 + Namespace *currNsPtr;
1.2967 + int result;
1.2968 + CallFrame *savedFramePtr;
1.2969 + char *name;
1.2970 +
1.2971 + /*
1.2972 + * If the variable name is fully qualified, do as if the lookup were
1.2973 + * done from the global namespace; this helps avoid repeated lookups
1.2974 + * of fully qualified names. It costs close to nothing, and may be very
1.2975 + * helpful for OO applications which pass along a command name ("this"),
1.2976 + * [Patch 456668]
1.2977 + */
1.2978 +
1.2979 + savedFramePtr = iPtr->varFramePtr;
1.2980 + name = Tcl_GetString(objPtr);
1.2981 + if ((*name++ == ':') && (*name == ':')) {
1.2982 + iPtr->varFramePtr = NULL;
1.2983 + }
1.2984 +
1.2985 + /*
1.2986 + * Get the internal representation, converting to a command type if
1.2987 + * needed. The internal representation is a ResolvedCmdName that points
1.2988 + * to the actual command.
1.2989 + */
1.2990 +
1.2991 + if (objPtr->typePtr != &tclCmdNameType) {
1.2992 + result = tclCmdNameType.setFromAnyProc(interp, objPtr);
1.2993 + if (result != TCL_OK) {
1.2994 + iPtr->varFramePtr = savedFramePtr;
1.2995 + return (Tcl_Command) NULL;
1.2996 + }
1.2997 + }
1.2998 + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
1.2999 +
1.3000 + /*
1.3001 + * Get the current namespace.
1.3002 + */
1.3003 +
1.3004 + if (iPtr->varFramePtr != NULL) {
1.3005 + currNsPtr = iPtr->varFramePtr->nsPtr;
1.3006 + } else {
1.3007 + currNsPtr = iPtr->globalNsPtr;
1.3008 + }
1.3009 +
1.3010 + /*
1.3011 + * Check the context namespace and the namespace epoch of the resolved
1.3012 + * symbol to make sure that it is fresh. If not, then force another
1.3013 + * conversion to the command type, to discard the old rep and create a
1.3014 + * new one. Note that we verify that the namespace id of the context
1.3015 + * namespace is the same as the one we cached; this insures that the
1.3016 + * namespace wasn't deleted and a new one created at the same address
1.3017 + * with the same command epoch.
1.3018 + */
1.3019 +
1.3020 + cmdPtr = NULL;
1.3021 + if ((resPtr != NULL)
1.3022 + && (resPtr->refNsPtr == currNsPtr)
1.3023 + && (resPtr->refNsId == currNsPtr->nsId)
1.3024 + && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
1.3025 + cmdPtr = resPtr->cmdPtr;
1.3026 + if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
1.3027 + cmdPtr = NULL;
1.3028 + }
1.3029 + }
1.3030 +
1.3031 + if (cmdPtr == NULL) {
1.3032 + result = tclCmdNameType.setFromAnyProc(interp, objPtr);
1.3033 + if (result != TCL_OK) {
1.3034 + iPtr->varFramePtr = savedFramePtr;
1.3035 + return (Tcl_Command) NULL;
1.3036 + }
1.3037 + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
1.3038 + if (resPtr != NULL) {
1.3039 + cmdPtr = resPtr->cmdPtr;
1.3040 + }
1.3041 + }
1.3042 + iPtr->varFramePtr = savedFramePtr;
1.3043 + return (Tcl_Command) cmdPtr;
1.3044 +}
1.3045 +
1.3046 +/*
1.3047 + *----------------------------------------------------------------------
1.3048 + *
1.3049 + * TclSetCmdNameObj --
1.3050 + *
1.3051 + * Modify an object to be an CmdName object that refers to the argument
1.3052 + * Command structure.
1.3053 + *
1.3054 + * Results:
1.3055 + * None.
1.3056 + *
1.3057 + * Side effects:
1.3058 + * The object's old internal rep is freed. It's string rep is not
1.3059 + * changed. The refcount in the Command structure is incremented to
1.3060 + * keep it from being freed if the command is later deleted until
1.3061 + * TclExecuteByteCode has a chance to recognize that it was deleted.
1.3062 + *
1.3063 + *----------------------------------------------------------------------
1.3064 + */
1.3065 +
1.3066 +void
1.3067 +TclSetCmdNameObj(interp, objPtr, cmdPtr)
1.3068 + Tcl_Interp *interp; /* Points to interpreter containing command
1.3069 + * that should be cached in objPtr. */
1.3070 + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
1.3071 + * a CmdName object. */
1.3072 + Command *cmdPtr; /* Points to Command structure that the
1.3073 + * CmdName object should refer to. */
1.3074 +{
1.3075 + Interp *iPtr = (Interp *) interp;
1.3076 + register ResolvedCmdName *resPtr;
1.3077 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.3078 + register Namespace *currNsPtr;
1.3079 +
1.3080 + if (oldTypePtr == &tclCmdNameType) {
1.3081 + return;
1.3082 + }
1.3083 +
1.3084 + /*
1.3085 + * Get the current namespace.
1.3086 + */
1.3087 +
1.3088 + if (iPtr->varFramePtr != NULL) {
1.3089 + currNsPtr = iPtr->varFramePtr->nsPtr;
1.3090 + } else {
1.3091 + currNsPtr = iPtr->globalNsPtr;
1.3092 + }
1.3093 +
1.3094 + cmdPtr->refCount++;
1.3095 + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
1.3096 + resPtr->cmdPtr = cmdPtr;
1.3097 + resPtr->refNsPtr = currNsPtr;
1.3098 + resPtr->refNsId = currNsPtr->nsId;
1.3099 + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
1.3100 + resPtr->cmdEpoch = cmdPtr->cmdEpoch;
1.3101 + resPtr->refCount = 1;
1.3102 +
1.3103 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.3104 + oldTypePtr->freeIntRepProc(objPtr);
1.3105 + }
1.3106 + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
1.3107 + objPtr->internalRep.twoPtrValue.ptr2 = NULL;
1.3108 + objPtr->typePtr = &tclCmdNameType;
1.3109 +}
1.3110 +
1.3111 +/*
1.3112 + *----------------------------------------------------------------------
1.3113 + *
1.3114 + * FreeCmdNameInternalRep --
1.3115 + *
1.3116 + * Frees the resources associated with a cmdName object's internal
1.3117 + * representation.
1.3118 + *
1.3119 + * Results:
1.3120 + * None.
1.3121 + *
1.3122 + * Side effects:
1.3123 + * Decrements the ref count of any cached ResolvedCmdName structure
1.3124 + * pointed to by the cmdName's internal representation. If this is
1.3125 + * the last use of the ResolvedCmdName, it is freed. This in turn
1.3126 + * decrements the ref count of the Command structure pointed to by
1.3127 + * the ResolvedSymbol, which may free the Command structure.
1.3128 + *
1.3129 + *----------------------------------------------------------------------
1.3130 + */
1.3131 +
1.3132 +static void
1.3133 +FreeCmdNameInternalRep(objPtr)
1.3134 + register Tcl_Obj *objPtr; /* CmdName object with internal
1.3135 + * representation to free. */
1.3136 +{
1.3137 + register ResolvedCmdName *resPtr =
1.3138 + (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
1.3139 +
1.3140 + if (resPtr != NULL) {
1.3141 + /*
1.3142 + * Decrement the reference count of the ResolvedCmdName structure.
1.3143 + * If there are no more uses, free the ResolvedCmdName structure.
1.3144 + */
1.3145 +
1.3146 + resPtr->refCount--;
1.3147 + if (resPtr->refCount == 0) {
1.3148 + /*
1.3149 + * Now free the cached command, unless it is still in its
1.3150 + * hash table or if there are other references to it
1.3151 + * from other cmdName objects.
1.3152 + */
1.3153 +
1.3154 + Command *cmdPtr = resPtr->cmdPtr;
1.3155 + TclCleanupCommand(cmdPtr);
1.3156 + ckfree((char *) resPtr);
1.3157 + }
1.3158 + }
1.3159 +}
1.3160 +
1.3161 +/*
1.3162 + *----------------------------------------------------------------------
1.3163 + *
1.3164 + * DupCmdNameInternalRep --
1.3165 + *
1.3166 + * Initialize the internal representation of an cmdName Tcl_Obj to a
1.3167 + * copy of the internal representation of an existing cmdName object.
1.3168 + *
1.3169 + * Results:
1.3170 + * None.
1.3171 + *
1.3172 + * Side effects:
1.3173 + * "copyPtr"s internal rep is set to point to the ResolvedCmdName
1.3174 + * structure corresponding to "srcPtr"s internal rep. Increments the
1.3175 + * ref count of the ResolvedCmdName structure pointed to by the
1.3176 + * cmdName's internal representation.
1.3177 + *
1.3178 + *----------------------------------------------------------------------
1.3179 + */
1.3180 +
1.3181 +static void
1.3182 +DupCmdNameInternalRep(srcPtr, copyPtr)
1.3183 + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
1.3184 + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
1.3185 +{
1.3186 + register ResolvedCmdName *resPtr =
1.3187 + (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;
1.3188 +
1.3189 + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
1.3190 + copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
1.3191 + if (resPtr != NULL) {
1.3192 + resPtr->refCount++;
1.3193 + }
1.3194 + copyPtr->typePtr = &tclCmdNameType;
1.3195 +}
1.3196 +
1.3197 +/*
1.3198 + *----------------------------------------------------------------------
1.3199 + *
1.3200 + * SetCmdNameFromAny --
1.3201 + *
1.3202 + * Generate an cmdName internal form for the Tcl object "objPtr".
1.3203 + *
1.3204 + * Results:
1.3205 + * The return value is a standard Tcl result. The conversion always
1.3206 + * succeeds and TCL_OK is returned.
1.3207 + *
1.3208 + * Side effects:
1.3209 + * A pointer to a ResolvedCmdName structure that holds a cached pointer
1.3210 + * to the command with a name that matches objPtr's string rep is
1.3211 + * stored as objPtr's internal representation. This ResolvedCmdName
1.3212 + * pointer will be NULL if no matching command was found. The ref count
1.3213 + * of the cached Command's structure (if any) is also incremented.
1.3214 + *
1.3215 + *----------------------------------------------------------------------
1.3216 + */
1.3217 +
1.3218 +static int
1.3219 +SetCmdNameFromAny(interp, objPtr)
1.3220 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.3221 + register Tcl_Obj *objPtr; /* The object to convert. */
1.3222 +{
1.3223 + Interp *iPtr = (Interp *) interp;
1.3224 + char *name;
1.3225 + Tcl_Command cmd;
1.3226 + register Command *cmdPtr;
1.3227 + Namespace *currNsPtr;
1.3228 + register ResolvedCmdName *resPtr;
1.3229 +
1.3230 + /*
1.3231 + * Get "objPtr"s string representation. Make it up-to-date if necessary.
1.3232 + */
1.3233 +
1.3234 + name = objPtr->bytes;
1.3235 + if (name == NULL) {
1.3236 + name = Tcl_GetString(objPtr);
1.3237 + }
1.3238 +
1.3239 + /*
1.3240 + * Find the Command structure, if any, that describes the command called
1.3241 + * "name". Build a ResolvedCmdName that holds a cached pointer to this
1.3242 + * Command, and bump the reference count in the referenced Command
1.3243 + * structure. A Command structure will not be deleted as long as it is
1.3244 + * referenced from a CmdName object.
1.3245 + */
1.3246 +
1.3247 + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
1.3248 + /*flags*/ 0);
1.3249 + cmdPtr = (Command *) cmd;
1.3250 + if (cmdPtr != NULL) {
1.3251 + /*
1.3252 + * Get the current namespace.
1.3253 + */
1.3254 +
1.3255 + if (iPtr->varFramePtr != NULL) {
1.3256 + currNsPtr = iPtr->varFramePtr->nsPtr;
1.3257 + } else {
1.3258 + currNsPtr = iPtr->globalNsPtr;
1.3259 + }
1.3260 +
1.3261 + cmdPtr->refCount++;
1.3262 + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
1.3263 + resPtr->cmdPtr = cmdPtr;
1.3264 + resPtr->refNsPtr = currNsPtr;
1.3265 + resPtr->refNsId = currNsPtr->nsId;
1.3266 + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
1.3267 + resPtr->cmdEpoch = cmdPtr->cmdEpoch;
1.3268 + resPtr->refCount = 1;
1.3269 + } else {
1.3270 + resPtr = NULL; /* no command named "name" was found */
1.3271 + }
1.3272 +
1.3273 + /*
1.3274 + * Free the old internalRep before setting the new one. We do this as
1.3275 + * late as possible to allow the conversion code, in particular
1.3276 + * GetStringFromObj, to use that old internalRep. If no Command
1.3277 + * structure was found, leave NULL as the cached value.
1.3278 + */
1.3279 +
1.3280 + if ((objPtr->typePtr != NULL)
1.3281 + && (objPtr->typePtr->freeIntRepProc != NULL)) {
1.3282 + objPtr->typePtr->freeIntRepProc(objPtr);
1.3283 + }
1.3284 +
1.3285 + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
1.3286 + objPtr->internalRep.twoPtrValue.ptr2 = NULL;
1.3287 + objPtr->typePtr = &tclCmdNameType;
1.3288 + return TCL_OK;
1.3289 +}