cgit.sxemacs.org Git - sxemacs/blob - 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 SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21 /* Synched up with: Not in FSF. */
  22
  23 /* Written by Ben Wing, October 1993. */
  24
  25 /* "Opaque" is used internally to hold keep track of allocated memory
  26    so it gets GC'd properly, and to store arbitrary data in places
  27    where a Lisp_Object is required and which may get GC'd. (e.g.  as
  28    the argument to record_unwind_protect()).  Once created in C,
  29    opaque objects cannot be resized.
  30
  31    OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL.  Some code
  32    depends on this.  As such, opaque objects are a generalization
  33    of the Qunbound marker.
  34  */
  35
  36 #include <config.h>
  37 #include "lisp.h"
  38 #include "opaque.h"
  39
  40 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
  41 Lisp_Object Vopaque_ptr_free_list;
  42 #endif  /* !BDWGC */
  43
  44 /* Should never, ever be called. (except by an external debugger) */
  45 static void
  46 print_opaque(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  47 {
  48         const Lisp_Opaque *p = XOPAQUE(obj);
  49         char buf[200];
  50
  51         sprintf(buf,
  52                 "#<INTERNAL OBJECT (SXEmacs bug?) (opaque, size=%lu) 0x%lx>",
  53                 (long)(p->size), (unsigned long)p);
  54         write_c_string(buf, printcharfun);
  55 }
  56
  57 static inline size_t
  58 aligned_sizeof_opaque(size_t opaque_size)
  59         __attribute__((always_inline));
  60 static inline size_t
  61 aligned_sizeof_opaque(size_t opaque_size)
  62 {
  63         return ALIGN_SIZE(offsetof(Lisp_Opaque, data) + opaque_size,
  64                           ALIGNOF(max_align_t));
  65 }
  66
  67 static size_t sizeof_opaque(const void *header)
  68 {
  69         return aligned_sizeof_opaque(((const Lisp_Opaque *)header)->size);
  70 }
  71
  72 /* Return an opaque object of size SIZE.
  73    If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
  74    If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
  75    Else the object's data is initialized by copying from DATA. */
  76 Lisp_Object
  77 make_opaque(const void *data, size_t size)
  78 {
  79         Lisp_Opaque *p = (Lisp_Opaque *)
  80                 alloc_lcrecord(aligned_sizeof_opaque(size), &lrecord_opaque);
  81         p->size = size;
  82
  83         if (data == OPAQUE_CLEAR)
  84                 memset(p->data, '\0', size);
  85         else if (data == OPAQUE_UNINIT)
  86                 DO_NOTHING;
  87         else
  88                 memcpy(p->data, data, size);
  89
  90         {
  91                 Lisp_Object val;
  92                 XSETOPAQUE(val, p);
  93                 return val;
  94         }
  95 }
  96
  97 /* This will not work correctly for opaques with subobjects! */
  98
  99 static int equal_opaque(Lisp_Object obj1, Lisp_Object obj2, int depth)
 100 {
 101         size_t size;
 102         return ((size = XOPAQUE_SIZE(obj1)) == XOPAQUE_SIZE(obj2) &&
 103                 !memcmp(XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2), size));
 104 }
 105
 106 /* This will not work correctly for opaques with subobjects! */
 107
 108 static unsigned long hash_opaque(Lisp_Object obj, int depth)
 109 {
 110         if (XOPAQUE_SIZE(obj) == sizeof(unsigned long))
 111                 return *((unsigned long *)XOPAQUE_DATA(obj));
 112         else
 113                 return memory_hash(XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj));
 114 }
 115
 116 static const struct lrecord_description opaque_description[] = {
 117         {XD_END}
 118 };
 119
 120 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("opaque", opaque,
 121                                        0, print_opaque, 0,
 122                                        equal_opaque, hash_opaque,
 123                                        opaque_description,
 124                                        sizeof_opaque, Lisp_Opaque);
 125
 126 /* stuff to handle opaque pointers */
 127
 128 /* Should never, ever be called. (except by an external debugger) */
 129 static void
 130 print_opaque_ptr(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 131 {
 132         const Lisp_Opaque_Ptr *p = XOPAQUE_PTR(obj);
 133         char buf[200];
 134
 135         sprintf(buf,
 136                 "#<INTERNAL OBJECT (SXEmacs bug?) "
 137                 "(opaque-ptr, adr=%p) %p>", p->ptr, p);
 138         write_c_string(buf, printcharfun);
 139 }
 140
 141 static int equal_opaque_ptr(Lisp_Object obj1, Lisp_Object obj2, int depth)
 142 {
 143         return (XOPAQUE_PTR(obj1)->ptr == XOPAQUE_PTR(obj2)->ptr);
 144 }
 145
 146 static unsigned long hash_opaque_ptr(Lisp_Object obj, int depth)
 147 {
 148         return (unsigned long)XOPAQUE_PTR(obj)->ptr;
 149 }
 150
 151 DEFINE_LRECORD_IMPLEMENTATION("opaque-ptr", opaque_ptr,
 152                               0, print_opaque_ptr, 0,
 153                               equal_opaque_ptr, hash_opaque_ptr, 0,
 154                               Lisp_Opaque_Ptr);
 155
 156 Lisp_Object make_opaque_ptr(void *val)
 157 {
 158 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
 159         Lisp_Object res = wrap_object(
 160                 alloc_lcrecord(sizeof(Lisp_Opaque_Ptr), &lrecord_opaque_ptr));
 161 #else  /* !BDWGC */
 162         Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
 163 #endif  /* BDWGC */
 164         /* escrow val */
 165         set_opaque_ptr(res, val);
 166         return res;
 167 }
 168
 169 /* Be very very careful with this.  Same admonitions as with
 170    free_cons() apply. */
 171
 172 void free_opaque_ptr(Lisp_Object ptr)
 173 {
 174 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
 175         xfree(ptr);
 176 #else  /* !BDWGC */
 177         free_managed_lcrecord(Vopaque_ptr_free_list, ptr);
 178 #endif  /* BDWGC */
 179         return;
 180 }
 181
 182 void
 183 reinit_opaque_once_early(void)
 184 {
 185 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
 186         Vopaque_ptr_free_list =
 187                 make_lcrecord_list(sizeof(Lisp_Opaque_Ptr),
 188                                    &lrecord_opaque_ptr);
 189         staticpro_nodump(&Vopaque_ptr_free_list);
 190 #endif  /* !BDWGC */
 191         return;
 192 }
 193
 194 void init_opaque_once_early(void)
 195 {
 196         INIT_LRECORD_IMPLEMENTATION(opaque);
 197         INIT_LRECORD_IMPLEMENTATION(opaque_ptr);
 198
 199         reinit_opaque_once_early();
 200 }