428
+ − 1 /* Opaque Lisp objects.
+ − 2 Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
800
+ − 3 Copyright (C) 1995, 1996, 2002 Ben Wing.
428
+ − 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
3263
+ − 41 #ifndef NEW_GC
428
+ − 42 Lisp_Object Vopaque_ptr_free_list;
3263
+ − 43 #endif /* not NEW_GC */
428
+ − 44
+ − 45 /* Should never, ever be called. (except by an external debugger) */
+ − 46 static void
2286
+ − 47 print_opaque (Lisp_Object obj, Lisp_Object printcharfun,
+ − 48 int UNUSED (escapeflag))
428
+ − 49 {
442
+ − 50 const Lisp_Opaque *p = XOPAQUE (obj);
428
+ − 51
800
+ − 52 write_fmt_string
+ − 53 (printcharfun,
+ − 54 "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>",
+ − 55 (long)(p->size), (unsigned long) p);
428
+ − 56 }
+ − 57
665
+ − 58 inline static Bytecount
+ − 59 aligned_sizeof_opaque (Bytecount opaque_size)
456
+ − 60 {
826
+ − 61 return MAX_ALIGN_SIZE (offsetof (Lisp_Opaque, data) + opaque_size);
456
+ − 62 }
+ − 63
665
+ − 64 static Bytecount
442
+ − 65 sizeof_opaque (const void *header)
428
+ − 66 {
456
+ − 67 return aligned_sizeof_opaque (((const Lisp_Opaque *) header)->size);
428
+ − 68 }
+ − 69
+ − 70 /* Return an opaque object of size SIZE.
+ − 71 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
+ − 72 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
+ − 73 Else the object's data is initialized by copying from DATA. */
+ − 74 Lisp_Object
665
+ − 75 make_opaque (const void *data, Bytecount size)
428
+ − 76 {
+ − 77 Lisp_Opaque *p = (Lisp_Opaque *)
3017
+ − 78 BASIC_ALLOC_LCRECORD (aligned_sizeof_opaque (size), &lrecord_opaque);
428
+ − 79 p->size = size;
+ − 80
+ − 81 if (data == OPAQUE_CLEAR)
+ − 82 memset (p->data, '\0', size);
+ − 83 else if (data == OPAQUE_UNINIT)
+ − 84 DO_NOTHING;
+ − 85 else
+ − 86 memcpy (p->data, data, size);
+ − 87
+ − 88 {
793
+ − 89 return wrap_opaque (p);
428
+ − 90 }
+ − 91 }
+ − 92
+ − 93 /* This will not work correctly for opaques with subobjects! */
+ − 94
+ − 95 static int
2286
+ − 96 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth))
428
+ − 97 {
665
+ − 98 Bytecount size;
428
+ − 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
2515
+ − 105 static Hashcode
2286
+ − 106 hash_opaque (Lisp_Object obj, int UNUSED (depth))
428
+ − 107 {
+ − 108 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
2515
+ − 109 return *((Hashcode *) XOPAQUE_DATA (obj));
428
+ − 110 else
+ − 111 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
+ − 112 }
+ − 113
1204
+ − 114 static const struct memory_description opaque_description[] = {
428
+ − 115 { XD_END }
+ − 116 };
+ − 117
934
+ − 118 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
+ − 119 1, /*dumpable-flag*/
+ − 120 0, print_opaque, 0,
+ − 121 equal_opaque, hash_opaque,
+ − 122 opaque_description,
+ − 123 sizeof_opaque, Lisp_Opaque);
428
+ − 124
+ − 125 /* stuff to handle opaque pointers */
+ − 126
+ − 127 /* Should never, ever be called. (except by an external debugger) */
+ − 128 static void
2286
+ − 129 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun,
+ − 130 int UNUSED (escapeflag))
428
+ − 131 {
442
+ − 132 const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj);
428
+ − 133
800
+ − 134 write_fmt_string
+ − 135 (printcharfun,
+ − 136 "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%lx>",
+ − 137 (long)(p->ptr), (unsigned long) p);
428
+ − 138 }
+ − 139
+ − 140 static int
2286
+ − 141 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth))
428
+ − 142 {
+ − 143 return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr);
+ − 144 }
+ − 145
2515
+ − 146 static Hashcode
2286
+ − 147 hash_opaque_ptr (Lisp_Object obj, int UNUSED (depth))
428
+ − 148 {
2515
+ − 149 return (Hashcode) XOPAQUE_PTR (obj)->ptr;
428
+ − 150 }
+ − 151
1575
+ − 152 static const struct memory_description opaque_ptr_description[] = {
+ − 153 { XD_END }
+ − 154 };
+ − 155
934
+ − 156 DEFINE_LRECORD_IMPLEMENTATION ("opaque-ptr", opaque_ptr,
+ − 157 0, /*dumpable-flag*/
+ − 158 0, print_opaque_ptr, 0,
1204
+ − 159 equal_opaque_ptr, hash_opaque_ptr,
1575
+ − 160 opaque_ptr_description, Lisp_Opaque_Ptr);
428
+ − 161
+ − 162 Lisp_Object
+ − 163 make_opaque_ptr (void *val)
+ − 164 {
3263
+ − 165 #ifdef NEW_GC
2720
+ − 166 Lisp_Object res =
+ − 167 wrap_pointer_1 (alloc_lrecord_type (Lisp_Opaque_Ptr,
+ − 168 &lrecord_opaque_ptr));
3263
+ − 169 #else /* not NEW_GC */
1204
+ − 170 Lisp_Object res = alloc_managed_lcrecord (Vopaque_ptr_free_list);
3263
+ − 171 #endif /* not NEW_GC */
428
+ − 172 set_opaque_ptr (res, val);
+ − 173 return res;
+ − 174 }
+ − 175
+ − 176 /* Be very very careful with this. Same admonitions as with
+ − 177 free_cons() apply. */
+ − 178
+ − 179 void
+ − 180 free_opaque_ptr (Lisp_Object ptr)
+ − 181 {
3263
+ − 182 #ifdef NEW_GC
2720
+ − 183 free_lrecord (ptr);
3263
+ − 184 #else /* not NEW_GC */
428
+ − 185 free_managed_lcrecord (Vopaque_ptr_free_list, ptr);
3263
+ − 186 #endif /* not NEW_GC */
428
+ − 187 }
+ − 188
3263
+ − 189 #ifndef NEW_GC
428
+ − 190 void
1204
+ − 191 reinit_opaque_early (void)
428
+ − 192 {
647
+ − 193 Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr),
+ − 194 &lrecord_opaque_ptr);
428
+ − 195 staticpro_nodump (&Vopaque_ptr_free_list);
+ − 196 }
3263
+ − 197 #endif /* not NEW_GC */
428
+ − 198
+ − 199 void
+ − 200 init_opaque_once_early (void)
+ − 201 {
442
+ − 202 INIT_LRECORD_IMPLEMENTATION (opaque);
+ − 203 INIT_LRECORD_IMPLEMENTATION (opaque_ptr);
+ − 204
3263
+ − 205 #ifndef NEW_GC
1204
+ − 206 reinit_opaque_early ();
3263
+ − 207 #endif /* not NEW_GC */
428
+ − 208 }