1 | /* |
---|
2 | * tclObj.c -- |
---|
3 | * |
---|
4 | * This file contains Tcl object-related procedures that are used by |
---|
5 | * many Tcl commands. |
---|
6 | * |
---|
7 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. |
---|
8 | * |
---|
9 | * See the file "license.terms" for information on usage and redistribution |
---|
10 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
11 | * |
---|
12 | * RCS: @(#) $Id: tclObj.c,v 1.1 2008-06-04 13:58:08 demin Exp $ |
---|
13 | */ |
---|
14 | |
---|
15 | #include "tclInt.h" |
---|
16 | #include "tclPort.h" |
---|
17 | |
---|
18 | /* |
---|
19 | * Table of all object types. |
---|
20 | */ |
---|
21 | |
---|
22 | static Tcl_HashTable typeTable; |
---|
23 | static int typeTableInitialized = 0; /* 0 means not yet initialized. */ |
---|
24 | |
---|
25 | /* |
---|
26 | * Head of the list of free Tcl_Objs we maintain. |
---|
27 | */ |
---|
28 | |
---|
29 | Tcl_Obj *tclFreeObjList = NULL; |
---|
30 | |
---|
31 | /* |
---|
32 | * Pointer to a heap-allocated string of length zero that the Tcl core uses |
---|
33 | * as the value of an empty string representation for an object. This value |
---|
34 | * is shared by all new objects allocated by Tcl_NewObj. |
---|
35 | */ |
---|
36 | |
---|
37 | char *tclEmptyStringRep = NULL; |
---|
38 | |
---|
39 | /* |
---|
40 | * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and |
---|
41 | * freed (by TclFreeObj). |
---|
42 | */ |
---|
43 | |
---|
44 | #ifdef TCL_COMPILE_STATS |
---|
45 | long tclObjsAlloced = 0; |
---|
46 | long tclObjsFreed = 0; |
---|
47 | #endif /* TCL_COMPILE_STATS */ |
---|
48 | |
---|
49 | /* |
---|
50 | * Prototypes for procedures defined later in this file: |
---|
51 | */ |
---|
52 | |
---|
53 | static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, |
---|
54 | Tcl_Obj *copyPtr)); |
---|
55 | static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, |
---|
56 | Tcl_Obj *copyPtr)); |
---|
57 | static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, |
---|
58 | Tcl_Obj *copyPtr)); |
---|
59 | static void FinalizeTypeTable _ANSI_ARGS_((void)); |
---|
60 | static void FinalizeFreeObjList _ANSI_ARGS_((void)); |
---|
61 | static void InitTypeTable _ANSI_ARGS_((void)); |
---|
62 | static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, |
---|
63 | Tcl_Obj *objPtr)); |
---|
64 | static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, |
---|
65 | Tcl_Obj *objPtr)); |
---|
66 | static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, |
---|
67 | Tcl_Obj *objPtr)); |
---|
68 | static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); |
---|
69 | static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); |
---|
70 | static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); |
---|
71 | |
---|
72 | /* |
---|
73 | * The structures below defines the Tcl object types defined in this file by |
---|
74 | * means of procedures that can be invoked by generic object code. See also |
---|
75 | * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager |
---|
76 | * implementations. |
---|
77 | */ |
---|
78 | |
---|
79 | Tcl_ObjType tclBooleanType = { |
---|
80 | "boolean", /* name */ |
---|
81 | (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ |
---|
82 | DupBooleanInternalRep, /* dupIntRepProc */ |
---|
83 | UpdateStringOfBoolean, /* updateStringProc */ |
---|
84 | SetBooleanFromAny /* setFromAnyProc */ |
---|
85 | }; |
---|
86 | |
---|
87 | Tcl_ObjType tclDoubleType = { |
---|
88 | "double", /* name */ |
---|
89 | (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ |
---|
90 | DupDoubleInternalRep, /* dupIntRepProc */ |
---|
91 | UpdateStringOfDouble, /* updateStringProc */ |
---|
92 | SetDoubleFromAny /* setFromAnyProc */ |
---|
93 | }; |
---|
94 | |
---|
95 | Tcl_ObjType tclIntType = { |
---|
96 | "int", /* name */ |
---|
97 | (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ |
---|
98 | DupIntInternalRep, /* dupIntRepProc */ |
---|
99 | UpdateStringOfInt, /* updateStringProc */ |
---|
100 | SetIntFromAny /* setFromAnyProc */ |
---|
101 | }; |
---|
102 | |
---|
103 | /* |
---|
104 | *-------------------------------------------------------------- |
---|
105 | * |
---|
106 | * InitTypeTable -- |
---|
107 | * |
---|
108 | * This procedure is invoked to perform once-only initialization of |
---|
109 | * the type table. It also registers the object types defined in |
---|
110 | * this file. |
---|
111 | * |
---|
112 | * Results: |
---|
113 | * None. |
---|
114 | * |
---|
115 | * Side effects: |
---|
116 | * Initializes the table of defined object types "typeTable" with |
---|
117 | * builtin object types defined in this file. It also initializes the |
---|
118 | * value of tclEmptyStringRep, which points to the heap-allocated |
---|
119 | * string of length zero used as the string representation for |
---|
120 | * newly-created objects. |
---|
121 | * |
---|
122 | *-------------------------------------------------------------- |
---|
123 | */ |
---|
124 | |
---|
125 | static void |
---|
126 | InitTypeTable() |
---|
127 | { |
---|
128 | typeTableInitialized = 1; |
---|
129 | |
---|
130 | Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); |
---|
131 | Tcl_RegisterObjType(&tclBooleanType); |
---|
132 | Tcl_RegisterObjType(&tclDoubleType); |
---|
133 | Tcl_RegisterObjType(&tclIntType); |
---|
134 | Tcl_RegisterObjType(&tclStringType); |
---|
135 | Tcl_RegisterObjType(&tclListType); |
---|
136 | Tcl_RegisterObjType(&tclByteCodeType); |
---|
137 | Tcl_RegisterObjType(&tclProcBodyType); |
---|
138 | |
---|
139 | tclEmptyStringRep = (char *) ckalloc((unsigned) 1); |
---|
140 | tclEmptyStringRep[0] = '\0'; |
---|
141 | } |
---|
142 | |
---|
143 | /* |
---|
144 | *---------------------------------------------------------------------- |
---|
145 | * |
---|
146 | * FinalizeTypeTable -- |
---|
147 | * |
---|
148 | * This procedure is called by Tcl_Finalize after all exit handlers |
---|
149 | * have been run to free up storage associated with the table of Tcl |
---|
150 | * object types. |
---|
151 | * |
---|
152 | * Results: |
---|
153 | * None. |
---|
154 | * |
---|
155 | * Side effects: |
---|
156 | * Deletes all entries in the hash table of object types, "typeTable". |
---|
157 | * Then sets "typeTableInitialized" to 0 so that the Tcl type system |
---|
158 | * will be properly reinitialized if Tcl is restarted. Also deallocates |
---|
159 | * the storage for tclEmptyStringRep. |
---|
160 | * |
---|
161 | *---------------------------------------------------------------------- |
---|
162 | */ |
---|
163 | |
---|
164 | static void |
---|
165 | FinalizeTypeTable() |
---|
166 | { |
---|
167 | if (typeTableInitialized) { |
---|
168 | Tcl_DeleteHashTable(&typeTable); |
---|
169 | ckfree(tclEmptyStringRep); |
---|
170 | typeTableInitialized = 0; |
---|
171 | } |
---|
172 | } |
---|
173 | |
---|
174 | /* |
---|
175 | *---------------------------------------------------------------------- |
---|
176 | * |
---|
177 | * FinalizeFreeObjList -- |
---|
178 | * |
---|
179 | * Resets the free object list so it can later be reinitialized. |
---|
180 | * |
---|
181 | * Results: |
---|
182 | * None. |
---|
183 | * |
---|
184 | * Side effects: |
---|
185 | * Resets the value of tclFreeObjList. |
---|
186 | * |
---|
187 | *---------------------------------------------------------------------- |
---|
188 | */ |
---|
189 | |
---|
190 | static void |
---|
191 | FinalizeFreeObjList() |
---|
192 | { |
---|
193 | tclFreeObjList = NULL; |
---|
194 | } |
---|
195 | |
---|
196 | /* |
---|
197 | *---------------------------------------------------------------------- |
---|
198 | * |
---|
199 | * TclFinalizeCompExecEnv -- |
---|
200 | * |
---|
201 | * Clean up the compiler execution environment so it can later be |
---|
202 | * properly reinitialized. |
---|
203 | * |
---|
204 | * Results: |
---|
205 | * None. |
---|
206 | * |
---|
207 | * Side effects: |
---|
208 | * Cleans up the execution environment |
---|
209 | * |
---|
210 | *---------------------------------------------------------------------- |
---|
211 | */ |
---|
212 | |
---|
213 | void |
---|
214 | TclFinalizeCompExecEnv() |
---|
215 | { |
---|
216 | FinalizeTypeTable(); |
---|
217 | FinalizeFreeObjList(); |
---|
218 | TclFinalizeExecEnv(); |
---|
219 | } |
---|
220 | |
---|
221 | /* |
---|
222 | *-------------------------------------------------------------- |
---|
223 | * |
---|
224 | * Tcl_RegisterObjType -- |
---|
225 | * |
---|
226 | * This procedure is called to register a new Tcl object type |
---|
227 | * in the table of all object types supported by Tcl. |
---|
228 | * |
---|
229 | * Results: |
---|
230 | * None. |
---|
231 | * |
---|
232 | * Side effects: |
---|
233 | * The type is registered in the Tcl type table. If there was already |
---|
234 | * a type with the same name as in typePtr, it is replaced with the |
---|
235 | * new type. |
---|
236 | * |
---|
237 | *-------------------------------------------------------------- |
---|
238 | */ |
---|
239 | |
---|
240 | void |
---|
241 | Tcl_RegisterObjType(typePtr) |
---|
242 | Tcl_ObjType *typePtr; /* Information about object type; |
---|
243 | * storage must be statically |
---|
244 | * allocated (must live forever). */ |
---|
245 | { |
---|
246 | register Tcl_HashEntry *hPtr; |
---|
247 | int new; |
---|
248 | |
---|
249 | if (!typeTableInitialized) { |
---|
250 | InitTypeTable(); |
---|
251 | } |
---|
252 | |
---|
253 | /* |
---|
254 | * If there's already an object type with the given name, remove it. |
---|
255 | */ |
---|
256 | |
---|
257 | hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); |
---|
258 | if (hPtr != (Tcl_HashEntry *) NULL) { |
---|
259 | Tcl_DeleteHashEntry(hPtr); |
---|
260 | } |
---|
261 | |
---|
262 | /* |
---|
263 | * Now insert the new object type. |
---|
264 | */ |
---|
265 | |
---|
266 | hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); |
---|
267 | if (new) { |
---|
268 | Tcl_SetHashValue(hPtr, typePtr); |
---|
269 | } |
---|
270 | } |
---|
271 | |
---|
272 | /* |
---|
273 | *---------------------------------------------------------------------- |
---|
274 | * |
---|
275 | * Tcl_AppendAllObjTypes -- |
---|
276 | * |
---|
277 | * This procedure appends onto the argument object the name of each |
---|
278 | * object type as a list element. This includes the builtin object |
---|
279 | * types (e.g. int, list) as well as those added using |
---|
280 | * Tcl_CreateObjType. These names can be used, for example, with |
---|
281 | * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType |
---|
282 | * structures. |
---|
283 | * |
---|
284 | * Results: |
---|
285 | * The return value is normally TCL_OK; in this case the object |
---|
286 | * referenced by objPtr has each type name appended to it. If an |
---|
287 | * error occurs, TCL_ERROR is returned and the interpreter's result |
---|
288 | * holds an error message. |
---|
289 | * |
---|
290 | * Side effects: |
---|
291 | * If necessary, the object referenced by objPtr is converted into |
---|
292 | * a list object. |
---|
293 | * |
---|
294 | *---------------------------------------------------------------------- |
---|
295 | */ |
---|
296 | |
---|
297 | int |
---|
298 | Tcl_AppendAllObjTypes(interp, objPtr) |
---|
299 | Tcl_Interp *interp; /* Interpreter used for error reporting. */ |
---|
300 | Tcl_Obj *objPtr; /* Points to the Tcl object onto which the |
---|
301 | * name of each registered type is appended |
---|
302 | * as a list element. */ |
---|
303 | { |
---|
304 | register Tcl_HashEntry *hPtr; |
---|
305 | Tcl_HashSearch search; |
---|
306 | Tcl_ObjType *typePtr; |
---|
307 | int result; |
---|
308 | |
---|
309 | if (!typeTableInitialized) { |
---|
310 | InitTypeTable(); |
---|
311 | } |
---|
312 | |
---|
313 | /* |
---|
314 | * This code assumes that types names do not contain embedded NULLs. |
---|
315 | */ |
---|
316 | |
---|
317 | for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); |
---|
318 | hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { |
---|
319 | typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); |
---|
320 | result = Tcl_ListObjAppendElement(interp, objPtr, |
---|
321 | Tcl_NewStringObj(typePtr->name, -1)); |
---|
322 | if (result == TCL_ERROR) { |
---|
323 | return result; |
---|
324 | } |
---|
325 | } |
---|
326 | return TCL_OK; |
---|
327 | } |
---|
328 | |
---|
329 | /* |
---|
330 | *---------------------------------------------------------------------- |
---|
331 | * |
---|
332 | * Tcl_GetObjType -- |
---|
333 | * |
---|
334 | * This procedure looks up an object type by name. |
---|
335 | * |
---|
336 | * Results: |
---|
337 | * If an object type with name matching "typeName" is found, a pointer |
---|
338 | * to its Tcl_ObjType structure is returned; otherwise, NULL is |
---|
339 | * returned. |
---|
340 | * |
---|
341 | * Side effects: |
---|
342 | * None. |
---|
343 | * |
---|
344 | *---------------------------------------------------------------------- |
---|
345 | */ |
---|
346 | |
---|
347 | Tcl_ObjType * |
---|
348 | Tcl_GetObjType(typeName) |
---|
349 | char *typeName; /* Name of Tcl object type to look up. */ |
---|
350 | { |
---|
351 | register Tcl_HashEntry *hPtr; |
---|
352 | Tcl_ObjType *typePtr; |
---|
353 | |
---|
354 | if (!typeTableInitialized) { |
---|
355 | InitTypeTable(); |
---|
356 | } |
---|
357 | |
---|
358 | hPtr = Tcl_FindHashEntry(&typeTable, typeName); |
---|
359 | if (hPtr != (Tcl_HashEntry *) NULL) { |
---|
360 | typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); |
---|
361 | return typePtr; |
---|
362 | } |
---|
363 | return NULL; |
---|
364 | } |
---|
365 | |
---|
366 | /* |
---|
367 | *---------------------------------------------------------------------- |
---|
368 | * |
---|
369 | * Tcl_ConvertToType -- |
---|
370 | * |
---|
371 | * Convert the Tcl object "objPtr" to have type "typePtr" if possible. |
---|
372 | * |
---|
373 | * Results: |
---|
374 | * The return value is TCL_OK on success and TCL_ERROR on failure. If |
---|
375 | * TCL_ERROR is returned, then the interpreter's result contains an |
---|
376 | * error message unless "interp" is NULL. Passing a NULL "interp" |
---|
377 | * allows this procedure to be used as a test whether the conversion |
---|
378 | * could be done (and in fact was done). |
---|
379 | * |
---|
380 | * Side effects: |
---|
381 | * Any internal representation for the old type is freed. |
---|
382 | * |
---|
383 | *---------------------------------------------------------------------- |
---|
384 | */ |
---|
385 | |
---|
386 | int |
---|
387 | Tcl_ConvertToType(interp, objPtr, typePtr) |
---|
388 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
389 | Tcl_Obj *objPtr; /* The object to convert. */ |
---|
390 | Tcl_ObjType *typePtr; /* The target type. */ |
---|
391 | { |
---|
392 | if (objPtr->typePtr == typePtr) { |
---|
393 | return TCL_OK; |
---|
394 | } |
---|
395 | |
---|
396 | /* |
---|
397 | * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal |
---|
398 | * form as appropriate for the target type. This frees the old internal |
---|
399 | * representation. |
---|
400 | */ |
---|
401 | |
---|
402 | return typePtr->setFromAnyProc(interp, objPtr); |
---|
403 | } |
---|
404 | |
---|
405 | /* |
---|
406 | *---------------------------------------------------------------------- |
---|
407 | * |
---|
408 | * Tcl_NewObj -- |
---|
409 | * |
---|
410 | * This procedure is normally called when not debugging: i.e., when |
---|
411 | * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote |
---|
412 | * the empty string. These objects have a NULL object type and NULL |
---|
413 | * string representation byte pointer. Type managers call this routine |
---|
414 | * to allocate new objects that they further initialize. |
---|
415 | * |
---|
416 | * When TCL_MEM_DEBUG is defined, this procedure just returns the |
---|
417 | * result of calling the debugging version Tcl_DbNewObj. |
---|
418 | * |
---|
419 | * Results: |
---|
420 | * The result is a newly allocated object that represents the empty |
---|
421 | * string. The new object's typePtr is set NULL and its ref count |
---|
422 | * is set to 0. |
---|
423 | * |
---|
424 | * Side effects: |
---|
425 | * If compiling with TCL_COMPILE_STATS, this procedure increments |
---|
426 | * the global count of allocated objects (tclObjsAlloced). |
---|
427 | * |
---|
428 | *---------------------------------------------------------------------- |
---|
429 | */ |
---|
430 | |
---|
431 | #ifdef TCL_MEM_DEBUG |
---|
432 | #undef Tcl_NewObj |
---|
433 | |
---|
434 | Tcl_Obj * |
---|
435 | Tcl_NewObj() |
---|
436 | { |
---|
437 | return Tcl_DbNewObj("unknown", 0); |
---|
438 | } |
---|
439 | |
---|
440 | #else /* if not TCL_MEM_DEBUG */ |
---|
441 | |
---|
442 | Tcl_Obj * |
---|
443 | Tcl_NewObj() |
---|
444 | { |
---|
445 | register Tcl_Obj *objPtr; |
---|
446 | |
---|
447 | /* |
---|
448 | * Allocate the object using the list of free Tcl_Objs we maintain. |
---|
449 | */ |
---|
450 | |
---|
451 | if (tclFreeObjList == NULL) { |
---|
452 | TclAllocateFreeObjects(); |
---|
453 | } |
---|
454 | objPtr = tclFreeObjList; |
---|
455 | tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; |
---|
456 | |
---|
457 | objPtr->refCount = 0; |
---|
458 | objPtr->bytes = tclEmptyStringRep; |
---|
459 | objPtr->length = 0; |
---|
460 | objPtr->typePtr = NULL; |
---|
461 | #ifdef TCL_COMPILE_STATS |
---|
462 | tclObjsAlloced++; |
---|
463 | #endif /* TCL_COMPILE_STATS */ |
---|
464 | return objPtr; |
---|
465 | } |
---|
466 | #endif /* TCL_MEM_DEBUG */ |
---|
467 | |
---|
468 | /* |
---|
469 | *---------------------------------------------------------------------- |
---|
470 | * |
---|
471 | * Tcl_DbNewObj -- |
---|
472 | * |
---|
473 | * This procedure is normally called when debugging: i.e., when |
---|
474 | * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the |
---|
475 | * empty string. It is the same as the Tcl_NewObj procedure above |
---|
476 | * except that it calls Tcl_DbCkalloc directly with the file name and |
---|
477 | * line number from its caller. This simplifies debugging since then |
---|
478 | * the checkmem command will report the correct file name and line |
---|
479 | * number when reporting objects that haven't been freed. |
---|
480 | * |
---|
481 | * When TCL_MEM_DEBUG is not defined, this procedure just returns the |
---|
482 | * result of calling Tcl_NewObj. |
---|
483 | * |
---|
484 | * Results: |
---|
485 | * The result is a newly allocated that represents the empty string. |
---|
486 | * The new object's typePtr is set NULL and its ref count is set to 0. |
---|
487 | * |
---|
488 | * Side effects: |
---|
489 | * If compiling with TCL_COMPILE_STATS, this procedure increments |
---|
490 | * the global count of allocated objects (tclObjsAlloced). |
---|
491 | * |
---|
492 | *---------------------------------------------------------------------- |
---|
493 | */ |
---|
494 | |
---|
495 | #ifdef TCL_MEM_DEBUG |
---|
496 | |
---|
497 | Tcl_Obj * |
---|
498 | Tcl_DbNewObj(file, line) |
---|
499 | register char *file; /* The name of the source file calling this |
---|
500 | * procedure; used for debugging. */ |
---|
501 | register int line; /* Line number in the source file; used |
---|
502 | * for debugging. */ |
---|
503 | { |
---|
504 | register Tcl_Obj *objPtr; |
---|
505 | |
---|
506 | /* |
---|
507 | * If debugging Tcl's memory usage, allocate the object using ckalloc. |
---|
508 | * Otherwise, allocate it using the list of free Tcl_Objs we maintain. |
---|
509 | */ |
---|
510 | |
---|
511 | objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); |
---|
512 | objPtr->refCount = 0; |
---|
513 | objPtr->bytes = tclEmptyStringRep; |
---|
514 | objPtr->length = 0; |
---|
515 | objPtr->typePtr = NULL; |
---|
516 | #ifdef TCL_COMPILE_STATS |
---|
517 | tclObjsAlloced++; |
---|
518 | #endif /* TCL_COMPILE_STATS */ |
---|
519 | return objPtr; |
---|
520 | } |
---|
521 | |
---|
522 | #else /* if not TCL_MEM_DEBUG */ |
---|
523 | |
---|
524 | Tcl_Obj * |
---|
525 | Tcl_DbNewObj(file, line) |
---|
526 | char *file; /* The name of the source file calling this |
---|
527 | * procedure; used for debugging. */ |
---|
528 | int line; /* Line number in the source file; used |
---|
529 | * for debugging. */ |
---|
530 | { |
---|
531 | return Tcl_NewObj(); |
---|
532 | } |
---|
533 | #endif /* TCL_MEM_DEBUG */ |
---|
534 | |
---|
535 | /* |
---|
536 | *---------------------------------------------------------------------- |
---|
537 | * |
---|
538 | * TclAllocateFreeObjects -- |
---|
539 | * |
---|
540 | * Procedure to allocate a number of free Tcl_Objs. This is done using |
---|
541 | * a single ckalloc to reduce the overhead for Tcl_Obj allocation. |
---|
542 | * |
---|
543 | * Results: |
---|
544 | * None. |
---|
545 | * |
---|
546 | * Side effects: |
---|
547 | * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the |
---|
548 | * first of a number of free Tcl_Obj's linked together by their |
---|
549 | * internalRep.otherValuePtrs. |
---|
550 | * |
---|
551 | *---------------------------------------------------------------------- |
---|
552 | */ |
---|
553 | |
---|
554 | #define OBJS_TO_ALLOC_EACH_TIME 100 |
---|
555 | |
---|
556 | void |
---|
557 | TclAllocateFreeObjects() |
---|
558 | { |
---|
559 | Tcl_Obj tmp[2]; |
---|
560 | size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ |
---|
561 | ((int)(&(tmp[1])) - (int)(&(tmp[0]))); |
---|
562 | size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); |
---|
563 | char *basePtr; |
---|
564 | register Tcl_Obj *prevPtr, *objPtr; |
---|
565 | register int i; |
---|
566 | |
---|
567 | basePtr = (char *) ckalloc(bytesToAlloc); |
---|
568 | memset(basePtr, 0, bytesToAlloc); |
---|
569 | |
---|
570 | prevPtr = NULL; |
---|
571 | objPtr = (Tcl_Obj *) basePtr; |
---|
572 | for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { |
---|
573 | objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; |
---|
574 | prevPtr = objPtr; |
---|
575 | objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); |
---|
576 | } |
---|
577 | tclFreeObjList = prevPtr; |
---|
578 | } |
---|
579 | #undef OBJS_TO_ALLOC_EACH_TIME |
---|
580 | |
---|
581 | /* |
---|
582 | *---------------------------------------------------------------------- |
---|
583 | * |
---|
584 | * TclFreeObj -- |
---|
585 | * |
---|
586 | * This procedure frees the memory associated with the argument |
---|
587 | * object. It is called by the tcl.h macro Tcl_DecrRefCount when an |
---|
588 | * object's ref count is zero. It is only "public" since it must |
---|
589 | * be callable by that macro wherever the macro is used. It should not |
---|
590 | * be directly called by clients. |
---|
591 | * |
---|
592 | * Results: |
---|
593 | * None. |
---|
594 | * |
---|
595 | * Side effects: |
---|
596 | * Deallocates the storage for the object's Tcl_Obj structure |
---|
597 | * after deallocating the string representation and calling the |
---|
598 | * type-specific Tcl_FreeInternalRepProc to deallocate the object's |
---|
599 | * internal representation. If compiling with TCL_COMPILE_STATS, |
---|
600 | * this procedure increments the global count of freed objects |
---|
601 | * (tclObjsFreed). |
---|
602 | * |
---|
603 | *---------------------------------------------------------------------- |
---|
604 | */ |
---|
605 | |
---|
606 | void |
---|
607 | TclFreeObj(objPtr) |
---|
608 | register Tcl_Obj *objPtr; /* The object to be freed. */ |
---|
609 | { |
---|
610 | register Tcl_ObjType *typePtr = objPtr->typePtr; |
---|
611 | |
---|
612 | #ifdef TCL_MEM_DEBUG |
---|
613 | if ((objPtr)->refCount < -1) { |
---|
614 | panic("Reference count for %lx was negative", objPtr); |
---|
615 | } |
---|
616 | #endif /* TCL_MEM_DEBUG */ |
---|
617 | |
---|
618 | Tcl_InvalidateStringRep(objPtr); |
---|
619 | if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { |
---|
620 | typePtr->freeIntRepProc(objPtr); |
---|
621 | } |
---|
622 | |
---|
623 | /* |
---|
624 | * If debugging Tcl's memory usage, deallocate the object using ckfree. |
---|
625 | * Otherwise, deallocate it by adding it onto the list of free |
---|
626 | * Tcl_Objs we maintain. |
---|
627 | */ |
---|
628 | |
---|
629 | #ifdef TCL_MEM_DEBUG |
---|
630 | ckfree((char *) objPtr); |
---|
631 | #else |
---|
632 | objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; |
---|
633 | tclFreeObjList = objPtr; |
---|
634 | #endif /* TCL_MEM_DEBUG */ |
---|
635 | |
---|
636 | #ifdef TCL_COMPILE_STATS |
---|
637 | tclObjsFreed++; |
---|
638 | #endif /* TCL_COMPILE_STATS */ |
---|
639 | } |
---|
640 | |
---|
641 | /* |
---|
642 | *---------------------------------------------------------------------- |
---|
643 | * |
---|
644 | * Tcl_DuplicateObj -- |
---|
645 | * |
---|
646 | * Create and return a new object that is a duplicate of the argument |
---|
647 | * object. |
---|
648 | * |
---|
649 | * Results: |
---|
650 | * The return value is a pointer to a newly created Tcl_Obj. This |
---|
651 | * object has reference count 0 and the same type, if any, as the |
---|
652 | * source object objPtr. Also: |
---|
653 | * 1) If the source object has a valid string rep, we copy it; |
---|
654 | * otherwise, the duplicate's string rep is set NULL to mark |
---|
655 | * it invalid. |
---|
656 | * 2) If the source object has an internal representation (i.e. its |
---|
657 | * typePtr is non-NULL), the new object's internal rep is set to |
---|
658 | * a copy; otherwise the new internal rep is marked invalid. |
---|
659 | * |
---|
660 | * Side effects: |
---|
661 | * What constitutes "copying" the internal representation depends on |
---|
662 | * the type. For example, if the argument object is a list, |
---|
663 | * the element objects it points to will not actually be copied but |
---|
664 | * will be shared with the duplicate list. That is, the ref counts of |
---|
665 | * the element objects will be incremented. |
---|
666 | * |
---|
667 | *---------------------------------------------------------------------- |
---|
668 | */ |
---|
669 | |
---|
670 | Tcl_Obj * |
---|
671 | Tcl_DuplicateObj(objPtr) |
---|
672 | register Tcl_Obj *objPtr; /* The object to duplicate. */ |
---|
673 | { |
---|
674 | register Tcl_ObjType *typePtr = objPtr->typePtr; |
---|
675 | register Tcl_Obj *dupPtr; |
---|
676 | |
---|
677 | TclNewObj(dupPtr); |
---|
678 | |
---|
679 | if (objPtr->bytes == NULL) { |
---|
680 | dupPtr->bytes = NULL; |
---|
681 | } else if (objPtr->bytes != tclEmptyStringRep) { |
---|
682 | int len = objPtr->length; |
---|
683 | |
---|
684 | dupPtr->bytes = (char *) ckalloc((unsigned) len+1); |
---|
685 | if (len > 0) { |
---|
686 | memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, |
---|
687 | (unsigned) len); |
---|
688 | } |
---|
689 | dupPtr->bytes[len] = '\0'; |
---|
690 | dupPtr->length = len; |
---|
691 | } |
---|
692 | |
---|
693 | if (typePtr != NULL) { |
---|
694 | typePtr->dupIntRepProc(objPtr, dupPtr); |
---|
695 | } |
---|
696 | return dupPtr; |
---|
697 | } |
---|
698 | |
---|
699 | /* |
---|
700 | *---------------------------------------------------------------------- |
---|
701 | * |
---|
702 | * Tcl_GetStringFromObj -- |
---|
703 | * |
---|
704 | * Returns the string representation's byte array pointer and length |
---|
705 | * for an object. |
---|
706 | * |
---|
707 | * Results: |
---|
708 | * Returns a pointer to the string representation of objPtr. If |
---|
709 | * lengthPtr isn't NULL, the length of the string representation is |
---|
710 | * stored at *lengthPtr. The byte array referenced by the returned |
---|
711 | * pointer must not be modified by the caller. Furthermore, the |
---|
712 | * caller must copy the bytes if they need to retain them since the |
---|
713 | * object's string rep can change as a result of other operations. |
---|
714 | * |
---|
715 | * Side effects: |
---|
716 | * May call the object's updateStringProc to update the string |
---|
717 | * representation from the internal representation. |
---|
718 | * |
---|
719 | *---------------------------------------------------------------------- |
---|
720 | */ |
---|
721 | |
---|
722 | char * |
---|
723 | Tcl_GetStringFromObj(objPtr, lengthPtr) |
---|
724 | register Tcl_Obj *objPtr; /* Object whose string rep byte pointer |
---|
725 | * should be returned. */ |
---|
726 | register int *lengthPtr; /* If non-NULL, the location where the |
---|
727 | * string rep's byte array length should be |
---|
728 | * stored. If NULL, no length is stored. */ |
---|
729 | { |
---|
730 | if (objPtr->bytes != NULL) { |
---|
731 | if (lengthPtr != NULL) { |
---|
732 | *lengthPtr = objPtr->length; |
---|
733 | } |
---|
734 | return objPtr->bytes; |
---|
735 | } |
---|
736 | |
---|
737 | objPtr->typePtr->updateStringProc(objPtr); |
---|
738 | if (lengthPtr != NULL) { |
---|
739 | *lengthPtr = objPtr->length; |
---|
740 | } |
---|
741 | return objPtr->bytes; |
---|
742 | } |
---|
743 | |
---|
744 | /* |
---|
745 | *---------------------------------------------------------------------- |
---|
746 | * |
---|
747 | * Tcl_InvalidateStringRep -- |
---|
748 | * |
---|
749 | * This procedure is called to invalidate an object's string |
---|
750 | * representation. |
---|
751 | * |
---|
752 | * Results: |
---|
753 | * None. |
---|
754 | * |
---|
755 | * Side effects: |
---|
756 | * Deallocates the storage for any old string representation, then |
---|
757 | * sets the string representation NULL to mark it invalid. |
---|
758 | * |
---|
759 | *---------------------------------------------------------------------- |
---|
760 | */ |
---|
761 | |
---|
762 | void |
---|
763 | Tcl_InvalidateStringRep(objPtr) |
---|
764 | register Tcl_Obj *objPtr; /* Object whose string rep byte pointer |
---|
765 | * should be freed. */ |
---|
766 | { |
---|
767 | if (objPtr->bytes != NULL) { |
---|
768 | if (objPtr->bytes != tclEmptyStringRep) { |
---|
769 | ckfree((char *) objPtr->bytes); |
---|
770 | } |
---|
771 | objPtr->bytes = NULL; |
---|
772 | } |
---|
773 | } |
---|
774 | |
---|
775 | /* |
---|
776 | *---------------------------------------------------------------------- |
---|
777 | * |
---|
778 | * Tcl_NewBooleanObj -- |
---|
779 | * |
---|
780 | * This procedure is normally called when not debugging: i.e., when |
---|
781 | * TCL_MEM_DEBUG is not defined. It creates a new boolean object and |
---|
782 | * initializes it from the argument boolean value. A nonzero |
---|
783 | * "boolValue" is coerced to 1. |
---|
784 | * |
---|
785 | * When TCL_MEM_DEBUG is defined, this procedure just returns the |
---|
786 | * result of calling the debugging version Tcl_DbNewBooleanObj. |
---|
787 | * |
---|
788 | * Results: |
---|
789 | * The newly created object is returned. This object will have an |
---|
790 | * invalid string representation. The returned object has ref count 0. |
---|
791 | * |
---|
792 | * Side effects: |
---|
793 | * None. |
---|
794 | * |
---|
795 | *---------------------------------------------------------------------- |
---|
796 | */ |
---|
797 | |
---|
798 | #ifdef TCL_MEM_DEBUG |
---|
799 | #undef Tcl_NewBooleanObj |
---|
800 | |
---|
801 | Tcl_Obj * |
---|
802 | Tcl_NewBooleanObj(boolValue) |
---|
803 | register int boolValue; /* Boolean used to initialize new object. */ |
---|
804 | { |
---|
805 | return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); |
---|
806 | } |
---|
807 | |
---|
808 | #else /* if not TCL_MEM_DEBUG */ |
---|
809 | |
---|
810 | Tcl_Obj * |
---|
811 | Tcl_NewBooleanObj(boolValue) |
---|
812 | register int boolValue; /* Boolean used to initialize new object. */ |
---|
813 | { |
---|
814 | register Tcl_Obj *objPtr; |
---|
815 | |
---|
816 | TclNewObj(objPtr); |
---|
817 | objPtr->bytes = NULL; |
---|
818 | |
---|
819 | objPtr->internalRep.longValue = (boolValue? 1 : 0); |
---|
820 | objPtr->typePtr = &tclBooleanType; |
---|
821 | return objPtr; |
---|
822 | } |
---|
823 | #endif /* TCL_MEM_DEBUG */ |
---|
824 | |
---|
825 | /* |
---|
826 | *---------------------------------------------------------------------- |
---|
827 | * |
---|
828 | * Tcl_DbNewBooleanObj -- |
---|
829 | * |
---|
830 | * This procedure is normally called when debugging: i.e., when |
---|
831 | * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the |
---|
832 | * same as the Tcl_NewBooleanObj procedure above except that it calls |
---|
833 | * Tcl_DbCkalloc directly with the file name and line number from its |
---|
834 | * caller. This simplifies debugging since then the checkmem command |
---|
835 | * will report the correct file name and line number when reporting |
---|
836 | * objects that haven't been freed. |
---|
837 | * |
---|
838 | * When TCL_MEM_DEBUG is not defined, this procedure just returns the |
---|
839 | * result of calling Tcl_NewBooleanObj. |
---|
840 | * |
---|
841 | * Results: |
---|
842 | * The newly created object is returned. This object will have an |
---|
843 | * invalid string representation. The returned object has ref count 0. |
---|
844 | * |
---|
845 | * Side effects: |
---|
846 | * None. |
---|
847 | * |
---|
848 | *---------------------------------------------------------------------- |
---|
849 | */ |
---|
850 | |
---|
851 | #ifdef TCL_MEM_DEBUG |
---|
852 | |
---|
853 | Tcl_Obj * |
---|
854 | Tcl_DbNewBooleanObj(boolValue, file, line) |
---|
855 | register int boolValue; /* Boolean used to initialize new object. */ |
---|
856 | char *file; /* The name of the source file calling this |
---|
857 | * procedure; used for debugging. */ |
---|
858 | int line; /* Line number in the source file; used |
---|
859 | * for debugging. */ |
---|
860 | { |
---|
861 | register Tcl_Obj *objPtr; |
---|
862 | |
---|
863 | TclDbNewObj(objPtr, file, line); |
---|
864 | objPtr->bytes = NULL; |
---|
865 | |
---|
866 | objPtr->internalRep.longValue = (boolValue? 1 : 0); |
---|
867 | objPtr->typePtr = &tclBooleanType; |
---|
868 | return objPtr; |
---|
869 | } |
---|
870 | |
---|
871 | #else /* if not TCL_MEM_DEBUG */ |
---|
872 | |
---|
873 | Tcl_Obj * |
---|
874 | Tcl_DbNewBooleanObj(boolValue, file, line) |
---|
875 | register int boolValue; /* Boolean used to initialize new object. */ |
---|
876 | char *file; /* The name of the source file calling this |
---|
877 | * procedure; used for debugging. */ |
---|
878 | int line; /* Line number in the source file; used |
---|
879 | * for debugging. */ |
---|
880 | { |
---|
881 | return Tcl_NewBooleanObj(boolValue); |
---|
882 | } |
---|
883 | #endif /* TCL_MEM_DEBUG */ |
---|
884 | |
---|
885 | /* |
---|
886 | *---------------------------------------------------------------------- |
---|
887 | * |
---|
888 | * Tcl_SetBooleanObj -- |
---|
889 | * |
---|
890 | * Modify an object to be a boolean object and to have the specified |
---|
891 | * boolean value. A nonzero "boolValue" is coerced to 1. |
---|
892 | * |
---|
893 | * Results: |
---|
894 | * None. |
---|
895 | * |
---|
896 | * Side effects: |
---|
897 | * The object's old string rep, if any, is freed. Also, any old |
---|
898 | * internal rep is freed. |
---|
899 | * |
---|
900 | *---------------------------------------------------------------------- |
---|
901 | */ |
---|
902 | |
---|
903 | void |
---|
904 | Tcl_SetBooleanObj(objPtr, boolValue) |
---|
905 | register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ |
---|
906 | register int boolValue; /* Boolean used to set object's value. */ |
---|
907 | { |
---|
908 | register Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
909 | |
---|
910 | if (Tcl_IsShared(objPtr)) { |
---|
911 | panic("Tcl_SetBooleanObj called with shared object"); |
---|
912 | } |
---|
913 | |
---|
914 | Tcl_InvalidateStringRep(objPtr); |
---|
915 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
916 | oldTypePtr->freeIntRepProc(objPtr); |
---|
917 | } |
---|
918 | |
---|
919 | objPtr->internalRep.longValue = (boolValue? 1 : 0); |
---|
920 | objPtr->typePtr = &tclBooleanType; |
---|
921 | } |
---|
922 | |
---|
923 | /* |
---|
924 | *---------------------------------------------------------------------- |
---|
925 | * |
---|
926 | * Tcl_GetBooleanFromObj -- |
---|
927 | * |
---|
928 | * Attempt to return a boolean from the Tcl object "objPtr". If the |
---|
929 | * object is not already a boolean, an attempt will be made to convert |
---|
930 | * it to one. |
---|
931 | * |
---|
932 | * Results: |
---|
933 | * The return value is a standard Tcl object result. If an error occurs |
---|
934 | * during conversion, an error message is left in the interpreter's |
---|
935 | * result unless "interp" is NULL. |
---|
936 | * |
---|
937 | * Side effects: |
---|
938 | * If the object is not already a boolean, the conversion will free |
---|
939 | * any old internal representation. |
---|
940 | * |
---|
941 | *---------------------------------------------------------------------- |
---|
942 | */ |
---|
943 | |
---|
944 | int |
---|
945 | Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) |
---|
946 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
947 | register Tcl_Obj *objPtr; /* The object from which to get boolean. */ |
---|
948 | register int *boolPtr; /* Place to store resulting boolean. */ |
---|
949 | { |
---|
950 | register int result; |
---|
951 | |
---|
952 | result = SetBooleanFromAny(interp, objPtr); |
---|
953 | if (result == TCL_OK) { |
---|
954 | *boolPtr = (int) objPtr->internalRep.longValue; |
---|
955 | } |
---|
956 | return result; |
---|
957 | } |
---|
958 | |
---|
959 | /* |
---|
960 | *---------------------------------------------------------------------- |
---|
961 | * |
---|
962 | * DupBooleanInternalRep -- |
---|
963 | * |
---|
964 | * Initialize the internal representation of a boolean Tcl_Obj to a |
---|
965 | * copy of the internal representation of an existing boolean object. |
---|
966 | * |
---|
967 | * Results: |
---|
968 | * None. |
---|
969 | * |
---|
970 | * Side effects: |
---|
971 | * "copyPtr"s internal rep is set to the boolean (an integer) |
---|
972 | * corresponding to "srcPtr"s internal rep. |
---|
973 | * |
---|
974 | *---------------------------------------------------------------------- |
---|
975 | */ |
---|
976 | |
---|
977 | static void |
---|
978 | DupBooleanInternalRep(srcPtr, copyPtr) |
---|
979 | register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
---|
980 | register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
---|
981 | { |
---|
982 | copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; |
---|
983 | copyPtr->typePtr = &tclBooleanType; |
---|
984 | } |
---|
985 | |
---|
986 | /* |
---|
987 | *---------------------------------------------------------------------- |
---|
988 | * |
---|
989 | * SetBooleanFromAny -- |
---|
990 | * |
---|
991 | * Attempt to generate a boolean internal form for the Tcl object |
---|
992 | * "objPtr". |
---|
993 | * |
---|
994 | * Results: |
---|
995 | * The return value is a standard Tcl result. If an error occurs during |
---|
996 | * conversion, an error message is left in the interpreter's result |
---|
997 | * unless "interp" is NULL. |
---|
998 | * |
---|
999 | * Side effects: |
---|
1000 | * If no error occurs, an integer 1 or 0 is stored as "objPtr"s |
---|
1001 | * internal representation and the type of "objPtr" is set to boolean. |
---|
1002 | * |
---|
1003 | *---------------------------------------------------------------------- |
---|
1004 | */ |
---|
1005 | |
---|
1006 | static int |
---|
1007 | SetBooleanFromAny(interp, objPtr) |
---|
1008 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
1009 | register Tcl_Obj *objPtr; /* The object to convert. */ |
---|
1010 | { |
---|
1011 | Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
1012 | char *string, *end; |
---|
1013 | register char c; |
---|
1014 | char lowerCase[10]; |
---|
1015 | int newBool, length; |
---|
1016 | register int i; |
---|
1017 | double dbl; |
---|
1018 | |
---|
1019 | /* |
---|
1020 | * Get the string representation. Make it up-to-date if necessary. |
---|
1021 | */ |
---|
1022 | |
---|
1023 | string = TclGetStringFromObj(objPtr, &length); |
---|
1024 | |
---|
1025 | /* |
---|
1026 | * Copy the string converting its characters to lower case. |
---|
1027 | */ |
---|
1028 | |
---|
1029 | for (i = 0; (i < 9) && (i < length); i++) { |
---|
1030 | c = string[i]; |
---|
1031 | if (isupper(UCHAR(c))) { |
---|
1032 | c = (char) tolower(UCHAR(c)); |
---|
1033 | } |
---|
1034 | lowerCase[i] = c; |
---|
1035 | } |
---|
1036 | lowerCase[i] = 0; |
---|
1037 | |
---|
1038 | /* |
---|
1039 | * Parse the string as a boolean. We use an implementation here that |
---|
1040 | * doesn't report errors in interp if interp is NULL. |
---|
1041 | */ |
---|
1042 | |
---|
1043 | c = lowerCase[0]; |
---|
1044 | if ((c == '0') && (lowerCase[1] == '\0')) { |
---|
1045 | newBool = 0; |
---|
1046 | } else if ((c == '1') && (lowerCase[1] == '\0')) { |
---|
1047 | newBool = 1; |
---|
1048 | } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { |
---|
1049 | newBool = 1; |
---|
1050 | } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { |
---|
1051 | newBool = 0; |
---|
1052 | } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { |
---|
1053 | newBool = 1; |
---|
1054 | } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { |
---|
1055 | newBool = 0; |
---|
1056 | } else if ((c == 'o') && (length >= 2)) { |
---|
1057 | if (strncmp(lowerCase, "on", (size_t) length) == 0) { |
---|
1058 | newBool = 1; |
---|
1059 | } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { |
---|
1060 | newBool = 0; |
---|
1061 | } else { |
---|
1062 | goto badBoolean; |
---|
1063 | } |
---|
1064 | } else { |
---|
1065 | /* |
---|
1066 | * Still might be a string containing the characters representing an |
---|
1067 | * int or double that wasn't handled above. This would be a string |
---|
1068 | * like "27" or "1.0" that is non-zero and not "1". Such a string |
---|
1069 | * whould result in the boolean value true. We try converting to |
---|
1070 | * double. If that succeeds and the resulting double is non-zero, we |
---|
1071 | * have a "true". Note that numbers can't have embedded NULLs. |
---|
1072 | */ |
---|
1073 | |
---|
1074 | dbl = strtod(string, &end); |
---|
1075 | if (end == string) { |
---|
1076 | goto badBoolean; |
---|
1077 | } |
---|
1078 | |
---|
1079 | /* |
---|
1080 | * Make sure the string has no garbage after the end of the double. |
---|
1081 | */ |
---|
1082 | |
---|
1083 | while ((end < (string+length)) && isspace(UCHAR(*end))) { |
---|
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 | Tcl_InvalidateStringRep(objPtr); |
---|
1291 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
1292 | oldTypePtr->freeIntRepProc(objPtr); |
---|
1293 | } |
---|
1294 | |
---|
1295 | objPtr->internalRep.doubleValue = dblValue; |
---|
1296 | objPtr->typePtr = &tclDoubleType; |
---|
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 | * DupDoubleInternalRep -- |
---|
1344 | * |
---|
1345 | * Initialize the internal representation of a double Tcl_Obj to a |
---|
1346 | * copy of the internal representation of an existing double object. |
---|
1347 | * |
---|
1348 | * Results: |
---|
1349 | * None. |
---|
1350 | * |
---|
1351 | * Side effects: |
---|
1352 | * "copyPtr"s internal rep is set to the double precision floating |
---|
1353 | * point number corresponding to "srcPtr"s internal rep. |
---|
1354 | * |
---|
1355 | *---------------------------------------------------------------------- |
---|
1356 | */ |
---|
1357 | |
---|
1358 | static void |
---|
1359 | DupDoubleInternalRep(srcPtr, copyPtr) |
---|
1360 | register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
---|
1361 | register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
---|
1362 | { |
---|
1363 | copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue; |
---|
1364 | copyPtr->typePtr = &tclDoubleType; |
---|
1365 | } |
---|
1366 | |
---|
1367 | /* |
---|
1368 | *---------------------------------------------------------------------- |
---|
1369 | * |
---|
1370 | * SetDoubleFromAny -- |
---|
1371 | * |
---|
1372 | * Attempt to generate an double-precision floating point internal form |
---|
1373 | * for the Tcl object "objPtr". |
---|
1374 | * |
---|
1375 | * Results: |
---|
1376 | * The return value is a standard Tcl object result. If an error occurs |
---|
1377 | * during conversion, an error message is left in the interpreter's |
---|
1378 | * result unless "interp" is NULL. |
---|
1379 | * |
---|
1380 | * Side effects: |
---|
1381 | * If no error occurs, a double is stored as "objPtr"s internal |
---|
1382 | * representation. |
---|
1383 | * |
---|
1384 | *---------------------------------------------------------------------- |
---|
1385 | */ |
---|
1386 | |
---|
1387 | static int |
---|
1388 | SetDoubleFromAny(interp, objPtr) |
---|
1389 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
1390 | register Tcl_Obj *objPtr; /* The object to convert. */ |
---|
1391 | { |
---|
1392 | Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
1393 | char *string, *end; |
---|
1394 | double newDouble; |
---|
1395 | int length; |
---|
1396 | |
---|
1397 | /* |
---|
1398 | * Get the string representation. Make it up-to-date if necessary. |
---|
1399 | */ |
---|
1400 | |
---|
1401 | string = TclGetStringFromObj(objPtr, &length); |
---|
1402 | |
---|
1403 | /* |
---|
1404 | * Now parse "objPtr"s string as an double. Numbers can't have embedded |
---|
1405 | * NULLs. We use an implementation here that doesn't report errors in |
---|
1406 | * interp if interp is NULL. |
---|
1407 | */ |
---|
1408 | |
---|
1409 | errno = 0; |
---|
1410 | newDouble = strtod(string, &end); |
---|
1411 | if (end == string) { |
---|
1412 | badDouble: |
---|
1413 | if (interp != NULL) { |
---|
1414 | /* |
---|
1415 | * Must copy string before resetting the result in case a caller |
---|
1416 | * is trying to convert the interpreter's result to an int. |
---|
1417 | */ |
---|
1418 | |
---|
1419 | char buf[100]; |
---|
1420 | sprintf(buf, "expected floating-point number but got \"%.50s\"", |
---|
1421 | string); |
---|
1422 | Tcl_ResetResult(interp); |
---|
1423 | Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); |
---|
1424 | } |
---|
1425 | return TCL_ERROR; |
---|
1426 | } |
---|
1427 | if (errno != 0) { |
---|
1428 | if (interp != NULL) { |
---|
1429 | TclExprFloatError(interp, newDouble); |
---|
1430 | } |
---|
1431 | return TCL_ERROR; |
---|
1432 | } |
---|
1433 | |
---|
1434 | /* |
---|
1435 | * Make sure that the string has no garbage after the end of the double. |
---|
1436 | */ |
---|
1437 | |
---|
1438 | while ((end < (string+length)) && isspace(UCHAR(*end))) { |
---|
1439 | end++; |
---|
1440 | } |
---|
1441 | if (end != (string+length)) { |
---|
1442 | goto badDouble; |
---|
1443 | } |
---|
1444 | |
---|
1445 | /* |
---|
1446 | * The conversion to double succeeded. Free the old internalRep before |
---|
1447 | * setting the new one. We do this as late as possible to allow the |
---|
1448 | * conversion code, in particular Tcl_GetStringFromObj, to use that old |
---|
1449 | * internalRep. |
---|
1450 | */ |
---|
1451 | |
---|
1452 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
1453 | oldTypePtr->freeIntRepProc(objPtr); |
---|
1454 | } |
---|
1455 | |
---|
1456 | objPtr->internalRep.doubleValue = newDouble; |
---|
1457 | objPtr->typePtr = &tclDoubleType; |
---|
1458 | return TCL_OK; |
---|
1459 | } |
---|
1460 | |
---|
1461 | /* |
---|
1462 | *---------------------------------------------------------------------- |
---|
1463 | * |
---|
1464 | * UpdateStringOfDouble -- |
---|
1465 | * |
---|
1466 | * Update the string representation for a double-precision floating |
---|
1467 | * point object. This must obey the current tcl_precision value for |
---|
1468 | * double-to-string conversions. Note: This procedure does not free an |
---|
1469 | * existing old string rep so storage will be lost if this has not |
---|
1470 | * already been done. |
---|
1471 | * |
---|
1472 | * Results: |
---|
1473 | * None. |
---|
1474 | * |
---|
1475 | * Side effects: |
---|
1476 | * The object's string is set to a valid string that results from |
---|
1477 | * the double-to-string conversion. |
---|
1478 | * |
---|
1479 | *---------------------------------------------------------------------- |
---|
1480 | */ |
---|
1481 | |
---|
1482 | static void |
---|
1483 | UpdateStringOfDouble(objPtr) |
---|
1484 | register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ |
---|
1485 | { |
---|
1486 | char buffer[TCL_DOUBLE_SPACE]; |
---|
1487 | register int len; |
---|
1488 | |
---|
1489 | Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, |
---|
1490 | buffer); |
---|
1491 | len = strlen(buffer); |
---|
1492 | |
---|
1493 | objPtr->bytes = (char *) ckalloc((unsigned) len + 1); |
---|
1494 | strcpy(objPtr->bytes, buffer); |
---|
1495 | objPtr->length = len; |
---|
1496 | } |
---|
1497 | |
---|
1498 | /* |
---|
1499 | *---------------------------------------------------------------------- |
---|
1500 | * |
---|
1501 | * Tcl_NewIntObj -- |
---|
1502 | * |
---|
1503 | * If a client is compiled with TCL_MEM_DEBUG defined, calls to |
---|
1504 | * Tcl_NewIntObj to create a new integer object end up calling the |
---|
1505 | * debugging procedure Tcl_DbNewLongObj instead. |
---|
1506 | * |
---|
1507 | * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, |
---|
1508 | * calls to Tcl_NewIntObj result in a call to one of the two |
---|
1509 | * Tcl_NewIntObj implementations below. We provide two implementations |
---|
1510 | * so that the Tcl core can be compiled to do memory debugging of the |
---|
1511 | * core even if a client does not request it for itself. |
---|
1512 | * |
---|
1513 | * Integer and long integer objects share the same "integer" type |
---|
1514 | * implementation. We store all integers as longs and Tcl_GetIntFromObj |
---|
1515 | * checks whether the current value of the long can be represented by |
---|
1516 | * an int. |
---|
1517 | * |
---|
1518 | * Results: |
---|
1519 | * The newly created object is returned. This object will have an |
---|
1520 | * invalid string representation. The returned object has ref count 0. |
---|
1521 | * |
---|
1522 | * Side effects: |
---|
1523 | * None. |
---|
1524 | * |
---|
1525 | *---------------------------------------------------------------------- |
---|
1526 | */ |
---|
1527 | |
---|
1528 | #ifdef TCL_MEM_DEBUG |
---|
1529 | #undef Tcl_NewIntObj |
---|
1530 | |
---|
1531 | Tcl_Obj * |
---|
1532 | Tcl_NewIntObj(intValue) |
---|
1533 | register int intValue; /* Int used to initialize the new object. */ |
---|
1534 | { |
---|
1535 | return Tcl_DbNewLongObj((long)intValue, "unknown", 0); |
---|
1536 | } |
---|
1537 | |
---|
1538 | #else /* if not TCL_MEM_DEBUG */ |
---|
1539 | |
---|
1540 | Tcl_Obj * |
---|
1541 | Tcl_NewIntObj(intValue) |
---|
1542 | register int intValue; /* Int used to initialize the new object. */ |
---|
1543 | { |
---|
1544 | register Tcl_Obj *objPtr; |
---|
1545 | |
---|
1546 | TclNewObj(objPtr); |
---|
1547 | objPtr->bytes = NULL; |
---|
1548 | |
---|
1549 | objPtr->internalRep.longValue = (long)intValue; |
---|
1550 | objPtr->typePtr = &tclIntType; |
---|
1551 | return objPtr; |
---|
1552 | } |
---|
1553 | #endif /* if TCL_MEM_DEBUG */ |
---|
1554 | |
---|
1555 | /* |
---|
1556 | *---------------------------------------------------------------------- |
---|
1557 | * |
---|
1558 | * Tcl_SetIntObj -- |
---|
1559 | * |
---|
1560 | * Modify an object to be an integer and to have the specified integer |
---|
1561 | * value. |
---|
1562 | * |
---|
1563 | * Results: |
---|
1564 | * None. |
---|
1565 | * |
---|
1566 | * Side effects: |
---|
1567 | * The object's old string rep, if any, is freed. Also, any old |
---|
1568 | * internal rep is freed. |
---|
1569 | * |
---|
1570 | *---------------------------------------------------------------------- |
---|
1571 | */ |
---|
1572 | |
---|
1573 | void |
---|
1574 | Tcl_SetIntObj(objPtr, intValue) |
---|
1575 | register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ |
---|
1576 | register int intValue; /* Integer used to set object's value. */ |
---|
1577 | { |
---|
1578 | register Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
1579 | |
---|
1580 | if (Tcl_IsShared(objPtr)) { |
---|
1581 | panic("Tcl_SetIntObj called with shared object"); |
---|
1582 | } |
---|
1583 | |
---|
1584 | Tcl_InvalidateStringRep(objPtr); |
---|
1585 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
1586 | oldTypePtr->freeIntRepProc(objPtr); |
---|
1587 | } |
---|
1588 | |
---|
1589 | objPtr->internalRep.longValue = (long) intValue; |
---|
1590 | objPtr->typePtr = &tclIntType; |
---|
1591 | } |
---|
1592 | |
---|
1593 | /* |
---|
1594 | *---------------------------------------------------------------------- |
---|
1595 | * |
---|
1596 | * Tcl_GetIntFromObj -- |
---|
1597 | * |
---|
1598 | * Attempt to return an int from the Tcl object "objPtr". If the object |
---|
1599 | * is not already an int, an attempt will be made to convert it to one. |
---|
1600 | * |
---|
1601 | * Integer and long integer objects share the same "integer" type |
---|
1602 | * implementation. We store all integers as longs and Tcl_GetIntFromObj |
---|
1603 | * checks whether the current value of the long can be represented by |
---|
1604 | * an int. |
---|
1605 | * |
---|
1606 | * Results: |
---|
1607 | * The return value is a standard Tcl object result. If an error occurs |
---|
1608 | * during conversion or if the long integer held by the object |
---|
1609 | * can not be represented by an int, an error message is left in |
---|
1610 | * the interpreter's result unless "interp" is NULL. |
---|
1611 | * |
---|
1612 | * Side effects: |
---|
1613 | * If the object is not already an int, the conversion will free |
---|
1614 | * any old internal representation. |
---|
1615 | * |
---|
1616 | *---------------------------------------------------------------------- |
---|
1617 | */ |
---|
1618 | |
---|
1619 | int |
---|
1620 | Tcl_GetIntFromObj(interp, objPtr, intPtr) |
---|
1621 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
1622 | register Tcl_Obj *objPtr; /* The object from which to get a int. */ |
---|
1623 | register int *intPtr; /* Place to store resulting int. */ |
---|
1624 | { |
---|
1625 | register long l; |
---|
1626 | int result; |
---|
1627 | |
---|
1628 | if (objPtr->typePtr != &tclIntType) { |
---|
1629 | result = SetIntFromAny(interp, objPtr); |
---|
1630 | if (result != TCL_OK) { |
---|
1631 | return result; |
---|
1632 | } |
---|
1633 | } |
---|
1634 | l = objPtr->internalRep.longValue; |
---|
1635 | if (((long)((int)l)) == l) { |
---|
1636 | *intPtr = (int)objPtr->internalRep.longValue; |
---|
1637 | return TCL_OK; |
---|
1638 | } |
---|
1639 | if (interp != NULL) { |
---|
1640 | Tcl_ResetResult(interp); |
---|
1641 | Tcl_AppendToObj(Tcl_GetObjResult(interp), |
---|
1642 | "integer value too large to represent as non-long integer", -1); |
---|
1643 | } |
---|
1644 | return TCL_ERROR; |
---|
1645 | } |
---|
1646 | |
---|
1647 | /* |
---|
1648 | *---------------------------------------------------------------------- |
---|
1649 | * |
---|
1650 | * DupIntInternalRep -- |
---|
1651 | * |
---|
1652 | * Initialize the internal representation of an int Tcl_Obj to a |
---|
1653 | * copy of the internal representation of an existing int object. |
---|
1654 | * |
---|
1655 | * Results: |
---|
1656 | * None. |
---|
1657 | * |
---|
1658 | * Side effects: |
---|
1659 | * "copyPtr"s internal rep is set to the integer corresponding to |
---|
1660 | * "srcPtr"s internal rep. |
---|
1661 | * |
---|
1662 | *---------------------------------------------------------------------- |
---|
1663 | */ |
---|
1664 | |
---|
1665 | static void |
---|
1666 | DupIntInternalRep(srcPtr, copyPtr) |
---|
1667 | register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
---|
1668 | register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
---|
1669 | { |
---|
1670 | copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; |
---|
1671 | copyPtr->typePtr = &tclIntType; |
---|
1672 | } |
---|
1673 | |
---|
1674 | /* |
---|
1675 | *---------------------------------------------------------------------- |
---|
1676 | * |
---|
1677 | * SetIntFromAny -- |
---|
1678 | * |
---|
1679 | * Attempt to generate an integer internal form for the Tcl object |
---|
1680 | * "objPtr". |
---|
1681 | * |
---|
1682 | * Results: |
---|
1683 | * The return value is a standard object Tcl result. If an error occurs |
---|
1684 | * during conversion, an error message is left in the interpreter's |
---|
1685 | * result unless "interp" is NULL. |
---|
1686 | * |
---|
1687 | * Side effects: |
---|
1688 | * If no error occurs, an int is stored as "objPtr"s internal |
---|
1689 | * representation. |
---|
1690 | * |
---|
1691 | *---------------------------------------------------------------------- |
---|
1692 | */ |
---|
1693 | |
---|
1694 | static int |
---|
1695 | SetIntFromAny(interp, objPtr) |
---|
1696 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
1697 | register Tcl_Obj *objPtr; /* The object to convert. */ |
---|
1698 | { |
---|
1699 | Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
1700 | char *string, *end; |
---|
1701 | int length; |
---|
1702 | register char *p; |
---|
1703 | long newLong; |
---|
1704 | |
---|
1705 | /* |
---|
1706 | * Get the string representation. Make it up-to-date if necessary. |
---|
1707 | */ |
---|
1708 | |
---|
1709 | string = TclGetStringFromObj(objPtr, &length); |
---|
1710 | |
---|
1711 | /* |
---|
1712 | * Now parse "objPtr"s string as an int. We use an implementation here |
---|
1713 | * that doesn't report errors in interp if interp is NULL. Note: use |
---|
1714 | * strtoul instead of strtol for integer conversions to allow full-size |
---|
1715 | * unsigned numbers, but don't depend on strtoul to handle sign |
---|
1716 | * characters; it won't in some implementations. |
---|
1717 | */ |
---|
1718 | |
---|
1719 | errno = 0; |
---|
1720 | for (p = string; isspace(UCHAR(*p)); p++) { |
---|
1721 | /* Empty loop body. */ |
---|
1722 | } |
---|
1723 | if (*p == '-') { |
---|
1724 | p++; |
---|
1725 | newLong = -((long)strtoul(p, &end, 0)); |
---|
1726 | } else if (*p == '+') { |
---|
1727 | p++; |
---|
1728 | newLong = strtoul(p, &end, 0); |
---|
1729 | } else { |
---|
1730 | newLong = strtoul(p, &end, 0); |
---|
1731 | } |
---|
1732 | if (end == p) { |
---|
1733 | badInteger: |
---|
1734 | if (interp != NULL) { |
---|
1735 | /* |
---|
1736 | * Must copy string before resetting the result in case a caller |
---|
1737 | * is trying to convert the interpreter's result to an int. |
---|
1738 | */ |
---|
1739 | |
---|
1740 | char buf[100]; |
---|
1741 | sprintf(buf, "expected integer but got \"%.50s\"", string); |
---|
1742 | Tcl_ResetResult(interp); |
---|
1743 | Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); |
---|
1744 | } |
---|
1745 | return TCL_ERROR; |
---|
1746 | } |
---|
1747 | if (errno == ERANGE) { |
---|
1748 | if (interp != NULL) { |
---|
1749 | char *s = "integer value too large to represent"; |
---|
1750 | Tcl_ResetResult(interp); |
---|
1751 | Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
---|
1752 | Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); |
---|
1753 | } |
---|
1754 | return TCL_ERROR; |
---|
1755 | } |
---|
1756 | |
---|
1757 | /* |
---|
1758 | * Make sure that the string has no garbage after the end of the int. |
---|
1759 | */ |
---|
1760 | |
---|
1761 | while ((end < (string+length)) && isspace(UCHAR(*end))) { |
---|
1762 | end++; |
---|
1763 | } |
---|
1764 | if (end != (string+length)) { |
---|
1765 | goto badInteger; |
---|
1766 | } |
---|
1767 | |
---|
1768 | /* |
---|
1769 | * The conversion to int succeeded. Free the old internalRep before |
---|
1770 | * setting the new one. We do this as late as possible to allow the |
---|
1771 | * conversion code, in particular Tcl_GetStringFromObj, to use that old |
---|
1772 | * internalRep. |
---|
1773 | */ |
---|
1774 | |
---|
1775 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
1776 | oldTypePtr->freeIntRepProc(objPtr); |
---|
1777 | } |
---|
1778 | |
---|
1779 | objPtr->internalRep.longValue = newLong; |
---|
1780 | objPtr->typePtr = &tclIntType; |
---|
1781 | return TCL_OK; |
---|
1782 | } |
---|
1783 | |
---|
1784 | /* |
---|
1785 | *---------------------------------------------------------------------- |
---|
1786 | * |
---|
1787 | * UpdateStringOfInt -- |
---|
1788 | * |
---|
1789 | * Update the string representation for an integer object. |
---|
1790 | * Note: This procedure does not free an existing old string rep |
---|
1791 | * so storage will be lost if this has not already been done. |
---|
1792 | * |
---|
1793 | * Results: |
---|
1794 | * None. |
---|
1795 | * |
---|
1796 | * Side effects: |
---|
1797 | * The object's string is set to a valid string that results from |
---|
1798 | * the int-to-string conversion. |
---|
1799 | * |
---|
1800 | *---------------------------------------------------------------------- |
---|
1801 | */ |
---|
1802 | |
---|
1803 | static void |
---|
1804 | UpdateStringOfInt(objPtr) |
---|
1805 | register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ |
---|
1806 | { |
---|
1807 | char buffer[TCL_DOUBLE_SPACE]; |
---|
1808 | register int len; |
---|
1809 | |
---|
1810 | len = TclFormatInt(buffer, objPtr->internalRep.longValue); |
---|
1811 | |
---|
1812 | objPtr->bytes = ckalloc((unsigned) len + 1); |
---|
1813 | strcpy(objPtr->bytes, buffer); |
---|
1814 | objPtr->length = len; |
---|
1815 | } |
---|
1816 | |
---|
1817 | /* |
---|
1818 | *---------------------------------------------------------------------- |
---|
1819 | * |
---|
1820 | * Tcl_NewLongObj -- |
---|
1821 | * |
---|
1822 | * If a client is compiled with TCL_MEM_DEBUG defined, calls to |
---|
1823 | * Tcl_NewLongObj to create a new long integer object end up calling |
---|
1824 | * the debugging procedure Tcl_DbNewLongObj instead. |
---|
1825 | * |
---|
1826 | * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, |
---|
1827 | * calls to Tcl_NewLongObj result in a call to one of the two |
---|
1828 | * Tcl_NewLongObj implementations below. We provide two implementations |
---|
1829 | * so that the Tcl core can be compiled to do memory debugging of the |
---|
1830 | * core even if a client does not request it for itself. |
---|
1831 | * |
---|
1832 | * Integer and long integer objects share the same "integer" type |
---|
1833 | * implementation. We store all integers as longs and Tcl_GetIntFromObj |
---|
1834 | * checks whether the current value of the long can be represented by |
---|
1835 | * an int. |
---|
1836 | * |
---|
1837 | * Results: |
---|
1838 | * The newly created object is returned. This object will have an |
---|
1839 | * invalid string representation. The returned object has ref count 0. |
---|
1840 | * |
---|
1841 | * Side effects: |
---|
1842 | * None. |
---|
1843 | * |
---|
1844 | *---------------------------------------------------------------------- |
---|
1845 | */ |
---|
1846 | |
---|
1847 | #ifdef TCL_MEM_DEBUG |
---|
1848 | #undef Tcl_NewLongObj |
---|
1849 | |
---|
1850 | Tcl_Obj * |
---|
1851 | Tcl_NewLongObj(longValue) |
---|
1852 | register long longValue; /* Long integer used to initialize the |
---|
1853 | * new object. */ |
---|
1854 | { |
---|
1855 | return Tcl_DbNewLongObj(longValue, "unknown", 0); |
---|
1856 | } |
---|
1857 | |
---|
1858 | #else /* if not TCL_MEM_DEBUG */ |
---|
1859 | |
---|
1860 | Tcl_Obj * |
---|
1861 | Tcl_NewLongObj(longValue) |
---|
1862 | register long longValue; /* Long integer used to initialize the |
---|
1863 | * new object. */ |
---|
1864 | { |
---|
1865 | register Tcl_Obj *objPtr; |
---|
1866 | |
---|
1867 | TclNewObj(objPtr); |
---|
1868 | objPtr->bytes = NULL; |
---|
1869 | |
---|
1870 | objPtr->internalRep.longValue = longValue; |
---|
1871 | objPtr->typePtr = &tclIntType; |
---|
1872 | return objPtr; |
---|
1873 | } |
---|
1874 | #endif /* if TCL_MEM_DEBUG */ |
---|
1875 | |
---|
1876 | /* |
---|
1877 | *---------------------------------------------------------------------- |
---|
1878 | * |
---|
1879 | * Tcl_DbNewLongObj -- |
---|
1880 | * |
---|
1881 | * If a client is compiled with TCL_MEM_DEBUG defined, calls to |
---|
1882 | * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or |
---|
1883 | * long integer objects end up calling the debugging procedure |
---|
1884 | * Tcl_DbNewLongObj instead. We provide two implementations of |
---|
1885 | * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do |
---|
1886 | * memory debugging of the core is independent of whether a client |
---|
1887 | * requests debugging for itself. |
---|
1888 | * |
---|
1889 | * When the core is compiled with TCL_MEM_DEBUG defined, |
---|
1890 | * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and |
---|
1891 | * line number from its caller. This simplifies debugging since then |
---|
1892 | * the checkmem command will report the caller's file name and line |
---|
1893 | * number when reporting objects that haven't been freed. |
---|
1894 | * |
---|
1895 | * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, |
---|
1896 | * this procedure just returns the result of calling Tcl_NewLongObj. |
---|
1897 | * |
---|
1898 | * Results: |
---|
1899 | * The newly created long integer object is returned. This object |
---|
1900 | * will have an invalid string representation. The returned object has |
---|
1901 | * ref count 0. |
---|
1902 | * |
---|
1903 | * Side effects: |
---|
1904 | * Allocates memory. |
---|
1905 | * |
---|
1906 | *---------------------------------------------------------------------- |
---|
1907 | */ |
---|
1908 | |
---|
1909 | #ifdef TCL_MEM_DEBUG |
---|
1910 | |
---|
1911 | Tcl_Obj * |
---|
1912 | Tcl_DbNewLongObj(longValue, file, line) |
---|
1913 | register long longValue; /* Long integer used to initialize the |
---|
1914 | * new object. */ |
---|
1915 | char *file; /* The name of the source file calling this |
---|
1916 | * procedure; used for debugging. */ |
---|
1917 | int line; /* Line number in the source file; used |
---|
1918 | * for debugging. */ |
---|
1919 | { |
---|
1920 | register Tcl_Obj *objPtr; |
---|
1921 | |
---|
1922 | TclDbNewObj(objPtr, file, line); |
---|
1923 | objPtr->bytes = NULL; |
---|
1924 | |
---|
1925 | objPtr->internalRep.longValue = longValue; |
---|
1926 | objPtr->typePtr = &tclIntType; |
---|
1927 | return objPtr; |
---|
1928 | } |
---|
1929 | |
---|
1930 | #else /* if not TCL_MEM_DEBUG */ |
---|
1931 | |
---|
1932 | Tcl_Obj * |
---|
1933 | Tcl_DbNewLongObj(longValue, file, line) |
---|
1934 | register long longValue; /* Long integer used to initialize the |
---|
1935 | * new object. */ |
---|
1936 | char *file; /* The name of the source file calling this |
---|
1937 | * procedure; used for debugging. */ |
---|
1938 | int line; /* Line number in the source file; used |
---|
1939 | * for debugging. */ |
---|
1940 | { |
---|
1941 | return Tcl_NewLongObj(longValue); |
---|
1942 | } |
---|
1943 | #endif /* TCL_MEM_DEBUG */ |
---|
1944 | |
---|
1945 | /* |
---|
1946 | *---------------------------------------------------------------------- |
---|
1947 | * |
---|
1948 | * Tcl_SetLongObj -- |
---|
1949 | * |
---|
1950 | * Modify an object to be an integer object and to have the specified |
---|
1951 | * long integer value. |
---|
1952 | * |
---|
1953 | * Results: |
---|
1954 | * None. |
---|
1955 | * |
---|
1956 | * Side effects: |
---|
1957 | * The object's old string rep, if any, is freed. Also, any old |
---|
1958 | * internal rep is freed. |
---|
1959 | * |
---|
1960 | *---------------------------------------------------------------------- |
---|
1961 | */ |
---|
1962 | |
---|
1963 | void |
---|
1964 | Tcl_SetLongObj(objPtr, longValue) |
---|
1965 | register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ |
---|
1966 | register long longValue; /* Long integer used to initialize the |
---|
1967 | * object's value. */ |
---|
1968 | { |
---|
1969 | register Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
---|
1970 | |
---|
1971 | if (Tcl_IsShared(objPtr)) { |
---|
1972 | panic("Tcl_SetLongObj called with shared object"); |
---|
1973 | } |
---|
1974 | |
---|
1975 | Tcl_InvalidateStringRep(objPtr); |
---|
1976 | if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
---|
1977 | oldTypePtr->freeIntRepProc(objPtr); |
---|
1978 | } |
---|
1979 | |
---|
1980 | objPtr->internalRep.longValue = longValue; |
---|
1981 | objPtr->typePtr = &tclIntType; |
---|
1982 | } |
---|
1983 | |
---|
1984 | /* |
---|
1985 | *---------------------------------------------------------------------- |
---|
1986 | * |
---|
1987 | * Tcl_GetLongFromObj -- |
---|
1988 | * |
---|
1989 | * Attempt to return an long integer from the Tcl object "objPtr". If |
---|
1990 | * the object is not already an int object, an attempt will be made to |
---|
1991 | * convert it to one. |
---|
1992 | * |
---|
1993 | * Results: |
---|
1994 | * The return value is a standard Tcl object result. If an error occurs |
---|
1995 | * during conversion, an error message is left in the interpreter's |
---|
1996 | * result unless "interp" is NULL. |
---|
1997 | * |
---|
1998 | * Side effects: |
---|
1999 | * If the object is not already an int object, the conversion will free |
---|
2000 | * any old internal representation. |
---|
2001 | * |
---|
2002 | *---------------------------------------------------------------------- |
---|
2003 | */ |
---|
2004 | |
---|
2005 | int |
---|
2006 | Tcl_GetLongFromObj(interp, objPtr, longPtr) |
---|
2007 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
---|
2008 | register Tcl_Obj *objPtr; /* The object from which to get a long. */ |
---|
2009 | register long *longPtr; /* Place to store resulting long. */ |
---|
2010 | { |
---|
2011 | register int result; |
---|
2012 | |
---|
2013 | if (objPtr->typePtr == &tclIntType) { |
---|
2014 | *longPtr = objPtr->internalRep.longValue; |
---|
2015 | return TCL_OK; |
---|
2016 | } |
---|
2017 | result = SetIntFromAny(interp, objPtr); |
---|
2018 | if (result == TCL_OK) { |
---|
2019 | *longPtr = objPtr->internalRep.longValue; |
---|
2020 | } |
---|
2021 | return result; |
---|
2022 | } |
---|
2023 | |
---|
2024 | /* |
---|
2025 | *---------------------------------------------------------------------- |
---|
2026 | * |
---|
2027 | * Tcl_DbIncrRefCount -- |
---|
2028 | * |
---|
2029 | * This procedure is normally called when debugging: i.e., when |
---|
2030 | * TCL_MEM_DEBUG is defined. This checks to see whether or not |
---|
2031 | * the memory has been freed before incrementing the ref count. |
---|
2032 | * |
---|
2033 | * When TCL_MEM_DEBUG is not defined, this procedure just increments |
---|
2034 | * the reference count of the object. |
---|
2035 | * |
---|
2036 | * Results: |
---|
2037 | * None. |
---|
2038 | * |
---|
2039 | * Side effects: |
---|
2040 | * The object's ref count is incremented. |
---|
2041 | * |
---|
2042 | *---------------------------------------------------------------------- |
---|
2043 | */ |
---|
2044 | |
---|
2045 | void |
---|
2046 | Tcl_DbIncrRefCount(objPtr, file, line) |
---|
2047 | register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ |
---|
2048 | char *file; /* The name of the source file calling this |
---|
2049 | * procedure; used for debugging. */ |
---|
2050 | int line; /* Line number in the source file; used |
---|
2051 | * for debugging. */ |
---|
2052 | { |
---|
2053 | #ifdef TCL_MEM_DEBUG |
---|
2054 | if (objPtr->refCount == 0x61616161) { |
---|
2055 | fprintf(stderr, "file = %s, line = %d\n", file, line); |
---|
2056 | fflush(stderr); |
---|
2057 | panic("Trying to increment refCount of previously disposed object."); |
---|
2058 | } |
---|
2059 | #endif |
---|
2060 | ++(objPtr)->refCount; |
---|
2061 | } |
---|
2062 | |
---|
2063 | /* |
---|
2064 | *---------------------------------------------------------------------- |
---|
2065 | * |
---|
2066 | * Tcl_DbDecrRefCount -- |
---|
2067 | * |
---|
2068 | * This procedure is normally called when debugging: i.e., when |
---|
2069 | * TCL_MEM_DEBUG is defined. This checks to see whether or not |
---|
2070 | * the memory has been freed before incrementing the ref count. |
---|
2071 | * |
---|
2072 | * When TCL_MEM_DEBUG is not defined, this procedure just increments |
---|
2073 | * the reference count of the object. |
---|
2074 | * |
---|
2075 | * Results: |
---|
2076 | * None. |
---|
2077 | * |
---|
2078 | * Side effects: |
---|
2079 | * The object's ref count is incremented. |
---|
2080 | * |
---|
2081 | *---------------------------------------------------------------------- |
---|
2082 | */ |
---|
2083 | |
---|
2084 | void |
---|
2085 | Tcl_DbDecrRefCount(objPtr, file, line) |
---|
2086 | register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ |
---|
2087 | char *file; /* The name of the source file calling this |
---|
2088 | * procedure; used for debugging. */ |
---|
2089 | int line; /* Line number in the source file; used |
---|
2090 | * for debugging. */ |
---|
2091 | { |
---|
2092 | #ifdef TCL_MEM_DEBUG |
---|
2093 | if (objPtr->refCount == 0x61616161) { |
---|
2094 | fprintf(stderr, "file = %s, line = %d\n", file, line); |
---|
2095 | fflush(stderr); |
---|
2096 | panic("Trying to decrement refCount of previously disposed object."); |
---|
2097 | } |
---|
2098 | #endif |
---|
2099 | if (--(objPtr)->refCount <= 0) { |
---|
2100 | TclFreeObj(objPtr); |
---|
2101 | } |
---|
2102 | } |
---|
2103 | |
---|
2104 | /* |
---|
2105 | *---------------------------------------------------------------------- |
---|
2106 | * |
---|
2107 | * Tcl_DbIsShared -- |
---|
2108 | * |
---|
2109 | * This procedure is normally called when debugging: i.e., when |
---|
2110 | * TCL_MEM_DEBUG is defined. This checks to see whether or not |
---|
2111 | * the memory has been freed before incrementing the ref count. |
---|
2112 | * |
---|
2113 | * When TCL_MEM_DEBUG is not defined, this procedure just decrements |
---|
2114 | * the reference count of the object and throws it away if the count |
---|
2115 | * is 0 or less. |
---|
2116 | * |
---|
2117 | * Results: |
---|
2118 | * None. |
---|
2119 | * |
---|
2120 | * Side effects: |
---|
2121 | * The object's ref count is incremented. |
---|
2122 | * |
---|
2123 | *---------------------------------------------------------------------- |
---|
2124 | */ |
---|
2125 | |
---|
2126 | int |
---|
2127 | Tcl_DbIsShared(objPtr, file, line) |
---|
2128 | register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ |
---|
2129 | char *file; /* The name of the source file calling this |
---|
2130 | * procedure; used for debugging. */ |
---|
2131 | int line; /* Line number in the source file; used |
---|
2132 | * for debugging. */ |
---|
2133 | { |
---|
2134 | #ifdef TCL_MEM_DEBUG |
---|
2135 | if (objPtr->refCount == 0x61616161) { |
---|
2136 | fprintf(stderr, "file = %s, line = %d\n", file, line); |
---|
2137 | fflush(stderr); |
---|
2138 | panic("Trying to check whether previously disposed object is shared."); |
---|
2139 | } |
---|
2140 | #endif |
---|
2141 | return ((objPtr)->refCount > 1); |
---|
2142 | } |
---|