git.chise.org Git - chise/xemacs-chise.git.1/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 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    "Opaque lists" are used to keep track of lots of opaque objects
  37    of a particular size so that they can be efficiently "freed" and
  38    re-used again without actually entering the Lisp allocation system
  39    (and consequently doing a malloc()).
  40  */
  41
  42 #include <config.h>
  43 #include "lisp.h"
  44 #include "opaque.h"
  45
  46 Lisp_Object Qopaquep;
  47
  48 static int in_opaque_list_marking;
  49
  50 /* Holds freed opaque objects created with make_opaque_ptr().
  51    We do this quite often so it's a noticeable win if we don't
  52    create GC junk. */
  53 Lisp_Object Vopaque_ptr_free_list;
  54
  55 static Lisp_Object
  56 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
  57 {
  58 #ifdef ERROR_CHECK_GC
  59   if (!in_opaque_list_marking)
  60     /* size is non-int for objects on an opaque free list.  We sure
  61        as hell better not be marking any of these objects unless
  62        we're marking an opaque list. */
  63     assert (INTP (XOPAQUE (obj)->size_or_chain));
  64   else
  65     /* marking an opaque on the free list doesn't do any recursive
  66        markings, so we better not have non-freed opaques on a free
  67        list. */
  68     assert (!INTP (XOPAQUE (obj)->size_or_chain));
  69 #endif
  70   if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj))
  71     return XOPAQUE_MARKFUN (obj) (obj, markobj);
  72   else
  73     return XOPAQUE (obj)->size_or_chain;
  74 }
  75
  76 /* Should never, ever be called. (except by an external debugger) */
  77 static void
  78 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  79 {
  80   char buf[200];
  81   if (INTP (XOPAQUE (obj)->size_or_chain))
  82     sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>",
  83              (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj));
  84   else
  85     sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>",
  86              (unsigned long) XPNTR (obj));
  87   write_c_string (buf, printcharfun);
  88 }
  89
  90 static size_t
  91 sizeof_opaque (CONST void *header)
  92 {
  93   CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header;
  94   if (!INTP (p->size_or_chain))
  95     return sizeof (*p);
  96   return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int);
  97 }
  98
  99 Lisp_Object
 100 make_opaque (int size, CONST void *data)
 101 {
 102   struct Lisp_Opaque *p = (struct Lisp_Opaque *)
 103     alloc_lcrecord (sizeof (*p) + size - sizeof (int), lrecord_opaque);
 104   Lisp_Object val;
 105
 106   p->markfun = 0;
 107   p->size_or_chain = make_int (size);
 108   if (data)
 109     memcpy (p->data, data, size);
 110   else
 111     memset (p->data, 0, size);
 112   XSETOPAQUE (val, p);
 113   return val;
 114 }
 115
 116 /* This will not work correctly for opaques with subobjects! */
 117
 118 static int
 119 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
 120 {
 121 #ifdef DEBUG_XEMACS
 122   assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
 123   assert (INTP (XOPAQUE(obj1)->size_or_chain));
 124   assert (INTP (XOPAQUE(obj2)->size_or_chain));
 125 #endif
 126   if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2))
 127     return 0;
 128   return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1))
 129           ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2)
 130           : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2),
 131                     XOPAQUE_SIZE(obj1)) == 0);
 132 }
 133
 134 /* This will not work correctly for opaques with subobjects! */
 135
 136 static unsigned long
 137 hash_opaque (Lisp_Object obj, int depth)
 138 {
 139 #ifdef DEBUG_XEMACS
 140   assert (!XOPAQUE_MARKFUN (obj));
 141   assert (INTP (XOPAQUE(obj)->size_or_chain));
 142 #endif
 143   if (XOPAQUE_SIZE(obj) == sizeof (unsigned long))
 144     return (unsigned int) *XOPAQUE_DATA(obj);
 145   else
 146     return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj));
 147 }
 148
 149 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
 150                                         mark_opaque, print_opaque, 0,
 151                                         equal_opaque, hash_opaque,
 152                                         sizeof_opaque, struct Lisp_Opaque);
 153
 154 static Lisp_Object
 155 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
 156 {
 157   in_opaque_list_marking++;
 158   (markobj) (XOPAQUE_LIST (obj)->free);
 159   in_opaque_list_marking--;
 160   return Qnil;
 161 }
 162
 163 Lisp_Object
 164 make_opaque_list (int size,
 165                   Lisp_Object (*markfun) (Lisp_Object obj,
 166                                           void (*markobj) (Lisp_Object)))
 167 {
 168   Lisp_Object val;
 169   struct Lisp_Opaque_List *p =
 170     alloc_lcrecord_type (struct Lisp_Opaque_List, lrecord_opaque_list);
 171
 172   p->markfun = markfun;
 173   p->size = size;
 174   p->free = Qnil;
 175   XSETOPAQUE_LIST (val, p);
 176   return val;
 177 }
 178
 179 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
 180                                mark_opaque_list, internal_object_printer,
 181                                0, 0, 0, struct Lisp_Opaque_List);
 182
 183 Lisp_Object
 184 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
 185 {
 186   struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 187   Lisp_Object val;
 188
 189   if (!NILP (li->free))
 190     {
 191       val = li->free;
 192       li->free = XOPAQUE (val)->size_or_chain;
 193 #ifdef ERROR_CHECK_GC
 194       assert (NILP (li->free) || OPAQUEP (li->free));
 195 #endif
 196       XOPAQUE (val)->size_or_chain = make_int (li->size);
 197       if (data)
 198         memcpy (XOPAQUE (val)->data, data, li->size);
 199       else
 200         memset (XOPAQUE (val)->data, 0, li->size);
 201     }
 202   else
 203     val = make_opaque (li->size, data);
 204   XOPAQUE (val)->markfun = li->markfun;
 205   return val;
 206 }
 207
 208 void
 209 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
 210 {
 211   struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 212
 213 #ifdef ERROR_CHECK_GC
 214   assert (INTP (XOPAQUE (opaque)->size_or_chain));
 215 #endif
 216   XOPAQUE (opaque)->size_or_chain = li->free;
 217   li->free = opaque;
 218 }
 219
 220 /* stuff to handle opaque pointers */
 221
 222 Lisp_Object
 223 make_opaque_ptr (CONST void *val)
 224 {
 225   return allocate_managed_opaque (Vopaque_ptr_free_list,
 226                                   (CONST void *) &val);
 227 }
 228
 229 /* Be wery wery careful with this.  Same admonitions as with
 230    free_cons() apply. */
 231
 232 void
 233 free_opaque_ptr (Lisp_Object ptr)
 234 {
 235   free_managed_opaque (Vopaque_ptr_free_list, ptr);
 236 }
 237
 238 Lisp_Object
 239 make_opaque_long (long val)
 240 {
 241   return make_opaque (sizeof (val), (void *) &val);
 242 }
 243
 244 void
 245 init_opaque_once_early (void)
 246 {
 247   Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
 248   staticpro (&Vopaque_ptr_free_list);
 249 }