/[dtapublic]/projs/trunk/shared_source/tcl_base/tclobj.c
ViewVC logotype

Contents of /projs/trunk/shared_source/tcl_base/tclobj.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25