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