/* The "lrecord" structure (header of a compound lisp object).
   Copyright (C) 1993, 1994 Free Software Foundation, Inc.

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, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/* Synched up with: Not in FSF. */

#ifndef _XEMACS_LRECORD_H_
#define _XEMACS_LRECORD_H_

/* The "lrecord" type of Lisp object is used for all object types
   other than a few simple ones.  This allows many types to be
   implemented but only a few bits required in a Lisp object for
   type information. (The tradeoff is that each object has its
   type marked in it, thereby increasing its size.) The first
   four bytes of all lrecords is a pointer to a struct
   lrecord_implementation, which contains methods describing
   how to process this object.

   lrecords are of two types: straight lrecords, and lcrecords.
   Straight lrecords are used for those types of objects that
   have their own allocation routines (typically allocated out
   of 2K chunks of memory).  These objects have a
   `struct lrecord_header' at the top, containing only the
   implementation pointer.  There are special routines in alloc.c
   to deal with each such object type.

   Lcrecords are used for less common sorts of objects that don't
   do their own allocation.  Each such object is malloc()ed
   individually, and the objects are chained together through
   a `next' pointer.  Lcrecords have a `struct lcrecord_header'
   at the top, which contains an implementation pointer and
   a `next' pointer, and are allocated using alloc_lcrecord().

   Creating a new lcrecord type is fairly easy; just follow the
   lead of some existing type (e.g. hashtables).  Note that you
   do not need to supply all the methods (see below); reasonable
   defaults are provided for many of them.  Alternatively, if you're
   just looking for a way of encapsulating data (which possibly
   could contain Lisp_Objects in it), you may well be able to use
   the opaque type. */

struct lrecord_header
  {
    /* It would be better to put the mark-bit together with the
     * following datatype identification field in an 8- or 16-bit integer
     *  rather than playing funny games with changing header->implementation
     *  and "wasting" 32 bits on the below pointer.
     *  The type-id would then be a 7 or 15
     *  bit index into a table of lrecord-implementations rather than a
     *  direct pointer.  There would be 24 (or 16) bits left over for
     *  datatype-specific per-instance flags.
     * The below is the simplest thing to do for the present,
     *  and doesn't incur that much overhead as most Emacs records
     *  are of such a size that the overhead isn't too bad.
     *  (The marker datatype is the worst case.)
     *  It also has the very very very slight advantage that type-checking
     *  involves one memory read (of the "implementation" slot) and a
     *  comparison against a link-time constant address rather than a
     *  read and a comparison against a variable value. (Variable since
     *  it is a very good idea to assign the indices into the hypothetical
     *  type-code table dynamically rather that pre-defining them.)
     *  I think I remember that Elk Lisp does something like this.
     *  Gee, I wonder if some cretin has patented it?
     */
    CONST struct lrecord_implementation *implementation;
  };
#define set_lheader_implementation(header,imp) (header)->implementation=(imp)

struct lcrecord_header
  {
    struct lrecord_header lheader;
    /* The "next" field is normally used to chain all lrecords together
     *  so that the GC can find (and free) all of them.
     *  "alloc_lcrecord" threads records together.
     * The "next" field may be used for other purposes as long as some
     *  other mechanism is provided for letting the GC do its work.
     *  (For example, the event and marker datatypes allocates members out
     *  of memory chunks, and it are able to find all unmarked
     *  events by sweeping through the elements of the list of chunks)
     */
    struct lcrecord_header *next;
    /* This is just for debugging/printing convenience.
       Having this slot doesn't hurt us much spacewise, since an lcrecord
       already has the above slots together with malloc overhead. */
    int uid;
  };

/* This as the value of lheader->implementation->finalizer 
 *  means that this record is already marked */
extern void this_marks_a_marked_record (void *, int);

/* see alloc.c for an explanation */
extern Lisp_Object this_one_is_unmarkable (Lisp_Object obj,
					   void (*markobj) (Lisp_Object));

struct lrecord_implementation
  {
    CONST char *name;
    /* This function is called at GC time, to make sure that all Lisp_Objects
       pointed to by this object get properly marked.  It should call
       the mark_object function on all Lisp_Objects in the object.  If
       the return value is non-nil, it should be a Lisp_Object to be
       marked (don't call the mark_object function explicitly on it,
       because the GC routines will do this).  Doing it this way reduces
       recursion, so the object returned should preferably be the one
       with the deepest level of Lisp_Object pointers.  This function
       can be NULL, meaning no GC marking is necessary. */
    Lisp_Object (*marker) (Lisp_Object, void (*mark_object) (Lisp_Object));
    /* This can be NULL if the object is an lcrecord; the
       default_object_printer() in print.c will be used. */
    void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag);
    /* This function is called at GC time when the object is about to
       be freed, and at dump time (FOR_DISKSAVE will be non-zero in this
       case).  It should perform any necessary cleanup (e.g. freeing
       malloc()ed memory.  This can be NULL, meaning no special
       finalization is necessary.
       
       WARNING: The finalizer will be called multiple times if there are
       multiple pointers to the object.  Therefore, your routine *must*
       ensure that it doesn't mess up (e.g. free a memory block twice) if
       called twice on the same object.  Also remember that the finalizer
       is called at dump time even though the object is not being freed. */
    void (*finalizer) (void *header, int for_disksave);
    /* This can be NULL, meaning compare objects with EQ(). */
    int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth);
    /* This can be NULL, meaning use the Lisp_Object itself as the hash;
       but *only* if the `equal' function is EQ (if two objects are
       `equal', they *must* hash to the same value or the hashing won't
       work). */
    unsigned long (*hash) (Lisp_Object, int);
    int (*getprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object *value_out);
    int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val);
    int (*remprop) (Lisp_Object obj, Lisp_Object prop);
    Lisp_Object (*props) (Lisp_Object obj);

    /* Only one of these is non-0.  If both are 0, it means that this type
       is not instantiable by alloc_lcrecord(). */
    unsigned int static_size;
    unsigned int (*size_in_bytes_method) (CONST void *header);
    /* A unique subtag-code (dynamically) assigned to this datatype. */
    /* (This is a pointer so the rest of this structure can be read-only.) */
    int *lrecord_type_index;
  };

#define MARKED_RECORD_P(obj) (gc_in_progress &&				\
  XRECORD_LHEADER (obj)->implementation->finalizer ==			\
  this_marks_a_marked_record)

/* Declaring the following structures as const puts them in the
   text (read-only) segment, which makes debugging inconvenient
   because this segment is not mapped when processing a core-
   dump file */

#ifdef DEBUG_XEMACS
#define CONST_IF_NOT_DEBUG
#else
#define CONST_IF_NOT_DEBUG CONST
#endif

/* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size.
   DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies.
 */

/* This uses macros instead of a separate function call to verify
   the type of the Lisp_Object deferenced in XRECORD().

   For as yet unknown reasons, this makes things break in a spectacular
   fashion using the Dec CC compiler on the Alphas.  Yet another
   compiler bug, no doubt. */

#ifndef BROKEN_MACROIZE_ERROR_CHECKING
# define MACROIZE_ERROR_CHECKING
#endif

#if defined (ERROR_CHECK_TYPECHECK) && !defined (MACROIZE_ERROR_CHECKING)
# define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)		\
structtype *								\
error_check_##c_name (Lisp_Object _obj)					\
{									\
  XUNMARK (_obj);							\
  assert (RECORD_TYPEP (_obj, lrecord_##c_name) ||			\
	  MARKED_RECORD_P (_obj));					\
  return (structtype *) XPNTR (_obj);					\
}
#else
# define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)
#endif

#define DEFINE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,structtype) \
DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)			\
static int lrecord_##c_name##_lrecord_type_index; 			\
CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] =	\
  { { name, marker, printer, nuker, equal, hash,			\
      0, 0, 0, 0, sizeof (structtype), 0,				\
      &(lrecord_##c_name##_lrecord_type_index) }, 			\
    { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }

#define DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \
DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)			\
static int lrecord_##c_name##_lrecord_type_index; 			\
CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] =	\
  { { name, marker, printer, nuker, equal, hash,			\
      getprop, putprop, remprop, props, sizeof (structtype), 0,		\
      &(lrecord_##c_name##_lrecord_type_index) }, 			\
    { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }

#define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,sizer,structtype) \
DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)			\
static int lrecord_##c_name##_lrecord_type_index;			\
CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] =	\
  { { name, marker, printer, nuker, equal, hash,			\
      0, 0, 0, 0, 0, sizer,						\
      &(lrecord_##c_name##_lrecord_type_index) },			\
    { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }

#define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizer,structtype) \
DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)			\
static int lrecord_##c_name##_lrecord_type_index;			\
CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] =	\
  { { name, marker, printer, nuker, equal, hash,			\
      getprop, putprop, remprop, props, 0, sizer,			\
      &(lrecord_##c_name##_lrecord_type_index) },			\
    { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }

#define LRECORDP(a) (XTYPE ((a)) == Lisp_Record)
#define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a))
#define RECORD_TYPEP(x, ty) \
  (LRECORDP (x) && XRECORD_LHEADER (x)->implementation == (ty))

/* NOTE: the DECLARE_LRECORD() must come before the associated
   DEFINE_LRECORD_*() or you will get compile errors. */

#ifdef ERROR_CHECK_TYPECHECK

# define DECLARE_LRECORD(c_name, structtype)				\
extern Lisp_Object Q##c_name##p;					\
extern structtype *error_check_##c_name (Lisp_Object _obj);		\
extern CONST_IF_NOT_DEBUG struct lrecord_implementation			\
  lrecord_##c_name[]
# define DECLARE_NONRECORD(c_name, structtype)				\
extern Lisp_Object Q##c_name##p;					\
extern structtype *error_check_##c_name (Lisp_Object _obj)

# ifdef MACROIZE_ERROR_CHECKING
MAC_DECLARE_EXTERN (Lisp_Object, mactemp_xrecord)
#  define XRECORD(x, c_name, structtype)			\
MAC_BEGIN							\
  MAC_DECLARE (Lisp_Object, mactemp_xrecord, x)			\
  XUNMARK (mactemp_xrecord)					\
  MAC_SEP							\
  assert (RECORD_TYPEP (mactemp_xrecord, lrecord_##c_name) ||	\
	 MARKED_RECORD_P (mactemp_xrecord))			\
  MAC_SEP							\
  (structtype *) XPNTR (mactemp_xrecord)			\
MAC_END
#  define XNONRECORD(x, c_name, type_enum, structtype)		\
MAC_BEGIN							\
  MAC_DECLARE (Lisp_Object, mactemp_xrecord, x)			\
  XUNMARK (mactemp_xrecord)					\
  MAC_SEP							\
  assert (XTYPE (mactemp_xrecord) == type_enum ||		\
	 MARKED_RECORD_P (mactemp_xrecord))			\
  MAC_SEP							\
  (structtype *) XPNTR (mactemp_xrecord)			\
MAC_END

# else /* not MACROIZE_ERROR_CHECKING */

#  define XRECORD(x, c_name, structtype) error_check_##c_name (x)
#  define XNONRECORD(x, c_name, type_enum, structtype)		\
  error_check_##c_name (x)

# endif /* not MACROIZE_ERROR_CHECKING */

# define XSETRECORD(var, p, c_name) do					\
{									\
  XSETOBJ (var, Lisp_Record, p);					\
  assert (RECORD_TYPEP (var, lrecord_##c_name) ||			\
	  MARKED_RECORD_P (var));					\
} while (0)

#else /* not ERROR_CHECK_TYPECHECK */

# define DECLARE_LRECORD(c_name, structtype)				\
extern Lisp_Object Q##c_name##p;					\
extern CONST_IF_NOT_DEBUG struct lrecord_implementation			\
  lrecord_##c_name[]
# define DECLARE_NONRECORD(c_name, structtype)				\
extern Lisp_Object Q##c_name##p
# define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x))
# define XNONRECORD(x, c_name, type_enum, structtype)			\
  ((structtype *) XPNTR (x))
# define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Record, p)

#endif /* not ERROR_CHECK_TYPECHECK */

#define RECORDP(x, c_name) RECORD_TYPEP (x, lrecord_##c_name)
#define CHECK_RECORD(x, c_name) do					\
{ if (!RECORD_TYPEP (x, lrecord_##c_name))				\
    x = wrong_type_argument (Q##c_name##p, x); }			\
  while (0)

extern void *alloc_lcrecord (int size, CONST struct lrecord_implementation *);

extern int gc_record_type_p (Lisp_Object frob,
			     CONST struct lrecord_implementation *type);

/* Copy the data from one lcrecord structure into another, but don't
   overwrite the header information. */

#define copy_lcrecord(dst, src)						\
  memcpy ((char *) dst + sizeof (struct lcrecord_header),		\
	  (char *) src + sizeof (struct lcrecord_header),		\
	  sizeof (*dst) - sizeof (struct lcrecord_header))

#define zero_lcrecord(lcr)						\
   memset ((char *) lcr + sizeof (struct lcrecord_header), 0,		\
	   sizeof (*lcr) - sizeof (struct lcrecord_header))

#endif /* _XEMACS_LRECORD_H_ */
