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 }