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
  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 static size_t
  56 sizeof_opaque (CONST void *header)
  57 {
  58   CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
  59   return offsetof (Lisp_Opaque, data) + p->size;
  60 }
  61
  62 /* Return an opaque object of size SIZE.
  63    If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
  64    If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
  65    Else the object's data is initialized by copying from DATA. */
  66 Lisp_Object
  67 make_opaque (size_t size, CONST void *data)
  68 {
  69   Lisp_Opaque *p = (Lisp_Opaque *)
  70     alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
  71   p->size = size;
  72
  73   if (data == OPAQUE_CLEAR)
  74     memset (p->data, '\0', size);
  75   else if (data == OPAQUE_UNINIT)
  76     DO_NOTHING;
  77   else
  78     memcpy (p->data, data, size);
  79
  80   {
  81     Lisp_Object val;
  82     XSETOPAQUE (val, p);
  83     return val;
  84   }
  85 }
  86
  87 /* This will not work correctly for opaques with subobjects! */
  88
  89 static int
  90 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
  91 {
  92   size_t size;
  93   return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
  94           !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
  95 }
  96
  97 /* This will not work correctly for opaques with subobjects! */
  98
  99 static unsigned long
 100 hash_opaque (Lisp_Object obj, int depth)
 101 {
 102   if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
 103     return *((unsigned long *) XOPAQUE_DATA (obj));
 104   else
 105     return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
 106 }
 107
 108 static const struct lrecord_description opaque_description[] = {
 109   { XD_END }
 110 };
 111
 112 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
 113                                         0, print_opaque, 0,
 114                                         equal_opaque, hash_opaque,
 115                                         opaque_description,
 116                                         sizeof_opaque, Lisp_Opaque);
 117
 118 /* stuff to handle opaque pointers */
 119
 120 /* Should never, ever be called. (except by an external debugger) */
 121 static void
 122 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 123 {
 124   CONST Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj);
 125   char buf[200];
 126
 127   sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque_ptr, adr=0x%lx) 0x%lx>",
 128            (long)(p->ptr), (unsigned long) p);
 129   write_c_string (buf, printcharfun);
 130 }
 131
 132 static int
 133 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int depth)
 134 {
 135   return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr);
 136 }
 137
 138 static unsigned long
 139 hash_opaque_ptr (Lisp_Object obj, int depth)
 140 {
 141   return (unsigned long) XOPAQUE_PTR (obj)->ptr;
 142 }
 143
 144 DEFINE_LRECORD_IMPLEMENTATION ("opaque_ptr", opaque_ptr,
 145                                0, print_opaque_ptr, 0,
 146                                equal_opaque_ptr, hash_opaque_ptr, 0,
 147                                Lisp_Opaque_Ptr);
 148
 149 Lisp_Object
 150 make_opaque_ptr (void *val)
 151 {
 152   Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
 153   set_opaque_ptr (res, val);
 154   return res;
 155 }
 156
 157 /* Be very very careful with this.  Same admonitions as with
 158    free_cons() apply. */
 159
 160 void
 161 free_opaque_ptr (Lisp_Object ptr)
 162 {
 163   free_managed_lcrecord (Vopaque_ptr_free_list, ptr);
 164 }
 165
 166 void
 167 reinit_opaque_once_early (void)
 168 {
 169   Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), &lrecord_opaque_ptr);
 170   staticpro_nodump (&Vopaque_ptr_free_list);
 171 }
 172
 173 void
 174 init_opaque_once_early (void)
 175 {
 176   reinit_opaque_once_early ();
 177 }