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.
41 Lisp_Object Vopaque_ptr_free_list;
43 /* Should never, ever be called. (except by an external debugger) */
45 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
47 const Lisp_Opaque *p = XOPAQUE (obj);
50 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>",
51 (long)(p->size), (unsigned long) p);
52 write_c_string (buf, printcharfun);
56 sizeof_opaque (const void *header)
58 const Lisp_Opaque *p = (const Lisp_Opaque *) header;
59 return offsetof (Lisp_Opaque, data) + p->size;
62 /* Return an opaque object of size SIZE.
63 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
64 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
65 Else the object's data is initialized by copying from DATA. */
67 make_opaque (const void *data, size_t size)
69 Lisp_Opaque *p = (Lisp_Opaque *)
70 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
73 if (data == OPAQUE_CLEAR)
74 memset (p->data, '\0', size);
75 else if (data == OPAQUE_UNINIT)
78 memcpy (p->data, data, size);
87 /* This will not work correctly for opaques with subobjects! */
90 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
93 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
94 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
97 /* This will not work correctly for opaques with subobjects! */
100 hash_opaque (Lisp_Object obj, int depth)
102 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
103 return *((unsigned long *) XOPAQUE_DATA (obj));
105 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
108 static const struct lrecord_description opaque_description[] = {
112 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
114 equal_opaque, hash_opaque,
116 sizeof_opaque, Lisp_Opaque);
118 /* stuff to handle opaque pointers */
120 /* Should never, ever be called. (except by an external debugger) */
122 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
124 const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj);
127 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque_ptr, adr=0x%lx) 0x%lx>",
128 (long)(p->ptr), (unsigned long) p);
129 write_c_string (buf, printcharfun);
133 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int depth)
135 return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr);
139 hash_opaque_ptr (Lisp_Object obj, int depth)
141 return (unsigned long) XOPAQUE_PTR (obj)->ptr;
144 DEFINE_LRECORD_IMPLEMENTATION ("opaque_ptr", opaque_ptr,
145 0, print_opaque_ptr, 0,
146 equal_opaque_ptr, hash_opaque_ptr, 0,
150 make_opaque_ptr (void *val)
152 Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
153 set_opaque_ptr (res, val);
157 /* Be very very careful with this. Same admonitions as with
158 free_cons() apply. */
161 free_opaque_ptr (Lisp_Object ptr)
163 free_managed_lcrecord (Vopaque_ptr_free_list, ptr);
167 reinit_opaque_once_early (void)
169 Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), &lrecord_opaque_ptr);
170 staticpro_nodump (&Vopaque_ptr_free_list);
174 init_opaque_once_early (void)
176 INIT_LRECORD_IMPLEMENTATION (opaque);
177 INIT_LRECORD_IMPLEMENTATION (opaque_ptr);
179 reinit_opaque_once_early ();