1 /* Opaque Lisp objects.
2 Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Not in FSF. */
24 /* Written by Ben Wing, October 1993. */
26 /* "Opaque" is used internally to hold keep track of allocated memory
27 so it gets GC'd properly, and to store arbitrary data in places
28 where a Lisp_Object is required and which may get GC'd. (e.g. as
29 the argument to record_unwind_protect()). Once created in C,
30 opaque objects cannot be resized.
32 OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL. Some code
33 depends on this. As such, opaque objects are a generalization
34 of the Qunbound marker.
36 "Opaque lists" are used to keep track of lots of opaque objects
37 of a particular size so that they can be efficiently "freed" and
38 re-used again without actually entering the Lisp allocation system
39 (and consequently doing a malloc()).
48 static int in_opaque_list_marking;
50 /* Holds freed opaque objects created with make_opaque_ptr().
51 We do this quite often so it's a noticeable win if we don't
53 Lisp_Object Vopaque_ptr_free_list;
56 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
58 Lisp_Opaque *p = XOPAQUE (obj);
59 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
60 Lisp_Object size_or_chain = p->size_or_chain;
62 if (!in_opaque_list_marking)
63 /* size is non-int for objects on an opaque free list. We sure
64 as hell better not be marking any of these objects unless
65 we're marking an opaque list. */
66 assert (GC_INTP (size_or_chain));
68 /* marking an opaque on the free list doesn't do any recursive
69 markings, so we better not have non-freed opaques on a free
71 assert (!GC_INTP (size_or_chain));
73 if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
74 return OPAQUE_MARKFUN (p) (obj, markobj);
79 /* Should never, ever be called. (except by an external debugger) */
81 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
83 CONST Lisp_Opaque *p = XOPAQUE (obj);
84 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
85 Lisp_Object size_or_chain = p->size_or_chain;
89 if (INTP (size_or_chain))
90 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
92 sprintf (size_buf, "freed");
94 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
95 size_buf, (unsigned long) p);
96 write_c_string (buf, printcharfun);
100 sizeof_opaque (CONST void *header)
102 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
103 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
104 Lisp_Object size_or_chain = p->size_or_chain;
105 return offsetof (Lisp_Opaque, data)
106 + (GC_INTP (size_or_chain) ? XINT (size_or_chain) : 0);
109 /* Return an opaque object of size SIZE.
110 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
111 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
112 Else the object's data is initialized by copying from DATA. */
114 make_opaque (size_t size, CONST void *data)
116 Lisp_Opaque *p = (Lisp_Opaque *)
117 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
119 p->size_or_chain = make_int (size);
121 if (data == OPAQUE_CLEAR)
122 memset (p->data, '\0', size);
123 else if (data == OPAQUE_UNINIT)
126 memcpy (p->data, data, size);
135 /* This will not work correctly for opaques with subobjects! */
138 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
142 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
143 Lisp_Object size_or_chain_1 = XOPAQUE (obj1)->size_or_chain;
144 Lisp_Object size_or_chain_2 = XOPAQUE (obj2)->size_or_chain;
145 assert (INTP (size_or_chain_1));
146 assert (INTP (size_or_chain_2));
147 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
152 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
153 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
157 /* This will not work correctly for opaques with subobjects! */
160 hash_opaque (Lisp_Object obj, int depth)
164 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
165 Lisp_Object size_or_chain = XOPAQUE (obj)->size_or_chain;
166 assert (INTP (size_or_chain));
167 assert (!XOPAQUE_MARKFUN (obj));
170 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
171 return *((unsigned long *) XOPAQUE_DATA (obj));
173 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
176 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
177 mark_opaque, print_opaque, 0,
178 equal_opaque, hash_opaque, 0,
179 sizeof_opaque, Lisp_Opaque);
182 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
184 in_opaque_list_marking++;
185 markobj (XOPAQUE_LIST (obj)->free);
186 in_opaque_list_marking--;
191 make_opaque_list (size_t size,
192 Lisp_Object (*markfun) (Lisp_Object obj,
193 void (*markobj) (Lisp_Object)))
196 Lisp_Opaque_List *p =
197 alloc_lcrecord_type (Lisp_Opaque_List, &lrecord_opaque_list);
199 p->markfun = markfun;
202 XSETOPAQUE_LIST (val, p);
206 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
207 mark_opaque_list, internal_object_printer,
208 0, 0, 0, 0, Lisp_Opaque_List);
211 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
213 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
216 if (!NILP (li->free))
219 li->free = XOPAQUE (val)->size_or_chain;
220 #ifdef ERROR_CHECK_GC
221 assert (NILP (li->free) || OPAQUEP (li->free));
223 XOPAQUE (val)->size_or_chain = make_int (li->size);
225 memcpy (XOPAQUE (val)->data, data, li->size);
227 memset (XOPAQUE (val)->data, 0, li->size);
230 val = make_opaque (li->size, data);
231 XOPAQUE (val)->markfun = li->markfun;
236 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
238 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
240 #ifdef ERROR_CHECK_GC
242 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
243 Lisp_Object size_or_chain = XOPAQUE (opaque)->size_or_chain;
244 assert (INTP (size_or_chain));
247 XOPAQUE (opaque)->size_or_chain = li->free;
251 /* stuff to handle opaque pointers */
254 make_opaque_ptr (CONST void *val)
256 return allocate_managed_opaque (Vopaque_ptr_free_list,
257 (CONST void *) &val);
260 /* Be very very careful with this. Same admonitions as with
261 free_cons() apply. */
264 free_opaque_ptr (Lisp_Object ptr)
266 free_managed_opaque (Vopaque_ptr_free_list, ptr);
270 make_opaque_long (long val)
272 return make_opaque (sizeof (val), (void *) &val);
276 init_opaque_once_early (void)
278 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
279 staticpro (&Vopaque_ptr_free_list);