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()).
49 static int in_opaque_list_marking;
51 /* Holds freed opaque objects created with make_opaque_ptr().
52 We do this quite often so it's a noticeable win if we don't
54 Lisp_Object Vopaque_ptr_free_list;
57 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
59 Lisp_Opaque *p = XOPAQUE (obj);
60 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
61 Lisp_Object size_or_chain = p->size_or_chain;
63 if (!in_opaque_list_marking)
64 /* size is non-int for objects on an opaque free list. We sure
65 as hell better not be marking any of these objects unless
66 we're marking an opaque list. */
67 assert (GC_INTP (size_or_chain));
69 /* marking an opaque on the free list doesn't do any recursive
70 markings, so we better not have non-freed opaques on a free
72 assert (!GC_INTP (size_or_chain));
74 if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
75 return OPAQUE_MARKFUN (p) (obj, markobj);
80 /* Should never, ever be called. (except by an external debugger) */
82 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
84 CONST Lisp_Opaque *p = XOPAQUE (obj);
85 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
86 Lisp_Object size_or_chain = p->size_or_chain;
90 if (INTP (size_or_chain))
91 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
93 sprintf (size_buf, "freed");
95 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
96 size_buf, (unsigned long) p);
97 write_c_string (buf, printcharfun);
101 sizeof_opaque (CONST void *header)
103 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
104 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
105 Lisp_Object size_or_chain = p->size_or_chain;
106 return offsetof (Lisp_Opaque, data)
107 + (GC_INTP (size_or_chain) ? XINT (size_or_chain) : 0);
110 /* Return an opaque object of size SIZE.
111 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
112 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
113 Else the object's data is initialized by copying from DATA. */
115 make_opaque (size_t size, CONST void *data)
117 Lisp_Opaque *p = (Lisp_Opaque *)
118 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
120 p->size_or_chain = make_int (size);
122 if (data == OPAQUE_CLEAR)
123 memset (p->data, '\0', size);
124 else if (data == OPAQUE_UNINIT)
127 memcpy (p->data, data, size);
136 /* This will not work correctly for opaques with subobjects! */
139 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
143 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
144 Lisp_Object size_or_chain_1 = XOPAQUE (obj1)->size_or_chain;
145 Lisp_Object size_or_chain_2 = XOPAQUE (obj2)->size_or_chain;
146 assert (INTP (size_or_chain_1));
147 assert (INTP (size_or_chain_2));
148 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
153 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
154 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
158 /* This will not work correctly for opaques with subobjects! */
161 hash_opaque (Lisp_Object obj, int depth)
165 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
166 Lisp_Object size_or_chain = XOPAQUE (obj)->size_or_chain;
167 assert (INTP (size_or_chain));
168 assert (!XOPAQUE_MARKFUN (obj));
171 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
172 return *((unsigned long *) XOPAQUE_DATA (obj));
174 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
177 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
178 mark_opaque, print_opaque, 0,
179 equal_opaque, hash_opaque,
180 sizeof_opaque, Lisp_Opaque);
183 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
185 in_opaque_list_marking++;
186 markobj (XOPAQUE_LIST (obj)->free);
187 in_opaque_list_marking--;
192 make_opaque_list (size_t size,
193 Lisp_Object (*markfun) (Lisp_Object obj,
194 void (*markobj) (Lisp_Object)))
197 Lisp_Opaque_List *p =
198 alloc_lcrecord_type (Lisp_Opaque_List, &lrecord_opaque_list);
200 p->markfun = markfun;
203 XSETOPAQUE_LIST (val, p);
207 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
208 mark_opaque_list, internal_object_printer,
209 0, 0, 0, Lisp_Opaque_List);
212 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
214 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
217 if (!NILP (li->free))
220 li->free = XOPAQUE (val)->size_or_chain;
221 #ifdef ERROR_CHECK_GC
222 assert (NILP (li->free) || OPAQUEP (li->free));
224 XOPAQUE (val)->size_or_chain = make_int (li->size);
226 memcpy (XOPAQUE (val)->data, data, li->size);
228 memset (XOPAQUE (val)->data, 0, li->size);
231 val = make_opaque (li->size, data);
232 XOPAQUE (val)->markfun = li->markfun;
237 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
239 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
241 #ifdef ERROR_CHECK_GC
243 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
244 Lisp_Object size_or_chain = XOPAQUE (opaque)->size_or_chain;
245 assert (INTP (size_or_chain));
248 XOPAQUE (opaque)->size_or_chain = li->free;
252 /* stuff to handle opaque pointers */
255 make_opaque_ptr (CONST void *val)
257 return allocate_managed_opaque (Vopaque_ptr_free_list,
258 (CONST void *) &val);
261 /* Be very very careful with this. Same admonitions as with
262 free_cons() apply. */
265 free_opaque_ptr (Lisp_Object ptr)
267 free_managed_opaque (Vopaque_ptr_free_list, ptr);
271 make_opaque_long (long val)
273 return make_opaque (sizeof (val), (void *) &val);
277 init_opaque_once_early (void)
279 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
280 staticpro (&Vopaque_ptr_free_list);