update.
[chise/xemacs-chise.git.1] / src / opaque.c
1 /* Opaque Lisp objects.
2    Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
3    Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
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
10 later version.
11
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
15 for more details.
16
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.  */
21
22 /* Synched up with: Not in FSF. */
23
24 /* Written by Ben Wing, October 1993. */
25
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.
31
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.
35  */
36
37 #include <config.h>
38 #include "lisp.h"
39 #include "opaque.h"
40
41 Lisp_Object Vopaque_ptr_free_list;
42
43 /* Should never, ever be called. (except by an external debugger) */
44 static void
45 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
46 {
47   const Lisp_Opaque *p = XOPAQUE (obj);
48   char buf[200];
49
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);
53 }
54
55 inline static size_t
56 aligned_sizeof_opaque (size_t opaque_size)
57 {
58   return ALIGN_SIZE (offsetof (Lisp_Opaque, data) + opaque_size,
59                      ALIGNOF (max_align_t));
60 }
61
62 static size_t
63 sizeof_opaque (const void *header)
64 {
65   return aligned_sizeof_opaque (((const Lisp_Opaque *) header)->size);
66 }
67
68 /* Return an opaque object of size SIZE.
69    If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
70    If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
71    Else the object's data is initialized by copying from DATA. */
72 Lisp_Object
73 make_opaque (const void *data, size_t size)
74 {
75   Lisp_Opaque *p = (Lisp_Opaque *)
76     alloc_lcrecord (aligned_sizeof_opaque (size), &lrecord_opaque);
77   p->size = size;
78
79   if (data == OPAQUE_CLEAR)
80     memset (p->data, '\0', size);
81   else if (data == OPAQUE_UNINIT)
82     DO_NOTHING;
83   else
84     memcpy (p->data, data, size);
85
86   {
87     Lisp_Object val;
88     XSETOPAQUE (val, p);
89     return val;
90   }
91 }
92
93 /* This will not work correctly for opaques with subobjects! */
94
95 static int
96 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
97 {
98   size_t size;
99   return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
100           !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
101 }
102
103 /* This will not work correctly for opaques with subobjects! */
104
105 static unsigned long
106 hash_opaque (Lisp_Object obj, int depth)
107 {
108   if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
109     return *((unsigned long *) XOPAQUE_DATA (obj));
110   else
111     return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
112 }
113
114 static const struct lrecord_description opaque_description[] = {
115   { XD_END }
116 };
117
118 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
119                                         0, print_opaque, 0,
120                                         equal_opaque, hash_opaque,
121                                         opaque_description,
122                                         sizeof_opaque, Lisp_Opaque);
123
124 /* stuff to handle opaque pointers */
125
126 /* Should never, ever be called. (except by an external debugger) */
127 static void
128 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
129 {
130   const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj);
131   char buf[200];
132
133   sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%lx>",
134            (long)(p->ptr), (unsigned long) p);
135   write_c_string (buf, printcharfun);
136 }
137
138 static int
139 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int depth)
140 {
141   return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr);
142 }
143
144 static unsigned long
145 hash_opaque_ptr (Lisp_Object obj, int depth)
146 {
147   return (unsigned long) XOPAQUE_PTR (obj)->ptr;
148 }
149
150 DEFINE_LRECORD_IMPLEMENTATION ("opaque-ptr", opaque_ptr,
151                                0, print_opaque_ptr, 0,
152                                equal_opaque_ptr, hash_opaque_ptr, 0,
153                                Lisp_Opaque_Ptr);
154
155 Lisp_Object
156 make_opaque_ptr (void *val)
157 {
158   Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
159   set_opaque_ptr (res, val);
160   return res;
161 }
162
163 /* Be very very careful with this.  Same admonitions as with
164    free_cons() apply. */
165
166 void
167 free_opaque_ptr (Lisp_Object ptr)
168 {
169   free_managed_lcrecord (Vopaque_ptr_free_list, ptr);
170 }
171
172 void
173 reinit_opaque_once_early (void)
174 {
175   Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), &lrecord_opaque_ptr);
176   staticpro_nodump (&Vopaque_ptr_free_list);
177 }
178
179 void
180 init_opaque_once_early (void)
181 {
182   INIT_LRECORD_IMPLEMENTATION (opaque);
183   INIT_LRECORD_IMPLEMENTATION (opaque_ptr);
184
185   reinit_opaque_once_early ();
186 }