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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 70166 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
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 */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25