1 |
/* $Header$ */
|
2 |
/*
|
3 |
* tclObj.c --
|
4 |
*
|
5 |
* This file contains Tcl object-related procedures that are used by
|
6 |
* many Tcl commands.
|
7 |
*
|
8 |
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
9 |
* Copyright (c) 1999 by Scriptics Corporation.
|
10 |
*
|
11 |
* See the file "license.terms" for information on usage and redistribution
|
12 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
13 |
*
|
14 |
* RCS: @(#) $Id: tclobj.c,v 1.3 2001/09/12 18:12:20 dtashley Exp $
|
15 |
*/
|
16 |
|
17 |
#include "tclInt.h"
|
18 |
#include "tclPort.h"
|
19 |
|
20 |
/*
|
21 |
* Table of all object types.
|
22 |
*/
|
23 |
|
24 |
static Tcl_HashTable typeTable;
|
25 |
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
|
26 |
TCL_DECLARE_MUTEX(tableMutex)
|
27 |
|
28 |
/*
|
29 |
* Head of the list of free Tcl_Obj structs we maintain.
|
30 |
*/
|
31 |
|
32 |
Tcl_Obj *tclFreeObjList = NULL;
|
33 |
|
34 |
/*
|
35 |
* The object allocator is single threaded. This mutex is referenced
|
36 |
* by the TclNewObj macro, however, so must be visible.
|
37 |
*/
|
38 |
|
39 |
#ifdef TCL_THREADS
|
40 |
Tcl_Mutex tclObjMutex;
|
41 |
#endif
|
42 |
|
43 |
/*
|
44 |
* Pointer to a heap-allocated string of length zero that the Tcl core uses
|
45 |
* as the value of an empty string representation for an object. This value
|
46 |
* is shared by all new objects allocated by Tcl_NewObj.
|
47 |
*/
|
48 |
|
49 |
static char emptyString;
|
50 |
char *tclEmptyStringRep = &emptyString;
|
51 |
|
52 |
/*
|
53 |
* The number of Tcl objects ever allocated (by Tcl_NewObj) and freed
|
54 |
* (by TclFreeObj).
|
55 |
*/
|
56 |
|
57 |
#ifdef TCL_COMPILE_STATS
|
58 |
long tclObjsAlloced = 0;
|
59 |
long tclObjsFreed = 0;
|
60 |
#endif /* TCL_COMPILE_STATS */
|
61 |
|
62 |
/*
|
63 |
* Prototypes for procedures defined later in this file:
|
64 |
*/
|
65 |
|
66 |
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
67 |
Tcl_Obj *objPtr));
|
68 |
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
69 |
Tcl_Obj *objPtr));
|
70 |
static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
71 |
Tcl_Obj *objPtr));
|
72 |
static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
|
73 |
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
|
74 |
static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
|
75 |
|
76 |
/*
|
77 |
* The structures below defines the Tcl object types defined in this file by
|
78 |
* means of procedures that can be invoked by generic object code. See also
|
79 |
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
|
80 |
* implementations.
|
81 |
*/
|
82 |
|
83 |
Tcl_ObjType tclBooleanType = {
|
84 |
"boolean", /* name */
|
85 |
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
86 |
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
|
87 |
UpdateStringOfBoolean, /* updateStringProc */
|
88 |
SetBooleanFromAny /* setFromAnyProc */
|
89 |
};
|
90 |
|
91 |
Tcl_ObjType tclDoubleType = {
|
92 |
"double", /* name */
|
93 |
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
94 |
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
|
95 |
UpdateStringOfDouble, /* updateStringProc */
|
96 |
SetDoubleFromAny /* setFromAnyProc */
|
97 |
};
|
98 |
|
99 |
Tcl_ObjType tclIntType = {
|
100 |
"int", /* name */
|
101 |
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
102 |
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
|
103 |
UpdateStringOfInt, /* updateStringProc */
|
104 |
SetIntFromAny /* setFromAnyProc */
|
105 |
};
|
106 |
|
107 |
/*
|
108 |
*-------------------------------------------------------------------------
|
109 |
*
|
110 |
* TclInitObjectSubsystem --
|
111 |
*
|
112 |
* This procedure is invoked to perform once-only initialization of
|
113 |
* the type table. It also registers the object types defined in
|
114 |
* this file.
|
115 |
*
|
116 |
* Results:
|
117 |
* None.
|
118 |
*
|
119 |
* Side effects:
|
120 |
* Initializes the table of defined object types "typeTable" with
|
121 |
* builtin object types defined in this file.
|
122 |
*
|
123 |
*-------------------------------------------------------------------------
|
124 |
*/
|
125 |
|
126 |
void
|
127 |
TclInitObjSubsystem()
|
128 |
{
|
129 |
Tcl_MutexLock(&tableMutex);
|
130 |
typeTableInitialized = 1;
|
131 |
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
|
132 |
Tcl_MutexUnlock(&tableMutex);
|
133 |
|
134 |
Tcl_RegisterObjType(&tclBooleanType);
|
135 |
Tcl_RegisterObjType(&tclByteArrayType);
|
136 |
Tcl_RegisterObjType(&tclDoubleType);
|
137 |
Tcl_RegisterObjType(&tclIntType);
|
138 |
Tcl_RegisterObjType(&tclStringType);
|
139 |
Tcl_RegisterObjType(&tclListType);
|
140 |
Tcl_RegisterObjType(&tclByteCodeType);
|
141 |
Tcl_RegisterObjType(&tclProcBodyType);
|
142 |
|
143 |
#ifdef TCL_COMPILE_STATS
|
144 |
Tcl_MutexLock(&tclObjMutex);
|
145 |
tclObjsAlloced = 0;
|
146 |
tclObjsFreed = 0;
|
147 |
Tcl_MutexUnlock(&tclObjMutex);
|
148 |
#endif
|
149 |
}
|
150 |
|
151 |
/*
|
152 |
*----------------------------------------------------------------------
|
153 |
*
|
154 |
* TclFinalizeCompExecEnv --
|
155 |
*
|
156 |
* This procedure is called by Tcl_Finalize to clean up the Tcl
|
157 |
* compilation and execution environment so it can later be properly
|
158 |
* reinitialized.
|
159 |
*
|
160 |
* Results:
|
161 |
* None.
|
162 |
*
|
163 |
* Side effects:
|
164 |
* Cleans up the compilation and execution environment
|
165 |
*
|
166 |
*----------------------------------------------------------------------
|
167 |
*/
|
168 |
|
169 |
void
|
170 |
TclFinalizeCompExecEnv()
|
171 |
{
|
172 |
Tcl_MutexLock(&tableMutex);
|
173 |
if (typeTableInitialized) {
|
174 |
Tcl_DeleteHashTable(&typeTable);
|
175 |
typeTableInitialized = 0;
|
176 |
}
|
177 |
Tcl_MutexUnlock(&tableMutex);
|
178 |
Tcl_MutexLock(&tclObjMutex);
|
179 |
tclFreeObjList = NULL;
|
180 |
Tcl_MutexUnlock(&tclObjMutex);
|
181 |
|
182 |
TclFinalizeCompilation();
|
183 |
TclFinalizeExecution();
|
184 |
}
|
185 |
|
186 |
/*
|
187 |
*--------------------------------------------------------------
|
188 |
*
|
189 |
* Tcl_RegisterObjType --
|
190 |
*
|
191 |
* This procedure is called to register a new Tcl object type
|
192 |
* in the table of all object types supported by Tcl.
|
193 |
*
|
194 |
* Results:
|
195 |
* None.
|
196 |
*
|
197 |
* Side effects:
|
198 |
* The type is registered in the Tcl type table. If there was already
|
199 |
* a type with the same name as in typePtr, it is replaced with the
|
200 |
* new type.
|
201 |
*
|
202 |
*--------------------------------------------------------------
|
203 |
*/
|
204 |
|
205 |
void
|
206 |
Tcl_RegisterObjType(typePtr)
|
207 |
Tcl_ObjType *typePtr; /* Information about object type;
|
208 |
* storage must be statically
|
209 |
* allocated (must live forever). */
|
210 |
{
|
211 |
register Tcl_HashEntry *hPtr;
|
212 |
int new;
|
213 |
|
214 |
/*
|
215 |
* If there's already an object type with the given name, remove it.
|
216 |
*/
|
217 |
Tcl_MutexLock(&tableMutex);
|
218 |
hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
|
219 |
if (hPtr != (Tcl_HashEntry *) NULL) {
|
220 |
Tcl_DeleteHashEntry(hPtr);
|
221 |
}
|
222 |
|
223 |
/*
|
224 |
* Now insert the new object type.
|
225 |
*/
|
226 |
|
227 |
hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
|
228 |
if (new) {
|
229 |
Tcl_SetHashValue(hPtr, typePtr);
|
230 |
}
|
231 |
Tcl_MutexUnlock(&tableMutex);
|
232 |
}
|
233 |
|
234 |
/*
|
235 |
*----------------------------------------------------------------------
|
236 |
*
|
237 |
* Tcl_AppendAllObjTypes --
|
238 |
*
|
239 |
* This procedure appends onto the argument object the name of each
|
240 |
* object type as a list element. This includes the builtin object
|
241 |
* types (e.g. int, list) as well as those added using
|
242 |
* Tcl_NewObj. These names can be used, for example, with
|
243 |
* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
|
244 |
* structures.
|
245 |
*
|
246 |
* Results:
|
247 |
* The return value is normally TCL_OK; in this case the object
|
248 |
* referenced by objPtr has each type name appended to it. If an
|
249 |
* error occurs, TCL_ERROR is returned and the interpreter's result
|
250 |
* holds an error message.
|
251 |
*
|
252 |
* Side effects:
|
253 |
* If necessary, the object referenced by objPtr is converted into
|
254 |
* a list object.
|
255 |
*
|
256 |
*----------------------------------------------------------------------
|
257 |
*/
|
258 |
|
259 |
int
|
260 |
Tcl_AppendAllObjTypes(interp, objPtr)
|
261 |
Tcl_Interp *interp; /* Interpreter used for error reporting. */
|
262 |
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
|
263 |
* name of each registered type is appended
|
264 |
* as a list element. */
|
265 |
{
|
266 |
register Tcl_HashEntry *hPtr;
|
267 |
Tcl_HashSearch search;
|
268 |
Tcl_ObjType *typePtr;
|
269 |
int result;
|
270 |
|
271 |
/*
|
272 |
* This code assumes that types names do not contain embedded NULLs.
|
273 |
*/
|
274 |
|
275 |
Tcl_MutexLock(&tableMutex);
|
276 |
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
|
277 |
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
|
278 |
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
279 |
result = Tcl_ListObjAppendElement(interp, objPtr,
|
280 |
Tcl_NewStringObj(typePtr->name, -1));
|
281 |
if (result == TCL_ERROR) {
|
282 |
Tcl_MutexUnlock(&tableMutex);
|
283 |
return result;
|
284 |
}
|
285 |
}
|
286 |
Tcl_MutexUnlock(&tableMutex);
|
287 |
return TCL_OK;
|
288 |
}
|
289 |
|
290 |
/*
|
291 |
*----------------------------------------------------------------------
|
292 |
*
|
293 |
* Tcl_GetObjType --
|
294 |
*
|
295 |
* This procedure looks up an object type by name.
|
296 |
*
|
297 |
* Results:
|
298 |
* If an object type with name matching "typeName" is found, a pointer
|
299 |
* to its Tcl_ObjType structure is returned; otherwise, NULL is
|
300 |
* returned.
|
301 |
*
|
302 |
* Side effects:
|
303 |
* None.
|
304 |
*
|
305 |
*----------------------------------------------------------------------
|
306 |
*/
|
307 |
|
308 |
Tcl_ObjType *
|
309 |
Tcl_GetObjType(typeName)
|
310 |
char *typeName; /* Name of Tcl object type to look up. */
|
311 |
{
|
312 |
register Tcl_HashEntry *hPtr;
|
313 |
Tcl_ObjType *typePtr;
|
314 |
|
315 |
Tcl_MutexLock(&tableMutex);
|
316 |
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
|
317 |
if (hPtr != (Tcl_HashEntry *) NULL) {
|
318 |
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
|
319 |
Tcl_MutexUnlock(&tableMutex);
|
320 |
return typePtr;
|
321 |
}
|
322 |
Tcl_MutexUnlock(&tableMutex);
|
323 |
return NULL;
|
324 |
}
|
325 |
|
326 |
/*
|
327 |
*----------------------------------------------------------------------
|
328 |
*
|
329 |
* Tcl_ConvertToType --
|
330 |
*
|
331 |
* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
|
332 |
*
|
333 |
* Results:
|
334 |
* The return value is TCL_OK on success and TCL_ERROR on failure. If
|
335 |
* TCL_ERROR is returned, then the interpreter's result contains an
|
336 |
* error message unless "interp" is NULL. Passing a NULL "interp"
|
337 |
* allows this procedure to be used as a test whether the conversion
|
338 |
* could be done (and in fact was done).
|
339 |
*
|
340 |
* Side effects:
|
341 |
* Any internal representation for the old type is freed.
|
342 |
*
|
343 |
*----------------------------------------------------------------------
|
344 |
*/
|
345 |
|
346 |
int
|
347 |
Tcl_ConvertToType(interp, objPtr, typePtr)
|
348 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
349 |
Tcl_Obj *objPtr; /* The object to convert. */
|
350 |
Tcl_ObjType *typePtr; /* The target type. */
|
351 |
{
|
352 |
if (objPtr->typePtr == typePtr) {
|
353 |
return TCL_OK;
|
354 |
}
|
355 |
|
356 |
/*
|
357 |
* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
|
358 |
* form as appropriate for the target type. This frees the old internal
|
359 |
* representation.
|
360 |
*/
|
361 |
|
362 |
return typePtr->setFromAnyProc(interp, objPtr);
|
363 |
}
|
364 |
|
365 |
/*
|
366 |
*----------------------------------------------------------------------
|
367 |
*
|
368 |
* Tcl_NewObj --
|
369 |
*
|
370 |
* This procedure is normally called when not debugging: i.e., when
|
371 |
* TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
|
372 |
* the empty string. These objects have a NULL object type and NULL
|
373 |
* string representation byte pointer. Type managers call this routine
|
374 |
* to allocate new objects that they further initialize.
|
375 |
*
|
376 |
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
377 |
* result of calling the debugging version Tcl_DbNewObj.
|
378 |
*
|
379 |
* Results:
|
380 |
* The result is a newly allocated object that represents the empty
|
381 |
* string. The new object's typePtr is set NULL and its ref count
|
382 |
* is set to 0.
|
383 |
*
|
384 |
* Side effects:
|
385 |
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
386 |
* the global count of allocated objects (tclObjsAlloced).
|
387 |
*
|
388 |
*----------------------------------------------------------------------
|
389 |
*/
|
390 |
|
391 |
#ifdef TCL_MEM_DEBUG
|
392 |
#undef Tcl_NewObj
|
393 |
|
394 |
Tcl_Obj *
|
395 |
Tcl_NewObj()
|
396 |
{
|
397 |
return Tcl_DbNewObj("unknown", 0);
|
398 |
}
|
399 |
|
400 |
#else /* if not TCL_MEM_DEBUG */
|
401 |
|
402 |
Tcl_Obj *
|
403 |
Tcl_NewObj()
|
404 |
{
|
405 |
register Tcl_Obj *objPtr;
|
406 |
|
407 |
/*
|
408 |
* Allocate the object using the list of free Tcl_Obj structs
|
409 |
* we maintain.
|
410 |
*/
|
411 |
|
412 |
Tcl_MutexLock(&tclObjMutex);
|
413 |
if (tclFreeObjList == NULL) {
|
414 |
TclAllocateFreeObjects();
|
415 |
}
|
416 |
objPtr = tclFreeObjList;
|
417 |
tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
|
418 |
|
419 |
objPtr->refCount = 0;
|
420 |
objPtr->bytes = tclEmptyStringRep;
|
421 |
objPtr->length = 0;
|
422 |
objPtr->typePtr = NULL;
|
423 |
#ifdef TCL_COMPILE_STATS
|
424 |
tclObjsAlloced++;
|
425 |
#endif /* TCL_COMPILE_STATS */
|
426 |
Tcl_MutexUnlock(&tclObjMutex);
|
427 |
return objPtr;
|
428 |
}
|
429 |
#endif /* TCL_MEM_DEBUG */
|
430 |
|
431 |
/*
|
432 |
*----------------------------------------------------------------------
|
433 |
*
|
434 |
* Tcl_DbNewObj --
|
435 |
*
|
436 |
* This procedure is normally called when debugging: i.e., when
|
437 |
* TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
|
438 |
* empty string. It is the same as the Tcl_NewObj procedure above
|
439 |
* except that it calls Tcl_DbCkalloc directly with the file name and
|
440 |
* line number from its caller. This simplifies debugging since then
|
441 |
* the checkmem command will report the correct file name and line
|
442 |
* number when reporting objects that haven't been freed.
|
443 |
*
|
444 |
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
445 |
* result of calling Tcl_NewObj.
|
446 |
*
|
447 |
* Results:
|
448 |
* The result is a newly allocated that represents the empty string.
|
449 |
* The new object's typePtr is set NULL and its ref count is set to 0.
|
450 |
*
|
451 |
* Side effects:
|
452 |
* If compiling with TCL_COMPILE_STATS, this procedure increments
|
453 |
* the global count of allocated objects (tclObjsAlloced).
|
454 |
*
|
455 |
*----------------------------------------------------------------------
|
456 |
*/
|
457 |
|
458 |
#ifdef TCL_MEM_DEBUG
|
459 |
|
460 |
Tcl_Obj *
|
461 |
Tcl_DbNewObj(file, line)
|
462 |
register char *file; /* The name of the source file calling this
|
463 |
* procedure; used for debugging. */
|
464 |
register int line; /* Line number in the source file; used
|
465 |
* for debugging. */
|
466 |
{
|
467 |
register Tcl_Obj *objPtr;
|
468 |
|
469 |
/*
|
470 |
* If debugging Tcl's memory usage, allocate the object using ckalloc.
|
471 |
* Otherwise, allocate it using the list of free Tcl_Obj structs we
|
472 |
* maintain.
|
473 |
*/
|
474 |
|
475 |
objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
|
476 |
objPtr->refCount = 0;
|
477 |
objPtr->bytes = tclEmptyStringRep;
|
478 |
objPtr->length = 0;
|
479 |
objPtr->typePtr = NULL;
|
480 |
#ifdef TCL_COMPILE_STATS
|
481 |
Tcl_MutexLock(&tclObjMutex);
|
482 |
tclObjsAlloced++;
|
483 |
Tcl_MutexUnlock(&tclObjMutex);
|
484 |
#endif /* TCL_COMPILE_STATS */
|
485 |
return objPtr;
|
486 |
}
|
487 |
|
488 |
#else /* if not TCL_MEM_DEBUG */
|
489 |
|
490 |
Tcl_Obj *
|
491 |
Tcl_DbNewObj(file, line)
|
492 |
char *file; /* The name of the source file calling this
|
493 |
* procedure; used for debugging. */
|
494 |
int line; /* Line number in the source file; used
|
495 |
* for debugging. */
|
496 |
{
|
497 |
return Tcl_NewObj();
|
498 |
}
|
499 |
#endif /* TCL_MEM_DEBUG */
|
500 |
|
501 |
/*
|
502 |
*----------------------------------------------------------------------
|
503 |
*
|
504 |
* TclAllocateFreeObjects --
|
505 |
*
|
506 |
* Procedure to allocate a number of free Tcl_Objs. This is done using
|
507 |
* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
|
508 |
*
|
509 |
* Assumes mutex is held.
|
510 |
*
|
511 |
* Results:
|
512 |
* None.
|
513 |
*
|
514 |
* Side effects:
|
515 |
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
|
516 |
* first of a number of free Tcl_Obj's linked together by their
|
517 |
* internalRep.otherValuePtrs.
|
518 |
*
|
519 |
*----------------------------------------------------------------------
|
520 |
*/
|
521 |
|
522 |
#define OBJS_TO_ALLOC_EACH_TIME 100
|
523 |
|
524 |
void
|
525 |
TclAllocateFreeObjects()
|
526 |
{
|
527 |
Tcl_Obj tmp[2];
|
528 |
size_t objSizePlusPadding = /* NB: this assumes byte addressing. */
|
529 |
((int)(&(tmp[1])) - (int)(&(tmp[0])));
|
530 |
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
|
531 |
char *basePtr;
|
532 |
register Tcl_Obj *prevPtr, *objPtr;
|
533 |
register int i;
|
534 |
|
535 |
basePtr = (char *) ckalloc(bytesToAlloc);
|
536 |
memset(basePtr, 0, bytesToAlloc);
|
537 |
|
538 |
prevPtr = NULL;
|
539 |
objPtr = (Tcl_Obj *) basePtr;
|
540 |
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
|
541 |
objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
|
542 |
prevPtr = objPtr;
|
543 |
objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
|
544 |
}
|
545 |
tclFreeObjList = prevPtr;
|
546 |
}
|
547 |
#undef OBJS_TO_ALLOC_EACH_TIME
|
548 |
|
549 |
/*
|
550 |
*----------------------------------------------------------------------
|
551 |
*
|
552 |
* TclFreeObj --
|
553 |
*
|
554 |
* This procedure frees the memory associated with the argument
|
555 |
* object. It is called by the tcl.h macro Tcl_DecrRefCount when an
|
556 |
* object's ref count is zero. It is only "public" since it must
|
557 |
* be callable by that macro wherever the macro is used. It should not
|
558 |
* be directly called by clients.
|
559 |
*
|
560 |
* Results:
|
561 |
* None.
|
562 |
*
|
563 |
* Side effects:
|
564 |
* Deallocates the storage for the object's Tcl_Obj structure
|
565 |
* after deallocating the string representation and calling the
|
566 |
* type-specific Tcl_FreeInternalRepProc to deallocate the object's
|
567 |
* internal representation. If compiling with TCL_COMPILE_STATS,
|
568 |
* this procedure increments the global count of freed objects
|
569 |
* (tclObjsFreed).
|
570 |
*
|
571 |
*----------------------------------------------------------------------
|
572 |
*/
|
573 |
|
574 |
void
|
575 |
TclFreeObj(objPtr)
|
576 |
register Tcl_Obj *objPtr; /* The object to be freed. */
|
577 |
{
|
578 |
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
579 |
|
580 |
#ifdef TCL_MEM_DEBUG
|
581 |
if ((objPtr)->refCount < -1) {
|
582 |
panic("Reference count for %lx was negative", objPtr);
|
583 |
}
|
584 |
#endif /* TCL_MEM_DEBUG */
|
585 |
|
586 |
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
|
587 |
typePtr->freeIntRepProc(objPtr);
|
588 |
}
|
589 |
Tcl_InvalidateStringRep(objPtr);
|
590 |
|
591 |
/*
|
592 |
* If debugging Tcl's memory usage, deallocate the object using ckfree.
|
593 |
* Otherwise, deallocate it by adding it onto the list of free
|
594 |
* Tcl_Obj structs we maintain.
|
595 |
*/
|
596 |
|
597 |
Tcl_MutexLock(&tclObjMutex);
|
598 |
#ifdef TCL_MEM_DEBUG
|
599 |
ckfree((char *) objPtr);
|
600 |
#else
|
601 |
objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
|
602 |
tclFreeObjList = objPtr;
|
603 |
#endif /* TCL_MEM_DEBUG */
|
604 |
|
605 |
#ifdef TCL_COMPILE_STATS
|
606 |
tclObjsFreed++;
|
607 |
#endif /* TCL_COMPILE_STATS */
|
608 |
Tcl_MutexUnlock(&tclObjMutex);
|
609 |
}
|
610 |
|
611 |
/*
|
612 |
*----------------------------------------------------------------------
|
613 |
*
|
614 |
* Tcl_DuplicateObj --
|
615 |
*
|
616 |
* Create and return a new object that is a duplicate of the argument
|
617 |
* object.
|
618 |
*
|
619 |
* Results:
|
620 |
* The return value is a pointer to a newly created Tcl_Obj. This
|
621 |
* object has reference count 0 and the same type, if any, as the
|
622 |
* source object objPtr. Also:
|
623 |
* 1) If the source object has a valid string rep, we copy it;
|
624 |
* otherwise, the duplicate's string rep is set NULL to mark
|
625 |
* it invalid.
|
626 |
* 2) If the source object has an internal representation (i.e. its
|
627 |
* typePtr is non-NULL), the new object's internal rep is set to
|
628 |
* a copy; otherwise the new internal rep is marked invalid.
|
629 |
*
|
630 |
* Side effects:
|
631 |
* What constitutes "copying" the internal representation depends on
|
632 |
* the type. For example, if the argument object is a list,
|
633 |
* the element objects it points to will not actually be copied but
|
634 |
* will be shared with the duplicate list. That is, the ref counts of
|
635 |
* the element objects will be incremented.
|
636 |
*
|
637 |
*----------------------------------------------------------------------
|
638 |
*/
|
639 |
|
640 |
Tcl_Obj *
|
641 |
Tcl_DuplicateObj(objPtr)
|
642 |
register Tcl_Obj *objPtr; /* The object to duplicate. */
|
643 |
{
|
644 |
register Tcl_ObjType *typePtr = objPtr->typePtr;
|
645 |
register Tcl_Obj *dupPtr;
|
646 |
|
647 |
TclNewObj(dupPtr);
|
648 |
|
649 |
if (objPtr->bytes == NULL) {
|
650 |
dupPtr->bytes = NULL;
|
651 |
} else if (objPtr->bytes != tclEmptyStringRep) {
|
652 |
int len = objPtr->length;
|
653 |
|
654 |
dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
|
655 |
if (len > 0) {
|
656 |
memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
|
657 |
(unsigned) len);
|
658 |
}
|
659 |
dupPtr->bytes[len] = '\0';
|
660 |
dupPtr->length = len;
|
661 |
}
|
662 |
|
663 |
if (typePtr != NULL) {
|
664 |
if (typePtr->dupIntRepProc == NULL) {
|
665 |
dupPtr->internalRep = objPtr->internalRep;
|
666 |
dupPtr->typePtr = typePtr;
|
667 |
} else {
|
668 |
(*typePtr->dupIntRepProc)(objPtr, dupPtr);
|
669 |
}
|
670 |
}
|
671 |
return dupPtr;
|
672 |
}
|
673 |
|
674 |
/*
|
675 |
*----------------------------------------------------------------------
|
676 |
*
|
677 |
* Tcl_GetString --
|
678 |
*
|
679 |
* Returns the string representation byte array pointer for an object.
|
680 |
*
|
681 |
* Results:
|
682 |
* Returns a pointer to the string representation of objPtr. The byte
|
683 |
* array referenced by the returned pointer must not be modified by the
|
684 |
* caller. Furthermore, the caller must copy the bytes if they need to
|
685 |
* retain them since the object's string rep can change as a result of
|
686 |
* other operations.
|
687 |
*
|
688 |
* Side effects:
|
689 |
* May call the object's updateStringProc to update the string
|
690 |
* representation from the internal representation.
|
691 |
*
|
692 |
*----------------------------------------------------------------------
|
693 |
*/
|
694 |
|
695 |
char *
|
696 |
Tcl_GetString(objPtr)
|
697 |
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
698 |
* should be returned. */
|
699 |
{
|
700 |
if (objPtr->bytes != NULL) {
|
701 |
return objPtr->bytes;
|
702 |
}
|
703 |
|
704 |
if (objPtr->typePtr->updateStringProc == NULL) {
|
705 |
panic("UpdateStringProc should not be invoked for type %s",
|
706 |
objPtr->typePtr->name);
|
707 |
}
|
708 |
(*objPtr->typePtr->updateStringProc)(objPtr);
|
709 |
return objPtr->bytes;
|
710 |
}
|
711 |
|
712 |
/*
|
713 |
*----------------------------------------------------------------------
|
714 |
*
|
715 |
* Tcl_GetStringFromObj --
|
716 |
*
|
717 |
* Returns the string representation's byte array pointer and length
|
718 |
* for an object.
|
719 |
*
|
720 |
* Results:
|
721 |
* Returns a pointer to the string representation of objPtr. If
|
722 |
* lengthPtr isn't NULL, the length of the string representation is
|
723 |
* stored at *lengthPtr. The byte array referenced by the returned
|
724 |
* pointer must not be modified by the caller. Furthermore, the
|
725 |
* caller must copy the bytes if they need to retain them since the
|
726 |
* object's string rep can change as a result of other operations.
|
727 |
*
|
728 |
* Side effects:
|
729 |
* May call the object's updateStringProc to update the string
|
730 |
* representation from the internal representation.
|
731 |
*
|
732 |
*----------------------------------------------------------------------
|
733 |
*/
|
734 |
|
735 |
char *
|
736 |
Tcl_GetStringFromObj(objPtr, lengthPtr)
|
737 |
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
738 |
* should be returned. */
|
739 |
register int *lengthPtr; /* If non-NULL, the location where the
|
740 |
* string rep's byte array length should be
|
741 |
* stored. If NULL, no length is stored. */
|
742 |
{
|
743 |
if (objPtr->bytes != NULL) {
|
744 |
if (lengthPtr != NULL) {
|
745 |
*lengthPtr = objPtr->length;
|
746 |
}
|
747 |
return objPtr->bytes;
|
748 |
}
|
749 |
|
750 |
if (objPtr->typePtr->updateStringProc == NULL) {
|
751 |
panic("UpdateStringProc should not be invoked for type %s",
|
752 |
objPtr->typePtr->name);
|
753 |
}
|
754 |
(*objPtr->typePtr->updateStringProc)(objPtr);
|
755 |
if (lengthPtr != NULL) {
|
756 |
*lengthPtr = objPtr->length;
|
757 |
}
|
758 |
return objPtr->bytes;
|
759 |
}
|
760 |
|
761 |
/*
|
762 |
*----------------------------------------------------------------------
|
763 |
*
|
764 |
* Tcl_InvalidateStringRep --
|
765 |
*
|
766 |
* This procedure is called to invalidate an object's string
|
767 |
* representation.
|
768 |
*
|
769 |
* Results:
|
770 |
* None.
|
771 |
*
|
772 |
* Side effects:
|
773 |
* Deallocates the storage for any old string representation, then
|
774 |
* sets the string representation NULL to mark it invalid.
|
775 |
*
|
776 |
*----------------------------------------------------------------------
|
777 |
*/
|
778 |
|
779 |
void
|
780 |
Tcl_InvalidateStringRep(objPtr)
|
781 |
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
782 |
* should be freed. */
|
783 |
{
|
784 |
if (objPtr->bytes != NULL) {
|
785 |
if (objPtr->bytes != tclEmptyStringRep) {
|
786 |
ckfree((char *) objPtr->bytes);
|
787 |
}
|
788 |
objPtr->bytes = NULL;
|
789 |
}
|
790 |
}
|
791 |
|
792 |
/*
|
793 |
*----------------------------------------------------------------------
|
794 |
*
|
795 |
* Tcl_NewBooleanObj --
|
796 |
*
|
797 |
* This procedure is normally called when not debugging: i.e., when
|
798 |
* TCL_MEM_DEBUG is not defined. It creates a new boolean object and
|
799 |
* initializes it from the argument boolean value. A nonzero
|
800 |
* "boolValue" is coerced to 1.
|
801 |
*
|
802 |
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
803 |
* result of calling the debugging version Tcl_DbNewBooleanObj.
|
804 |
*
|
805 |
* Results:
|
806 |
* The newly created object is returned. This object will have an
|
807 |
* invalid string representation. The returned object has ref count 0.
|
808 |
*
|
809 |
* Side effects:
|
810 |
* None.
|
811 |
*
|
812 |
*----------------------------------------------------------------------
|
813 |
*/
|
814 |
|
815 |
#ifdef TCL_MEM_DEBUG
|
816 |
#undef Tcl_NewBooleanObj
|
817 |
|
818 |
Tcl_Obj *
|
819 |
Tcl_NewBooleanObj(boolValue)
|
820 |
register int boolValue; /* Boolean used to initialize new object. */
|
821 |
{
|
822 |
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
|
823 |
}
|
824 |
|
825 |
#else /* if not TCL_MEM_DEBUG */
|
826 |
|
827 |
Tcl_Obj *
|
828 |
Tcl_NewBooleanObj(boolValue)
|
829 |
register int boolValue; /* Boolean used to initialize new object. */
|
830 |
{
|
831 |
register Tcl_Obj *objPtr;
|
832 |
|
833 |
TclNewObj(objPtr);
|
834 |
objPtr->bytes = NULL;
|
835 |
|
836 |
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
837 |
objPtr->typePtr = &tclBooleanType;
|
838 |
return objPtr;
|
839 |
}
|
840 |
#endif /* TCL_MEM_DEBUG */
|
841 |
|
842 |
/*
|
843 |
*----------------------------------------------------------------------
|
844 |
*
|
845 |
* Tcl_DbNewBooleanObj --
|
846 |
*
|
847 |
* This procedure is normally called when debugging: i.e., when
|
848 |
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
|
849 |
* same as the Tcl_NewBooleanObj procedure above except that it calls
|
850 |
* Tcl_DbCkalloc directly with the file name and line number from its
|
851 |
* caller. This simplifies debugging since then the checkmem command
|
852 |
* will report the correct file name and line number when reporting
|
853 |
* objects that haven't been freed.
|
854 |
*
|
855 |
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
856 |
* result of calling Tcl_NewBooleanObj.
|
857 |
*
|
858 |
* Results:
|
859 |
* The newly created object is returned. This object will have an
|
860 |
* invalid string representation. The returned object has ref count 0.
|
861 |
*
|
862 |
* Side effects:
|
863 |
* None.
|
864 |
*
|
865 |
*----------------------------------------------------------------------
|
866 |
*/
|
867 |
|
868 |
#ifdef TCL_MEM_DEBUG
|
869 |
|
870 |
Tcl_Obj *
|
871 |
Tcl_DbNewBooleanObj(boolValue, file, line)
|
872 |
register int boolValue; /* Boolean used to initialize new object. */
|
873 |
char *file; /* The name of the source file calling this
|
874 |
* procedure; used for debugging. */
|
875 |
int line; /* Line number in the source file; used
|
876 |
* for debugging. */
|
877 |
{
|
878 |
register Tcl_Obj *objPtr;
|
879 |
|
880 |
TclDbNewObj(objPtr, file, line);
|
881 |
objPtr->bytes = NULL;
|
882 |
|
883 |
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
884 |
objPtr->typePtr = &tclBooleanType;
|
885 |
return objPtr;
|
886 |
}
|
887 |
|
888 |
#else /* if not TCL_MEM_DEBUG */
|
889 |
|
890 |
Tcl_Obj *
|
891 |
Tcl_DbNewBooleanObj(boolValue, file, line)
|
892 |
register int boolValue; /* Boolean used to initialize new object. */
|
893 |
char *file; /* The name of the source file calling this
|
894 |
* procedure; used for debugging. */
|
895 |
int line; /* Line number in the source file; used
|
896 |
* for debugging. */
|
897 |
{
|
898 |
return Tcl_NewBooleanObj(boolValue);
|
899 |
}
|
900 |
#endif /* TCL_MEM_DEBUG */
|
901 |
|
902 |
/*
|
903 |
*----------------------------------------------------------------------
|
904 |
*
|
905 |
* Tcl_SetBooleanObj --
|
906 |
*
|
907 |
* Modify an object to be a boolean object and to have the specified
|
908 |
* boolean value. A nonzero "boolValue" is coerced to 1.
|
909 |
*
|
910 |
* Results:
|
911 |
* None.
|
912 |
*
|
913 |
* Side effects:
|
914 |
* The object's old string rep, if any, is freed. Also, any old
|
915 |
* internal rep is freed.
|
916 |
*
|
917 |
*----------------------------------------------------------------------
|
918 |
*/
|
919 |
|
920 |
void
|
921 |
Tcl_SetBooleanObj(objPtr, boolValue)
|
922 |
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
923 |
register int boolValue; /* Boolean used to set object's value. */
|
924 |
{
|
925 |
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
926 |
|
927 |
if (Tcl_IsShared(objPtr)) {
|
928 |
panic("Tcl_SetBooleanObj called with shared object");
|
929 |
}
|
930 |
|
931 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
932 |
oldTypePtr->freeIntRepProc(objPtr);
|
933 |
}
|
934 |
|
935 |
objPtr->internalRep.longValue = (boolValue? 1 : 0);
|
936 |
objPtr->typePtr = &tclBooleanType;
|
937 |
Tcl_InvalidateStringRep(objPtr);
|
938 |
}
|
939 |
|
940 |
/*
|
941 |
*----------------------------------------------------------------------
|
942 |
*
|
943 |
* Tcl_GetBooleanFromObj --
|
944 |
*
|
945 |
* Attempt to return a boolean from the Tcl object "objPtr". If the
|
946 |
* object is not already a boolean, an attempt will be made to convert
|
947 |
* it to one.
|
948 |
*
|
949 |
* Results:
|
950 |
* The return value is a standard Tcl object result. If an error occurs
|
951 |
* during conversion, an error message is left in the interpreter's
|
952 |
* result unless "interp" is NULL.
|
953 |
*
|
954 |
* Side effects:
|
955 |
* If the object is not already a boolean, the conversion will free
|
956 |
* any old internal representation.
|
957 |
*
|
958 |
*----------------------------------------------------------------------
|
959 |
*/
|
960 |
|
961 |
int
|
962 |
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
|
963 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
964 |
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
|
965 |
register int *boolPtr; /* Place to store resulting boolean. */
|
966 |
{
|
967 |
register int result;
|
968 |
|
969 |
result = SetBooleanFromAny(interp, objPtr);
|
970 |
if (result == TCL_OK) {
|
971 |
*boolPtr = (int) objPtr->internalRep.longValue;
|
972 |
}
|
973 |
return result;
|
974 |
}
|
975 |
|
976 |
/*
|
977 |
*----------------------------------------------------------------------
|
978 |
*
|
979 |
* SetBooleanFromAny --
|
980 |
*
|
981 |
* Attempt to generate a boolean internal form for the Tcl object
|
982 |
* "objPtr".
|
983 |
*
|
984 |
* Results:
|
985 |
* The return value is a standard Tcl result. If an error occurs during
|
986 |
* conversion, an error message is left in the interpreter's result
|
987 |
* unless "interp" is NULL.
|
988 |
*
|
989 |
* Side effects:
|
990 |
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s
|
991 |
* internal representation and the type of "objPtr" is set to boolean.
|
992 |
*
|
993 |
*----------------------------------------------------------------------
|
994 |
*/
|
995 |
|
996 |
static int
|
997 |
SetBooleanFromAny(interp, objPtr)
|
998 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
999 |
register Tcl_Obj *objPtr; /* The object to convert. */
|
1000 |
{
|
1001 |
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
1002 |
char *string, *end;
|
1003 |
register char c;
|
1004 |
char lowerCase[10];
|
1005 |
int newBool, length;
|
1006 |
register int i;
|
1007 |
double dbl;
|
1008 |
|
1009 |
/*
|
1010 |
* Get the string representation. Make it up-to-date if necessary.
|
1011 |
*/
|
1012 |
|
1013 |
string = Tcl_GetStringFromObj(objPtr, &length);
|
1014 |
|
1015 |
/*
|
1016 |
* Copy the string converting its characters to lower case.
|
1017 |
*/
|
1018 |
|
1019 |
for (i = 0; (i < 9) && (i < length); i++) {
|
1020 |
c = string[i];
|
1021 |
/*
|
1022 |
* Weed out international characters so we can safely operate
|
1023 |
* on single bytes.
|
1024 |
*/
|
1025 |
|
1026 |
if (c & 0x80) {
|
1027 |
goto badBoolean;
|
1028 |
}
|
1029 |
if (Tcl_UniCharIsUpper(UCHAR(c))) {
|
1030 |
c = (char) Tcl_UniCharToLower(UCHAR(c));
|
1031 |
}
|
1032 |
lowerCase[i] = c;
|
1033 |
}
|
1034 |
lowerCase[i] = 0;
|
1035 |
|
1036 |
/*
|
1037 |
* Parse the string as a boolean. We use an implementation here that
|
1038 |
* doesn't report errors in interp if interp is NULL.
|
1039 |
*/
|
1040 |
|
1041 |
c = lowerCase[0];
|
1042 |
if ((c == '0') && (lowerCase[1] == '\0')) {
|
1043 |
newBool = 0;
|
1044 |
} else if ((c == '1') && (lowerCase[1] == '\0')) {
|
1045 |
newBool = 1;
|
1046 |
} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
|
1047 |
newBool = 1;
|
1048 |
} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
|
1049 |
newBool = 0;
|
1050 |
} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
|
1051 |
newBool = 1;
|
1052 |
} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
|
1053 |
newBool = 0;
|
1054 |
} else if ((c == 'o') && (length >= 2)) {
|
1055 |
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
|
1056 |
newBool = 1;
|
1057 |
} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
|
1058 |
newBool = 0;
|
1059 |
} else {
|
1060 |
goto badBoolean;
|
1061 |
}
|
1062 |
} else {
|
1063 |
/*
|
1064 |
* Still might be a string containing the characters representing an
|
1065 |
* int or double that wasn't handled above. This would be a string
|
1066 |
* like "27" or "1.0" that is non-zero and not "1". Such a string
|
1067 |
* whould result in the boolean value true. We try converting to
|
1068 |
* double. If that succeeds and the resulting double is non-zero, we
|
1069 |
* have a "true". Note that numbers can't have embedded NULLs.
|
1070 |
*/
|
1071 |
|
1072 |
dbl = strtod(string, &end);
|
1073 |
if (end == string) {
|
1074 |
goto badBoolean;
|
1075 |
}
|
1076 |
|
1077 |
/*
|
1078 |
* Make sure the string has no garbage after the end of the double.
|
1079 |
*/
|
1080 |
|
1081 |
while ((end < (string+length))
|
1082 |
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
|
1083 |
end++;
|
1084 |
}
|
1085 |
if (end != (string+length)) {
|
1086 |
goto badBoolean;
|
1087 |
}
|
1088 |
newBool = (dbl != 0.0);
|
1089 |
}
|
1090 |
|
1091 |
/*
|
1092 |
* Free the old internalRep before setting the new one. We do this as
|
1093 |
* late as possible to allow the conversion code, in particular
|
1094 |
* Tcl_GetStringFromObj, to use that old internalRep.
|
1095 |
*/
|
1096 |
|
1097 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
1098 |
oldTypePtr->freeIntRepProc(objPtr);
|
1099 |
}
|
1100 |
|
1101 |
objPtr->internalRep.longValue = newBool;
|
1102 |
objPtr->typePtr = &tclBooleanType;
|
1103 |
return TCL_OK;
|
1104 |
|
1105 |
badBoolean:
|
1106 |
if (interp != NULL) {
|
1107 |
/*
|
1108 |
* Must copy string before resetting the result in case a caller
|
1109 |
* is trying to convert the interpreter's result to a boolean.
|
1110 |
*/
|
1111 |
|
1112 |
char buf[100];
|
1113 |
sprintf(buf, "expected boolean value but got \"%.50s\"", string);
|
1114 |
Tcl_ResetResult(interp);
|
1115 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
1116 |
}
|
1117 |
return TCL_ERROR;
|
1118 |
}
|
1119 |
|
1120 |
/*
|
1121 |
*----------------------------------------------------------------------
|
1122 |
*
|
1123 |
* UpdateStringOfBoolean --
|
1124 |
*
|
1125 |
* Update the string representation for a boolean object.
|
1126 |
* Note: This procedure does not free an existing old string rep
|
1127 |
* so storage will be lost if this has not already been done.
|
1128 |
*
|
1129 |
* Results:
|
1130 |
* None.
|
1131 |
*
|
1132 |
* Side effects:
|
1133 |
* The object's string is set to a valid string that results from
|
1134 |
* the boolean-to-string conversion.
|
1135 |
*
|
1136 |
*----------------------------------------------------------------------
|
1137 |
*/
|
1138 |
|
1139 |
static void
|
1140 |
UpdateStringOfBoolean(objPtr)
|
1141 |
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
1142 |
{
|
1143 |
char *s = ckalloc((unsigned) 2);
|
1144 |
|
1145 |
s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
|
1146 |
s[1] = '\0';
|
1147 |
objPtr->bytes = s;
|
1148 |
objPtr->length = 1;
|
1149 |
}
|
1150 |
|
1151 |
/*
|
1152 |
*----------------------------------------------------------------------
|
1153 |
*
|
1154 |
* Tcl_NewDoubleObj --
|
1155 |
*
|
1156 |
* This procedure is normally called when not debugging: i.e., when
|
1157 |
* TCL_MEM_DEBUG is not defined. It creates a new double object and
|
1158 |
* initializes it from the argument double value.
|
1159 |
*
|
1160 |
* When TCL_MEM_DEBUG is defined, this procedure just returns the
|
1161 |
* result of calling the debugging version Tcl_DbNewDoubleObj.
|
1162 |
*
|
1163 |
* Results:
|
1164 |
* The newly created object is returned. This object will have an
|
1165 |
* invalid string representation. The returned object has ref count 0.
|
1166 |
*
|
1167 |
* Side effects:
|
1168 |
* None.
|
1169 |
*
|
1170 |
*----------------------------------------------------------------------
|
1171 |
*/
|
1172 |
|
1173 |
#ifdef TCL_MEM_DEBUG
|
1174 |
#undef Tcl_NewDoubleObj
|
1175 |
|
1176 |
Tcl_Obj *
|
1177 |
Tcl_NewDoubleObj(dblValue)
|
1178 |
register double dblValue; /* Double used to initialize the object. */
|
1179 |
{
|
1180 |
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
|
1181 |
}
|
1182 |
|
1183 |
#else /* if not TCL_MEM_DEBUG */
|
1184 |
|
1185 |
Tcl_Obj *
|
1186 |
Tcl_NewDoubleObj(dblValue)
|
1187 |
register double dblValue; /* Double used to initialize the object. */
|
1188 |
{
|
1189 |
register Tcl_Obj *objPtr;
|
1190 |
|
1191 |
TclNewObj(objPtr);
|
1192 |
objPtr->bytes = NULL;
|
1193 |
|
1194 |
objPtr->internalRep.doubleValue = dblValue;
|
1195 |
objPtr->typePtr = &tclDoubleType;
|
1196 |
return objPtr;
|
1197 |
}
|
1198 |
#endif /* if TCL_MEM_DEBUG */
|
1199 |
|
1200 |
/*
|
1201 |
*----------------------------------------------------------------------
|
1202 |
*
|
1203 |
* Tcl_DbNewDoubleObj --
|
1204 |
*
|
1205 |
* This procedure is normally called when debugging: i.e., when
|
1206 |
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
|
1207 |
* same as the Tcl_NewDoubleObj procedure above except that it calls
|
1208 |
* Tcl_DbCkalloc directly with the file name and line number from its
|
1209 |
* caller. This simplifies debugging since then the checkmem command
|
1210 |
* will report the correct file name and line number when reporting
|
1211 |
* objects that haven't been freed.
|
1212 |
*
|
1213 |
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
|
1214 |
* result of calling Tcl_NewDoubleObj.
|
1215 |
*
|
1216 |
* Results:
|
1217 |
* The newly created object is returned. This object will have an
|
1218 |
* invalid string representation. The returned object has ref count 0.
|
1219 |
*
|
1220 |
* Side effects:
|
1221 |
* None.
|
1222 |
*
|
1223 |
*----------------------------------------------------------------------
|
1224 |
*/
|
1225 |
|
1226 |
#ifdef TCL_MEM_DEBUG
|
1227 |
|
1228 |
Tcl_Obj *
|
1229 |
Tcl_DbNewDoubleObj(dblValue, file, line)
|
1230 |
register double dblValue; /* Double used to initialize the object. */
|
1231 |
char *file; /* The name of the source file calling this
|
1232 |
* procedure; used for debugging. */
|
1233 |
int line; /* Line number in the source file; used
|
1234 |
* for debugging. */
|
1235 |
{
|
1236 |
register Tcl_Obj *objPtr;
|
1237 |
|
1238 |
TclDbNewObj(objPtr, file, line);
|
1239 |
objPtr->bytes = NULL;
|
1240 |
|
1241 |
objPtr->internalRep.doubleValue = dblValue;
|
1242 |
objPtr->typePtr = &tclDoubleType;
|
1243 |
return objPtr;
|
1244 |
}
|
1245 |
|
1246 |
#else /* if not TCL_MEM_DEBUG */
|
1247 |
|
1248 |
Tcl_Obj *
|
1249 |
Tcl_DbNewDoubleObj(dblValue, file, line)
|
1250 |
register double dblValue; /* Double used to initialize the object. */
|
1251 |
char *file; /* The name of the source file calling this
|
1252 |
* procedure; used for debugging. */
|
1253 |
int line; /* Line number in the source file; used
|
1254 |
* for debugging. */
|
1255 |
{
|
1256 |
return Tcl_NewDoubleObj(dblValue);
|
1257 |
}
|
1258 |
#endif /* TCL_MEM_DEBUG */
|
1259 |
|
1260 |
/*
|
1261 |
*----------------------------------------------------------------------
|
1262 |
*
|
1263 |
* Tcl_SetDoubleObj --
|
1264 |
*
|
1265 |
* Modify an object to be a double object and to have the specified
|
1266 |
* double value.
|
1267 |
*
|
1268 |
* Results:
|
1269 |
* None.
|
1270 |
*
|
1271 |
* Side effects:
|
1272 |
* The object's old string rep, if any, is freed. Also, any old
|
1273 |
* internal rep is freed.
|
1274 |
*
|
1275 |
*----------------------------------------------------------------------
|
1276 |
*/
|
1277 |
|
1278 |
void
|
1279 |
Tcl_SetDoubleObj(objPtr, dblValue)
|
1280 |
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
1281 |
register double dblValue; /* Double used to set the object's value. */
|
1282 |
{
|
1283 |
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
1284 |
|
1285 |
if (Tcl_IsShared(objPtr)) {
|
1286 |
panic("Tcl_SetDoubleObj called with shared object");
|
1287 |
}
|
1288 |
|
1289 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
1290 |
oldTypePtr->freeIntRepProc(objPtr);
|
1291 |
}
|
1292 |
|
1293 |
objPtr->internalRep.doubleValue = dblValue;
|
1294 |
objPtr->typePtr = &tclDoubleType;
|
1295 |
Tcl_InvalidateStringRep(objPtr);
|
1296 |
}
|
1297 |
|
1298 |
/*
|
1299 |
*----------------------------------------------------------------------
|
1300 |
*
|
1301 |
* Tcl_GetDoubleFromObj --
|
1302 |
*
|
1303 |
* Attempt to return a double from the Tcl object "objPtr". If the
|
1304 |
* object is not already a double, an attempt will be made to convert
|
1305 |
* it to one.
|
1306 |
*
|
1307 |
* Results:
|
1308 |
* The return value is a standard Tcl object result. If an error occurs
|
1309 |
* during conversion, an error message is left in the interpreter's
|
1310 |
* result unless "interp" is NULL.
|
1311 |
*
|
1312 |
* Side effects:
|
1313 |
* If the object is not already a double, the conversion will free
|
1314 |
* any old internal representation.
|
1315 |
*
|
1316 |
*----------------------------------------------------------------------
|
1317 |
*/
|
1318 |
|
1319 |
int
|
1320 |
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
|
1321 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
1322 |
register Tcl_Obj *objPtr; /* The object from which to get a double. */
|
1323 |
register double *dblPtr; /* Place to store resulting double. */
|
1324 |
{
|
1325 |
register int result;
|
1326 |
|
1327 |
if (objPtr->typePtr == &tclDoubleType) {
|
1328 |
*dblPtr = objPtr->internalRep.doubleValue;
|
1329 |
return TCL_OK;
|
1330 |
}
|
1331 |
|
1332 |
result = SetDoubleFromAny(interp, objPtr);
|
1333 |
if (result == TCL_OK) {
|
1334 |
*dblPtr = objPtr->internalRep.doubleValue;
|
1335 |
}
|
1336 |
return result;
|
1337 |
}
|
1338 |
|
1339 |
/*
|
1340 |
*----------------------------------------------------------------------
|
1341 |
*
|
1342 |
* SetDoubleFromAny --
|
1343 |
*
|
1344 |
* Attempt to generate an double-precision floating point internal form
|
1345 |
* for the Tcl object "objPtr".
|
1346 |
*
|
1347 |
* Results:
|
1348 |
* The return value is a standard Tcl object result. If an error occurs
|
1349 |
* during conversion, an error message is left in the interpreter's
|
1350 |
* result unless "interp" is NULL.
|
1351 |
*
|
1352 |
* Side effects:
|
1353 |
* If no error occurs, a double is stored as "objPtr"s internal
|
1354 |
* representation.
|
1355 |
*
|
1356 |
*----------------------------------------------------------------------
|
1357 |
*/
|
1358 |
|
1359 |
static int
|
1360 |
SetDoubleFromAny(interp, objPtr)
|
1361 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
1362 |
register Tcl_Obj *objPtr; /* The object to convert. */
|
1363 |
{
|
1364 |
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
1365 |
char *string, *end;
|
1366 |
double newDouble;
|
1367 |
int length;
|
1368 |
|
1369 |
/*
|
1370 |
* Get the string representation. Make it up-to-date if necessary.
|
1371 |
*/
|
1372 |
|
1373 |
string = Tcl_GetStringFromObj(objPtr, &length);
|
1374 |
|
1375 |
/*
|
1376 |
* Now parse "objPtr"s string as an double. Numbers can't have embedded
|
1377 |
* NULLs. We use an implementation here that doesn't report errors in
|
1378 |
* interp if interp is NULL.
|
1379 |
*/
|
1380 |
|
1381 |
errno = 0;
|
1382 |
newDouble = strtod(string, &end);
|
1383 |
if (end == string) {
|
1384 |
badDouble:
|
1385 |
if (interp != NULL) {
|
1386 |
/*
|
1387 |
* Must copy string before resetting the result in case a caller
|
1388 |
* is trying to convert the interpreter's result to an int.
|
1389 |
*/
|
1390 |
|
1391 |
char buf[100];
|
1392 |
sprintf(buf, "expected floating-point number but got \"%.50s\"",
|
1393 |
string);
|
1394 |
Tcl_ResetResult(interp);
|
1395 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
1396 |
}
|
1397 |
return TCL_ERROR;
|
1398 |
}
|
1399 |
if (errno != 0) {
|
1400 |
if (interp != NULL) {
|
1401 |
TclExprFloatError(interp, newDouble);
|
1402 |
}
|
1403 |
return TCL_ERROR;
|
1404 |
}
|
1405 |
|
1406 |
/*
|
1407 |
* Make sure that the string has no garbage after the end of the double.
|
1408 |
*/
|
1409 |
|
1410 |
while ((end < (string+length))
|
1411 |
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
|
1412 |
end++;
|
1413 |
}
|
1414 |
if (end != (string+length)) {
|
1415 |
goto badDouble;
|
1416 |
}
|
1417 |
|
1418 |
/*
|
1419 |
* The conversion to double succeeded. Free the old internalRep before
|
1420 |
* setting the new one. We do this as late as possible to allow the
|
1421 |
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
1422 |
* internalRep.
|
1423 |
*/
|
1424 |
|
1425 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
1426 |
oldTypePtr->freeIntRepProc(objPtr);
|
1427 |
}
|
1428 |
|
1429 |
objPtr->internalRep.doubleValue = newDouble;
|
1430 |
objPtr->typePtr = &tclDoubleType;
|
1431 |
return TCL_OK;
|
1432 |
}
|
1433 |
|
1434 |
/*
|
1435 |
*----------------------------------------------------------------------
|
1436 |
*
|
1437 |
* UpdateStringOfDouble --
|
1438 |
*
|
1439 |
* Update the string representation for a double-precision floating
|
1440 |
* point object. This must obey the current tcl_precision value for
|
1441 |
* double-to-string conversions. Note: This procedure does not free an
|
1442 |
* existing old string rep so storage will be lost if this has not
|
1443 |
* already been done.
|
1444 |
*
|
1445 |
* Results:
|
1446 |
* None.
|
1447 |
*
|
1448 |
* Side effects:
|
1449 |
* The object's string is set to a valid string that results from
|
1450 |
* the double-to-string conversion.
|
1451 |
*
|
1452 |
*----------------------------------------------------------------------
|
1453 |
*/
|
1454 |
|
1455 |
static void
|
1456 |
UpdateStringOfDouble(objPtr)
|
1457 |
register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
|
1458 |
{
|
1459 |
char buffer[TCL_DOUBLE_SPACE];
|
1460 |
register int len;
|
1461 |
|
1462 |
Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
|
1463 |
buffer);
|
1464 |
len = strlen(buffer);
|
1465 |
|
1466 |
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
|
1467 |
strcpy(objPtr->bytes, buffer);
|
1468 |
objPtr->length = len;
|
1469 |
}
|
1470 |
|
1471 |
/*
|
1472 |
*----------------------------------------------------------------------
|
1473 |
*
|
1474 |
* Tcl_NewIntObj --
|
1475 |
*
|
1476 |
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
1477 |
* Tcl_NewIntObj to create a new integer object end up calling the
|
1478 |
* debugging procedure Tcl_DbNewLongObj instead.
|
1479 |
*
|
1480 |
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
1481 |
* calls to Tcl_NewIntObj result in a call to one of the two
|
1482 |
* Tcl_NewIntObj implementations below. We provide two implementations
|
1483 |
* so that the Tcl core can be compiled to do memory debugging of the
|
1484 |
* core even if a client does not request it for itself.
|
1485 |
*
|
1486 |
* Integer and long integer objects share the same "integer" type
|
1487 |
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
1488 |
* checks whether the current value of the long can be represented by
|
1489 |
* an int.
|
1490 |
*
|
1491 |
* Results:
|
1492 |
* The newly created object is returned. This object will have an
|
1493 |
* invalid string representation. The returned object has ref count 0.
|
1494 |
*
|
1495 |
* Side effects:
|
1496 |
* None.
|
1497 |
*
|
1498 |
*----------------------------------------------------------------------
|
1499 |
*/
|
1500 |
|
1501 |
#ifdef TCL_MEM_DEBUG
|
1502 |
#undef Tcl_NewIntObj
|
1503 |
|
1504 |
Tcl_Obj *
|
1505 |
Tcl_NewIntObj(intValue)
|
1506 |
register int intValue; /* Int used to initialize the new object. */
|
1507 |
{
|
1508 |
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
|
1509 |
}
|
1510 |
|
1511 |
#else /* if not TCL_MEM_DEBUG */
|
1512 |
|
1513 |
Tcl_Obj *
|
1514 |
Tcl_NewIntObj(intValue)
|
1515 |
register int intValue; /* Int used to initialize the new object. */
|
1516 |
{
|
1517 |
register Tcl_Obj *objPtr;
|
1518 |
|
1519 |
TclNewObj(objPtr);
|
1520 |
objPtr->bytes = NULL;
|
1521 |
|
1522 |
objPtr->internalRep.longValue = (long)intValue;
|
1523 |
objPtr->typePtr = &tclIntType;
|
1524 |
return objPtr;
|
1525 |
}
|
1526 |
#endif /* if TCL_MEM_DEBUG */
|
1527 |
|
1528 |
/*
|
1529 |
*----------------------------------------------------------------------
|
1530 |
*
|
1531 |
* Tcl_SetIntObj --
|
1532 |
*
|
1533 |
* Modify an object to be an integer and to have the specified integer
|
1534 |
* value.
|
1535 |
*
|
1536 |
* Results:
|
1537 |
* None.
|
1538 |
*
|
1539 |
* Side effects:
|
1540 |
* The object's old string rep, if any, is freed. Also, any old
|
1541 |
* internal rep is freed.
|
1542 |
*
|
1543 |
*----------------------------------------------------------------------
|
1544 |
*/
|
1545 |
|
1546 |
void
|
1547 |
Tcl_SetIntObj(objPtr, intValue)
|
1548 |
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
1549 |
register int intValue; /* Integer used to set object's value. */
|
1550 |
{
|
1551 |
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
1552 |
|
1553 |
if (Tcl_IsShared(objPtr)) {
|
1554 |
panic("Tcl_SetIntObj called with shared object");
|
1555 |
}
|
1556 |
|
1557 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
1558 |
oldTypePtr->freeIntRepProc(objPtr);
|
1559 |
}
|
1560 |
|
1561 |
objPtr->internalRep.longValue = (long) intValue;
|
1562 |
objPtr->typePtr = &tclIntType;
|
1563 |
Tcl_InvalidateStringRep(objPtr);
|
1564 |
}
|
1565 |
|
1566 |
|
1567 |
|
1568 |
/*
|
1569 |
*----------------------------------------------------------------------
|
1570 |
* Tcl_ParseStringToInts --
|
1571 |
*----------------------------------------------------------------------
|
1572 |
* DESCRIPTION
|
1573 |
* Parses a string to both a machine signed integer and a machine
|
1574 |
* signed long (and, depending on the platform, these may be the same
|
1575 |
* size). All errors, including overflow, are detected. The three
|
1576 |
* formats accepted are decimal, octal, and hexadecimal.
|
1577 |
*
|
1578 |
* This function forms the canonical arbiter of what is and is not
|
1579 |
* an integer. This function can be used to parse only, without
|
1580 |
* returning any numerical results.
|
1581 |
*
|
1582 |
* All formats (decimal, octal, hexadecimal) allow whitespace both
|
1583 |
* before and after the digits of the number.
|
1584 |
*
|
1585 |
* All formats (decimal, octal, hexadecimal) allow an arbitrary number
|
1586 |
* of unary sign operators before the number (+ and -). The number
|
1587 |
* will be negated if the number of "-" operators is odd, and not
|
1588 |
* negated if the number is even. The operators are not required to
|
1589 |
* be contiguous, and may be separated by whitespace. The operators
|
1590 |
* may be separated from the digits by whitespace (this is to be con-
|
1591 |
* sistent with current behavior).
|
1592 |
*
|
1593 |
* A decimal number consists of the following components.
|
1594 |
* a)Optional leading whitespace.
|
1595 |
* b)An arbitrary number of leading "-" and "+" unary operators,
|
1596 |
* which may be separated by whitespace, and may be separated
|
1597 |
* from the digits of the number by whitespace.
|
1598 |
* c)The digits of the number, which may not begin with "0", and
|
1599 |
* must be contiguous.
|
1600 |
* d)Optional trailing whitespace.
|
1601 |
*
|
1602 |
* A decimal number is illegal if it is effectively positive but
|
1603 |
* is larger than the maximum positive integer of the size being
|
1604 |
* considered. By "effectively" positive, I mean having an even
|
1605 |
* number of unary "-" operators (including zero of them).
|
1606 |
*
|
1607 |
* A decimal number is also illegal if it is effectively negative
|
1608 |
* but less than the maximum negative integer of the size being
|
1609 |
* considered.
|
1610 |
*
|
1611 |
* An octal number is just like a decimal number, except that its
|
1612 |
* first digit is zero, and no digit may exceed "7". An octal number
|
1613 |
* is illegal only if the configuration of 1-bits specified before
|
1614 |
* negation exceeds the ability of the machine integer being
|
1615 |
* considered to hold them--an octal number is exempt from sign
|
1616 |
* considerations.
|
1617 |
*
|
1618 |
* A hexadecimal number is just like an octal number, except that
|
1619 |
* the first two digits must be "0x" or "0X", and the digits in
|
1620 |
* the number may be 0-9, A-F, and a-f. Again, a hexadecimal number
|
1621 |
* is exempt from sign considerations, and will be declared illegal
|
1622 |
* only if the bit pattern before possible negation will not fit in
|
1623 |
* the machine integer being considered.
|
1624 |
*
|
1625 |
* The descriptions of legal and illegal above carry over to long
|
1626 |
* integers. A string may represent a valid long integer but an
|
1627 |
* invalid integer. In all cases, the criteria for illegality is
|
1628 |
* the same.
|
1629 |
*
|
1630 |
* Negation in all cases is carried out in the two's complement
|
1631 |
* fashion (i.e. one's complement plus one).
|
1632 |
*
|
1633 |
* LEGALITY/ILLEGALITY EXAMPLES
|
1634 |
* Below are listed several examples which illustrate what is legal and
|
1635 |
* what is illegal, and why. Assume a 32-bit machine integer in
|
1636 |
* standard 2's complement configuration.
|
1637 |
*
|
1638 |
* 4000000000 (illegal)
|
1639 |
* Illegal because a positive number is specified which is larger
|
1640 |
* than the largest machine positive integer.
|
1641 |
* 2147483647 (legal)
|
1642 |
* This maps to a legal positive machine integer.
|
1643 |
* 2147483648 (illegal)
|
1644 |
* This number is larger than the largest positive integer.
|
1645 |
* -2147483648 (legal)
|
1646 |
* This number is a legal negative integer.
|
1647 |
* ----2147483648 (illegal)
|
1648 |
* The number is effectively positive, but will not fit into
|
1649 |
* a positive integer.
|
1650 |
* -----2147483648 (legal)
|
1651 |
* The number is effectively negative, and will fit into a negative
|
1652 |
* machine integer.
|
1653 |
* + - +++ - + - + ---- 0000000000000000 (legal)
|
1654 |
* Any number of unary + and - operators may be specified, they
|
1655 |
* are not required to be contiguous, and any number of zero digits
|
1656 |
* are allowed.
|
1657 |
*
|
1658 |
* + - +++ - + - + ---- 0000000000000008 (illegal)
|
1659 |
* The digit "8" cannot appear in an octal number.
|
1660 |
*
|
1661 |
* +-+-+---- 0x0000000000000000000000000000000000000000000Ff (legal)
|
1662 |
* The only consideration for a hexadecimal number is that the
|
1663 |
* 1's in the bit pattern fit into 32 bits. They do.
|
1664 |
*
|
1665 |
* -0xABCDEF01 (legal)
|
1666 |
* The number, before negation, fits into 32 bits.
|
1667 |
*
|
1668 |
* -0x6ABCDEF01 (illegal)
|
1669 |
* The number, before negation, does not fit into 32 bits.
|
1670 |
*
|
1671 |
* 077777777777 (illegal)
|
1672 |
* The octal number contains 33 significant bits, and cannot be
|
1673 |
* contained by a machine integer.
|
1674 |
* 037777777777 (illegal)
|
1675 |
* This octal number contains only 32 significant bits, and
|
1676 |
* can be contained in a machine integer.
|
1677 |
*
|
1678 |
*
|
1679 |
* INPUTS
|
1680 |
* s
|
1681 |
* Pointer to string to accept as input. This pointer may not
|
1682 |
* be NULL.
|
1683 |
* len
|
1684 |
* The maximum number of characters to use from s. If this
|
1685 |
* parameter is non-negative, this function will treat s as if
|
1686 |
* s[len] is the \0 terminator. (By the way, since a valid integer
|
1687 |
* can never be specified with zero characters, zero here will
|
1688 |
* always result in unsuccessful parses.) If this parameter is
|
1689 |
* negative (commonly "-1"), it indicates to use a zero terminator
|
1690 |
* in s.
|
1691 |
* *err_result
|
1692 |
* This is a bit-packed integer which indicates the result
|
1693 |
* of the parsing. Bits are set on failure rather than
|
1694 |
* success. If this integer tests 0, then no errors occured.
|
1695 |
* The pointer to this integer may be NULL, in which case the
|
1696 |
* result is not assigned.
|
1697 |
*
|
1698 |
* Since the ANSI C spec requires that integers be at least
|
1699 |
* 16 bits, we have room for 16 flags here.
|
1700 |
*
|
1701 |
* The bits defined in this integer are listed below. All bits
|
1702 |
* not identified are unused and will always be zero.
|
1703 |
* a)0x0001 : The input string was syntactically bad and could
|
1704 |
* not be parsed as an integer at all, of any
|
1705 |
* size (example: illegal characters). In other
|
1706 |
* words, the error was not related to size of the
|
1707 |
* integer, but rather it was not well-formed.
|
1708 |
* b)0x0002 : Could not be parsed as a signed integer--too
|
1709 |
* negative.
|
1710 |
* c)0x0004 : Could not be parsed as a signed integer--too
|
1711 |
* positive.
|
1712 |
* d)0x0008 : Could not be parsed as an unsigned integer--
|
1713 |
* too negative (which means < 0).
|
1714 |
* e)0x0010 : Could not be parsed as an unsigned integer--
|
1715 |
* too positive.
|
1716 |
* f)0x0020 : Could not be parsed as an integer--too many
|
1717 |
* bits specified (applies only to octal and hex
|
1718 |
* numbers).
|
1719 |
* g)0x0040 : Could not be parsed as a signed long--too negative.
|
1720 |
* h)0x0080 : Could not be parsed as a signed long--too positive.
|
1721 |
* i)0x0100 : Could not be parsed as an unsigned long--too negative.
|
1722 |
* j)0x0200 : Could not be parsed as an unsigned long--too positive.
|
1723 |
* k)0x0400 : Could not be parsed as an long--too many
|
1724 |
* bits specified (applies only to octal and hex
|
1725 |
* numbers).
|
1726 |
*
|
1727 |
* *int_result
|
1728 |
* The result of attempted conversion to an integer. If
|
1729 |
* flag (a) or flag (f) is set, this result is undefined.
|
1730 |
* If at least one of (b) or (c) are set but neither of
|
1731 |
* (d) or (e) are set, this contains the bit pattern of a
|
1732 |
* valid unsigned integer.
|
1733 |
* of flags (b) through (d) are set but none of flags
|
1734 |
*
|
1735 |
*
|
1736 |
*----------------------------------------------------------------------
|
1737 |
*/
|
1738 |
|
1739 |
void Tcl_ParseStringToInts(char *s)
|
1740 |
{
|
1741 |
|
1742 |
}
|
1743 |
|
1744 |
|
1745 |
|
1746 |
/*
|
1747 |
*----------------------------------------------------------------------
|
1748 |
*
|
1749 |
* Tcl_GetIntFromObj --
|
1750 |
*
|
1751 |
* Attempt to return an int from the Tcl object "objPtr". If the object
|
1752 |
* is not already an int, an attempt will be made to convert it to one.
|
1753 |
*
|
1754 |
* Integer and long integer objects share the same "integer" type
|
1755 |
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
1756 |
* checks whether the current value of the long can be represented by
|
1757 |
* an int.
|
1758 |
*
|
1759 |
* Results:
|
1760 |
* The return value is a standard Tcl object result. If an error occurs
|
1761 |
* during conversion or if the long integer held by the object
|
1762 |
* can not be represented by an int, an error message is left in
|
1763 |
* the interpreter's result unless "interp" is NULL.
|
1764 |
*
|
1765 |
* Side effects:
|
1766 |
* If the object is not already an int, the conversion will free
|
1767 |
* any old internal representation.
|
1768 |
*
|
1769 |
*----------------------------------------------------------------------
|
1770 |
*/
|
1771 |
|
1772 |
int
|
1773 |
Tcl_GetIntFromObj(interp, objPtr, intPtr)
|
1774 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
1775 |
register Tcl_Obj *objPtr; /* The object from which to get a int. */
|
1776 |
register int *intPtr; /* Place to store resulting int. */
|
1777 |
{
|
1778 |
register long l;
|
1779 |
int result;
|
1780 |
|
1781 |
if (objPtr->typePtr != &tclIntType) {
|
1782 |
result = SetIntFromAny(interp, objPtr);
|
1783 |
if (result != TCL_OK) {
|
1784 |
return result;
|
1785 |
}
|
1786 |
}
|
1787 |
l = objPtr->internalRep.longValue;
|
1788 |
if (((long)((int)l)) == l) {
|
1789 |
*intPtr = (int)objPtr->internalRep.longValue;
|
1790 |
return TCL_OK;
|
1791 |
}
|
1792 |
if (interp != NULL) {
|
1793 |
Tcl_ResetResult(interp);
|
1794 |
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
1795 |
"integer value too large to represent as non-long integer", -1);
|
1796 |
}
|
1797 |
return TCL_ERROR;
|
1798 |
}
|
1799 |
|
1800 |
/*
|
1801 |
*----------------------------------------------------------------------
|
1802 |
*
|
1803 |
* SetIntFromAny --
|
1804 |
*
|
1805 |
* Attempt to generate an integer internal form for the Tcl object
|
1806 |
* "objPtr".
|
1807 |
*
|
1808 |
* Results:
|
1809 |
* The return value is a standard object Tcl result. If an error occurs
|
1810 |
* during conversion, an error message is left in the interpreter's
|
1811 |
* result unless "interp" is NULL.
|
1812 |
*
|
1813 |
* Side effects:
|
1814 |
* If no error occurs, an int is stored as "objPtr"s internal
|
1815 |
* representation.
|
1816 |
*
|
1817 |
*----------------------------------------------------------------------
|
1818 |
*/
|
1819 |
|
1820 |
static int
|
1821 |
SetIntFromAny(interp, objPtr)
|
1822 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
1823 |
register Tcl_Obj *objPtr; /* The object to convert. */
|
1824 |
{
|
1825 |
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
1826 |
char *string, *end;
|
1827 |
int length;
|
1828 |
register char *p;
|
1829 |
long newLong;
|
1830 |
|
1831 |
/*
|
1832 |
* Get the string representation. Make it up-to-date if necessary.
|
1833 |
*/
|
1834 |
|
1835 |
string = Tcl_GetStringFromObj(objPtr, &length);
|
1836 |
|
1837 |
/*
|
1838 |
* Now parse "objPtr"s string as an int. We use an implementation here
|
1839 |
* that doesn't report errors in interp if interp is NULL. Note: use
|
1840 |
* strtoul instead of strtol for integer conversions to allow full-size
|
1841 |
* unsigned numbers, but don't depend on strtoul to handle sign
|
1842 |
* characters; it won't in some implementations.
|
1843 |
*/
|
1844 |
|
1845 |
errno = 0;
|
1846 |
for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
|
1847 |
/* Empty loop body. */
|
1848 |
}
|
1849 |
if (*p == '-') {
|
1850 |
p++;
|
1851 |
newLong = -((long)strtoul(p, &end, 0));
|
1852 |
} else if (*p == '+') {
|
1853 |
p++;
|
1854 |
newLong = strtoul(p, &end, 0);
|
1855 |
} else {
|
1856 |
newLong = strtoul(p, &end, 0);
|
1857 |
}
|
1858 |
if (end == p) {
|
1859 |
badInteger:
|
1860 |
if (interp != NULL) {
|
1861 |
/*
|
1862 |
* Must copy string before resetting the result in case a caller
|
1863 |
* is trying to convert the interpreter's result to an int.
|
1864 |
*/
|
1865 |
|
1866 |
char buf[100];
|
1867 |
sprintf(buf, "expected integer but got \"%.50s\"", string);
|
1868 |
Tcl_ResetResult(interp);
|
1869 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
1870 |
TclCheckBadOctal(interp, string);
|
1871 |
}
|
1872 |
return TCL_ERROR;
|
1873 |
}
|
1874 |
if (errno == ERANGE) {
|
1875 |
if (interp != NULL) {
|
1876 |
char *s = "integer value too large to represent";
|
1877 |
Tcl_ResetResult(interp);
|
1878 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
|
1879 |
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
|
1880 |
}
|
1881 |
return TCL_ERROR;
|
1882 |
}
|
1883 |
|
1884 |
/*
|
1885 |
* Make sure that the string has no garbage after the end of the int.
|
1886 |
*/
|
1887 |
|
1888 |
while ((end < (string+length))
|
1889 |
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
|
1890 |
end++;
|
1891 |
}
|
1892 |
if (end != (string+length)) {
|
1893 |
goto badInteger;
|
1894 |
}
|
1895 |
|
1896 |
/*
|
1897 |
* The conversion to int succeeded. Free the old internalRep before
|
1898 |
* setting the new one. We do this as late as possible to allow the
|
1899 |
* conversion code, in particular Tcl_GetStringFromObj, to use that old
|
1900 |
* internalRep.
|
1901 |
*/
|
1902 |
|
1903 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
1904 |
oldTypePtr->freeIntRepProc(objPtr);
|
1905 |
}
|
1906 |
|
1907 |
objPtr->internalRep.longValue = newLong;
|
1908 |
objPtr->typePtr = &tclIntType;
|
1909 |
return TCL_OK;
|
1910 |
}
|
1911 |
|
1912 |
/*
|
1913 |
*----------------------------------------------------------------------
|
1914 |
*
|
1915 |
* UpdateStringOfInt --
|
1916 |
*
|
1917 |
* Update the string representation for an integer object.
|
1918 |
* Note: This procedure does not free an existing old string rep
|
1919 |
* so storage will be lost if this has not already been done.
|
1920 |
*
|
1921 |
* Results:
|
1922 |
* None.
|
1923 |
*
|
1924 |
* Side effects:
|
1925 |
* The object's string is set to a valid string that results from
|
1926 |
* the int-to-string conversion.
|
1927 |
*
|
1928 |
*----------------------------------------------------------------------
|
1929 |
*/
|
1930 |
|
1931 |
static void
|
1932 |
UpdateStringOfInt(objPtr)
|
1933 |
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
1934 |
{
|
1935 |
char buffer[TCL_INTEGER_SPACE];
|
1936 |
register int len;
|
1937 |
|
1938 |
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
|
1939 |
|
1940 |
objPtr->bytes = ckalloc((unsigned) len + 1);
|
1941 |
strcpy(objPtr->bytes, buffer);
|
1942 |
objPtr->length = len;
|
1943 |
}
|
1944 |
|
1945 |
/*
|
1946 |
*----------------------------------------------------------------------
|
1947 |
*
|
1948 |
* Tcl_NewLongObj --
|
1949 |
*
|
1950 |
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
1951 |
* Tcl_NewLongObj to create a new long integer object end up calling
|
1952 |
* the debugging procedure Tcl_DbNewLongObj instead.
|
1953 |
*
|
1954 |
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
|
1955 |
* calls to Tcl_NewLongObj result in a call to one of the two
|
1956 |
* Tcl_NewLongObj implementations below. We provide two implementations
|
1957 |
* so that the Tcl core can be compiled to do memory debugging of the
|
1958 |
* core even if a client does not request it for itself.
|
1959 |
*
|
1960 |
* Integer and long integer objects share the same "integer" type
|
1961 |
* implementation. We store all integers as longs and Tcl_GetIntFromObj
|
1962 |
* checks whether the current value of the long can be represented by
|
1963 |
* an int.
|
1964 |
*
|
1965 |
* Results:
|
1966 |
* The newly created object is returned. This object will have an
|
1967 |
* invalid string representation. The returned object has ref count 0.
|
1968 |
*
|
1969 |
* Side effects:
|
1970 |
* None.
|
1971 |
*
|
1972 |
*----------------------------------------------------------------------
|
1973 |
*/
|
1974 |
|
1975 |
#ifdef TCL_MEM_DEBUG
|
1976 |
#undef Tcl_NewLongObj
|
1977 |
|
1978 |
Tcl_Obj *
|
1979 |
Tcl_NewLongObj(longValue)
|
1980 |
register long longValue; /* Long integer used to initialize the
|
1981 |
* new object. */
|
1982 |
{
|
1983 |
return Tcl_DbNewLongObj(longValue, "unknown", 0);
|
1984 |
}
|
1985 |
|
1986 |
#else /* if not TCL_MEM_DEBUG */
|
1987 |
|
1988 |
Tcl_Obj *
|
1989 |
Tcl_NewLongObj(longValue)
|
1990 |
register long longValue; /* Long integer used to initialize the
|
1991 |
* new object. */
|
1992 |
{
|
1993 |
register Tcl_Obj *objPtr;
|
1994 |
|
1995 |
TclNewObj(objPtr);
|
1996 |
objPtr->bytes = NULL;
|
1997 |
|
1998 |
objPtr->internalRep.longValue = longValue;
|
1999 |
objPtr->typePtr = &tclIntType;
|
2000 |
return objPtr;
|
2001 |
}
|
2002 |
#endif /* if TCL_MEM_DEBUG */
|
2003 |
|
2004 |
/*
|
2005 |
*----------------------------------------------------------------------
|
2006 |
*
|
2007 |
* Tcl_DbNewLongObj --
|
2008 |
*
|
2009 |
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
2010 |
* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
|
2011 |
* long integer objects end up calling the debugging procedure
|
2012 |
* Tcl_DbNewLongObj instead. We provide two implementations of
|
2013 |
* Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
|
2014 |
* memory debugging of the core is independent of whether a client
|
2015 |
* requests debugging for itself.
|
2016 |
*
|
2017 |
* When the core is compiled with TCL_MEM_DEBUG defined,
|
2018 |
* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
|
2019 |
* line number from its caller. This simplifies debugging since then
|
2020 |
* the checkmem command will report the caller's file name and line
|
2021 |
* number when reporting objects that haven't been freed.
|
2022 |
*
|
2023 |
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
|
2024 |
* this procedure just returns the result of calling Tcl_NewLongObj.
|
2025 |
*
|
2026 |
* Results:
|
2027 |
* The newly created long integer object is returned. This object
|
2028 |
* will have an invalid string representation. The returned object has
|
2029 |
* ref count 0.
|
2030 |
*
|
2031 |
* Side effects:
|
2032 |
* Allocates memory.
|
2033 |
*
|
2034 |
*----------------------------------------------------------------------
|
2035 |
*/
|
2036 |
|
2037 |
#ifdef TCL_MEM_DEBUG
|
2038 |
|
2039 |
Tcl_Obj *
|
2040 |
Tcl_DbNewLongObj(longValue, file, line)
|
2041 |
register long longValue; /* Long integer used to initialize the
|
2042 |
* new object. */
|
2043 |
char *file; /* The name of the source file calling this
|
2044 |
* procedure; used for debugging. */
|
2045 |
int line; /* Line number in the source file; used
|
2046 |
* for debugging. */
|
2047 |
{
|
2048 |
register Tcl_Obj *objPtr;
|
2049 |
|
2050 |
TclDbNewObj(objPtr, file, line);
|
2051 |
objPtr->bytes = NULL;
|
2052 |
|
2053 |
objPtr->internalRep.longValue = longValue;
|
2054 |
objPtr->typePtr = &tclIntType;
|
2055 |
return objPtr;
|
2056 |
}
|
2057 |
|
2058 |
#else /* if not TCL_MEM_DEBUG */
|
2059 |
|
2060 |
Tcl_Obj *
|
2061 |
Tcl_DbNewLongObj(longValue, file, line)
|
2062 |
register long longValue; /* Long integer used to initialize the
|
2063 |
* new object. */
|
2064 |
char *file; /* The name of the source file calling this
|
2065 |
* procedure; used for debugging. */
|
2066 |
int line; /* Line number in the source file; used
|
2067 |
* for debugging. */
|
2068 |
{
|
2069 |
return Tcl_NewLongObj(longValue);
|
2070 |
}
|
2071 |
#endif /* TCL_MEM_DEBUG */
|
2072 |
|
2073 |
/*
|
2074 |
*----------------------------------------------------------------------
|
2075 |
*
|
2076 |
* Tcl_SetLongObj --
|
2077 |
*
|
2078 |
* Modify an object to be an integer object and to have the specified
|
2079 |
* long integer value.
|
2080 |
*
|
2081 |
* Results:
|
2082 |
* None.
|
2083 |
*
|
2084 |
* Side effects:
|
2085 |
* The object's old string rep, if any, is freed. Also, any old
|
2086 |
* internal rep is freed.
|
2087 |
*
|
2088 |
*----------------------------------------------------------------------
|
2089 |
*/
|
2090 |
|
2091 |
void
|
2092 |
Tcl_SetLongObj(objPtr, longValue)
|
2093 |
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
2094 |
register long longValue; /* Long integer used to initialize the
|
2095 |
* object's value. */
|
2096 |
{
|
2097 |
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
|
2098 |
|
2099 |
if (Tcl_IsShared(objPtr)) {
|
2100 |
panic("Tcl_SetLongObj called with shared object");
|
2101 |
}
|
2102 |
|
2103 |
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
|
2104 |
oldTypePtr->freeIntRepProc(objPtr);
|
2105 |
}
|
2106 |
|
2107 |
objPtr->internalRep.longValue = longValue;
|
2108 |
objPtr->typePtr = &tclIntType;
|
2109 |
Tcl_InvalidateStringRep(objPtr);
|
2110 |
}
|
2111 |
|
2112 |
/*
|
2113 |
*----------------------------------------------------------------------
|
2114 |
*
|
2115 |
* Tcl_GetLongFromObj --
|
2116 |
*
|
2117 |
* Attempt to return an long integer from the Tcl object "objPtr". If
|
2118 |
* the object is not already an int object, an attempt will be made to
|
2119 |
* convert it to one.
|
2120 |
*
|
2121 |
* Results:
|
2122 |
* The return value is a standard Tcl object result. If an error occurs
|
2123 |
* during conversion, an error message is left in the interpreter's
|
2124 |
* result unless "interp" is NULL.
|
2125 |
*
|
2126 |
* Side effects:
|
2127 |
* If the object is not already an int object, the conversion will free
|
2128 |
* any old internal representation.
|
2129 |
*
|
2130 |
*----------------------------------------------------------------------
|
2131 |
*/
|
2132 |
|
2133 |
int
|
2134 |
Tcl_GetLongFromObj(interp, objPtr, longPtr)
|
2135 |
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
2136 |
register Tcl_Obj *objPtr; /* The object from which to get a long. */
|
2137 |
register long *longPtr; /* Place to store resulting long. */
|
2138 |
{
|
2139 |
register int result;
|
2140 |
|
2141 |
if (objPtr->typePtr == &tclIntType) {
|
2142 |
*longPtr = objPtr->internalRep.longValue;
|
2143 |
return TCL_OK;
|
2144 |
}
|
2145 |
result = SetIntFromAny(interp, objPtr);
|
2146 |
if (result == TCL_OK) {
|
2147 |
*longPtr = objPtr->internalRep.longValue;
|
2148 |
}
|
2149 |
return result;
|
2150 |
}
|
2151 |
|
2152 |
/*
|
2153 |
*----------------------------------------------------------------------
|
2154 |
*
|
2155 |
* Tcl_DbIncrRefCount --
|
2156 |
*
|
2157 |
* This procedure is normally called when debugging: i.e., when
|
2158 |
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
2159 |
* the memory has been freed before incrementing the ref count.
|
2160 |
*
|
2161 |
* When TCL_MEM_DEBUG is not defined, this procedure just increments
|
2162 |
* the reference count of the object.
|
2163 |
*
|
2164 |
* Results:
|
2165 |
* None.
|
2166 |
*
|
2167 |
* Side effects:
|
2168 |
* The object's ref count is incremented.
|
2169 |
*
|
2170 |
*----------------------------------------------------------------------
|
2171 |
*/
|
2172 |
|
2173 |
void
|
2174 |
Tcl_DbIncrRefCount(objPtr, file, line)
|
2175 |
register Tcl_Obj *objPtr; /* The object we are registering a
|
2176 |
* reference to. */
|
2177 |
char *file; /* The name of the source file calling this
|
2178 |
* procedure; used for debugging. */
|
2179 |
int line; /* Line number in the source file; used
|
2180 |
* for debugging. */
|
2181 |
{
|
2182 |
#ifdef TCL_MEM_DEBUG
|
2183 |
if (objPtr->refCount == 0x61616161) {
|
2184 |
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
2185 |
fflush(stderr);
|
2186 |
panic("Trying to increment refCount of previously disposed object.");
|
2187 |
}
|
2188 |
#endif
|
2189 |
++(objPtr)->refCount;
|
2190 |
}
|
2191 |
|
2192 |
/*
|
2193 |
*----------------------------------------------------------------------
|
2194 |
*
|
2195 |
* Tcl_DbDecrRefCount --
|
2196 |
*
|
2197 |
* This procedure is normally called when debugging: i.e., when
|
2198 |
* TCL_MEM_DEBUG is defined. This checks to see whether or not
|
2199 |
* the memory has been freed before decrementing the ref count.
|
2200 |
*
|
2201 |
* When TCL_MEM_DEBUG is not defined, this procedure just decrements
|
2202 |
* the reference count of the object.
|
2203 |
*
|
2204 |
* Results:
|
2205 |
* None.
|
2206 |
*
|
2207 |
* Side effects:
|
2208 |
* The object's ref count is incremented.
|
2209 |
*
|
2210 |
*----------------------------------------------------------------------
|
2211 |
*/
|
2212 |
|
2213 |
void
|
2214 |
Tcl_DbDecrRefCount(objPtr, file, line)
|
2215 |
register Tcl_Obj *objPtr; /* The object we are releasing a reference
|
2216 |
* to. */
|
2217 |
char *file; /* The name of the source file calling this
|
2218 |
* procedure; used for debugging. */
|
2219 |
int line; /* Line number in the source file; used
|
2220 |
* for debugging. */
|
2221 |
{
|
2222 |
#ifdef TCL_MEM_DEBUG
|
2223 |
if (objPtr->refCount == 0x61616161) {
|
2224 |
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
2225 |
fflush(stderr);
|
2226 |
panic("Trying to decrement refCount of previously disposed object.");
|
2227 |
}
|
2228 |
#endif
|
2229 |
if (--(objPtr)->refCount <= 0) {
|
2230 |
TclFreeObj(objPtr);
|
2231 |
}
|
2232 |
}
|
2233 |
|
2234 |
/*
|
2235 |
*----------------------------------------------------------------------
|
2236 |
*
|
2237 |
* Tcl_DbIsShared --
|
2238 |
*
|
2239 |
* This procedure is normally called when debugging: i.e., when
|
2240 |
* TCL_MEM_DEBUG is defined. It tests whether the object has a ref
|
2241 |
* count greater than one.
|
2242 |
*
|
2243 |
* When TCL_MEM_DEBUG is not defined, this procedure just tests
|
2244 |
* if the object has a ref count greater than one.
|
2245 |
*
|
2246 |
* Results:
|
2247 |
* None.
|
2248 |
*
|
2249 |
* Side effects:
|
2250 |
* None.
|
2251 |
*
|
2252 |
*----------------------------------------------------------------------
|
2253 |
*/
|
2254 |
|
2255 |
int
|
2256 |
Tcl_DbIsShared(objPtr, file, line)
|
2257 |
register Tcl_Obj *objPtr; /* The object to test for being shared. */
|
2258 |
char *file; /* The name of the source file calling this
|
2259 |
* procedure; used for debugging. */
|
2260 |
int line; /* Line number in the source file; used
|
2261 |
* for debugging. */
|
2262 |
{
|
2263 |
#ifdef TCL_MEM_DEBUG
|
2264 |
if (objPtr->refCount == 0x61616161) {
|
2265 |
fprintf(stderr, "file = %s, line = %d\n", file, line);
|
2266 |
fflush(stderr);
|
2267 |
panic("Trying to check whether previously disposed object is shared.");
|
2268 |
}
|
2269 |
#endif
|
2270 |
return ((objPtr)->refCount > 1);
|
2271 |
}
|
2272 |
|
2273 |
/* End of tclobj.c */
|