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 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);
87 if (INTP (p->size_or_chain))
88 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
90 sprintf (size_buf, "freed");
92 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
93 size_buf, (unsigned long) p);
94 write_c_string (buf, printcharfun);
98 sizeof_opaque (CONST void *header)
100 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
101 return offsetof (Lisp_Opaque, data)
102 + (GC_INTP (p->size_or_chain) ? XINT (p->size_or_chain) : 0);
105 /* Return an opaque object of size SIZE.
106 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
107 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
108 Else the object's data is initialized by copying from DATA. */
110 make_opaque (size_t size, CONST void *data)
112 Lisp_Opaque *p = (Lisp_Opaque *)
113 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque);
115 p->size_or_chain = make_int (size);
117 if (data == OPAQUE_CLEAR)
118 memset (p->data, '\0', size);
119 else if (data == OPAQUE_UNINIT)
122 memcpy (p->data, data, size);
131 /* This will not work correctly for opaques with subobjects! */
134 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
138 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
139 assert (INTP (XOPAQUE (obj1)->size_or_chain));
140 assert (INTP (XOPAQUE (obj2)->size_or_chain));
142 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
143 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
146 /* This will not work correctly for opaques with subobjects! */
149 hash_opaque (Lisp_Object obj, int depth)
152 assert (!XOPAQUE_MARKFUN (obj));
153 assert (INTP (XOPAQUE (obj)->size_or_chain));
155 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
156 return *((unsigned long *) XOPAQUE_DATA(obj));
158 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
161 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
162 mark_opaque, print_opaque, 0,
163 equal_opaque, hash_opaque,
164 sizeof_opaque, Lisp_Opaque);
167 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
169 in_opaque_list_marking++;
170 markobj (XOPAQUE_LIST (obj)->free);
171 in_opaque_list_marking--;
176 make_opaque_list (size_t size,
177 Lisp_Object (*markfun) (Lisp_Object obj,
178 void (*markobj) (Lisp_Object)))
181 Lisp_Opaque_List *p =
182 alloc_lcrecord_type (Lisp_Opaque_List, lrecord_opaque_list);
184 p->markfun = markfun;
187 XSETOPAQUE_LIST (val, p);
191 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
192 mark_opaque_list, internal_object_printer,
193 0, 0, 0, Lisp_Opaque_List);
196 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
198 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
201 if (!NILP (li->free))
204 li->free = XOPAQUE (val)->size_or_chain;
205 #ifdef ERROR_CHECK_GC
206 assert (NILP (li->free) || OPAQUEP (li->free));
208 XOPAQUE (val)->size_or_chain = make_int (li->size);
210 memcpy (XOPAQUE (val)->data, data, li->size);
212 memset (XOPAQUE (val)->data, 0, li->size);
215 val = make_opaque (li->size, data);
216 XOPAQUE (val)->markfun = li->markfun;
221 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
223 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
225 #ifdef ERROR_CHECK_GC
226 assert (INTP (XOPAQUE (opaque)->size_or_chain));
228 XOPAQUE (opaque)->size_or_chain = li->free;
232 /* stuff to handle opaque pointers */
235 make_opaque_ptr (CONST void *val)
237 return allocate_managed_opaque (Vopaque_ptr_free_list,
238 (CONST void *) &val);
241 /* Be very very careful with this. Same admonitions as with
242 free_cons() apply. */
245 free_opaque_ptr (Lisp_Object ptr)
247 free_managed_opaque (Vopaque_ptr_free_list, ptr);
251 make_opaque_long (long val)
253 return make_opaque (sizeof (val), (void *) &val);
257 init_opaque_once_early (void)
259 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
260 staticpro (&Vopaque_ptr_free_list);