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