--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/opaque.c	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,221 @@
+/* Opaque Lisp objects.
+   Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
+   Copyright (C) 1995, 1996 Ben Wing.
+
+This file is part of XEmacs.
+
+XEmacs is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with XEmacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Synched up with: Not in FSF. */
+
+/* Written by Ben Wing, October 1993. */
+
+/* "Opaque" is used internally to hold keep track of allocated memory
+   so it gets GC'd properly, and to store arbitrary data in places
+   where a Lisp_Object is required and which may get GC'd. (e.g.  as
+   the argument to record_unwind_protect()).  Once created in C,
+   opaque objects cannot be resized.
+
+   OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL.  Some code
+   depends on this.  As such, opaque objects are a generalization
+   of the Qunbound marker.
+
+   "Opaque lists" are used to keep track of lots of opaque objects
+   of a particular size so that they can be efficiently "freed" and
+   re-used again without actually entering the Lisp allocation system
+   (and consequently doing a malloc()).
+ */
+
+#include <config.h>
+#include "lisp.h"
+#include "opaque.h"
+
+Lisp_Object Qopaquep;
+
+static int in_opaque_list_marking;
+
+/* Holds freed opaque objects created with make_opaque_ptr().
+   We do this quite often so it's a noticeable win if we don't
+   create GC junk. */
+Lisp_Object Vopaque_ptr_free_list;
+
+static Lisp_Object mark_opaque (Lisp_Object, void (*) (Lisp_Object));
+static unsigned int sizeof_opaque (CONST void *header);
+static void print_opaque (Lisp_Object obj, Lisp_Object printcharfun,
+			  int escapeflag);
+DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
+					mark_opaque, print_opaque, 0, 0, 0,
+					sizeof_opaque, struct Lisp_Opaque);
+
+static Lisp_Object
+mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+#ifdef ERROR_CHECK_GC
+  if (!in_opaque_list_marking)
+    /* size is non-int for objects on an opaque free list.  We sure
+       as hell better not be marking any of these objects unless
+       we're marking an opaque list. */
+    assert (INTP (XOPAQUE (obj)->size_or_chain));
+  else
+    /* marking an opaque on the free list doesn't do any recursive
+       markings, so we better not have non-freed opaques on a free
+       list. */
+    assert (!INTP (XOPAQUE (obj)->size_or_chain));
+#endif
+  if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj))
+    return (XOPAQUE_MARKFUN (obj)) (obj, markobj);
+  else
+    return XOPAQUE (obj)->size_or_chain;
+}
+
+/* Should never, ever be called. (except by an external debugger) */
+static void
+print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+  char buf[200];
+  if (INTP (XOPAQUE (obj)->size_or_chain))
+    sprintf (buf, "#<INTERNAL EMACS BUG (opaque, size=%d) 0x%x>",
+	     (EMACS_INT) XOPAQUE_SIZE (obj),
+	     (EMACS_INT) XPNTR (obj));
+  else
+    sprintf (buf, "#<INTERNAL EMACS BUG (opaque, freed) 0x%x>",
+	     (EMACS_INT) XPNTR (obj));
+  write_c_string (buf, printcharfun);
+}
+
+static unsigned int
+sizeof_opaque (CONST void *header)
+{
+  CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header;
+  if (!INTP (p->size_or_chain))
+    return sizeof (*p);
+  return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int);
+}
+
+Lisp_Object
+make_opaque (int size, CONST void *data)
+{
+  struct Lisp_Opaque *p = alloc_lcrecord (sizeof (*p) + size - sizeof (int),
+					  lrecord_opaque);
+  Lisp_Object val;
+
+  p->markfun = 0;
+  p->size_or_chain = make_int (size);
+  if (data)
+    memcpy (p->data, data, size);
+  else
+    memset (p->data, 0, size);
+  XSETOPAQUE (val, p);
+  return val;
+}
+
+static Lisp_Object mark_opaque_list (Lisp_Object, void (*) (Lisp_Object));
+DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
+			       mark_opaque_list, internal_object_printer,
+			       0, 0, 0, struct Lisp_Opaque_List);
+
+static Lisp_Object
+mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+  in_opaque_list_marking++;
+  (markobj) (XOPAQUE_LIST (obj)->free);
+  in_opaque_list_marking--;
+  return Qnil;
+}
+
+Lisp_Object
+make_opaque_list (int size,
+		  Lisp_Object (*markfun) (Lisp_Object obj,
+					  void (*markobj) (Lisp_Object)))
+{
+  struct Lisp_Opaque_List *p = alloc_lcrecord (sizeof (*p),
+					       lrecord_opaque_list);
+  Lisp_Object val = Qnil;
+
+  p->markfun = markfun;
+  p->size = size;
+  p->free = Qnil;
+  XSETOPAQUE_LIST (val, p);
+  return val;
+}
+
+Lisp_Object
+allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
+{
+  struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
+  Lisp_Object val;
+
+  if (!NILP (li->free))
+    {
+      val = li->free;
+      li->free = XOPAQUE (val)->size_or_chain;
+#ifdef ERROR_CHECK_GC
+      assert (NILP (li->free) || OPAQUEP (li->free));
+#endif
+      XOPAQUE (val)->size_or_chain = make_int (li->size);
+      if (data)
+	memcpy (XOPAQUE (val)->data, data, li->size);
+      else
+	memset (XOPAQUE (val)->data, 0, li->size);
+    }
+  else
+    val = make_opaque (li->size, data);
+  XOPAQUE (val)->markfun = li->markfun;
+  return val;
+}
+
+void
+free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
+{
+  struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
+
+#ifdef ERROR_CHECK_GC
+  assert (INTP (XOPAQUE (opaque)->size_or_chain));
+#endif
+  XOPAQUE (opaque)->size_or_chain = li->free;
+  li->free = opaque;
+}
+
+/* stuff to handle opaque pointers */
+
+Lisp_Object
+make_opaque_ptr (CONST void *val)
+{
+  return allocate_managed_opaque (Vopaque_ptr_free_list,
+				  (CONST void *) &val);
+}
+
+/* Be wery wery careful with this.  Same admonitions as with
+   free_cons() apply. */
+
+void
+free_opaque_ptr (Lisp_Object ptr)
+{
+  free_managed_opaque (Vopaque_ptr_free_list, ptr);
+}
+
+Lisp_Object
+make_opaque_long (long val)
+{
+  return make_opaque (sizeof (val), (void *) &val);
+}
+
+void
+init_opaque_once_early (void)
+{
+  Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
+  staticpro (&Vopaque_ptr_free_list);
+}