diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/configure xemacs-20.0-b26/configure --- xemacs-20.0-b26-orig/configure Thu Jun 20 19:48:39 1996 +++ xemacs-20.0-b26/configure Thu Jul 18 12:40:10 1996 @@ -94,4 +94,5 @@ dynamic='' with_x11='' +with_shlib='' rel_alloc='default' use_system_malloc='default' @@ -227,4 +228,5 @@ This doesn't currently work. --with-socks Compile with support for SOCKS (an Internet proxy). +--with-shlib Compile with support for SHLIB. --with-term Compile with support for TERM (a way to multiplex serial lines and provide vaguely Internet-like @@ -604,4 +606,20 @@ ;; + ## Has the user requested SHLIB support? + "with_shlib" ) + ## Make sure the value given was either "yes" or "no". + case "${val}" in + y | ye | yes ) val=yes ;; + n | no ) val=no ;; + * ) + (echo "${progname}: the \`--${optname}' option is supposed to have a boolean value. +Set it to either \`yes' or \`no'." + echo "${short_usage}") >&2 + exit 1 + ;; + esac + eval "${opt}=\"${val}\"" + ;; + ## Has the user requested TERM support? "with_term" ) @@ -3821,4 +3839,10 @@ #endif +#ifdef SHLIB_LL_OBJS +configure___ SHLIBLLOBJS=SHLIB_LL_OBJS +#else +configure___ SHLIBLLOBJS= +#endif + #ifdef SYSTEM_MALLOC configure___ system_malloc=yes @@ -7741,4 +7765,22 @@ fi +if [ "${with_shlib}" = "yes" ]; then + if [ "x${SHLIBLLOBJS}" = "x" ]; then + echo " --with-shlib=yes not supported for ${configuration}" + with_shlib=no + else +{ +test -n "$verbose" && \ +echo " defining HAVE_SHLIB" +echo "#define" HAVE_SHLIB "1" >> confdefs.h +DEFS="$DEFS -DHAVE_SHLIB=1" +ac_sed_defs="${ac_sed_defs}\${ac_dA}HAVE_SHLIB\${ac_dB}HAVE_SHLIB\${ac_dC}1\${ac_dD} +\${ac_uA}HAVE_SHLIB\${ac_uB}HAVE_SHLIB\${ac_uC}1\${ac_uD} +\${ac_eA}HAVE_SHLIB\${ac_eB}HAVE_SHLIB\${ac_eC}1\${ac_eD} +" +} + +fi +fi if [ "${with_term}" = "yes" ]; then @@ -8099,4 +8141,7 @@ if [ "$with_socks" = "yes" ]; then echo " Compiling in support for SOCKS." +fi +if [ "$with_shlib" = "yes" ]; then + echo " Compiling in support for SHLIB." fi if [ "$with_term" = "yes" ]; then diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/configure.in xemacs-20.0-b26/configure.in --- xemacs-20.0-b26-orig/configure.in Sat Jun 22 16:18:17 1996 +++ xemacs-20.0-b26/configure.in Mon Jul 8 14:36:24 1996 @@ -242,4 +242,5 @@ This doesn't currently work. --with-socks Compile with support for SOCKS (an Internet proxy). +--with-shlib Compile with support for SHLIB. --with-term Compile with support for TERM (a way to multiplex serial lines and provide vaguely Internet-like @@ -619,4 +620,20 @@ ;; + ## Has the user requested SHLIB support? + "with_shlib" ) + ## Make sure the value given was either "yes" or "no". + case "${val}" in + y | ye | yes ) val=yes ;; + n | no ) val=no ;; + * ) + (echo "${progname}: the \`--${optname}' option is supposed to have a boolean value. +Set it to either \`yes' or \`no'." + echo "${short_usage}") >&2 + exit 1 + ;; + esac + eval "${opt}=\"${val}\"" + ;; + ## Has the user requested TERM support? "with_term" ) @@ -2995,4 +3012,10 @@ #endif +#ifdef SHLIB_TYPE +configure___ SHLIBTYPE=SHLIB_TYPE +#else +configure___ SHLIBTYPE= +#endif + #ifdef SYSTEM_MALLOC configure___ system_malloc=yes @@ -4200,4 +4223,12 @@ ] AC_DEFINE(HAVE_SOCKS) [ fi +if [ "${with_shlib}" = "yes" ]; then + if [ "x${SHLIBTYPE}" = "x" ]; then + echo " --with-shlib=yes not supported for ${configuration}" + with_shlib=no + else + ] AC_DEFINE(HAVE_SHLIB) [ + fi +fi if [ "${with_term}" = "yes" ]; then ] AC_DEFINE(HAVE_TERM) [ @@ -4349,4 +4380,7 @@ if [ "$with_socks" = "yes" ]; then echo " Compiling in support for SOCKS." +fi +if [ "$with_shlib" = "yes" ]; then + echo " Compiling in support for SHLIB (type: $SHLIBTYPE)." fi if [ "$with_term" = "yes" ]; then diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/lisp/prim/loadup.el xemacs-20.0-b26/lisp/prim/loadup.el --- xemacs-20.0-b26-orig/lisp/prim/loadup.el Fri Jun 7 14:28:04 1996 +++ xemacs-20.0-b26/lisp/prim/loadup.el Wed Jul 17 09:42:12 1996 @@ -170,4 +170,6 @@ (if (featurep 'dialog) (funcall l "dialog")) + (if (featurep 'shlib) + (funcall l "shlib")) (if (featurep 'mule) (funcall l "mule-load.el")) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/lisp/prim/shlib.el xemacs-20.0-b26/lisp/prim/shlib.el --- xemacs-20.0-b26-orig/lisp/prim/shlib.el Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/lisp/prim/shlib.el Thu Jul 18 08:24:10 1996 @@ -0,0 +1,32 @@ +;;; shlib.el --- Lisp level functions for "Shared Libraries" support + + +;; 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 + +;; This file is loaded from loadup.el, but only if the feature shlib is defined. + +;;; Code: + +(add-hook 'post-gc-hook 'finalize-all-unload-shlib) + +;; ###TM###: (defun list-shlibs () +;; somewhat like list-processes&co + + +;;; shlib.el ends here diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/Makefile.in.in xemacs-20.0-b26/src/Makefile.in.in --- xemacs-20.0-b26-orig/src/Makefile.in.in Sat Jun 22 00:49:59 1996 +++ xemacs-20.0-b26/src/Makefile.in.in Thu Jul 18 12:38:39 1996 @@ -375,4 +375,10 @@ #endif +#ifdef HAVE_SHLIB +# define SHLIB_OBJS shlib.o SHLIB_LL_OBJS +#else +# define SHLIB_OBJS +#endif + #ifdef HAVE_PNG # ifdef HAVE_PNG_GNUZ @@ -862,4 +868,16 @@ #endif +/* Support shared-libraries for some of the objects */ + +#ifdef MAKE_SHLIB_MD5 +# define ALL_SHLIB_MD5 libemacsmd5.so.1 +# define MD5_OBJS +#else +# define ALL_SHLIB_MD5 +# define MD5_OBJS md5.o +#endif + +#define ALL_SHLIB_LIBS ALL_SHLIB_MD5 + /* lastfile must follow all files whose initialized data areas should be dumped as pure by dump-emacs. @@ -870,5 +888,5 @@ objs= abbrev.o alloc.o blocktype.o buffer.o bytecode.o \ - callint.o callproc.o casefiddle.o casetab.o chartab.o cmdloop.o \ + callint.o callproc.o casefiddle.o casetab.o chartab.o classes.o cmdloop.o \ cmds.o console.o console-stream.o \ data.o DATABASE_OBJS DEBUG_OBJS device.o DIALOG_OBJS dired.o doc.o \ @@ -878,10 +896,10 @@ faces.o fileio.o filelock.o filemode.o floatfns.o fns.o font-lock.o \ frame.o \ - general.o getloadavg.o GIF_OBJS glyphs.o GUI_OBJS \ + general.o getloadavg.o GIF_OBJS SHLIB_OBJS glyphs.o GUI_OBJS \ hash.o \ indent.o inline.o insdel.o intl.o \ keymap.o \ lread.o lstream.o \ - macros.o marker.o md5.o MENUBAR_OBJS minibuf.o MOCKLISPOBJS \ + macros.o marker.o MD5_OBJS MENUBAR_OBJS minibuf.o MOCKLISPOBJS \ NAS_OBJS NSOBJS \ objects.o opaque.o \ @@ -953,4 +971,29 @@ allocaobjs = @ALLOCA@ +/* Now we try to figure out how to link a shared library. + If we can't figure it out, leave SHARED_LINK undefined and a shared + library will not be created. */ + +#ifdef USE_GCC +# ifdef USG5 +# define SHARED_LINK(objs, output) $(CC) -shared objs -Xlinker -z -Xlinker text -o output + /* I can't figure out how to do shared a.out libraries, so just punt. */ +# elif !defined (LINUX) || defined (__ELF__) +# define SHARED_LINK(objs, output) $(CC) -shared objs -o output +# endif +#elif defined (USG5) +# if defined (IRIX) +# define SHARED_LINK(objs, output) $(LD) -shared -g -check_registry ${TOOLROOT}/usr/lib/so_locations objs -o output +# else /* not IRIX */ +# define SHARED_LINK(objs, output) $(CC) -G objs -z text -o output +# endif /* not IRIX */ +#else /* not USG5 */ +# if defined (DEC_ALPHA) && defined (OSF1) +# define SHARED_LINK(objs, output) ld $(CFLAGS) $(LDFLAGS) LD_SWITCH_SHARED -d objs -o output $(LIBES) -lc +# else /* !(DEC_ALPHA && OSF1) */ +# define SHARED_LINK(objs, output) $(LD) -dc objs -assert pure-text -o output +# endif /* !(DEC_ALPHA && OSF1) */ +#endif /* not USG5 */ + #ifdef HAVE_X_WINDOWS @@ -958,31 +1001,6 @@ # define EXTERNAL_WIDGET_OBJS ExternalShell.o extw-Xt-nonshared.o extw-Xlib-nonshared.o -/* Now we try to figure out how to link a shared library. - If we can't figure it out, leave EXTW_LINK undefined and a shared - library will not be created. */ - -# ifdef USE_GCC -# ifdef USG5 -# define EXTW_LINK(objs, output) $(CC) -shared objs -Xlinker -z -Xlinker text -o output - /* I can't figure out how to do shared a.out libraries, so just punt. */ -# elif !defined (LINUX) || defined (__ELF__) -# define EXTW_LINK(objs, output) $(CC) -shared objs -o output -# endif -# elif defined (USG5) -# if defined (IRIX) -# define EXTW_LINK(objs, output) $(LD) -shared -g -check_registry ${TOOLROOT}/usr/lib/so_locations objs -o output -# else /* not IRIX */ -# define EXTW_LINK(objs, output) $(CC) -G objs -z text -o output -# endif /* not IRIX */ -# else /* not USG5 */ -# if defined (DEC_ALPHA) && defined (OSF1) -# define EXTW_LINK(objs, output) $(LD) $(LDFLAGS) LD_SWITCH_SHARED -d objs -o output $(LIBES) -# else /* !(DEC_ALPHA && OSF1) */ -# define EXTW_LINK(objs, output) $(LD) -dc objs -assert pure-text -o output -# endif /* !(DEC_ALPHA && OSF1) */ -# endif /* not USG5 */ - # ifdef LWLIB_USES_MOTIF -# ifdef EXTW_LINK +# ifdef SHARED_LINK # define MOTIF_OTHER_FILES libextcli_Xm.a libextcli_Xm.so.1 # else @@ -993,5 +1011,5 @@ #endif -# ifdef EXTW_LINK +# ifdef SHARED_LINK # define OTHER_FILES MOTIF_OTHER_FILES \ libextcli_Xt.a libextcli_Xt.so.1 \ @@ -1266,5 +1284,5 @@ #endif -all: xemacs OTHER_FILES +all: xemacs OTHER_FILES ALL_SHLIB_LIBS /* "make release" to build "xemacs" with an incremented version number; @@ -1493,14 +1511,14 @@ ar r libextcli_Xlib.a EXTERNAL_CLIENT_XLIB_OBJS_NONSHARED -#ifdef EXTW_LINK +#ifdef SHARED_LINK libextcli_Xm.so.1: EXTERNAL_CLIENT_MOTIF_OBJS_SHARED - EXTW_LINK(EXTERNAL_CLIENT_MOTIF_OBJS_SHARED, libextcli_Xm.so.1) + SHARED_LINK(EXTERNAL_CLIENT_MOTIF_OBJS_SHARED, libextcli_Xm.so.1) libextcli_Xt.so.1: EXTERNAL_CLIENT_XT_OBJS_SHARED - EXTW_LINK(EXTERNAL_CLIENT_XT_OBJS_SHARED, libextcli_Xt.so.1) + SHARED_LINK(EXTERNAL_CLIENT_XT_OBJS_SHARED, libextcli_Xt.so.1) libextcli_Xlib.so.1: EXTERNAL_CLIENT_XLIB_OBJS_SHARED - EXTW_LINK(EXTERNAL_CLIENT_XLIB_OBJS_SHARED, libextcli_Xlib.so.1) + SHARED_LINK(EXTERNAL_CLIENT_XLIB_OBJS_SHARED, libextcli_Xlib.so.1) #endif @@ -1508,4 +1526,9 @@ #endif /* EXTERNAL_WIDGET */ +#ifdef MAKE_SHLIB_MD5 +ALL_SHLIB_MD5: md5.o + SHARED_LINK(md5.o, ALL_SHLIB_MD5) +#endif + prefix-args: ${srcdir}/prefix-args.c config.h $(CC) $(ALL_CFLAGS) ${srcdir}/prefix-args.c -o prefix-args @@ -2315,4 +2338,12 @@ dgif_lib.o: config.h dgif_lib.o: gif_lib.h +#ifdef HAVE_SHLIB +eval.o: shlib.h +symbols.o: shlib.h +shlib.o: config.h +shlib.o: lisp.h +shlib.o: emacsfns.h +shlib.o: shlib.h +#endif dialog-x.o: $(LWLIBSRCDIR)/lwlib.h dialog-x.o: EmacsFrame.h diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/alloc.c xemacs-20.0-b26/src/alloc.c --- xemacs-20.0-b26-orig/src/alloc.c Tue May 28 00:33:21 1996 +++ xemacs-20.0-b26/src/alloc.c Wed Jul 17 15:41:53 1996 @@ -36,4 +36,5 @@ Added bit vectors for 19.13. Added lcrecord lists for 19.14. + Tonny Madsen: split LOBJECT stuff into classes.c */ @@ -43,4 +44,7 @@ #ifndef standalone #include "backtrace.h" +#ifdef HAVE_SHLIB +#include "shlib.h" +#endif #include "buffer.h" #include "bytecode.h" @@ -77,4 +81,9 @@ #endif + +/***************************************************************************** + GC + ****************************************************************************/ + /* Number of bytes of consing done since the last gc */ EMACS_INT consing_since_gc; @@ -142,7 +151,4 @@ EMACS_INT gc_generation_number[1]; -/* This is just for use by the printer, to allow things to print uniquely */ -static int lrecord_uid_counter; - /* Nonzero when calling certain hooks or doing other things where a GC would be bad */ @@ -474,5 +480,5 @@ -static void * +void * allocate_lisp_storage (int size) { @@ -490,132 +496,4 @@ } - -#define MARKED_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->finalizer) == this_marks_a_marked_record) -#define UNMARKABLE_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->marker) == this_one_is_unmarkable) -#define MARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)++); } while (0) -#define UNMARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)--); } while (0) - - -/* lrecords are chained together through their "next.v" field. - * After doing the mark phase, the GC will walk this linked - * list and free any record which hasn't been marked - */ -static struct lcrecord_header *all_lcrecords; - -void * -alloc_lcrecord (int size, CONST struct lrecord_implementation *implementation) -{ - struct lcrecord_header *lcheader; - - if (size <= 0) abort (); - if (implementation->static_size == 0) - { - if (!implementation->size_in_bytes_method) - abort (); - } - else if (implementation->static_size != size) - abort (); - - lcheader = allocate_lisp_storage (size); - lcheader->lheader.implementation = implementation; - lcheader->next = all_lcrecords; -#if 1 /* mly prefers to see small ID numbers */ - lcheader->uid = lrecord_uid_counter++; -#else /* jwz prefers to see real addrs */ - lcheader->uid = (int) &lcheader; -#endif - lcheader->free = 0; - all_lcrecords = lcheader; - INCREMENT_CONS_COUNTER (size, implementation->name); - return (lcheader); -} - -#if 0 /* Presently unused */ -/* Very, very poor man's EGC? - * This may be slow and thrash pages all over the place. - * Only call it if you really feel you must (and if the - * lrecord was fairly recently allocated). - * Otherwise, just let the GC do its job -- that's what it's there for - */ -void -free_lcrecord (struct lcrecord_header *lcrecord) -{ - if (all_lcrecords == lcrecord) - { - all_lcrecords = lcrecord->next; - } - else - { - struct lrecord_header *header = all_lcrecords; - for (;;) - { - struct lrecord_header *next = header->next; - if (next == lcrecord) - { - header->next = lrecord->next; - break; - } - else if (next == 0) - abort (); - else - header = next; - } - } - if (lrecord->implementation->finalizer) - ((lrecord->implementation->finalizer) (lrecord, 0)); - xfree (lrecord); - return; -} -#endif /* Unused */ - - -static void -disksave_object_finalization_1 (void) -{ - struct lcrecord_header *header; - - for (header = all_lcrecords; header; header = header->next) - { - if (header->lheader.implementation->finalizer && !header->free) - ((header->lheader.implementation->finalizer) (header, 1)); - } -} - - -/* This must not be called -- it just serves as for EQ test - * If lheader->implementation->finalizer is this_marks_a_marked_record, - * then lrecord has been marked by the GC sweeper - * header->implementation is put back to its correct value by - * sweep_records */ -void -this_marks_a_marked_record (void *dummy0, int dummy1) -{ - abort (); -} - -/* Semi-kludge -- lrecord_symbol_value_forward objects get stuck - in CONST space and you get SEGV's if you attempt to mark them. - This sits in lheader->implementation->marker. */ - -Lisp_Object -this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object)) -{ - abort (); - return Qnil; -} - -/* XGCTYPE for records */ -int -gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type) -{ - return (XGCTYPE (frob) == Lisp_Record - && (XRECORD_LHEADER (frob)->implementation == type - || XRECORD_LHEADER (frob)->implementation == type + 1)); -} - /**********************************************************************/ @@ -623,46 +501,44 @@ /**********************************************************************/ -/* For fixed-size types that are commonly used, we malloc() large blocks - of memory at a time and subdivide them into chunks of the correct - size for an object of that type. This is more efficient than - malloc()ing each object separately because we save on malloc() time - and overhead due to the fewer number of malloc()ed blocks, and - also because we don't need any extra pointers within each object - to keep them threaded together for GC purposes. For less common - (and frequently large-size) types, we use lcrecords, which are - malloc()ed individually and chained together through a pointer - in the lcrecord header. lcrecords do not need to be fixed-size - (i.e. two objects of the same type need not have the same size; - however, the size of a particular object cannot vary dynamically). - It is also much easier to create a new lcrecord type because no - additional code needs to be added to alloc.c. Finally, lcrecords - may be more efficient when there are only a small number of them. +/* For fixed-size types (called NONHEADER OBJECTS in classes.h) that + are commonly used, we malloc() large blocks of memory at a time and + subdivide them into chunks of the correct size for an object of + that type. This is more efficient than malloc()ing each object + separately because we save on malloc() time and overhead due to the + fewer number of malloc()ed blocks, and also because we don't need + any extra pointers within each object to keep them threaded + together for GC purposes. For less common (and frequently + large-size) types, we use LOBJECTS, which are malloc()ed + individually and chained together through a pointer in the LOBJECT + header (see classes.h for further information on LOBJECTS). The types that are stored in these large blocks (or "frob blocks") are cons, float, compiled-function, symbol, marker, extent, event, - and string. + and string. Some of these can be LOBJECTS depending on CPP + directives. Note that strings are special in that they are actually stored in two parts: a structure containing information about the string, and the actual data associated with the string. The former structure - (a struct Lisp_String) is a fixed-size structure and is managed the - same way as all the other such types. This structure contains a - pointer to the actual string data, which is stored in structures of - type struct string_chars_block. Each string_chars_block consists - of a pointer to a struct Lisp_String, followed by the data for that - string, followed by another pointer to a struct Lisp_String, - followed by the data for that string, etc. At GC time, the data in - these blocks is compacted by searching sequentially through all the - blocks and compressing out any holes created by unmarked strings. - Strings that are more than a certain size (bigger than the size of - a string_chars_block, although something like half as big might - make more sense) are malloc()ed separately and not stored in - string_chars_blocks. Furthermore, no one string stretches across - two string_chars_blocks. + (a struct Lisp_String) is a fixed-size (NONHEADER OBJECT) structure + and is managed the same way as all the other such types. This + structure contains a pointer to the actual string data, which is + stored in structures of type struct string_chars_block. Each + string_chars_block consists of a pointer to a struct Lisp_String, + followed by the data for that string, followed by another pointer + to a struct Lisp_String, followed by the data for that string, etc. + At GC time, the data in these blocks is compacted by searching + sequentially through all the blocks and compressing out any holes + created by unmarked strings. Strings that are more than a certain + size (bigger than the size of a string_chars_block, although + something like half as big might make more sense) are malloc()ed + separately and not stored in string_chars_blocks. Furthermore, no + one string stretches across two string_chars_blocks. - Vectors are each malloc()ed separately, similar to lcrecords. + Vectors are each malloc()ed separately, similar to lobjects. In the following discussion, we use conses, but it applies equally - well to the other fixed-size types. + well to the other fixed-size types (NONHEADER OBJECTS). The + allocation methods for LOBJECTS is described in classes.h We store cons cells inside of cons_blocks, allocating a new @@ -767,6 +643,5 @@ This way, we ensure that an object that gets freed will remain free for the next 1000 (or whatever) times that - an object of that type is allocated. -*/ + an object of that type is allocated. */ #ifndef MALLOC_OVERHEAD @@ -828,5 +703,5 @@ } while (0) -/* Allocate an instance of a type that is stored in blocks. +/* Allocate an object of a type that is stored in blocks. TYPE is the "name" of the type, STRUCTTYPE is the corresponding structure type. */ @@ -900,5 +775,6 @@ byte-aligned pointers, this pointer is at the very top of the address space and so it's almost inconceivable that it could ever be valid. */ - + + /* ###TM###: why not just use "~(unsigned int)0" */ #if INTBITS == 32 # define INVALID_POINTER_VALUE 0xFFFFFFFF @@ -960,5 +836,5 @@ /* Like FREE_FIXED_TYPE() but used when we are explicitly - freeing a structure through free_cons(), free_marker(), etc. + freeing a structure through free_cons(), etc. rather than through the normal process of sweeping. We attempt to undo the changes made to the allocation counters @@ -1111,30 +987,4 @@ /**********************************************************************/ -/* Float allocation */ -/**********************************************************************/ - -#ifdef LISP_FLOAT_TYPE - -DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float); -#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 - -Lisp_Object -make_float (double float_value) -{ - Lisp_Object val; - struct Lisp_Float *f; - - ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f); - f->lheader.implementation = lrecord_float; - float_next (f) = ((struct Lisp_Float *) -1); - float_data (f) = float_value; - XSETFLOAT (val, f); - return (val); -} - -#endif /* LISP_FLOAT_TYPE */ - - -/**********************************************************************/ /* Vector allocation */ /**********************************************************************/ @@ -1152,6 +1002,6 @@ ); struct Lisp_Vector *p = allocate_lisp_storage (sizem); -#ifdef LRECORD_VECTOR - set_lheader_implementation (&(p->lheader), lrecord_vector); +#ifdef USE_LOBJECT_VECTOR + SET_LOBJECT_CLASS (p, class_vector); #endif @@ -1328,118 +1178,4 @@ } -/**********************************************************************/ -/* Bit Vector allocation */ -/**********************************************************************/ - -static Lisp_Object all_bit_vectors; - -/* #### should allocate `small' bit vectors from a frob-block */ -static struct Lisp_Bit_Vector * -make_bit_vector_internal (EMACS_INT sizei) -{ - EMACS_INT sizem = (sizeof (struct Lisp_Bit_Vector) + - /* -1 because struct Lisp_Bit_Vector includes 1 slot */ - sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1)); - struct Lisp_Bit_Vector *p = allocate_lisp_storage (sizem); - set_lheader_implementation (&(p->lheader), lrecord_bit_vector); - - INCREMENT_CONS_COUNTER (sizem, "bit-vector"); - - bit_vector_length (p) = sizei; - bit_vector_next (p) = all_bit_vectors; - /* make sure the extra bits in the last long are 0; the calling - functions might not set them. */ - p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0; - XSETBIT_VECTOR (all_bit_vectors, p); - return (p); -} - -Lisp_Object -make_bit_vector (EMACS_INT length, Lisp_Object init) -{ - Lisp_Object bit_vector = Qnil; - struct Lisp_Bit_Vector *p; - EMACS_INT num_longs; - - if (length < 0) - length = XINT (wrong_type_argument (Qnatnump, make_int (length))); - - CHECK_BIT (init); - - num_longs = BIT_VECTOR_LONG_STORAGE (length); - p = make_bit_vector_internal (length); - XSETBIT_VECTOR (bit_vector, p); - - if (ZEROP (init)) - memset (p->bits, 0, num_longs * sizeof (long)); - else - { - EMACS_INT bits_in_last = length & (LONGBITS_POWER_OF_2 - 1); - memset (p->bits, ~0, num_longs * sizeof (long)); - /* But we have to make sure that the unused bits in the - last integer are 0, so that equal/hash is easy. */ - if (bits_in_last) - p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; - } - - return (bit_vector); -} - -Lisp_Object -make_bit_vector_from_byte_vector (unsigned char *bytevec, EMACS_INT length) -{ - Lisp_Object bit_vector = Qnil; - struct Lisp_Bit_Vector *p; - EMACS_INT i; - - if (length < 0) - length = XINT (wrong_type_argument (Qnatnump, make_int (length))); - - p = make_bit_vector_internal (length); - XSETBIT_VECTOR (bit_vector, p); - - for (i = 0; i < length; i++) - set_bit_vector_bit (p, i, bytevec[i]); - - return bit_vector; -} - -DEFUN ("make-bit-vector", Fmake_bit_vector, Smake_bit_vector, 2, 2, 0 /* -Return a newly created bit vector of length LENGTH. -Each element is set to INIT. See also the function `bit-vector'. -*/ ) - (length, init) - Lisp_Object length, init; -{ - if (!INTP (length) || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); - - return (make_bit_vector (XINT (length), init)); -} - -DEFUN ("bit-vector", Fbit_vector, Sbit_vector, 0, MANY, 0 /* -Return a newly created bit vector with specified arguments as elements. -Any number of arguments, even zero arguments, are allowed. -*/ ) - (nargs, args) - int nargs; - Lisp_Object *args; -{ - Lisp_Object bit_vector = Qnil; - int elt; - struct Lisp_Bit_Vector *p; - - for (elt = 0; elt < nargs; elt++) - CHECK_BIT (args[elt]); - - p = make_bit_vector_internal (nargs); - XSETBIT_VECTOR (bit_vector, p); - - for (elt = 0; elt < nargs; elt++) - set_bit_vector_bit (p, elt, !ZEROP (args[elt])); - - return (bit_vector); -} - /**********************************************************************/ @@ -1447,7 +1183,4 @@ /**********************************************************************/ -DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function); -#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 - static Lisp_Object make_compiled_function (int make_pure) @@ -1460,5 +1193,5 @@ { b = (struct Lisp_Compiled_Function *) (PUREBEG + pureptr); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + SET_LOBJECT_CLASS (b, class_compiled_function); pureptr += size; bump_purestat (&purestat_bytecode, size); @@ -1466,7 +1199,5 @@ else { - ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function, - b); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + b = alloc_lobject(class_compiled_function); } b->maxdepth = 0; @@ -1657,6 +1388,8 @@ /**********************************************************************/ +#ifndef USE_LOBJECT_SYMBOL DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 +#endif DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0 /* @@ -1672,7 +1405,8 @@ CHECK_STRING (str); +#ifdef USE_LOBJECT_SYMBOL + p = alloc_lobject(class_symbol); +#else ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p); -#ifdef LRECORD_SYMBOL - set_lheader_implementation (&(p->lheader), lrecord_symbol); #endif p->name = XSTRING (str); @@ -1687,100 +1421,5 @@ /**********************************************************************/ -/* Extent allocation */ -/**********************************************************************/ - -DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); -#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 - -struct extent * -allocate_extent (void) -{ - struct extent *e; - - ALLOCATE_FIXED_TYPE (extent, struct extent, e); - /* memset (e, 0, sizeof (struct extent)); */ - set_lheader_implementation (&(e->lheader), lrecord_extent); - extent_object (e) = Qnil; - set_extent_start (e, -1); - set_extent_end (e, -1); - e->plist = Qnil; - - memset (&e->flags, 0, sizeof (e->flags)); - - extent_face (e) = Qnil; - e->flags.end_open = 1; /* default is for endpoints to behave like markers */ - e->flags.detachable = 1; - - return (e); -} - - -/**********************************************************************/ -/* Event allocation */ -/**********************************************************************/ - -DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event); -#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 - -Lisp_Object -allocate_event (void) -{ - Lisp_Object val; - struct Lisp_Event *e; - - ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e); - set_lheader_implementation (&(e->lheader), lrecord_event); - - XSETEVENT (val, e); - return val; -} - - -/**********************************************************************/ -/* Marker allocation */ -/**********************************************************************/ - -DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker); -#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 - -DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0 /* -Return a newly allocated marker which does not point at any place. -*/ ) - () -{ - Lisp_Object val; - struct Lisp_Marker *p; - - ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p); - set_lheader_implementation (&(p->lheader), lrecord_marker); - p->buffer = 0; - p->memind = 0; - marker_next (p) = 0; - marker_prev (p) = 0; - p->insertion_type = 0; - XSETMARKER (val, p); - return val; -} - -Lisp_Object -noseeum_make_marker (void) -{ - Lisp_Object val; - struct Lisp_Marker *p; - - NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p); - set_lheader_implementation (&(p->lheader), lrecord_marker); - p->buffer = 0; - p->memind = 0; - marker_next (p) = 0; - marker_prev (p) = 0; - p->insertion_type = 0; - XSETMARKER (val, p); - return val; -} - - -/**********************************************************************/ -/* String allocation */ +/* String allocation */ /**********************************************************************/ @@ -2192,161 +1831,4 @@ -/************************************************************************/ -/* lcrecord lists */ -/************************************************************************/ - -/* Lcrecord lists are used to manage the allocation of particular - sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus - malloc() and garbage-collection junk) as much as possible. - It is similar to the Blocktype class. - - It works like this: - - 1) Create an lcrecord-list object using make_lcrecord_list(). - This is often done at initialization. Remember to staticpro - this object! The arguments to make_lcrecord_list() are the - same as would be passed to alloc_lcrecord(). - 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord() - and pass the lcrecord-list earlier created. - 3) When done with the lcrecord, call free_managed_lcrecord(). - The standard freeing caveats apply: ** make sure there are no - pointers to the object anywhere! ** - 4) Calling free_managed_lcrecord() is just like kissing the - lcrecord goodbye as if it were garbage-collected. This means: - -- the contents of the freed lcrecord are undefined, and the - contents of something produced by allocate_managed_lcrecord() - are undefined, just like for alloc_lcrecord(). - -- the mark method for the lcrecord's type will *NEVER* be called - on freed lcrecords. - -- the finalize method for the lcrecord's type will be called - at the time that free_managed_lcrecord() is called. - - */ - -static Lisp_Object mark_lcrecord_list (Lisp_Object, void (*) (Lisp_Object)); -DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list, - mark_lcrecord_list, internal_object_printer, - 0, 0, 0, struct lcrecord_list); - -static Lisp_Object -mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) -{ - struct lcrecord_list *list = XLCRECORD_LIST (obj); - Lisp_Object chain = list->free; - - while (!NILP (chain)) - { - struct lrecord_header *lheader = XRECORD_LHEADER (chain); - struct free_lcrecord_header *free_header = - (struct free_lcrecord_header *) lheader; - CONST struct lrecord_implementation *implementation - = lheader->implementation; - -#ifdef ERROR_CHECK_GC - /* There should be no other pointers to the free list. */ - assert (!MARKED_RECORD_HEADER_P (lheader)); - /* Only lcrecords should be here. */ - assert (!implementation->basic_p); - /* Only free lcrecords should be here. */ - assert (free_header->lcheader.free); - /* The type of the lcrecord must be right. */ - assert (implementation == list->implementation); - /* So must the size. */ - assert (implementation->static_size == 0 - || implementation->static_size == list->size); -#endif - MARK_RECORD_HEADER (lheader); - chain = free_header->chain; - } - - return Qnil; -} - -Lisp_Object -make_lcrecord_list (int size, - CONST struct lrecord_implementation *implementation) -{ - struct lcrecord_list *p = alloc_lcrecord (sizeof (*p), - lrecord_lcrecord_list); - Lisp_Object val = Qnil; - - p->implementation = implementation; - p->size = size; - p->free = Qnil; - XSETLCRECORD_LIST (val, p); - return val; -} - -Lisp_Object -allocate_managed_lcrecord (Lisp_Object lcrecord_list) -{ - struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); - if (!NILP (list->free)) - { - Lisp_Object val = list->free; - struct free_lcrecord_header *free_header = - (struct free_lcrecord_header *) XPNTR (val); - -#ifdef ERROR_CHECK_GC - struct lrecord_header *lheader = - (struct lrecord_header *) free_header; - CONST struct lrecord_implementation *implementation - = lheader->implementation; - - /* There should be no other pointers to the free list. */ - assert (!MARKED_RECORD_HEADER_P (lheader)); - /* Only lcrecords should be here. */ - assert (!implementation->basic_p); - /* Only free lcrecords should be here. */ - assert (free_header->lcheader.free); - /* The type of the lcrecord must be right. */ - assert (implementation == list->implementation); - /* So must the size. */ - assert (implementation->static_size == 0 - || implementation->static_size == list->size); -#endif - list->free = free_header->chain; - free_header->lcheader.free = 0; - return val; - } - else - { - Lisp_Object foo = Qnil; - - XSETOBJ (foo, Lisp_Record, - alloc_lcrecord (list->size, list->implementation)); - return foo; - } -} - -void -free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) -{ - struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); - struct free_lcrecord_header *free_header = - (struct free_lcrecord_header *) XPNTR (lcrecord); - struct lrecord_header *lheader = - (struct lrecord_header *) free_header; - CONST struct lrecord_implementation *implementation - = lheader->implementation; - -#ifdef ERROR_CHECK_GC - /* Make sure the size is correct. This will catch, for example, - putting a window configuration on the wrong free list. */ - if (implementation->size_in_bytes_method) - assert (((implementation->size_in_bytes_method) (lheader)) - == list->size); - else - assert (implementation->static_size == list->size); -#endif - - if (implementation->finalizer) - ((implementation->finalizer) (lheader, 0)); - free_header->chain = list->free; - free_header->lcheader.free = 1; - list->free = lcrecord; -} - - /**********************************************************************/ /* Purity of essence, peace on earth */ @@ -2493,5 +1975,5 @@ f = (struct Lisp_Float *) (PUREBEG + pureptr); - set_lheader_implementation (&(f->lheader), lrecord_float); + SET_LOBJECT_CLASS (f, class_float); pureptr += sizeof (struct Lisp_Float); bump_purestat (&purestat_float, sizeof (struct Lisp_Float)); @@ -2529,21 +2011,4 @@ } -#if 0 -/* Presently unused */ -void * -alloc_pure_lrecord (int size, struct lrecord_implementation *implementation) -{ - struct lrecord_header *header = (void *) (PUREBEG + pureptr); - - if (pureptr + size > PURESIZE) - pure_storage_exhausted (); - - set_lheader_implementation (header, implementation); - header->next = 0; - return (header); -} -#endif - - DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0 /* @@ -2585,9 +2050,9 @@ default: { - if (COMPILED_FUNCTIONP (obj)) + if (class_compiled_function && COMPILED_FUNCTIONP (obj)) { struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj); Lisp_Object new = make_compiled_function (1); - struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (obj); + struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new); n->flags = o->flags; n->bytecodes = Fpurecopy (o->bytecodes); @@ -2598,5 +2063,5 @@ } #ifdef LISP_FLOAT_TYPE - else if (FLOATP (obj)) + else if (class_float && FLOATP (obj)) return make_pure_float (float_data (XFLOAT (obj))); #endif /* LISP_FLOAT_TYPE */ @@ -2732,11 +2197,7 @@ struct gcpro *gcprolist; -/* 415 used Mly 29-Jun-93 */ -#define NSTATICS 1500 -/* Not "static" because of linker lossage on some systems */ -Lisp_Object *staticvec[NSTATICS] - /* Force it into data space! */ - = {0}; -static int staticidx; +static Lisp_Object **staticvec = 0; +static int staticsize = 0; +static int staticidx = 0; /* Put an entry in staticvec, pointing at the variable whose address is given @@ -2745,6 +2206,14 @@ staticpro (Lisp_Object *varaddress) { - if (staticidx >= countof (staticvec)) - abort (); + /* Allocate the staticvec dynamically */ + if (staticidx >= staticsize) { + if (staticsize) { + staticsize = 2*staticsize; + staticvec = xrealloc(staticvec, staticsize*sizeof(*staticvec)); + } else { + staticsize = 1500; + staticvec = xmalloc(staticsize*sizeof(*staticvec)); + } + } staticvec[staticidx++] = varaddress; } @@ -2784,22 +2253,28 @@ } - case Lisp_Record: + case Lisp_LObject: /* case Lisp_Symbol_Value_Magic: */ { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = lheader->implementation; + struct lobject_header *header = XLOBJECT_LHEADER (obj); + Lisp_Class *aclass = XLHEADER_CLASS (header); + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + assert (impl->objecttype == LC_LOBJECT); + assert (!header->free); - if (! MARKED_RECORD_HEADER_P (lheader) && - ! UNMARKABLE_RECORD_HEADER_P (lheader)) + if (! MARKED_LHEADER_P (header)) { - MARK_RECORD_HEADER (lheader); -#ifdef ERROR_CHECK_GC - if (!implementation->basic_p) - assert (! ((struct lcrecord_header *) lheader)->free); -#endif - if (implementation->marker != 0) + MARK_LHEADER (header); + + /* The following 'if' is not needed, but this will be + executed ALOT of times and therefore this is kept here + to optimize the marking of aclass a bit. */ + if (!MARKED_LHEADER_P(&aclass->header)) { + Lisp_Object obj; + XSETCLASS(obj, aclass); + mark_object (obj); + } + if (impl->marker != 0) { - obj = ((implementation->marker) (obj, mark_object)); + obj = ((impl->marker) (obj, mark_object)); if (!NILP (obj)) goto tail_recurse; } @@ -2843,5 +2318,5 @@ break; -#ifndef LRECORD_SYMBOL +#ifndef USE_LOBJECT_SYMBOL case Lisp_Symbol: { @@ -2875,5 +2350,5 @@ } break; -#endif /* !LRECORD_SYMBOL */ +#endif /* !USE_LOBJECT_SYMBOL */ default: @@ -2980,14 +2455,14 @@ break; - case Lisp_Record: + case Lisp_LObject: { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = lheader->implementation; + struct lobject_header *header = XLOBJECT_LHEADER (obj); + CONST Lisp_Class *aclass = XLHEADER_CLASS(header); + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); - if (implementation->size_in_bytes_method) - total += ((implementation->size_in_bytes_method) (lheader)); + if (impl->size_in_bytes_method) + total += ((impl->size_in_bytes_method) (header)); else - total += implementation->static_size; + total += impl->static_size; #if 0 /* unused */ @@ -2995,10 +2470,10 @@ break; - if (implementation->marker != 0) + if (impl->marker != 0) { int old = idiot_c_doesnt_have_closures; idiot_c_doesnt_have_closures = 0; - obj = ((implementation->marker) (obj, idiot_c)); + obj = ((impl->marker) (obj, idiot_c)); total += idiot_c_doesnt_have_closures; idiot_c_doesnt_have_closures = old; @@ -3047,104 +2522,13 @@ static int gc_count_num_vector_used, gc_count_vector_total_size; static int gc_count_vector_storage; -static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size; -static int gc_count_bit_vector_storage; static int gc_count_num_short_string_in_use; static int gc_count_string_total_size; static int gc_count_short_string_total_size; -/* static int gc_count_total_records_used, gc_count_records_total_size; */ - - -/* This will be used more extensively In The Future */ -static int last_lrecord_type_index_assigned; - -static CONST struct lrecord_implementation *lrecord_implementations_table[128]; -#define max_lrecord_type (countof (lrecord_implementations_table) - 1) - -static int -lrecord_type_index (CONST struct lrecord_implementation *implementation) -{ - int type_index = *(implementation->lrecord_type_index); - /* Have to do this circuitous and validation test because of problems - dumping out initialized variables (ie can't set xxx_type_index to -1 - because that would make xxx_type_index read-only in a dumped emacs. */ - if (type_index < 0 || type_index > max_lrecord_type - || lrecord_implementations_table[type_index] != implementation) - { - if (last_lrecord_type_index_assigned == max_lrecord_type) - abort (); - type_index = ++last_lrecord_type_index_assigned; - lrecord_implementations_table[type_index] = implementation; - *(implementation->lrecord_type_index) = type_index; - } - return (type_index); -} - -/* stats on lcrecords in use - kinda kludgy */ - -static struct -{ - int instances_in_use; - int bytes_in_use; - int instances_freed; - int bytes_freed; - int instances_on_free_list; -} lcrecord_stats [countof (lrecord_implementations_table)]; - - -static void -reset_lcrecord_stats (void) -{ - int i; - for (i = 0; i < countof (lcrecord_stats); i++) - { - lcrecord_stats[i].instances_in_use = 0; - lcrecord_stats[i].bytes_in_use = 0; - lcrecord_stats[i].instances_freed = 0; - lcrecord_stats[i].bytes_freed = 0; - lcrecord_stats[i].instances_on_free_list = 0; - } -} - -static void -tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p) -{ - CONST struct lrecord_implementation *implementation = h->implementation; - int type_index = lrecord_type_index (implementation); - - if (((struct lcrecord_header *) h)->free) - { - assert (!free_p); - lcrecord_stats[type_index].instances_on_free_list++; - } - else - { - unsigned int sz = (implementation->size_in_bytes_method - ? ((implementation->size_in_bytes_method) (h)) - : implementation->static_size); - - if (free_p) - { - lcrecord_stats[type_index].instances_freed++; - lcrecord_stats[type_index].bytes_freed += sz; - } - else - { - lcrecord_stats[type_index].instances_in_use++; - lcrecord_stats[type_index].bytes_in_use += sz; - } - } -} - /* Free all unmarked records */ static void -sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) +sweep_lobjects () { - struct lcrecord_header *header; - int num_used = 0; - /* int total_size = 0; */ - reset_lcrecord_stats (); - /* First go through and call all the finalize methods. Then go through and free the objects. There used to @@ -3157,38 +2541,16 @@ other object. */ - for (header = *prev; header; header = header->next) - { - struct lrecord_header *h = &(header->lheader); - if (!MARKED_RECORD_HEADER_P (h) && ! (header->free)) - { - if (h->implementation->finalizer) - ((h->implementation->finalizer) (h, 0)); - } - } - - for (header = *prev; header; ) - { - struct lrecord_header *h = &(header->lheader); - if (MARKED_RECORD_HEADER_P (h)) - { - UNMARK_RECORD_HEADER (h); - num_used++; - /* total_size += ((n->implementation->size_in_bytes) (h));*/ - prev = &(header->next); - header = *prev; - tick_lcrecord_stats (h, 0); - } - else - { - struct lcrecord_header *next = header->next; - *prev = next; - tick_lcrecord_stats (h, 1); - /* used to call finalizer right here. */ - xfree (header); - header = next; - } - } - *used = num_used; - /* *total = total_size; */ + /* We have the "finalize" the classes last, as these probably will + delete some of the intenral chains with objects of that + aclass. This happens automatically as the class for classes + (class_class) always is the first one initialized with + init_lobject_header. */ + + CLASSES_LOOP(aclass, + if (XCLASS_IMPL (aclass)->sweeper) (XCLASS_IMPL (aclass)->sweeper)(aclass, SWEEPER_FINALIZE, 0); + ) + CLASSES_LOOP(aclass, + if (XCLASS_IMPL (aclass)->sweeper) (XCLASS_IMPL (aclass)->sweeper)(aclass, SWEEPER_FREE, 0); + ) } @@ -3231,44 +2593,4 @@ } -static void -sweep_bit_vectors_1 (Lisp_Object *prev, - int *used, int *total, int *storage) -{ - Lisp_Object bit_vector; - int num_used = 0; - int total_size = 0; - int total_storage = 0; - - /* BIT_VECTORP fails because the objects are marked, which changes - their implementation */ - for (bit_vector = *prev; !EQ (bit_vector, Qzero); ) - { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); - int len = v->size; - if (MARKED_RECORD_P (bit_vector)) - { - UNMARK_RECORD_HEADER (&(v->lheader)); - total_size += len; - total_storage += (MALLOC_OVERHEAD - + sizeof (struct Lisp_Bit_Vector) - + (BIT_VECTOR_LONG_STORAGE (len) - 1) - * sizeof (long)); - num_used++; - prev = &(bit_vector_next (v)); - bit_vector = *prev; - } - else - { - Lisp_Object next = bit_vector_next (v); - *prev = next; - xfree (v); - bit_vector = next; - } - } - *used = num_used; - *total = total_size; - *storage = total_storage; -} - /* And the Lord said: Thou shalt use the `c-backslash-region' command to make macros prettier. */ @@ -3463,96 +2785,15 @@ } -static void -sweep_compiled_functions (void) -{ -#define MARKED_compiled_function_P(ptr) \ - MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -#define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#define ADDITIONAL_FREE_compiled_function(ptr) - - SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function); -} - - -#ifdef LISP_FLOAT_TYPE -static void -sweep_floats (void) -{ -#define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -#define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#define ADDITIONAL_FREE_float(ptr) - - SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float); -} -#endif /* LISP_FLOAT_TYPE */ - +#ifndef USE_LOBJECT_SYMBOL static void sweep_symbols (void) { -#ifndef LRECORD_SYMBOL # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist) # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0) -#else -# define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -# define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#endif /* !LRECORD_SYMBOL */ #define ADDITIONAL_FREE_symbol(ptr) SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol); } - - -#ifndef standalone - -static void -sweep_extents (void) -{ -#define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -#define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#define ADDITIONAL_FREE_extent(ptr) - - SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); -} - -static void -sweep_events (void) -{ -#define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -#define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#define ADDITIONAL_FREE_event(ptr) - - SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event); -} - -static void -sweep_markers (void) -{ -#define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) -#define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) -#define ADDITIONAL_FREE_marker(ptr) \ - do { Lisp_Object tem; \ - XSETMARKER (tem, ptr); \ - unchain_marker (tem); \ - } while (0) - - SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker); -} - -/* Explicitly free a marker. */ -void -free_marker (struct Lisp_Marker *ptr) -{ -#ifdef ERROR_CHECK_GC - /* Perhaps this will catch freeing an already-freed marker. */ - Lisp_Object temmy; - XSETMARKER (temmy, ptr); - assert (GC_MARKERP (temmy)); -#endif -#ifndef ALLOC_NO_POOLS - FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr); -#endif /* ALLOC_NO_POOLS */ -} - -#endif /* not standalone */ +#endif /* !USE_LOBJECT_SYMBOL */ @@ -3772,11 +3013,11 @@ case Lisp_Cons: return XMARKBIT (XCAR (obj)); - case Lisp_Record: - return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); + case Lisp_LObject: + return MARKED_LHEADER_P (XLOBJECT_LHEADER (obj)); case Lisp_String: return XMARKBIT (XSTRING (obj)->plist); case Lisp_Vector: return (vector_length (XVECTOR (obj)) < 0); -#ifndef LRECORD_SYMBOL +#ifndef USE_LOBJECT_SYMBOL case Lisp_Symbol: return XMARKBIT (XSYMBOL (obj)->plist); @@ -3793,11 +3034,8 @@ /* Free all unmarked records. Do this at the very beginning, before anything else, so that the finalize methods can safely - examine items in the objects. sweep_lcrecords_1() makes + examine items in the objects. sweep_lobjects() makes sure to call all the finalize methods *before* freeing anything, to complete the safety. */ - { - int ignored; - sweep_lcrecords_1 (&all_lcrecords, &ignored); - } + sweep_lobjects (); compact_string_chars (); @@ -3805,12 +3043,7 @@ /* Finalize methods below (called through the ADDITIONAL_FREE_foo macros) must be *extremely* careful to make sure they're not - referencing freed objects. The only two existing finalize - methods (for strings and markers) pass muster -- the string - finalizer doesn't look at anything but its own specially- - created block, and the marker finalizer only looks at live - buffers (which will never be freed) and at the markers before - and after it in the chain (which, by induction, will never be - freed because if so, they would have already removed themselves - from the chain). */ + referencing freed objects. The only existing finalize method + (for strings) pass muster -- the string finalizer doesn't look at + anything but its own specially- created block */ /* Put all unmarked strings on free list, free'ing the string chars @@ -3826,30 +3059,8 @@ &gc_count_vector_storage); - /* Free all unmarked bit vectors */ - sweep_bit_vectors_1 (&all_bit_vectors, - &gc_count_num_bit_vector_used, - &gc_count_bit_vector_total_size, - &gc_count_bit_vector_storage); - - /* Free all unmarked compiled-function objects */ - sweep_compiled_functions (); - -#ifdef LISP_FLOAT_TYPE - /* Put all unmarked floats on free list */ - sweep_floats (); -#endif - +#ifndef USE_LOBJECT_SYMBOL /* Put all unmarked symbols on free list */ sweep_symbols (); - - /* Put all unmarked extents on free list */ - sweep_extents (); - - /* Put all unmarked markers on free list. - Dechain each one first from the buffer into which it points. */ - sweep_markers (); - - sweep_events (); - +#endif } @@ -3890,5 +3101,7 @@ /* Run the disksave finalization methods of all live objects. */ - disksave_object_finalization_1 (); + CLASSES_LOOP(aclass, + if (XCLASS_IMPL (aclass)->sweeper) (XCLASS_IMPL (aclass)->sweeper)(aclass, SWEEPER_DUMP, 0); + ) /* Zero out the unused portion of purespace */ @@ -4074,4 +3287,8 @@ } + CLASSES_LOOP(aclass, + if (XCLASS_IMPL (aclass)->sweeper) + (XCLASS_IMPL (aclass)->sweeper)(aclass, SWEEPER_PROTECT, mark_object); + ) mark_redisplay (mark_object); mark_profiling_info (mark_object); @@ -4208,51 +3425,38 @@ garbage_collect_1 (); - for (i = 0; i < last_lrecord_type_index_assigned; i++) - { - if (lcrecord_stats[i].bytes_in_use != 0 - || lcrecord_stats[i].bytes_freed != 0 - || lcrecord_stats[i].instances_on_free_list != 0) - { - char buf [255]; - CONST char *name = lrecord_implementations_table[i]->name; - int len = strlen (name); - sprintf (buf, "%s-storage", name); - pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); - /* Okay, simple pluralization check for `symbol-value-varalias' */ - if (name[len-1] == 's') - sprintf (buf, "%ses-freed", name); - else - sprintf (buf, "%ss-freed", name); - if (lcrecord_stats[i].instances_freed != 0) - pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl); - if (name[len-1] == 's') - sprintf (buf, "%ses-on-free-list", name); - else - sprintf (buf, "%ss-on-free-list", name); - if (lcrecord_stats[i].instances_on_free_list != 0) - pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list, - pl); - if (name[len-1] == 's') - sprintf (buf, "%ses-used", name); - else - sprintf (buf, "%ss-used", name); - pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl); - } + CLASSES_LOOP(aclass, + if (aclass->stats.bytes_in_use != 0 + || aclass->stats.bytes_freed != 0 + || aclass->stats.objects_on_free_list != 0) { + char buf [255]; + CONST char *name = XCLASS_IMPL (aclass)->name; + int len = strlen (name); + /* Okay, simple pluralization check for `symbol-value-varalias' */ + if (name[len-1] == 's') + sprintf (buf, "%ses-freed", name); + else + sprintf (buf, "%ss-freed", name); + if (aclass->stats.objects_freed != 0) + pl = gc_plist_hack (buf, aclass->stats.objects_freed, pl); + if (name[len-1] == 's') + sprintf (buf, "%ses-on-free-list", name); + else + sprintf (buf, "%ss-on-free-list", name); + if (aclass->stats.objects_on_free_list != 0) + pl = gc_plist_hack (buf, aclass->stats.objects_on_free_list, + pl); + if (name[len-1] == 's') + sprintf (buf, "%ses-used", name); + else + sprintf (buf, "%ss-used", name); + pl = gc_plist_hack (buf, aclass->stats.objects_in_use, pl); + if (name[len-1] == 's') + sprintf (buf, "%ses-storage", name); + else + sprintf (buf, "%ss-storage", name); + pl = gc_plist_hack (buf, aclass->stats.bytes_in_use+aclass->stats.bytes_on_free_list, pl); } + ) - HACK_O_MATIC (extent, "extent-storage", pl); - pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl); - pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl); - HACK_O_MATIC (event, "event-storage", pl); - pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl); - pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl); - HACK_O_MATIC (marker, "marker-storage", pl); - pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl); - pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl); -#ifdef LISP_FLOAT_TYPE - HACK_O_MATIC (float, "float-storage", pl); - pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl); - pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl); -#endif /* LISP_FLOAT_TYPE */ HACK_O_MATIC (string, "string-header-storage", pl); pl = gc_plist_hack ("long-strings-total-length", @@ -4269,4 +3473,5 @@ gc_count_num_short_string_in_use, pl); +#if 0 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl); pl = gc_plist_hack ("compiled-functions-free", @@ -4274,5 +3479,5 @@ pl = gc_plist_hack ("compiled-functions-used", gc_count_num_compiled_function_in_use, pl); - +#endif pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl); pl = gc_plist_hack ("vectors-total-length", @@ -4280,13 +3485,4 @@ pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl); - pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl); - pl = gc_plist_hack ("bit-vectors-total-length", - gc_count_bit_vector_total_size, pl); - pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl); - - HACK_O_MATIC (symbol, "symbol-storage", pl); - pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl); - pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl); - HACK_O_MATIC (cons, "cons-storage", pl); pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl); @@ -4296,8 +3492,8 @@ ret[0] = Fcons (make_int (gc_count_num_cons_in_use), make_int (gc_count_num_cons_freelist)); - ret[1] = Fcons (make_int (gc_count_num_symbol_in_use), - make_int (gc_count_num_symbol_freelist)); - ret[2] = Fcons (make_int (gc_count_num_marker_in_use), - make_int (gc_count_num_marker_freelist)); + ret[1] = Fcons (make_int (class_symbol->stats.objects_in_use), + make_int (class_symbol->stats.objects_on_free_list)); + ret[2] = Fcons (make_int (class_marker->stats.objects_in_use), + make_int (class_marker->stats.objects_on_free_list)); ret[3] = make_int (gc_count_string_total_size); ret[4] = make_int (gc_count_vector_total_size); @@ -4498,10 +3694,4 @@ #endif - last_lrecord_type_index_assigned = -1; - for (iii = 0; iii < countof (lrecord_implementations_table); iii++) - { - lrecord_implementations_table[iii] = 0; - } - symbols_initialized = 0; @@ -4514,20 +3704,11 @@ breathing_space = 0; XSETINT (all_vectors, 0); /* Qzero may not be set yet. */ - XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */ XSETINT (Vgc_message, 0); - all_lcrecords = 0; ignore_malloc_warnings = 1; init_string_alloc (); init_string_chars_alloc (); init_cons_alloc (); +#ifndef USE_LOBJECT_SYMBOL init_symbol_alloc (); - init_compiled_function_alloc (); -#ifdef LISP_FLOAT_TYPE - init_float_alloc (); -#endif /* LISP_FLOAT_TYPE */ -#ifndef standalone - init_marker_alloc (); - init_extent_alloc (); - init_event_alloc (); #endif ignore_malloc_warnings = 0; @@ -4543,5 +3724,4 @@ malloc_sbrk_used = 100000; /* as reasonable as any number */ #endif /* VIRT_ADDR_VARIES */ - lrecord_uid_counter = 259; debug_string_purity = 0; gcprolist = 0; @@ -4577,12 +3757,9 @@ defsubr (&Slist); defsubr (&Svector); - defsubr (&Sbit_vector); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); - defsubr (&Smake_bit_vector); defsubr (&Smake_string); defsubr (&Smake_symbol); - defsubr (&Smake_marker); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/buffer.c xemacs-20.0-b26/src/buffer.c --- xemacs-20.0-b26-orig/src/buffer.c Sat Mar 30 21:55:29 1996 +++ xemacs-20.0-b26/src/buffer.c Tue Jul 9 09:17:11 1996 @@ -213,7 +213,7 @@ because all buffers have `kill-buffer' applied to them before they disappear, and the children removal happens then. */ -DEFINE_LRECORD_IMPLEMENTATION ("buffer", buffer, - mark_buffer, print_buffer, 0, 0, 0, - struct buffer); +DEFINE_LOBJECT_CLASS ("Buffer", buffer, 0, + mark_buffer, print_buffer, 0, 0, 0, + struct buffer); #ifdef ENERGIZE @@ -574,7 +574,7 @@ allocate_buffer (void) { - struct buffer *b = alloc_lcrecord (sizeof (struct buffer), lrecord_buffer); + struct buffer *b = alloc_lobject (class_buffer); - copy_lcrecord (b, XBUFFER (Vbuffer_defaults)); + copy_lobject (b, XBUFFER (Vbuffer_defaults)); return b; @@ -1888,4 +1888,6 @@ syms_of_buffer (void) { + DEFCLASS (buffer); + defsymbol (&Qbuffer_live_p, "buffer-live-p"); defsymbol (&Qbuffer_or_string_p, "buffer-or-string-p"); @@ -2108,35 +2110,22 @@ from SunPro C's fix-and-continue feature (a way neato feature that makes debugging unbelievably more bearable) */ -#define DEFVAR_BUFFER_LOCAL(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, 0 }; \ +#define DEFVAR_BUFFER_BASIC(lname, type, field_name, magicfun) \ + do { static struct symbol_value_forward I_hate_C \ + = { { { CLASS_SYMBOL_VALUE_FORWARD_ID, }, type }, \ + (void *) &(buffer_local_flags.field_name), magicfun }; \ defvar_buffer_local ((lname), &I_hate_C); \ } while (0) +#define DEFVAR_BUFFER_LOCAL(lname, field_name) \ + DEFVAR_BUFFER_BASIC(lname, SYMVAL_CURRENT_BUFFER_FORWARD, field_name, 0) + #define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_BUFFER_BASIC(lname, SYMVAL_CURRENT_BUFFER_FORWARD, field_name, magicfun) #define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, 0 }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_BUFFER_BASIC(lname, SYMVAL_CONST_CURRENT_BUFFER_FORWARD, field_name, 0) #define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_BUFFER_BASIC(lname, SYMVAL_CONST_CURRENT_BUFFER_FORWARD, field_name, magicfun) static void @@ -2155,24 +2144,21 @@ /* DOC is ignored because it is snagged and recorded externally * by make-docfile */ -#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, 0 }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ +#define DEFVAR_BUFFER_DEFAULTS_BASIC(lname, type, field_name, magicfun) \ + do { static struct symbol_value_forward I_hate_C \ + = { { { CLASS_SYMBOL_VALUE_FORWARD_ID, }, type }, \ + (void *) &(buffer_local_flags.field_name), magicfun }; \ + defvar_mumble ((lname), &I_hate_C, sizeof(I_hate_C)); \ } while (0) +#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) \ + DEFVAR_BUFFER_DEFAULTS_BASIC(lname, SYMVAL_DEFAULT_BUFFER_FORWARD, field_name, 0) + #define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) + DEFVAR_BUFFER_DEFAULTS_BASIC(lname, SYMVAL_DEFAULT_BUFFER_FORWARD, field_name, magicfun) static void nuke_all_buffer_slots (struct buffer *b, Lisp_Object zap) { - zero_lcrecord (b); + zero_lobject (b); #define MARKED_SLOT(x) b->x = (zap); @@ -2187,8 +2173,6 @@ are initialized reasonably, so mark_buffer won't choke. */ - struct buffer *defs = alloc_lcrecord (sizeof (struct buffer), - lrecord_buffer); - struct buffer *syms = alloc_lcrecord (sizeof (struct buffer), - lrecord_buffer); + struct buffer *defs = alloc_lobject (class_buffer); + struct buffer *syms = alloc_lobject (class_buffer); staticpro (&Vbuffer_defaults); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/buffer.h xemacs-20.0-b26/src/buffer.h --- xemacs-20.0-b26-orig/src/buffer.h Thu Jun 6 19:16:32 1996 +++ xemacs-20.0-b26/src/buffer.h Mon Jul 8 14:36:25 1996 @@ -109,5 +109,5 @@ struct buffer { - struct lcrecord_header header; + struct lobject_header header; /* This structure holds the coordinates of the buffer contents @@ -212,11 +212,10 @@ }; -DECLARE_LRECORD (buffer, struct buffer); -#define XBUFFER(x) XRECORD (x, buffer, struct buffer) -#define XSETBUFFER(x, p) XSETRECORD (x, p, buffer) -#define BUFFERP(x) RECORDP (x, buffer) -#define GC_BUFFERP(x) GC_RECORDP (x, buffer) -#define CHECK_BUFFER(x) CHECK_RECORD (x, buffer) -#define CONCHECK_BUFFER(x) CONCHECK_RECORD (x, buffer) +DECLARE_LOBJECT_CLASS (buffer, struct buffer); +#define XBUFFER(x) XOBJECT (x, buffer, struct buffer) +#define XSETBUFFER(x, p) XSETLOBJECT (x, p, buffer) +#define BUFFERP(x) OBJECT_CLASSP (x, buffer) +#define CHECK_BUFFER(x) CHECK_OBJECT (x, buffer) +#define CONCHECK_BUFFER(x) CONCHECK_OBJECT (x, buffer) #define BUFFER_LIVE_P(b) (!NILP ((b)->name)) @@ -1389,5 +1388,5 @@ string_length (__gseda_s__), \ &__gseda_len__, fmt); \ - (stick_value_here) = alloca (1 + __gseda_len__); \ + (stick_value_here) = (Extbyte *)alloca (1 + __gseda_len__); \ memcpy ((Extbyte *) stick_value_here, __gseda_ptr__, 1 + __gseda_len__); \ (stick_len_here) = __gseda_len__; \ @@ -1878,5 +1877,5 @@ /* put it here, somewhat arbitrarily ... its needs to be in *some* header file. */ -DECLARE_LRECORD (range_table, struct Lisp_Range_Table); +DECLARE_LOBJECT_CLASS (range_table, struct Lisp_Range_Table); #endif /* _XEMACS_BUFFER_H_ */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/bytecode.h xemacs-20.0-b26/src/bytecode.h --- xemacs-20.0-b26-orig/src/bytecode.h Sat Mar 30 19:03:22 1996 +++ xemacs-20.0-b26/src/bytecode.h Mon Jul 8 14:36:25 1996 @@ -45,5 +45,5 @@ struct Lisp_Compiled_Function { - struct lrecord_header lheader; + struct lobject_header header; unsigned short maxdepth; struct @@ -75,12 +75,11 @@ Lisp_Object compiled_function_annotation (struct Lisp_Compiled_Function *b); -DECLARE_LRECORD (compiled_function, struct Lisp_Compiled_Function); -#define XCOMPILED_FUNCTION(x) XRECORD (x, compiled_function, \ +DECLARE_LOBJECT_CLASS (compiled_function, struct Lisp_Compiled_Function); +#define XCOMPILED_FUNCTION(x) XOBJECT (x, compiled_function, \ struct Lisp_Compiled_Function) -#define XSETCOMPILED_FUNCTION(x, p) XSETRECORD (x, p, compiled_function) -#define COMPILED_FUNCTIONP(x) RECORDP (x, compiled_function) -#define GC_COMPILED_FUNCTIONP(x) GC_RECORDP (x, compiled_function) -#define CHECK_COMPILED_FUNCTION(x) CHECK_RECORD (x, compiled_function) -#define CONCHECK_COMPILED_FUNCTION(x) CONCHECK_RECORD (x, compiled_function) +#define XSETCOMPILED_FUNCTION(x, p) XSETLOBJECT (x, p, compiled_function) +#define COMPILED_FUNCTIONP(x) OBJECT_CLASSP (x, compiled_function) +#define CHECK_COMPILED_FUNCTION(x) CHECK_OBJECT(x, compiled_function) +#define CONCHECK_COMPILED_FUNCTION(x) CONCHECK_OBJECTP (x, compiled_function) /* total 1765 internal 101 doc-and-int 775 doc-only 389 int-only 42 neither 559 diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/callint.c xemacs-20.0-b26/src/callint.c --- xemacs-20.0-b26-orig/src/callint.c Thu May 9 16:16:45 1996 +++ xemacs-20.0-b26/src/callint.c Thu Jul 11 08:08:26 1996 @@ -272,5 +272,5 @@ if (SUBRP (fun)) { - prompt_data = XSUBR (fun)->prompt; + prompt_data = subr_prompt (XSUBR (fun)); if (!prompt_data) { diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/chartab.c xemacs-20.0-b26/src/chartab.c --- xemacs-20.0-b26-orig/src/chartab.c Sun Apr 7 20:35:50 1996 +++ xemacs-20.0-b26/src/chartab.c Tue Jul 9 09:17:11 1996 @@ -93,9 +93,9 @@ static int char_table_entry_equal (Lisp_Object, Lisp_Object, int depth); static unsigned long char_table_entry_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, - mark_char_table_entry, internal_object_printer, - 0, char_table_entry_equal, - char_table_entry_hash, - struct Lisp_Char_Table_Entry); +DEFINE_LOBJECT_CLASS ("Char-Table-Entry", char_table_entry, 0, + mark_char_table_entry, internal_object_printer, + 0, char_table_entry_equal, + char_table_entry_hash, + struct Lisp_Char_Table_Entry); static Lisp_Object @@ -140,8 +140,8 @@ static int char_table_equal (Lisp_Object, Lisp_Object, int depth); static unsigned long char_table_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, - mark_char_table, print_char_table, 0, - char_table_equal, char_table_hash, - struct Lisp_Char_Table); +DEFINE_LOBJECT_CLASS ("Char-Table", char_table, 0, + mark_char_table, print_char_table, 0, + char_table_equal, char_table_hash, + struct Lisp_Char_Table); static Lisp_Object @@ -170,5 +170,5 @@ for (rest = Vall_syntax_tables; - !GC_NILP (rest); + !NILP (rest); rest = XCHAR_TABLE (rest)->next_table) { @@ -176,5 +176,5 @@ { /* This table is garbage. Remove it from the list. */ - if (GC_NILP (prev)) + if (NILP (prev)) Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; else @@ -615,6 +615,5 @@ enum char_table_type ty = symbol_to_char_table_type (type); - ct = (struct Lisp_Char_Table *) - alloc_lcrecord (sizeof (struct Lisp_Char_Table), lrecord_char_table); + ct = alloc_lobject (class_char_table); ct->type = ty; if (ty == CHAR_TABLE_TYPE_SYNTAX) @@ -644,7 +643,5 @@ int i; - cte = (struct Lisp_Char_Table_Entry *) - alloc_lcrecord (sizeof (struct Lisp_Char_Table_Entry), - lrecord_char_table_entry); + cte = alloc_lobject (class_char_table_entry); for (i = 0; i < 96; i++) cte->level2[i] = initval; @@ -662,6 +659,5 @@ ctenew = (struct Lisp_Char_Table_Entry *) - alloc_lcrecord (sizeof (struct Lisp_Char_Table_Entry), - lrecord_char_table_entry); + alloc_lobject (class_char_table_entry); for (i = 0; i < 96; i++) { @@ -693,6 +689,5 @@ CHECK_CHAR_TABLE (old_table); ct = XCHAR_TABLE (old_table); - ctnew = (struct Lisp_Char_Table *) - alloc_lcrecord (sizeof (struct Lisp_Char_Table), lrecord_char_table); + ctnew = alloc_lobject (class_char_table); ctnew->type = ct->type; @@ -1752,4 +1747,9 @@ syms_of_chartab (void) { + DEFCLASS (char_table); +#ifdef MULE + DEFCLASS (char_table_entry); +#endif + #ifdef MULE defsymbol (&Qcategory_table_p, "category-table-p"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/chartab.h xemacs-20.0-b26/src/chartab.h --- xemacs-20.0-b26-orig/src/chartab.h Thu May 9 16:18:09 1996 +++ xemacs-20.0-b26/src/chartab.h Mon Jul 8 14:36:26 1996 @@ -38,16 +38,15 @@ #ifdef MULE -DECLARE_LRECORD (char_table_entry, struct Lisp_Char_Table_Entry); +DECLARE_LOBJECT_CLASS (char_table_entry, struct Lisp_Char_Table_Entry); #define XCHAR_TABLE_ENTRY(x) \ - XRECORD (x, char_table_entry, struct Lisp_Char_Table_Entry) -#define XSETCHAR_TABLE_ENTRY(x, p) XSETRECORD (x, p, char_table_entry) -#define CHAR_TABLE_ENTRYP(x) RECORDP (x, char_table_entry) -#define GC_CHAR_TABLE_ENTRYP(x) GC_RECORDP (x, char_table_entry) -/* #define CHECK_CHAR_TABLE_ENTRY(x) CHECK_RECORD (x, char_table_entry) + XOBJECT (x, char_table_entry, struct Lisp_Char_Table_Entry) +#define XSETCHAR_TABLE_ENTRY(x, p) XSETLOBJECT (x, p, char_table_entry) +#define CHAR_TABLE_ENTRYP(x) OBJECT_CLASSP (x, char_table_entry) +/* #define CHECK_CHAR_TABLE_ENTRY(x) CHECK_OBJECT (x, char_table_entry) char table entries should never escape to Lisp */ struct Lisp_Char_Table_Entry { - struct lcrecord_header header; + struct lobject_header header; /* In the interests of simplicity, we just use a fixed 96-entry @@ -59,12 +58,11 @@ #endif /* MULE */ -DECLARE_LRECORD (char_table, struct Lisp_Char_Table); +DECLARE_LOBJECT_CLASS (char_table, struct Lisp_Char_Table); #define XCHAR_TABLE(x) \ - XRECORD (x, char_table, struct Lisp_Char_Table) -#define XSETCHAR_TABLE(x, p) XSETRECORD (x, p, char_table) -#define CHAR_TABLEP(x) RECORDP (x, char_table) -#define GC_CHAR_TABLEP(x) GC_RECORDP (x, char_table) -#define CHECK_CHAR_TABLE(x) CHECK_RECORD (x, char_table) -#define CONCHECK_CHAR_TABLE(x) CONCHECK_RECORD (x, char_table) + XOBJECT (x, char_table, struct Lisp_Char_Table) +#define XSETCHAR_TABLE(x, p) XSETLOBJECT (x, p, char_table) +#define CHAR_TABLEP(x) OBJECT_CLASSP (x, char_table) +#define CHECK_CHAR_TABLE(x) CHECK_OBJECT (x, char_table) +#define CONCHECK_CHAR_TABLE(x) CONCHECK_OBJECT (x, char_table) #define CHAR_TABLE_TYPE(ct) ((ct)->type) @@ -90,5 +88,5 @@ struct Lisp_Char_Table { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object ascii[NUM_ASCII_CHARS]; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/classes.c xemacs-20.0-b26/src/classes.c --- xemacs-20.0-b26-orig/src/classes.c Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/src/classes.c Thu Jul 18 12:13:54 1996 @@ -0,0 +1,719 @@ +/* Definition of the basic classes for XEmacs. + Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994 + Free Software Foundation, Inc. + Copyright (C) 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: FSF 19.28, Mule 2.0. Substantially different from + FSF. */ + +/* Authorship: + + Tonny Madsen: Initial Version. +*/ + +#include +#include "lisp.h" +#ifdef HAVE_SHLIB +#include "shlib.h" +#endif + + +/***************************************************************************** + * Variables * + *****************************************************************************/ + +/* This variables is used for all translation of class ID's to class + structures with the macro XLHEADER_CLASS (see classes.h). The + variable is updated with the function defclass and finalize_class + (see below). */ +Lisp_Class *class_ids[CLASS_IDS_SIZE]; + +Lisp_Object Qclassp; + +/* From alloc.c: Number of bytes of consing done since the last gc */ +extern EMACS_INT consing_since_gc; + +/* From alloc.c: Current debug level for allocation. */ +extern int debug_allocation; +extern int debug_allocation_backtrace_length; + + +/**************************************************************************** + * DIRECT OBJECTS * + ****************************************************************************/ + + +/**************************************************************************** + * NONHEADER OBJECTS * + ****************************************************************************/ + + +/**************************************************************************** + * LOBJECTS * + ****************************************************************************/ + +/* When LOBJECTS are allocated in frob blocks (see description in + classes.h), the size of the allocated memory is adjusted to fit + into the blocks used by the malloc system. MALLOC_OVERHEAD is the + expected overhead for some of the better known malloc systems. */ +#ifndef MALLOC_OVERHEAD +#ifdef GNU_MALLOC +#define MALLOC_OVERHEAD 0 +#elif defined (rcheck) +#define MALLOC_OVERHEAD 20 +#else +#define MALLOC_OVERHEAD 8 +#endif +#endif + +/* Initialize the header of a new object. */ +static void +init_lobject_header(Lisp_Class *aclass, lobject_header *header, int dynamic) +{ + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + struct lobject_intern *intern = LOBJECT_2_INTERN(header); + + assert (impl->objecttype == LC_LOBJECT); + assert ((header == &aclass->header) || /* Detect class_class */ + aclass->header.class_id); /* Already registered! */ + + if (!(impl->flags & LC_USEFROBBLOCKS)) { + /* Older objects must be later in the chain. This is important for + sweep_headers_1. */ + intern->next = aclass->objects.malloc.objects; + aclass->objects.malloc.objects = intern; + } + + SET_LHEADER_CLASS (header, aclass); + + header->dyn_alloced = dynamic; + header->marked = 0; + header->finalized = 1; + header->free = 1; + header->invisible = 0; + header->protected = 0; +} + +void * +alloc_lobject (Lisp_Class *aclass) +{ + assert (!XCLASS_IMPL (aclass)->size_in_bytes_method); + return alloc_lobject_size (aclass, XCLASS_IMPL (aclass)->static_size); +} + +void * +alloc_lobject_size (Lisp_Class *aclass, int size) +{ + lobject_header *header; + unsigned int i; + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + + struct lobject_intern *free = 0; + struct lobject_intern *f; + + assert (impl->objecttype == LC_LOBJECT); + assert (size > 0); + assert ((impl->static_size == 0) || (impl->static_size == size)); + + if (impl->flags & LC_USEFROBBLOCKS) { + if (!aclass->free_objects) { + /* No free objects: allocate new frob block and link the objects + into the free chain. */ + struct lobject_frob_block *frob; + assert (aclass->stats.objects_on_free_list == 0); + + frob = (struct lobject_frob_block*) + allocate_lisp_storage (sizeof(*frob)-sizeof(frob->data)+ + aclass->objects.frob.objects_per_frob*size); + /* Initialize all the to-be objects in the frob block and link + them together */ + for (i = 0; i < aclass->objects.frob.objects_per_frob; i++, free = f) { + f = LOBJECT_2_INTERN((char *)frob->data+i*size); + init_lobject_header(aclass, &f->header, 1); + f->next_free = free; + } + frob->next = aclass->objects.frob.last_frob; + aclass->objects.frob.last_frob = frob; + aclass->free_objects = free; + + /* Update the statistics */ + aclass->stats.objects_on_free_list = aclass->objects.frob.objects_per_frob; + aclass->stats.bytes_on_free_list = aclass->objects.frob.objects_per_frob*size; + } + + free = aclass->free_objects; + /* free is now the first free object */ + assert (free); + aclass->free_objects = free->next_free; + + /* Update the statistics */ + aclass->stats.objects_on_free_list--; + aclass->stats.bytes_on_free_list -= size; + } else { + /* If we keep a free-list for this class, then search the + list for an object with the correct size. */ + if ((impl->flags & LC_KEEPFREELIST) && aclass->free_objects) { + struct lobject_intern **prev = &aclass->free_objects; + + for (;(f = *prev) && (size != f->size); prev = &f->next_free); + + if (f) { + *prev = f->next_free; + + /* Update the statistics */ + aclass->stats.objects_on_free_list--; + aclass->stats.bytes_on_free_list -= size; + } + } + + /* If we didn't find any object on the free-list of the correct + size or if we don't use a free list, then allocate a new object + and initialize the header. */ + if (!free) { + free = (struct lobject_intern*)allocate_lisp_storage (size+sizeof(free->next)); + init_lobject_header(aclass, &free->header, 1); + } + } + + /* At this point we have a free object (not included in the + stats..._on_free_list */ + assert (free); + header = INTERN_2_LOBJECT(free); + assert (header->free); + header->finalized = 0; + header->free = 0; + + /* Update the statistics */ + aclass->stats.objects_in_use++; + aclass->stats.bytes_in_use += size; + + consing_since_gc += size; + +#ifdef DEBUG_XEMACS + if (debug_allocation) { + stderr_out ("allocating %s (size %d)\n", impl->name, size); + if (debug_allocation_backtrace_length > 0) + debug_short_backtrace (debug_allocation_backtrace_length); + } +#endif + + return (header); +} + +void +free_lobject (void *ptr) +{ + lobject_header *header = (lobject_header *)ptr; + struct lobject_intern *free = LOBJECT_2_INTERN (header); + Lisp_Class *aclass = XLHEADER_CLASS (header); + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + unsigned int size; + + assert (impl->objecttype == LC_LOBJECT); + /* It can *NOT* be marked at this point: either free_lobject is + called from sweep_lobjecs or directly by class code. In both + case, the object will be unmarked. */ + assert (!MARKED_LHEADER_P(header)); + /* The objects may not be freed already */ + assert (!header->free); + /* Must be correct class */ + assert (header->class_id == aclass->class_id); + + if (impl->size_in_bytes_method) + size = (impl->size_in_bytes_method) ((lobject_header*)header); + else + size = impl->static_size; + + if (!header->finalized) { + header->finalized = 1; + if (impl->finalizer) (impl->finalizer) (header, 0); + } + + if (impl->flags & LC_USEFROBBLOCKS) { + /* Object can be freed already!!! */ + free->next_free = aclass->free_objects; + aclass->free_objects = free; + + /* Update the statistics */ + aclass->stats.objects_on_free_list++; + aclass->stats.bytes_on_free_list += size; + } else { + /* If we use a free-list, then add the object to the list */ + if (impl->flags & LC_KEEPFREELIST) { + /* If we use a free-list, then check the wanted record have room + for the needed fields in struct lobject_intern. this can't be + done in defclass as the size can vary. */ + assert(size >= sizeof (struct lobject_intern)); + + /* Record the size of the object */ + free->size = size; + + free->next_free = aclass->free_objects; + aclass->free_objects = free; + + /* Update the statistics */ + aclass->stats.objects_on_free_list++; + aclass->stats.bytes_on_free_list += size; + } + /* LOBJECTS that are allocated using the malloc allocation method + (see below) are not freed here. The objects are freed in the + sweeper below. This insures the next-list is updated + corectly. */ + } + + /* Update the statistics */ + aclass->stats.objects_in_use--; + aclass->stats.bytes_in_use -= size; + aclass->stats.objects_freed++; + aclass->stats.bytes_freed += size; + + header->free = 1; +} + +void +lobject_class_sweeper (struct Lisp_Class *aclass, int function, void (*markobj) (Lisp_Object)) +{ + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + Lisp_Object obj; + + assert (impl->objecttype == LC_LOBJECT); + + /* We can optimize some cases */ + switch (function) { + case SWEEPER_FINALIZE: + case SWEEPER_DUMP: + /* If the class has no finalize function, then there are nothing to do here. */ + if (!impl->finalizer) return; + break; + case SWEEPER_FREE: + /* Reset the statistics */ + aclass->stats.objects_freed = 0; + aclass->stats.bytes_freed = 0; + + if (impl->flags & LC_USEFROBBLOCKS) { + aclass->free_objects = 0; + } + break; + case SWEEPER_PROTECT: + if (!(impl->flags & LC_PROTECTEDOBJECTS)) return; + assert (markobj); + break; + } + + /* First go through and call all the finalize methods. Then go + through and free the objects. There used to be only one loop + here, with the call to the finalizer occurring directly before + the xfree() below. That is marginally faster but much less safe + -- if the finalize method for an object needs to reference any + other objects contained within it (and many do), we could easily + be screwed by having already freed that other object. */ + + /* We have the "finalize" of the class last, as these probably will + delete some of the internal chains with objects of that + class. This happens automatically as the class for classs + (class_class) always is the first one initialized with + init_lobject_header. */ + + /* For LOBJECTS allocated in frob blocks, we re-create the + free_objects chain completely every time the garbage-collection + in run. This way the free_objects chain will have all free + objects from the same frob block as neighbours, with never frob + blocks prefered to older frob blocks. This in turn should give us + a better location-of-reference strategy - I hope. */ + + if (impl->flags & LC_USEFROBBLOCKS) { + struct lobject_frob_block *frob; + unsigned int i; + lobject_header *header; + + for (frob = aclass->objects.frob.last_frob; + frob; frob = frob->next) { + for (i = 0; i < aclass->objects.frob.objects_per_frob; i++) { + header = (lobject_header *)((char *)frob->data+i*impl->static_size); + + switch (function) { + case SWEEPER_FINALIZE: + if (header->free) continue; + if (!MARKED_LHEADER_P(header)) { + header->finalized = 1; + (impl->finalizer) (header, 0); + } + break; + case SWEEPER_FREE: + /* Free the object */ + if (MARKED_LHEADER_P(header)) { + UNMARK_LHEADER (header); + } else if (header->free) { + struct lobject_intern *free = LOBJECT_2_INTERN (header); + /* Just put the object back on the free chain */ + free->next_free = aclass->free_objects; + aclass->free_objects = free; + } else { + free_lobject (header); + } + break; + case SWEEPER_DUMP: + if (!header->free) (impl->finalizer) (header, 1); + break; + case SWEEPER_PROTECT: + if (header->free || !header->protected) continue; + XSETOBJ (obj, Lisp_LObject, header); + markobj(obj); + break; + } + } + } + } else { + lobject_header *header; + struct lobject_intern **prev; + + switch (function) { + case SWEEPER_FINALIZE: + LOBJECT_INUSE_LOOP(aclass, lobject_header *, header, + if (!MARKED_LHEADER_P (header)) { + header->finalized = 1; + ((impl->finalizer) (header, 0)); + } + ) + break; + case SWEEPER_FREE: + for (prev = &(aclass->objects.malloc.objects); *prev;) { + header = INTERN_2_LOBJECT (*prev); + if (MARKED_LHEADER_P (header)) { + UNMARK_LHEADER (header); + } else if (!header->free) { + free_lobject (header); + } + /* Objects can be free already (have header->free set). Our + action depends on the LC_KEEPFREELIST flag: + + - if set, this object is on the free-list and is ignored. + + - if cleared, this object has previously been freed with + free_lobject. In this case, we free the object below. */ + if ((!header->free) || (impl->flags & LC_KEEPFREELIST)) { + prev = &((*prev)->next); + } else { + *prev = (*prev)->next; + xfree_1 (LOBJECT_2_INTERN (header)); + } + } + break; + case SWEEPER_DUMP: + LOBJECT_INUSE_LOOP(aclass, lobject_header *, header, + if (!header->free) ((impl->finalizer) (header, 1)); + ) + break; + case SWEEPER_PROTECT: + LOBJECT_INUSE_LOOP(aclass, lobject_header *, header, + if (header->free || !header->protected) continue; + XSETOBJ (obj, Lisp_LObject, header); + markobj(obj); + ) + break; + } + } +} + +Lisp_Object +lobject_list(Lisp_Class *aclass) +{ + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + Lisp_Object o; + Lisp_Object retval = Qnil; + + assert (impl->objecttype == LC_LOBJECT); + + if (impl->flags & LC_INVISIBLEOBJECTS) return Qnil; + + LOBJECT_INUSE_LOOP(aclass, lobject_header *, header, + if (header->invisible) continue; + XSETOBJ (o, Lisp_LObject, header); + retval = Fcons (o, retval); + ) + return retval; +} + + +/***************************************************************************** + * Definition of the class "Class" * + *****************************************************************************/ + +static Lisp_Object mark_class (Lisp_Object, void (*) (Lisp_Object)); +static void print_class (Lisp_Object, Lisp_Object, int); +DEFINE_LOBJECT_CLASS ("Class", class, LC_PROTECTEDOBJECTS, + mark_class, print_class, 0, 0, + 0, Lisp_Class); + +static Lisp_Object +mark_class (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + /* Currently nothing; but that will probably change */ + return Qnil; +} + +static void +print_class (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Class *aclass = XCLASS (obj); + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + Lisp_Class *myclass = XLHEADER_CLASS (&aclass->header); + char buf[200]; + + if (print_readably) + error ("printing unreadable object #<%s %s 0x%x>", + XCLASS_IMPL (myclass)->name, impl->name, LHEADER_UID (&aclass->header)); + + sprintf (buf, "<%s %s ", XCLASS_IMPL (myclass)->name, impl->name); + write_c_string (buf, printcharfun); + switch (impl->objecttype) { + case LC_DIRECT: + write_c_string("DIRECT ", printcharfun); + break; + case LC_NONHEADER: + write_c_string("NONHEADER ", printcharfun); + break; + case LC_LOBJECT: + write_c_string("LOBJECT ", printcharfun); + break; + } + sprintf (buf, "0x%x>", LHEADER_UID (&aclass->header)); + write_c_string (buf, printcharfun); +} + +static void +finalize_class (void *header, int for_disksave) +{ + Lisp_Class *aclass = (Lisp_Class *)header; + + /* Check the class ID */ + assert ((0 < aclass->class_id) && (aclass->class_id < CLASS_IDS_SIZE)); + assert (class_ids[aclass->class_id] == aclass); + /* At this point there should be no more objects of this class */ + assert (aclass->stats.objects_in_use == 0); + assert (aclass->stats.bytes_in_use == 0); + + /* free allocated objects */ + if (aclass->impl->flags & LC_USEFROBBLOCKS) { + struct lobject_frob_block *frob; + struct lobject_frob_block *frobnext; + unsigned int i; + lobject_header *header; + + for (frobnext = aclass->objects.frob.last_frob; frob = frobnext;) { + /* Assert all objects in the block is free */ + for (i = 0; i < aclass->objects.frob.objects_per_frob; i++) { + header = (lobject_header *)((char *)frob->data+i*aclass->impl->static_size); + assert (header->free); + } + frobnext = frob->next; + xfree (frob); + } + } else { + struct lobject_intern *header; + struct lobject_intern *headernext; + + for (headernext = aclass->objects.malloc.objects; header = headernext;) { + assert (header->header.free); + xfree (header); + } + } + + /* Deallocate the class ID */ + class_ids[aclass->class_id] = 0; + aclass->class_id = 0; + assert(0); +} + +DEFUN ("object-list", Fobject_list, Sobject_list, 1, 1, 0 /* +Return a list with all objects of the specified CLASS. +*/ ) + (class) + Lisp_Object class; +{ + CHECK_CLASS (class, 0); + + return lobject_list(XCLASS(class)); +} + + +/**************************************************************************** + * defclass * + ****************************************************************************/ + +Lisp_Class* +defclass (CONST Lisp_Class_Impl *impl) +{ + Lisp_Class *aclass; + int id; + + /* Not already registered */ + CLASSES_LOOP(aclass, + assert (impl != aclass->impl); + ) + + /* Allocate an ID for the class andinitialize the class_ids table */ + if (impl == &class_impl_symbol_value_forward) { + id = CLASS_SYMBOL_VALUE_FORWARD_ID; + } else { + for (id = FIRST_FREE_CLASS_ID; id < countof(class_ids); id++) + if (!class_ids[id]) break; + + assert (id < countof(class_ids)); + } + assert (!class_ids[id]); + + /* Allocate a Lisp_Class structure for the class */ + if (impl == &class_impl_class) { + /* Special case code for class_class */ + struct lobject_intern *free = + (struct lobject_intern*)allocate_lisp_storage (sizeof(*aclass)+sizeof(free->next)); + aclass = (Lisp_Class*)INTERN_2_LOBJECT(free); + zero_lobject(aclass); + aclass->impl = impl; + aclass->class_id = id; + init_lobject_header(aclass, &aclass->header, 1); + /* Update the statistics */ + aclass->stats.objects_in_use++; + aclass->stats.bytes_in_use += sizeof(*aclass); + } else { + aclass = (Lisp_Class*)alloc_lobject(class_class); + zero_lobject(aclass); + aclass->impl = impl; + aclass->class_id = id; + } + + /* Initializa the class structure */ + class_ids[id] = aclass; + aclass->header.free = 0; + + /* Some consistency checks and some calculation of class fields */ + switch (impl->objecttype) { + case LC_DIRECT: + assert(!(impl->flags & LC_KEEPFREELIST)); + break; + case LC_NONHEADER: + assert(!(impl->flags & LC_KEEPFREELIST)); + break; + case LC_LOBJECT: + if (impl->flags & LC_USEFROBBLOCKS) { + assert(!impl->size_in_bytes_method); + assert(impl->static_size >= sizeof(lobject_header)); + assert(!(impl->flags & LC_KEEPFREELIST)); + /* We have to calculate objects.frob.objects_per_frob here */ + { + struct lobject_frob_block frob; + + aclass->objects.frob.objects_per_frob = + (2048 - MALLOC_OVERHEAD - sizeof(frob)-sizeof(frob.data))/ + impl->static_size; + } + } + } + + /* Intern the class name and set the value of the symbol to the + class. */ + defclass_install_name (aclass); + +#ifdef HAVE_SHLIB + if (!NILP (Vcurrent_shlib)) { + Lisp_Object obj; + + XSETCLASS(obj, aclass); + shlib_add_object (obj); + } +#endif + + assert (aclass->class_id == id); + assert (class_ids[aclass->class_id] == aclass); + return aclass; +} + +/* Install the name of the class in Vobarray. This can not be done + until Vobarray is defined. Thsi function is called twice for the + few classes that is defined before Vobarray (see below and in + symbols.c). */ +void +defclass_install_name (Lisp_Class *aclass) +{ + CONST Lisp_Class_Impl *impl = XCLASS_IMPL (aclass); + Lisp_Object kludge; + Lisp_Object name; + Lisp_Object sym; + + if (!VECTORP (Vobarray)) return; + if (impl->flags & LC_INVISIBLECLASS) { + SET_LOBJECT_PROTECTED(aclass, 1); + } else { + if (purify_flag) { + name = make_pure_pname ((CONST Bufbyte *) impl->name, + strlen (impl->name), 1); + } else { + name = make_string ((CONST Bufbyte *) impl->name, + strlen (impl->name)); + } + sym = Fintern (name, Qnil); + + /* Check that magic points somewhere we can represent as a Lisp pointer */ + XSETOBJ (kludge, Lisp_LObject, aclass); + assert (aclass == (CONST void *) XPNTR (kludge)); + + /* Set the value of the class symbol */ + Fset(sym, kludge); + } +} + +/* Removed all the normal references to the class, such as protected + flag and interned name. */ +void +defclass_uninstall_name(Lisp_Class *aclass) +{ + assert (VECTORP (Vobarray)); + if (aclass->impl->flags & LC_INVISIBLECLASS) { + SET_LOBJECT_PROTECTED(aclass, 0); + } else { + Lisp_Object sym = intern (aclass->impl->name); + + /* Clear the value of the class symbol */ + Fset(sym, Qunbound); + } +} + + +/**************************************************************************** + * Initialization * + ****************************************************************************/ + +void +init_classes_once_early (void) +{ + DEFCLASS (class); +} + +void +syms_of_classes (void) +{ + defclass_install_name (class_class); + + defsymbol (&Qclassp, "classp"); + + defsubr (&Sobject_list); +} diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/classes.h xemacs-20.0-b26/src/classes.h --- xemacs-20.0-b26-orig/src/classes.h Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/src/classes.h Thu Jul 18 12:18:28 1996 @@ -0,0 +1,954 @@ +/* Implementation of object classes in Emacs. + Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 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. */ + +#ifndef _XEMACS_CLASSES_H_ +#define _XEMACS_CLASSES_H_ + + +/**************************************************************************** + * Introduction * + ****************************************************************************/ + +/* All data in Emacs is organized as objects. Each object belong to + exactly one class. The class defines the common behaviour for all + objects of that class. + + For each class known to Emacs the developer must use the + DECLARE_..._CLASS and DEFINE_..._CLASS macros to fill out an + implementation structure that describe the implementation of the + class in terms of C functions and a few flags . This structure used + as argument to the defclass function to define the new class to + Emacs. + + Each class defined in emacs has a class id (always + non-zero). This id is a small integer, that is used as an index in + the table class_ids in order to find the class structure that + corresponds to the class. The constant CLASS_ID_BITS (defined + below) specify the number of bits that is used for the id in the + header of LOBJECTS. The number of possible classes is + 2**CLASS_ID_BITS. Pure emacs classes also have a class id. The ids + are allocated in defclass and freed again in the finalizer for the + class of the class, i.e. the meta-class. + + *** OBJECT REPRESENTATIONS *** + + Emacs uses three different representation of objects. Which + representation to use, depends on the amount of data for the + object. The representations are called DIRECT OBJECTS, NONHEADER + OBJECTS, and LOBJECTS. Each of these object representations is + described in details below. + + The decision about which representation to used for a new object + type is primary based on the number and the size of the new + objects, but in general you should always use the LOBJECT + representation. + + A very, very large number of very, very small objects may be should + be use NONHEADER OBJECTS. If the object is more than 4-5 words + (int) large, it very probably *should* be a LOBJECT. With this + said, just about all new objects in Emacs will be LOBJECTS. + + If you opt for using DIRECT or NONHEADER OBJECTS, you should know + that there is a lot of work involved with changes to most parts of + Emacs. So don't! + + If you have a Lisp_Object the corresponding class can be found with + the macro XOBJECT_CLASS(obj). + + The following text first describes the different object + representations and then describes how to make a new class. + + *** DIRECT OBJECTS *** + + These objects are used for objects that can be represented directly + in an Lisp_Object structure. These objects are *very* fast to + create, delete and access as they don't have any allocated data + associated with them. DIRECT OBJECTS are identified directly by the + value of the XTYPE(object) macro. + + These objects are ignored in garbage collection as there is no + memory to free. + + Emacs has two object classes of this type: integers and characters. + + *** NONHEADER OBJECTS *** + + These objects (previously known as "basic" lrecord objects??) are + objects that are not an LOBJECT, i.e. objects that do not have an + lobject_header at the front. These objects are allocated in frob + blocks (see alloc.c). A NONHEADER OBJECT can not be recognized from + the memory image without a Lisp_Object "pointer", but is identified + directly by the value of the XTYPE(object) macro. + + Garbage collection of these objects can easily become complicated + as some special field in the memory block of the objects must be + used for marking and mark_object and the corresponding + sweep-function must be modified to do this. + + Emacs has a number of objects of this type depending on options on + the compilation time: cons-cells, strings (depends on + USE_LOBJECT_STRING), symbols (depends on USE_LHEADER_SYMBOL) and + vectors (depends on USE_LOBJECT_VECTOR). Note that some of these + object types are likely to be changed into LOBJECTS in the future. + + *** LOBJECTS *** + + These objects are used for all objects that is not DIRECT or + NONHEADER. A LOBJECT is characterized by having an lobject_header + as the first field of the structure. + + LOBJECTS are allocated and freed using the functions alloc_lobject + and free_lobject. + + The memory used for LOBJECTS can be allocated using two different + methods: either in frob blocks, where the objects are grouped + together to save performance and malloc overhead (see below for a + longer description), or individually using malloc for each + object. The main difference between these allocation methods is how + garbage-collection is performed. Note through that objects + allocated in frob blocks must have the same size - if you have some + variable-size data, you will have to use individual allocation. + + Some flags are used to control LOBJECTS: + + - LC_USEFROBBLOCKS specify that frob blocks are to be used. + + - LC_KEEPFREELIST specify that a free-list should be used for the + malloc allocation method (this is normally not done; with this + flag, garbage-collected LOBJECTS are freed with xfree.). + + - LC_INVISIBLECLASS specify that the classes will not accessable + from elisp. This is not really used yet, but is ment for a class + like Opaque. + + - LC_INVISIBLEOBJECTS specify that objects of the class is not + visible at the elisp level. It currently only affect lobject_list, + which will return a list of all live objects of a specific class. + + - LC_PROTECTEDOBJECTS specify that objects of the class can be made + persistent by setting a flag in the object header. If the flag is + set, the works like if the object is put on the staticvec + array. This feature is primary ment for shlib loaded objects, which + can not be put in the staticvec array (not if they should be + unloaded later, that is). + + The class of an LOBJECT can be found with XLOBJECT_CLASS. + + LOBJECTS are identified as having (XTYPE(object) == Lisp_LObject) + (checked with the macro LOBJECTP(object)). + + The structures used for LOBJECTS *must* have a struct + lobject_header field as the first field. ###TM### I would like to + do away with this requirement, but that seems to be rather + difficult, and will probably require a replacement for malloc&co. + + All classes not mentioned above uses LOBJECTS. + + *** DECLARING A NEW CLASS *** + + ###TM###: DOC + + If you want to make a new LOBJECT class the object structure *must* + have an lobject_header as the first field. If you expect to use any + of the macroes found in this header file, the field name must be + 'header'. Thus we have: + + struct foo_object { + lobject_header header; + Other fields... + } + + + + *** FROB BLOCKS *** + + NONHEADER OBJECTS and LOBJECTS, with the LC_USEFROBBLOCKS flag + specified are allocated in frob blocks. + + Frob blocks are large malloc()ed blocks of memory and that are + subdivided into chunks of the correct size for an object of that + type. This is more efficient than malloc()ing each object + separately because we save on malloc() time and overhead due to the + fewer number of malloc()ed blocks, and also because we don't need + any extra pointers within each object to keep them threaded + together for GC purposes (this is accomplished by only allowing + static-sized LOBJECTS - NONHEADER OBJECTS are always static-sized). + + alloc.c contains a large comment on the allocation method for + NONHEADER OBJECTS. + + *** CURRENT CLASSES *** + + The following is a complete list of the defined object classes in + XEmacs. Please update this list if you alter anything in Emacs. + + The 'repre' field specify the type of the object in terms of the + basic object representation and can have the following values. The constants + in brackets are found as the value of the 'objecttype' field of + Lisp_Class. + + d [LC_DIRECT] embedded in the "pointer" directly + n [LC_NONHEADER] declared as NONHEADER + l [LC_LOBJECT] uses lobject_header + + Some of the LOBJECTS have the suffix "(fb)"; these LOBJECTS + (currently) uses frob blocks. + + + + Name Type Struct Notes + ---------------------------------------------------------------------------------------------------- + "integer" (Lisp_Int) d + "char" (Lisp_Char) d + "bit-vector" Lisp_Bit_Vector l(fb) + "char-table" Lisp_Char_Table l + "char-table-entry" Lisp_Char_Table_Entry l + "charset" Lisp_Charset l + "coding-system" Lisp_Coding_System l + "color-instance" Lisp_Color_Instance l + "compiled-function" Lisp_Compiled_Function l(fb) + "cons" Lisp_Cons n + "event" Lisp_Event l(fb) + "face" Lisp_Face l + "float" Lisp_Float l(fb) + "font-instance" Lisp_Font_Instance l + "glyph" Lisp_Glyph l + "image-instance" Lisp_Image_Instance l + "marker" Lisp_Marker l(fb) + "opaque" Lisp_Opaque l Should not be lisp visible + "opaque-list" Lisp_Opaque_List l Should not be lisp visible + "process" Lisp_Process l + "range-table" Lisp_Range_Table l + "shared-lib" Lisp_Shlib l + "specifier" Lisp_Specifier l + "string" Lisp_String n/l(fb) + "subr" Lisp_Subr l(fb) + "subwindow" Lisp_Subwindow l + "symbol" Lisp_Symbol n/l(fb) + "tooltalk-message" Lisp_Tooltalk_Message l + "tooltalk-pattern" Lisp_Tooltalk_Pattern l + "vector" Lisp_Vector n/l(fb) + "x-resource" Lisp_X_Resource l + "buffer" buffer l + "command-builder" command_builder l + "console" console l + "database" database_struct l + "device" device l + "extent" extent l(fb) + "extent-auxiliary" extent_auxiliary l + "extent-info" extent_info l + "frame" frame l + "hashtable" hashtable_struct l + "keymap" keymap l + "Class" Lisp_Class l + "stream" lstream l keep list of free objects + "popup-data" popup_data l + "toolbar-button" toolbar_button l + "toolbar-data" toolbar_data l + "weak-list" weak_list l + "window" window l + "window-configuration" window_configuration l keep list of free objects + + --- Lisp_Buffer_Cons n ? + "symbol-value-forward" symbol_value_forward l + "symbol-value-buffer-local" symbol_value_buffer_local l + "symbol-value-lisp-magic" symbol_value_lisp_magic l + "symbol-value-varalias" symbol_value_varalias l + + + */ + + +/**************************************************************************** + * Implementation CONSTANT * + ****************************************************************************/ + +/* This macro defines the number of bits in a class ID. See + documentation above. */ +#define CLASS_ID_BITS 12 +#define CLASS_IDS_SIZE (1<header)) + + +/**************************************************************************** + * Lisp_Class * + ****************************************************************************/ + +/* Forward declaration of some classes.c internal structures. */ +struct lobject_intern; + +struct lobject_frob_block +{ + struct lobject_frob_block *next; + int data[1]; +}; + +typedef struct Lisp_Class Lisp_Class; + + +/* The implementation structure is used by a developer (through the + DECLARE_..._CLASS and DEFINE_..._CLASS macroes) to describe a lisp + class. This structure is *NEVER* changed once initialized, and can + therefore be declared const. */ + +typedef +struct Lisp_Class_Impl { + /* Name of class. */ + CONST char *name; + /* The class ID of this class. The class ID is calculated and + assigned in the defclass function. */ + unsigned int objecttype : 2; + /* Implementation flags associated with the class. See below for the + definitions. */ + unsigned int flags : 10; + /* 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 function is called in two situations: in the sweep phase of + GC, to first finalize and later free the unmarked objects of this + class, and in the dump phase to prepare all objects for the dump. + + The function is called with a different second argument for each + of the three invocations: + + - 'function' argument is SWEEPER_DUMP: this time the function + should call the finalize function of the class (if defined) for + all objects. ###TM###: more doc + + - 'function' argument is SWEEPER_FINALIZE: this time the function + should call the finalize function of the class (if defined) for + each of the unmarked objects (i.e. the objects that should be + freed later). The function may NOT free the object as there can + be other object which reference to this object and for which the + finalize function have not been called yet. + + - 'function' argument is SWEEPER_FREE: this time the function + should simply free all the unmarked objects. Note for LOBJECTS + that have the LC_KEEPFREELIST and LC_USEFROBBLOCKS flags set, + then the memory used by the objects should NOT be freed but only + put on a free list. This is done by setting the 'free' bit of the + lobject_header and linking the object into free_objects + chain. See free_lobject for an example. + + - 'function' argumnent is SWEEPER_PROTECT: this time the function + should protect all objects that are automatically protected. Note + for LOBJECTS this is only done if the LC_PROTECTEDOBJECTS flag is + set for the class. */ + void (*sweeper) (Lisp_Class *aclass, int function, void (*markobj) (Lisp_Object)); + /* 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: 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 function is used to print the object. The arguments are the + object itself, the printer-function used (see Vstandard_output) + and a flag, that ###TM###: check print_internal + + This can be NULL if the object is an LOBJECT ###TM###; + the default_object_printer() in print.c will be used. */ + void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag); + /* See ###TM###: find doc + + 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); + /* The following four functions are used by the property code in ###TM###. + + These variables will be obsolete when the object system works.. */ + Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop); + int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val); + int (*remprop) (Lisp_Object obj, Lisp_Object prop); + Lisp_Object (*plist) (Lisp_Object obj); + + /* The size of objects of this class. Two methods exist: static-size + objects, where all objects have the same size and variable-size + objects, where objects can have different sizes. In the later + case a function must be supplied to return the correct size of a + given object. + + Exactly one of these is non-0. */ + unsigned int static_size; + unsigned int (*size_in_bytes_method) (CONST void* object); +} Lisp_Class_Impl; + +/* *** Possible flags for class->flags *** */ + +/* Free objects are not freed competely but are kept on a free + list. */ +#define LC_KEEPFREELIST 0x0001 +/* Allocate objects in frob blocks (see description above). */ +#define LC_USEFROBBLOCKS 0x0002 +/* The class are not visible from the lisp level */ +#define LC_INVISIBLECLASS 0x0004 +/* Objects of the class are not visible from the lisp level */ +#define LC_INVISIBLEOBJECTS 0x0008 +/* Objects of the class can be protected by setting the protected bit + of the object header. */ +#define LC_PROTECTEDOBJECTS 0x0010 + + +/* The next structure is used internally by Emacs to describe a lisp + class. These structure are created using the function defclass. */ + +struct Lisp_Class { + /* As all other records, we have a record header. */ + lobject_header header; + + /* The implementation of the class. */ + CONST Lisp_Class_Impl *impl; + + /* The class ID of this class. The class ID is calculated and + assigned in the defclass function. */ + unsigned int class_id : CLASS_ID_BITS; + /* Flags associated with the class. See below for the + definitions. */ + unsigned int flags : (INTBITS-CLASS_ID_BITS); + + /* Chain of free objects. */ + struct lobject_intern *free_objects; + + union { + struct { + /* For LOBJECTS with flag LC_USEFROBBLOCKS: */ + + /* No of objects in each frob block. */ + unsigned int objects_per_frob; + /* The last allocated frob block */ + struct lobject_frob_block *last_frob; + } frob; + + struct { + /* For LOBJECTS without flag LC_USEFROBBLOCKS: */ + + /* Head of a chain of all object of this class whether they are + allocated or free (with the LC_KEEPFREELIST flag). See the + 'next' field of the lobject_header above. */ + struct lobject_intern *objects; + } malloc; + } objects; + + /* Statistics for this class */ + struct { + unsigned int objects_in_use; + unsigned int bytes_in_use; + unsigned int objects_freed; + unsigned int bytes_freed; + unsigned int objects_on_free_list; + unsigned int bytes_on_free_list; + } stats; +}; + +/* Possible values for class->objecttype. The meaning of the constants + is described in the prologue of this file. ###TM###: this really + should be an enum, but can these be used in bit-fields???*/ +#define LC_DIRECT 0 +#define LC_NONHEADER 1 +#define LC_LOBJECT 2 + +/* Possible values of the 'function' argument of the sweeper function */ +#define SWEEPER_FREE 0 +#define SWEEPER_FINALIZE 1 +#define SWEEPER_DUMP 2 +#define SWEEPER_PROTECT 3 + +/* Iterate over all classes. The macro is used like this: + + { + Lisp_Class *aclass; + + CLASSES_LOOP(aclass, + do-something-with-aclass(aclass); + ) + } + + You can use break and continue in the loop. + + */ + +#define CLASSES_LOOP(aclass, block) \ +do { \ + unsigned int i__; \ + Lisp_Class *aclass; \ + \ + for (i__ = 0; i__ < CLASS_IDS_SIZE; i__++) { \ + aclass = class_ids[i__]; \ + if (!aclass) continue; \ + {block} \ + } \ +} while (0); + +/* Iterate over all objects of a specified class. The macroes are used + like this: + + { + struct buffer *buffer; + + OBJECT_LOOP(class_buffer, struct buffer*, buffer, + do-something-with-buffer(buffer); + ) + } + + You can use break and continue in the loop. + + WARNING WARNING WARNING WARNING: + + Don't do anything inside the loop that can cause a GC. The chain + used in this loop can be altered in a GC. */ + +/* Loop over all objects of all class (whether free or not) */ +#define LOBJECT_LOOP(aclass, itype, ivar, block) \ +do { \ + struct lobject_intern *obj__; \ + struct lobject_frob_block *frob__; \ + unsigned int i__; \ + itype ivar; \ + \ + if (XCLASS_IMPL (aclass)->flags & LC_USEFROBBLOCKS) { \ + for (frob__ = (aclass)->objects.frob.last_frob; \ + frob__; frob__ = frob__->next) { \ + for (i__ = 0; i__ < (aclass)->objects.frob.objects_per_frob; i__++) { \ + ivar = (itype)((char *)frob__->data+i__*(aclass)->impl->static_size); \ + {block} \ + } \ + } \ + } else { \ + for (obj__ = (aclass)->objects.malloc.objects; \ + obj__; obj__ = obj__->next) { \ + ivar = (itype)INTERN_2_LOBJECT(obj__); \ + {block} \ + } \ + } \ +} while (0); + +/* Iterate over all INUSE objects of a class (free objects are + ignored). This macro is for classes with LC_KEEPFREELIST */ +#define LOBJECT_INUSE_LOOP(aclass, itype, ivar, block) \ + LOBJECT_LOOP(aclass, itype, ivar, \ + if (!(obj__->header.free)) {block}) + + +/**************************************************************************** + * DECLARE_..._CLASS and friends * + ****************************************************************************/ + +/* The following macros are used to declare the Lisp_Class structures + used for classes. It must be before the corresponding + DEFINE_...CLASS macro defined below. + + The macros depends on whether typecheck of objects are enabled or + not. Note that if typecheck is enabled, this is a performance hit. */ + +#ifdef ERROR_CHECK_TYPECHECK + +#define DECLARE_DIRECT_CLASS(c_name, type_enum, directtype) \ +extern Lisp_Class *class_##c_name; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +INLINE directtype error_check_##c_name (Lisp_Object _obj); \ +INLINE directtype \ +error_check_##c_name (Lisp_Object _obj) \ +{ \ + assert (XGCTYPE (_obj) == type_enum); \ + return (directtype) XPNTR (_obj); \ +} \ +extern Lisp_Object Q##c_name##p + +#define DECLARE_NONHEADER_CLASS(c_name, type_enum, structtype) \ +extern Lisp_Class *class_##c_name; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype * \ +error_check_##c_name (Lisp_Object _obj) \ +{ \ + assert (XGCTYPE (_obj) == type_enum); \ + return (structtype *) XPNTR (_obj); \ +} \ +extern Lisp_Object Q##c_name##p + +#define DECLARE_LOBJECT_CLASS(c_name, structtype) \ +extern Lisp_Class *class_##c_name; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype * \ +error_check_##c_name (Lisp_Object _obj) \ +{ \ + assert (OBJECT_TYPEP (_obj, class_##c_name)); \ + return (structtype *) XPNTR (_obj); \ +} \ +extern Lisp_Object Q##c_name##p + +#define XOBJECT(x, c_name, structtype) error_check_##c_name (x) + +#define XSETLOBJECT(var, p, c_name) do \ +{ \ + XSETOBJ (var, Lisp_LObject, p); \ + assert (OBJECT_TYPEP (var, class_##c_name)); \ +} while (0) + +#else /* not ERROR_CHECK_TYPECHECK */ + +define DECLARE_DIRECT_CLASS(c_name, type_enum, structtype) \ +extern Lisp_Class *class_##c_name; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +extern Lisp_Object Q##c_name##p + +define DECLARE_NONHEADER_CLASS(c_name, type_enum, structtype) \ +extern Lisp_Class *class_##c_name; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +extern Lisp_Object Q##c_name##p + +define DECLARE_LOBJECT_CLASS(c_name, structtype) \ +extern Lisp_Object Q##c_name##p; \ +extern CONST Lisp_Class_Impl class_impl_##c_name; \ +extern Lisp_Class *class_##c_name + +define XOBJECT(x, c_name, structtype) ((structtype *) XPNTR (x)) + +define XSETLOBJECT(var, p, c_name) XSETOBJ (var, Lisp_LObject, p) + +#endif /* not ERROR_CHECK_TYPECHECK */ + + +/**************************************************************************** + * DEFINE_..._CLASS and friends * + ****************************************************************************/ + +/* The following macros are used to define the Lisp_Class structures + used for classes. */ + +#define DEFINE_DIRECT_CLASS(name,c_name,flags,marker,printer,nuker,equal,hash) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_DIRECT, flags, \ + marker, 0, nuker, printer, equal, hash, \ + 0, 0, 0, 0, 0, 0, \ + } + +#define DEFINE_NONHEADER_CLASS(name,c_name,flags,marker,printer,nuker,equal,hash,structtype) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_NONHEADER, flags, \ + marker, 0, nuker, printer, equal, hash, \ + 0, 0, 0, 0, sizeof (structtype), 0, \ + } + +#define DEFINE_LOBJECT_CLASS(name,c_name,flags,marker,printer,nuker,equal,hash,structtype) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_LOBJECT, flags, \ + marker, lobject_class_sweeper, nuker, printer, equal, hash, \ + 0, 0, 0, 0, sizeof (structtype), 0, \ + } + +#define DEFINE_LOBJECT_SEQUENCE_CLASS(name,c_name,flags,marker,printer,nuker,equal,hash,sizer,structtype) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_LOBJECT, flags, \ + marker, lobject_class_sweeper, nuker, printer, equal, hash, \ + 0, 0, 0, 0, 0, sizer, \ + } + +/* The following two macroes will be obsoleted with the new object system ###TM##*/ +#define DEFINE_LOBJECT_CLASS_WITH_PROPS(name,c_name,flags,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_LOBJECT, flags, \ + marker, lobject_class_sweeper, nuker, printer, equal, hash, \ + getprop, putprop, remprop, props, sizeof (structtype), 0, \ + } + +#define DEFINE_LOBJECT_SEQUENCE_CLASS_WITH_PROPS(name,c_name,flags,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizer,structtype) \ +Lisp_Class *class_##c_name; \ +CONST Lisp_Class_Impl class_impl_##c_name = \ + { name, LC_LOBJECT, flags, \ + marker, lobject_class_sweeper, nuker, printer, equal, hash, \ + getprop, putprop, remprop, props, 0, sizer, \ + } \ + +#define DEFCLASS(c_name) do { class_##c_name = defclass(&class_impl_##c_name); } while(0) + + +/**************************************************************************** + * Manipulation of LOBJECT * +