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 #include <stddef.h>
  46
  47 Lisp_Object Qopaquep;
  48
  49 static int in_opaque_list_marking;
  50
  51 /* Holds freed opaque objects created with make_opaque_ptr().
  52    We do this quite often so it's a noticeable win if we don't
  53    create GC junk. */
  54 Lisp_Object Vopaque_ptr_free_list;
  55
  56 static Lisp_Object
  57 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
  58 {
  59   Lisp_Opaque *p = XOPAQUE (obj);
  60   /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
  61   Lisp_Object size_or_chain = p->size_or_chain;
  62 #ifdef ERROR_CHECK_GC
  63   if (!in_opaque_list_marking)
  64     /* size is non-int for objects on an opaque free list.  We sure
  65        as hell better not be marking any of these objects unless
  66        we're marking an opaque list. */
  67     assert (GC_INTP (size_or_chain));
  68   else
  69     /* marking an opaque on the free list doesn't do any recursive
  70        markings, so we better not have non-freed opaques on a free
  71        list. */
  72     assert (!GC_INTP (size_or_chain));
  73 #endif
  74   if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
  75     return OPAQUE_MARKFUN (p) (obj, markobj);
  76   else
  77     return size_or_chain;
  78 }
  79
  80 /* Should never, ever be called. (except by an external debugger) */
  81 static void
  82 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  83 {
  84   CONST Lisp_Opaque *p = XOPAQUE (obj);
  85   /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
  86   Lisp_Object size_or_chain = p->size_or_chain;
  87   char buf[200];
  88   char size_buf[50];
  89
  90   if (INTP (size_or_chain))
  91     sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
  92   else
  93     sprintf (size_buf, "freed");
  94
  95   sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
  96            size_buf, (unsigned long) p);
  97   write_c_string (buf, printcharfun);
  98 }
  99
 100 static size_t
 101 sizeof_opaque (CONST void *header)
 102 {
 103   CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
 104   /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
 105   Lisp_Object size_or_chain = p->size_or_chain;
 106   return offsetof (Lisp_Opaque, data)
 107     + (GC_INTP (size_or_chain) ? XINT (size_or_chain) : 0);
 108 }
 109
 110 /* Return an opaque object of size SIZE.
 111    If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
 112    If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
 113    Else the object's data is initialized by copying from DATA. */
 114 Lisp_Object
 115 make_opaque (size_t size, CONST void *data)
 116 {
 117   Lisp_Opaque *p = (Lisp_Opaque *)
 118     alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
 119   p->markfun = 0;
 120   p->size_or_chain = make_int (size);
 121
 122   if (data == OPAQUE_CLEAR)
 123     memset (p->data, '\0', size);
 124   else if (data == OPAQUE_UNINIT)
 125     DO_NOTHING;
 126   else
 127     memcpy (p->data, data, size);
 128
 129   {
 130     Lisp_Object val;
 131     XSETOPAQUE (val, p);
 132     return val;
 133   }
 134 }
 135
 136 /* This will not work correctly for opaques with subobjects! */
 137
 138 static int
 139 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
 140 {
 141 #ifdef DEBUG_XEMACS
 142   {
 143     /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
 144     Lisp_Object size_or_chain_1 = XOPAQUE (obj1)->size_or_chain;
 145     Lisp_Object size_or_chain_2 = XOPAQUE (obj2)->size_or_chain;
 146     assert (INTP (size_or_chain_1));
 147     assert (INTP (size_or_chain_2));
 148     assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
 149   }
 150 #endif
 151   {
 152     size_t size;
 153     return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
 154             !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
 155   }
 156 }
 157
 158 /* This will not work correctly for opaques with subobjects! */
 159
 160 static unsigned long
 161 hash_opaque (Lisp_Object obj, int depth)
 162 {
 163 #ifdef DEBUG_XEMACS
 164   {
 165     /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
 166     Lisp_Object size_or_chain = XOPAQUE (obj)->size_or_chain;
 167     assert (INTP (size_or_chain));
 168     assert (!XOPAQUE_MARKFUN (obj));
 169   }
 170 #endif
 171   if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
 172     return *((unsigned long *) XOPAQUE_DATA (obj));
 173   else
 174     return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
 175 }
 176
 177 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
 178                                         mark_opaque, print_opaque, 0,
 179                                         equal_opaque, hash_opaque,
 180                                         sizeof_opaque, Lisp_Opaque);
 181
 182 static Lisp_Object
 183 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
 184 {
 185   in_opaque_list_marking++;
 186   markobj (XOPAQUE_LIST (obj)->free);
 187   in_opaque_list_marking--;
 188   return Qnil;
 189 }
 190
 191 Lisp_Object
 192 make_opaque_list (size_t size,
 193                   Lisp_Object (*markfun) (Lisp_Object obj,
 194                                           void (*markobj) (Lisp_Object)))
 195 {
 196   Lisp_Object val;
 197   Lisp_Opaque_List *p =
 198     alloc_lcrecord_type (Lisp_Opaque_List, &lrecord_opaque_list);
 199
 200   p->markfun = markfun;
 201   p->size = size;
 202   p->free = Qnil;
 203   XSETOPAQUE_LIST (val, p);
 204   return val;
 205 }
 206
 207 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
 208                                mark_opaque_list, internal_object_printer,
 209                                0, 0, 0, Lisp_Opaque_List);
 210
 211 Lisp_Object
 212 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
 213 {
 214   Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 215   Lisp_Object val;
 216
 217   if (!NILP (li->free))
 218     {
 219       val = li->free;
 220       li->free = XOPAQUE (val)->size_or_chain;
 221 #ifdef ERROR_CHECK_GC
 222       assert (NILP (li->free) || OPAQUEP (li->free));
 223 #endif
 224       XOPAQUE (val)->size_or_chain = make_int (li->size);
 225       if (data)
 226         memcpy (XOPAQUE (val)->data, data, li->size);
 227       else
 228         memset (XOPAQUE (val)->data, 0, li->size);
 229     }
 230   else
 231     val = make_opaque (li->size, data);
 232   XOPAQUE (val)->markfun = li->markfun;
 233   return val;
 234 }
 235
 236 void
 237 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
 238 {
 239   Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 240
 241 #ifdef ERROR_CHECK_GC
 242   {
 243     /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
 244     Lisp_Object size_or_chain = XOPAQUE (opaque)->size_or_chain;
 245     assert (INTP (size_or_chain));
 246   }
 247 #endif
 248   XOPAQUE (opaque)->size_or_chain = li->free;
 249   li->free = opaque;
 250 }
 251
 252 /* stuff to handle opaque pointers */
 253
 254 Lisp_Object
 255 make_opaque_ptr (CONST void *val)
 256 {
 257   return allocate_managed_opaque (Vopaque_ptr_free_list,
 258                                   (CONST void *) &val);
 259 }
 260
 261 /* Be very very careful with this.  Same admonitions as with
 262    free_cons() apply. */
 263
 264 void
 265 free_opaque_ptr (Lisp_Object ptr)
 266 {
 267   free_managed_opaque (Vopaque_ptr_free_list, ptr);
 268 }
 269
 270 Lisp_Object
 271 make_opaque_long (long val)
 272 {
 273   return make_opaque (sizeof (val), (void *) &val);
 274 }
 275
 276 void
 277 init_opaque_once_early (void)
 278 {
 279   Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
 280   staticpro (&Vopaque_ptr_free_list);
 281 }