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))
59 if (!in_opaque_list_marking)
60 /* size is non-int for objects on an opaque free list. We sure
61 as hell better not be marking any of these objects unless
62 we're marking an opaque list. */
63 assert (INTP (XOPAQUE (obj)->size_or_chain));
65 /* marking an opaque on the free list doesn't do any recursive
66 markings, so we better not have non-freed opaques on a free
68 assert (!INTP (XOPAQUE (obj)->size_or_chain));
70 if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj))
71 return XOPAQUE_MARKFUN (obj) (obj, markobj);
73 return XOPAQUE (obj)->size_or_chain;
76 /* Should never, ever be called. (except by an external debugger) */
78 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
81 if (INTP (XOPAQUE (obj)->size_or_chain))
82 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>",
83 (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj));
85 sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>",
86 (unsigned long) XPNTR (obj));
87 write_c_string (buf, printcharfun);
91 sizeof_opaque (CONST void *header)
93 CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header;
94 if (!INTP (p->size_or_chain))
96 return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int);
100 make_opaque (int size, CONST void *data)
102 struct Lisp_Opaque *p = (struct Lisp_Opaque *)
103 alloc_lcrecord (sizeof (*p) + size - sizeof (int), lrecord_opaque);
107 p->size_or_chain = make_int (size);
109 memcpy (p->data, data, size);
111 memset (p->data, 0, size);
116 /* This will not work correctly for opaques with subobjects! */
119 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
122 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
123 assert (INTP (XOPAQUE(obj1)->size_or_chain));
124 assert (INTP (XOPAQUE(obj2)->size_or_chain));
126 if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2))
128 return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1))
129 ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2)
130 : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2),
131 XOPAQUE_SIZE(obj1)) == 0);
134 /* This will not work correctly for opaques with subobjects! */
137 hash_opaque (Lisp_Object obj, int depth)
140 assert (!XOPAQUE_MARKFUN (obj));
141 assert (INTP (XOPAQUE(obj)->size_or_chain));
143 if (XOPAQUE_SIZE(obj) == sizeof (unsigned long))
144 return (unsigned int) *XOPAQUE_DATA(obj);
146 return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj));
149 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
150 mark_opaque, print_opaque, 0,
151 equal_opaque, hash_opaque,
152 sizeof_opaque, struct Lisp_Opaque);
155 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
157 in_opaque_list_marking++;
158 (markobj) (XOPAQUE_LIST (obj)->free);
159 in_opaque_list_marking--;
164 make_opaque_list (int size,
165 Lisp_Object (*markfun) (Lisp_Object obj,
166 void (*markobj) (Lisp_Object)))
169 struct Lisp_Opaque_List *p =
170 alloc_lcrecord_type (struct Lisp_Opaque_List, lrecord_opaque_list);
172 p->markfun = markfun;
175 XSETOPAQUE_LIST (val, p);
179 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
180 mark_opaque_list, internal_object_printer,
181 0, 0, 0, struct Lisp_Opaque_List);
184 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
186 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
189 if (!NILP (li->free))
192 li->free = XOPAQUE (val)->size_or_chain;
193 #ifdef ERROR_CHECK_GC
194 assert (NILP (li->free) || OPAQUEP (li->free));
196 XOPAQUE (val)->size_or_chain = make_int (li->size);
198 memcpy (XOPAQUE (val)->data, data, li->size);
200 memset (XOPAQUE (val)->data, 0, li->size);
203 val = make_opaque (li->size, data);
204 XOPAQUE (val)->markfun = li->markfun;
209 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
211 struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
213 #ifdef ERROR_CHECK_GC
214 assert (INTP (XOPAQUE (opaque)->size_or_chain));
216 XOPAQUE (opaque)->size_or_chain = li->free;
220 /* stuff to handle opaque pointers */
223 make_opaque_ptr (CONST void *val)
225 return allocate_managed_opaque (Vopaque_ptr_free_list,
226 (CONST void *) &val);
229 /* Be wery wery careful with this. Same admonitions as with
230 free_cons() apply. */
233 free_opaque_ptr (Lisp_Object ptr)
235 free_managed_opaque (Vopaque_ptr_free_list, ptr);
239 make_opaque_long (long val)
241 return make_opaque (sizeof (val), (void *) &val);
245 init_opaque_once_early (void)
247 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
248 staticpro (&Vopaque_ptr_free_list);