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 * + ****************************************************************************/ + +/* The following macros are used to manipulate LOBJECT structures */ +/* Given an HEADER return the corresponding class. */ +#define XLHEADER_CLASS(lh) (class_ids[(lh)->class_id]) +/* Given an HEADER return TRUE iff it corresponds to the given CLASS. */ +#define LHEADER_TYPEP(x, cl) ((x)->class_id == (cl)->class_id) +/* Given an HEADER return TRUE iff it is marked. */ +#define MARKED_LHEADER_P(header) ((header)->marked) +/* Return the UID of HEADER */ +#define LHEADER_UID(h) ((void*)(h)) +/* Mark the given HEADER. */ +#define MARK_LHEADER(header) do { (header)->marked = 1; } while (0); +/* Unmark the given LHEADER. */ +#define UNMARK_LHEADER(header) do { (header)->marked = 0; } while (0); + +/* Set the CLASS of the given LHEADER. */ +#define SET_LHEADER_CLASS(header,class) do { (header)->class_id = (class)->class_id; } while (0); + +/* Copy the data from one LOBJECT structure into another, but don't + overwrite the header information. */ +#define copy_lobject(dst, src) \ + memcpy (((char *) (dst) ) + sizeof ((dst)->header), \ + ((char *) (src)) + sizeof ((src)->header), \ + sizeof (*(src)) - sizeof ((src)->header)); + +#define zero_lobject(src) \ + memset ((char *) (src) + sizeof ((src)->header), 0, \ + sizeof (*(src)) - sizeof ((src)->header)) + + +/**************************************************************************** + * Manipulation of Lisp_Objects * + ****************************************************************************/ + +/* The following macros are used to manage/manipulate Lisp_Object + structures. */ +/* Given any object, return TRUE of the object is an LOBJECT */ +#define LOBJECTP(obj) (XTYPE (obj) == Lisp_LObject) +/* Given an LOBJECT return a pointer to the lobject_header + structure */ +#define XLOBJECT_LHEADER(obj) ((lobject_header *) XPNTR (obj)) +/* Given an LOBJECT return TRUE if the object is currently marked */ +#define MARKED_LOBJECT_P(obj) MARKED_LHEADER_P (XLOBJECT_LHEADER (obj)) +/* Given an LOBJECT return TRUE if the object is of the specified + class */ +#define OBJECT_CLASSP(x, c_name) OBJECT_TYPEP (x, class_##c_name) +/* Set the CLASS of the given LOBJECT. */ +#define SET_LOBJECT_CLASS(obj,class) SET_LHEADER_CLASS(&(obj)->header, class) +/* SET the INVISIBLE flag of the given LOBJECT */ +#define SET_LOBJECT_INVSIBLE(obj,invis) do { (obj)->header.invisible = (invis); } while (0) +/* SET the PROTECTED flag of the given LOBJECT */ +#define SET_LOBJECT_PROTECTED(obj,prot) do { (obj)->header.protected = (prot); } while (0) + +/* Given an Lisp_Object return true iff it is of the given class. */ +#define OBJECT_TYPEP(x, cl) (LOBJECTP (x) && LHEADER_TYPEP(XLOBJECT_LHEADER (x), cl)) +#define XOBJECT_CLASS(obj) (INTP (obj) ? class_integer : \ + LOBJECTP (obj) ? XLHEADER_CLASS(XLOBJECT_LHEADER(obj)) : \ + CONSP (obj) ? class_cons : \ + CHARP (obj) ? class_char : \ + STRINGP (obj) ? class_string : \ + VECTORP (obj) ? class_vector : \ + (assert_failed (__FILE__, __LINE__, "Unknown Lisp_Object type"), (Lisp_Class*)0) \ + ) +#define XLOBJECT_CLASS(obj) XLHEADER_CLASS (XLOBJECT_LHEADER (obj)) +#define XLOBJECT_IMPL(obj) XCLASS_IMPL (XLOBJECT_CLASS (obj)) + + +/**************************************************************************** + * Manipulation of Lisp_Class * + ****************************************************************************/ + +#define XCLASS_IMPL(class) ((class)->impl) + +/**************************************************************************** + * Type Checking * + ****************************************************************************/ + +/* Note: we now have two different kinds of type-checking macros. + The "old" kind has now been renamed CONCHECK_foo. The reason for + this is that the CONCHECK_foo macros signal a continuable error, + allowing the user (through debug-on-error) to subsitute a different + value and return from the signal, which causes the lvalue argument + to get changed. Quite a lot of code would crash if that happened, + because it did things like + + foo = XCAR (list); + CHECK_STRING (foo); + + and later on did XSTRING (XCAR (list)), assuming that the type + is correct (when it might be wrong, if the user substituted a + correct value in the debugger). + + To get around this, I made all the CHECK_foo macros signal a + non-continuable error. Places where a continuable error is OK + (generally only when called directly on the argument of a Lisp + primitive) should be changed to use CONCHECK(). + + FSF Emacs does not have this problem because RMS took the cheesy + way out and disabled returning from a signal entirely. */ + +#define CONCHECK_OBJECT(x, c_name) do \ +{ if (!OBJECT_CLASSP (x, c_name)) \ + x = wrong_type_argument (Q##c_name##p, x); } \ + while (0) +/* ###TM###: doc */ +#define CONCHECK_NONOBJECT(x, lisp_enum, predicate) do \ +{ if (XTYPE (x) != lisp_enum) \ + x = wrong_type_argument (predicate, x); } \ + while (0) +#define CHECK_OBJECT(x, c_name) do \ +{ if (!OBJECT_CLASSP (x, c_name)) \ + dead_wrong_type_argument (Q##c_name##p, x); } \ + while (0) +/* ###TM###: doc */ +#define CHECK_NONOBJECT(x, lisp_enum, predicate) do \ +{ if (XTYPE (x) != lisp_enum) \ + dead_wrong_type_argument (predicate, x); } \ + while (0) + + +/**************************************************************************** + * Declaration of the basic classes * + ****************************************************************************/ + +/* Declaration of OBJECT class as a separate type (defined in alloc.c) */ +DECLARE_LOBJECT_CLASS (class, Lisp_Class); +#define XCLASS(x) XOBJECT (x, class, Lisp_Class) +#define XSETCLASS(x, p) XSETLOBJECT (x, p, class) +#define CLASSP(x) OBJECT_CLASSP (x, class) +#define CHECK_CLASS(x, i) CHECK_OBJECT (x, class) + + +/**************************************************************************** + * Public Variables and Functions * + ****************************************************************************/ + +/* *** Classes *** */ + +/* This variables is used for all translation of class ID's to class + structures. The variable is updated with the function defclass and + finalize_class (see classes.c for both) */ +extern Lisp_Class *class_ids[]; + +/* Define new class. */ +extern Lisp_Class* defclass (CONST Lisp_Class_Impl *class_impl); +extern void defclass_install_name (Lisp_Class *aclass); +extern void defclass_uninstall_name(Lisp_Class *aclass); + +/* *** LOBJECTS *** */ + +/* Allocate new object of the specified static-size + class. */ +extern void *alloc_lobject (struct Lisp_Class *class); +/* Allocate new object of the specified class and size. */ +extern void *alloc_lobject_size (struct Lisp_Class *class, int size); + +/* Free object previously allocated with alloc_lobject or + alloc_lobject_size. + + Be carefull with this function. If you free something to which + references actually exists, you are likely to expirience some very + hard-to-find errors. */ +extern void free_lobject (void *object); +/* Sweeper function for LOBJECTS */ +extern void lobject_class_sweeper (struct Lisp_Class *aclass, int function, void (*markobj) (Lisp_Object)); +/* Return list of all INUSE objects of class. */ +extern Lisp_Object lobject_list(Lisp_Class *aclass); + +#endif /* _XEMACS_CLASSES_H_ */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/config.h.in xemacs-20.0-b26/src/config.h.in --- xemacs-20.0-b26-orig/src/config.h.in Thu Jun 20 19:44:46 1996 +++ xemacs-20.0-b26/src/config.h.in Wed Jul 17 15:12:41 1996 @@ -215,4 +215,14 @@ #undef HAVE_SOCKS +/* Define HAVE_SHLIB if you have the `shlib' library and want XEmacs to + use it. */ +#undef HAVE_SHLIB + +#ifdef HAVE_SHLIB +/* Define MAKE_SHLIB_... if you want a shared library for that + facility of XEmacs */ +#define MAKE_SHLIB_MD5 +#endif + /* Define HAVE_TERM if you run the `term' program (e.g. under Linux) and want XEmacs to use it. */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/console-x.h xemacs-20.0-b26/src/console-x.h --- xemacs-20.0-b26-orig/src/console-x.h Sat Jun 15 17:22:35 1996 +++ xemacs-20.0-b26/src/console-x.h Mon Jul 8 14:36:26 1996 @@ -376,5 +376,5 @@ in order for the error-checking functions to get defined. */ #ifdef EPOCH -DECLARE_LRECORD (x_resource, struct Lisp_X_Resource); +DECLARE_LOBJECT_CLASS (x_resource, struct Lisp_X_Resource); #endif diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/console.c xemacs-20.0-b26/src/console.c --- xemacs-20.0-b26-orig/src/console.c Mon Jun 17 16:07:57 1996 +++ xemacs-20.0-b26/src/console.c Tue Jul 16 08:32:01 1996 @@ -101,7 +101,7 @@ static Lisp_Object mark_console (Lisp_Object, void (*) (Lisp_Object)); static void print_console (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("console", console, - mark_console, print_console, 0, 0, 0, - struct console); +DEFINE_LOBJECT_CLASS ("Console", console, 0, + mark_console, print_console, 0, 0, 0, + struct console); static Lisp_Object @@ -132,5 +132,5 @@ if (print_readably) error ("printing unreadable object #", - string_data (XSTRING (con->name)), con->header.uid); + string_data (XSTRING (con->name)), LHEADER_UID (&con->header)); sprintf (buf, "#<%s-console", !CONSOLE_LIVE_P (con) ? "dead" : @@ -142,5 +142,5 @@ print_internal (CONSOLE_CONNECTION (con), printcharfun, 1); } - sprintf (buf, " 0x%x>", con->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&con->header)); write_c_string (buf, printcharfun); } @@ -151,9 +151,8 @@ { Lisp_Object console = Qnil; - struct console *con = alloc_lcrecord (sizeof (struct console), - lrecord_console); + struct console *con = alloc_lobject (class_console); struct gcpro gcpro1; - copy_lcrecord (con, XCONSOLE (Vconsole_defaults)); + copy_lobject (con, XCONSOLE (Vconsole_defaults)); XSETCONSOLE (console, con); @@ -1017,4 +1016,6 @@ syms_of_console (void) { + DEFCLASS (console); + defsubr (&Svalid_console_type_p); defsubr (&Sconsole_type_list); @@ -1100,51 +1101,29 @@ from SunPro C's fix-and-continue feature (a way neato feature that makes debugging unbelievably more bearable) */ -#define DEFVAR_CONSOLE_LOCAL(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_SELECTED_CONSOLE_FORWARD }, 0 }; \ +#define DEFVAR_CONSOLE_BASIC(lname, type, field_name, magicfun) \ + do { static struct symbol_value_forward I_hate_C \ + = { { { CLASS_SYMBOL_VALUE_FORWARD_ID, }, type }, \ + (void *) &(console_local_flags.field_name), magicfun }; \ defvar_console_local ((lname), &I_hate_C); \ } while (0) + +#define DEFVAR_CONSOLE_LOCAL(lname, field_name) \ + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_SELECTED_CONSOLE_FORWARD, field_name, 0) + #define DEFVAR_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_SELECTED_CONSOLE_FORWARD }, magicfun }; \ - defvar_console_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_SELECTED_CONSOLE_FORWARD, field_name, magicfun) #define DEFVAR_CONST_CONSOLE_LOCAL(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_CONST_SELECTED_CONSOLE_FORWARD }, 0 }; \ - defvar_console_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_CONST_SELECTED_CONSOLE_FORWARD, field_name, 0) #define DEFVAR_CONST_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_CONST_SELECTED_CONSOLE_FORWARD }, magicfun }; \ - defvar_console_local ((lname), &I_hate_C); \ - } while (0) + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_CONST_SELECTED_CONSOLE_FORWARD, field_name, magicfun) #define DEFVAR_CONSOLE_DEFAULTS(lname, field_name) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_CONSOLE_FORWARD }, 0 }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_DEFAULT_CONSOLE_FORWARD, field_name, 0) #define DEFVAR_CONSOLE_DEFAULTS_MAGIC(lname, field_name, magicfun) \ - do { static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, \ - (void *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_CONSOLE_FORWARD }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) + DEFVAR_CONSOLE_BASIC(lname, SYMVAL_DEFAULT_CONSOLE_FORWARD, field_name, magicfun) static void @@ -1164,5 +1143,5 @@ nuke_all_console_slots (struct console *con, Lisp_Object zap) { - zero_lcrecord (con); + zero_lobject (con); #define MARKED_SLOT(x) con->x = (zap); @@ -1177,8 +1156,6 @@ are initialized reasonably, so mark_console won't choke. */ - struct console *defs = alloc_lcrecord (sizeof (struct console), - lrecord_console); - struct console *syms = alloc_lcrecord (sizeof (struct console), - lrecord_console); + struct console *defs = alloc_lobject (class_console); + struct console *syms = alloc_lobject (class_console); staticpro (&Vconsole_defaults); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/console.h xemacs-20.0-b26/src/console.h --- xemacs-20.0-b26-orig/src/console.h Mon Jun 17 16:07:57 1996 +++ xemacs-20.0-b26/src/console.h Mon Jul 8 14:36:26 1996 @@ -338,5 +338,5 @@ struct console { - struct lcrecord_header header; + struct lobject_header header; /* Description of this console's methods. */ @@ -377,11 +377,10 @@ }; -DECLARE_LRECORD (console, struct console); -#define XCONSOLE(x) XRECORD (x, console, struct console) -#define XSETCONSOLE(x, p) XSETRECORD (x, p, console) -#define CONSOLEP(x) RECORDP (x, console) -#define GC_CONSOLEP(x) GC_RECORDP (x, console) -#define CHECK_CONSOLE(x) CHECK_RECORD (x, console) -#define CONCHECK_CONSOLE(x) CONCHECK_RECORD (x, console) +DECLARE_LOBJECT_CLASS (console, struct console); +#define XCONSOLE(x) XOBJECT (x, console, struct console) +#define XSETCONSOLE(x, p) XSETLOBJECT (x, p, console) +#define CONSOLEP(x) OBJECT_CLASSP (x, console) +#define CHECK_CONSOLE(x) CHECK_OBJECT (x, console) +#define CONCHECK_CONSOLE(x) CONCHECK_OBJECT (x, console) #define CHECK_LIVE_CONSOLE(x) \ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/data.c xemacs-20.0-b26/src/data.c --- xemacs-20.0-b26-orig/src/data.c Thu May 9 16:16:47 1996 +++ xemacs-20.0-b26/src/data.c Thu Jul 11 08:08:25 1996 @@ -174,4 +174,12 @@ } +/**********************************************************************/ +/* Integer objects */ +/**********************************************************************/ + +DEFINE_DIRECT_CLASS ("integer", integer, 0, + 0, 0, + 0, 0, 0); + #ifndef make_int Lisp_Object @@ -202,4 +210,12 @@ } +/**********************************************************************/ +/* Char objects */ +/**********************************************************************/ + +DEFINE_DIRECT_CLASS ("char", char, 0, + 0, 0, + 0, 0, 0); + /* characters do not need to sign extend so there's no need for special futzing like with ints. */ @@ -410,5 +426,5 @@ { CHECK_SUBR (subr); - return make_int (XSUBR (subr)->min_args); + return make_int (subr_min_args (XSUBR (subr))); } @@ -422,5 +438,5 @@ int nargs; CHECK_SUBR (subr); - nargs = XSUBR (subr)->max_args; + nargs = subr_max_args (XSUBR (subr)); if (nargs == MANY || nargs == UNEVALLED) return Qnil; @@ -682,9 +698,18 @@ if (VECTORP (object)) return Qvector; - assert (LRECORDP (object)); - return intern (XRECORD_LHEADER (object)->implementation->name); + assert (LOBJECTP (object)); + return intern (XCLASS_IMPL (XOBJECT_CLASS (object))->name); } +/**********************************************************************/ +/* Cons objects */ +/**********************************************************************/ + +DEFINE_NONHEADER_CLASS ("cons", cons, 0, + 0, 0, + 0, 0, 0, + struct Lisp_Cons); + /* Extract and set components of lists */ @@ -827,4 +852,18 @@ } +/**********************************************************************/ +/* String and Vector objects */ +/**********************************************************************/ + +DEFINE_NONHEADER_CLASS ("string", string, 0, + 0, 0, + 0, 0, 0, + struct Lisp_String); + +DEFINE_NONHEADER_CLASS ("vector", vector, 0, + 0, 0, + 0, 0, 0, + struct Lisp_Vector); + /* Extract and set vector and string elements */ @@ -1826,8 +1865,8 @@ static int weak_list_equal (Lisp_Object, Lisp_Object, int depth); static unsigned long weak_list_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list, - mark_weak_list, print_weak_list, - 0, weak_list_equal, weak_list_hash, - struct weak_list); +DEFINE_LOBJECT_CLASS ("Weak-List", weak_list, 0, + mark_weak_list, print_weak_list, + 0, weak_list_equal, weak_list_hash, + struct weak_list); static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ @@ -1882,6 +1921,5 @@ Lisp_Object result = Qnil; - struct weak_list *wl = - alloc_lcrecord (sizeof (struct weak_list), lrecord_weak_list); + struct weak_list *wl = alloc_lobject (class_weak_list); wl->list = Qnil; wl->type = type; @@ -1917,5 +1955,5 @@ for (rest = Vall_weak_lists; - !GC_NILP (rest); + !NILP (rest); rest = XWEAK_LIST (rest)->next_weak) { @@ -1931,5 +1969,5 @@ use CONSP instead of !NILP in case of user-visible imperfect lists */ - GC_CONSP (rest2); + CONSP (rest2); rest2 = XCDR (rest2)) { @@ -1959,5 +1997,5 @@ case WEAK_LIST_ASSOC: - if (!GC_CONSP (elem)) + if (!CONSP (elem)) { /* just leave bogus elements there */ @@ -1976,5 +2014,5 @@ case WEAK_LIST_KEY_ASSOC: - if (!GC_CONSP (elem)) + if (!CONSP (elem)) { /* just leave bogus elements there */ @@ -1992,5 +2030,5 @@ case WEAK_LIST_VALUE_ASSOC: - if (!GC_CONSP (elem)) + if (!CONSP (elem)) { /* just leave bogus elements there */ @@ -2035,5 +2073,5 @@ /* In case of imperfect list, need to mark the final cons because we're not removing it */ - if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2)) + if (!NILP (rest2) && ! (obj_marked_p) (rest2)) { (markobj) (rest2); @@ -2051,5 +2089,5 @@ for (rest = Vall_weak_lists; - !GC_NILP (rest); + !NILP (rest); rest = XWEAK_LIST (rest)->next_weak) { @@ -2057,5 +2095,5 @@ { /* This weak list itself is garbage. Remove it from the list. */ - if (GC_NILP (prev)) + if (NILP (prev)) Vall_weak_lists = XWEAK_LIST (rest)->next_weak; else @@ -2073,5 +2111,5 @@ use CONSP instead of !NILP in case of user-visible imperfect lists */ - GC_CONSP (rest2);) + CONSP (rest2);) { /* It suffices to check the cons for marking, @@ -2087,5 +2125,5 @@ { /* bye bye :-( */ - if (GC_NILP (prev2)) + if (NILP (prev2)) XWEAK_LIST (rest)->list = XCDR (rest2); else @@ -2128,5 +2166,5 @@ tortoise = XCDR (tortoise); go_tortoise = !go_tortoise; - if (GC_EQ (rest2, tortoise)) + if (EQ (rest2, tortoise)) break; } @@ -2351,4 +2389,11 @@ syms_of_data (void) { + DEFCLASS (weak_list); + DEFCLASS (vector); + DEFCLASS (string); + DEFCLASS (cons); + DEFCLASS (char); + DEFCLASS (integer); + defsymbol (&Qcons, "cons"); defsymbol (&Qkeyword, "keyword"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/database.c xemacs-20.0-b26/src/database.c --- xemacs-20.0-b26-orig/src/database.c Sat Jun 1 20:49:32 1996 +++ xemacs-20.0-b26/src/database.c Tue Jul 16 08:32:01 1996 @@ -67,5 +67,5 @@ struct database_struct { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object fname; XEMACS_DB_TYPE type; @@ -77,23 +77,21 @@ }; -#define XDATABASE(x) XRECORD (x, database, struct database_struct) -#define XSETDATABASE(x, p) XSETRECORD (x, p, database) -#define DATABASEP(x) RECORDP (x, database) -#define GC_DATABASEP(x) GC_RECORDP (x, database) -#define CHECK_DATABASE(x) CHECK_RECORD (x, database) +#define XDATABASE(x) XOBJECT (x, database, struct database_struct) +#define XSETDATABASE(x, p) XSETLOBJECT (x, p, database) +#define DATABASEP(x) OBJECT_CLASSP (x, database) +#define CHECK_DATABASE(x) CHECK_OBJECT (x, database) #define DATABASE_LIVE_P(x) (x->db_handle) static Lisp_Object mark_database (Lisp_Object, void (*) (Lisp_Object)); static void print_database (Lisp_Object, Lisp_Object, int); static void finalize_database (void *, int); -DEFINE_LRECORD_IMPLEMENTATION ("database", database, - mark_database, print_database, - finalize_database, 0, 0, - struct database_struct); +DEFINE_LOBJECT_CLASS ("Database", database, 0, + mark_database, print_database, + finalize_database, 0, 0, + struct database_struct); static struct database_struct * new_database (void) { - struct database_struct *dbase - = alloc_lcrecord (sizeof (struct database_struct), lrecord_database); + struct database_struct *dbase = alloc_lobject (class_database); dbase->fname = Qnil; @@ -123,5 +121,5 @@ if (print_readably) { - error ("printing unreadable object #", dbase->header.uid); + error ("printing unreadable object #", LHEADER_UID (&dbase->header)); } else @@ -140,5 +138,5 @@ sprintf (buf, "#", string_data (XSTRING (dbase->fname)), type, subtype, perms, - dbase->header.uid); + LHEADER_UID (&dbase->header)); write_c_string (buf, printcharfun); } @@ -153,5 +151,5 @@ { Lisp_Object obj; - XSETOBJ (obj, Lisp_Record, (void *) db); + XSETLOBJECT (obj, db, database); signal_simple_error @@ -720,4 +718,6 @@ syms_of_dbm (void) { + DEFCLASS (database); + defsymbol (&Qdatabasep, "databasep"); #ifdef HAVE_DBM diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/database.h xemacs-20.0-b26/src/database.h --- xemacs-20.0-b26-orig/src/database.h Sun Jan 21 17:48:28 1996 +++ xemacs-20.0-b26/src/database.h Mon Jul 8 14:36:27 1996 @@ -2,5 +2,5 @@ #define _XEMACS_DBM_H -DECLARE_LRECORD (database, struct database_struct); +DECLARE_LOBJECT_CLASS (database, struct database_struct); #endif diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/device.c xemacs-20.0-b26/src/device.c --- xemacs-20.0-b26-orig/src/device.c Fri Jun 21 02:56:12 1996 +++ xemacs-20.0-b26/src/device.c Tue Jul 16 08:32:01 1996 @@ -69,7 +69,7 @@ static Lisp_Object mark_device (Lisp_Object, void (*) (Lisp_Object)); static void print_device (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("device", device, - mark_device, print_device, 0, 0, 0, - struct device); +DEFINE_LOBJECT_CLASS ("Device", device, 0, + mark_device, print_device, 0, 0, 0, + struct device); static Lisp_Object @@ -115,5 +115,5 @@ if (print_readably) error ("printing unreadable object #", - string_data (XSTRING (d->name)), d->header.uid); + string_data (XSTRING (d->name)), LHEADER_UID (&d->header)); sprintf (buf, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" : @@ -125,5 +125,5 @@ print_internal (DEVICE_CONNECTION (d), printcharfun, 1); } - sprintf (buf, " 0x%x>", d->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&d->header)); write_c_string (buf, printcharfun); } @@ -163,8 +163,8 @@ { Lisp_Object device = Qnil; - struct device *d = alloc_lcrecord (sizeof (struct device), lrecord_device); + struct device *d = alloc_lobject (class_device); struct gcpro gcpro1; - zero_lcrecord (d); + zero_lobject (d); XSETDEVICE (device, d); @@ -1081,4 +1081,6 @@ syms_of_device (void) { + DEFCLASS (device); + defsubr (&Svalid_device_class_p); defsubr (&Sdevice_class_list); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/device.h xemacs-20.0-b26/src/device.h --- xemacs-20.0-b26-orig/src/device.h Mon Jun 17 16:07:55 1996 +++ xemacs-20.0-b26/src/device.h Mon Jul 8 14:36:27 1996 @@ -66,5 +66,5 @@ struct device { - struct lcrecord_header header; + struct lobject_header header; /* Methods for this device's console. This can also be retrieved @@ -211,11 +211,10 @@ }; -DECLARE_LRECORD (device, struct device); -#define XDEVICE(x) XRECORD (x, device, struct device) -#define XSETDEVICE(x, p) XSETRECORD (x, p, device) -#define DEVICEP(x) RECORDP (x, device) -#define GC_DEVICEP(x) GC_RECORDP (x, device) -#define CHECK_DEVICE(x) CHECK_RECORD (x, device) -#define CONCHECK_DEVICE(x) CONCHECK_RECORD (x, device) +DECLARE_LOBJECT_CLASS (device, struct device); +#define XDEVICE(x) XOBJECT (x, device, struct device) +#define XSETDEVICE(x, p) XSETLOBJECT (x, p, device) +#define DEVICEP(x) OBJECT_CLASSP (x, device) +#define CHECK_DEVICE(x) CHECK_OBJECT (x, device) +#define CONCHECK_DEVICE(x) CONCHECK_OBJECT (x, device) #define CHECK_LIVE_DEVICE(x) \ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/doc.c xemacs-20.0-b26/src/doc.c --- xemacs-20.0-b26-orig/src/doc.c Sun Apr 14 21:00:42 1996 +++ xemacs-20.0-b26/src/doc.c Thu Jul 11 08:12:45 1996 @@ -300,10 +300,11 @@ if (SUBRP (fun)) { - if (XSUBR (fun)->doc == 0) + CONST char *sdoc = subr_doc (XSUBR (fun)); + if (sdoc == 0) return Qnil; - if ((EMACS_INT) XSUBR (fun)->doc >= 0) - doc = build_string (XSUBR (fun)->doc); + if ((EMACS_INT) sdoc >= 0) + doc = build_string (sdoc); else - doc = get_doc_string (make_int (- (EMACS_INT) XSUBR (fun)->doc)); + doc = get_doc_string (make_int (- (EMACS_INT) sdoc)); } else if (COMPILED_FUNCTIONP (fun)) @@ -553,5 +554,5 @@ { /* Lisp_Subrs have a slot for it. */ - if (XSUBR (fun)->doc) + if (subr_doc (XSUBR (fun))) { weird_doc (sym, GETTEXT ("duplicate"), @@ -559,5 +560,5 @@ goto weird; } - XSUBR (fun)->doc = (char *) (- XINT (offset)); + subr_doc (XSUBR (fun)) = (char *) (- XINT (offset)); } else if (CONSP (fun)) @@ -685,5 +686,5 @@ if (SUBRP (fun)) - doc = (EMACS_INT) XSUBR (fun)->doc; + doc = (EMACS_INT) subr_doc (XSUBR (fun)); else if (SYMBOLP (fun)) doc = -1; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/elhash.c xemacs-20.0-b26/src/elhash.c --- xemacs-20.0-b26-orig/src/elhash.c Sun Apr 21 19:34:44 1996 +++ xemacs-20.0-b26/src/elhash.c Tue Jul 16 10:48:53 1996 @@ -34,5 +34,5 @@ struct hashtable_struct { - struct lcrecord_header header; + struct lobject_header header; unsigned int fullness; unsigned long (*hash_function) (CONST void *); @@ -49,7 +49,7 @@ static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object)); static void print_hashtable (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, - mark_hashtable, print_hashtable, 0, 0, 0, - struct hashtable_struct); +DEFINE_LOBJECT_CLASS ("Hashtable", hashtable, 0, + mark_hashtable, print_hashtable, 0, 0, 0, + struct hashtable_struct); static Lisp_Object @@ -78,5 +78,5 @@ if (print_readably) error ("printing unreadable object #", - table->header.uid); + LHEADER_UID (&table->header)); sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"), (table->type == HASHTABLE_WEAK ? "weak " : @@ -88,5 +88,5 @@ table->fullness, (vector_length (XVECTOR (table->harray)) / LISP_OBJECTS_PER_HENTRY), - table->header.uid); + LHEADER_UID (&table->header)); write_c_string (buf, printcharfun); } @@ -99,5 +99,5 @@ c_table->harray = (void *) vector_data (XVECTOR (ht->harray)); - c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry)); + c_table->zero_set = (!UNBOUNDP (ht->zero_entry)); c_table->zero_entry = LISP_TO_VOID (ht->zero_entry); len = vector_length (XVECTOR (ht->harray)); @@ -141,6 +141,5 @@ allocate_hashtable (void) { - struct hashtable_struct *table - = alloc_lcrecord (sizeof (struct hashtable_struct), lrecord_hashtable); + struct hashtable_struct *table = alloc_lobject (class_hashtable); table->harray = Qnil; table->zero_entry = Qunbound; @@ -714,5 +713,5 @@ for (rest = Vall_weak_hashtables; - !GC_NILP (rest); + !NILP (rest); rest = XHASHTABLE (rest)->next_weak) { @@ -791,5 +790,5 @@ Lisp_Object rest, prev = Qnil; for (rest = Vall_weak_hashtables; - !GC_NILP (rest); + !NILP (rest); rest = XHASHTABLE (rest)->next_weak) { @@ -797,5 +796,5 @@ { /* This table itself is garbage. Remove it from the list. */ - if (GC_NILP (prev)) + if (NILP (prev)) Vall_weak_hashtables = XHASHTABLE (rest)->next_weak; else @@ -866,5 +865,5 @@ return hash_string (string_data (XSTRING (obj)), string_length (XSTRING (obj))); -#ifndef LRECORD_VECTOR +#ifndef USE_LOBJECT_VECTOR else if (VECTORP (obj)) { @@ -874,11 +873,10 @@ depth + 1)); } -#endif /* !LRECORD_VECTOR */ - else if (LRECORDP (obj)) +#endif /* !USE_LOBJECT_VECTOR */ + else if (LOBJECTP (obj)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER (obj)->implementation; - if (imp->hash) - return ((imp->hash) (obj, depth)); + CONST Lisp_Class_Impl *impl = XLOBJECT_IMPL (obj); + if (impl->hash) + return ((impl->hash) (obj, depth)); } @@ -894,4 +892,6 @@ syms_of_elhash (void) { + DEFCLASS (hashtable); + defsubr (&Smake_hashtable); defsubr (&Scopy_hashtable); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/elhash.h xemacs-20.0-b26/src/elhash.h --- xemacs-20.0-b26-orig/src/elhash.h Sun Apr 21 19:35:08 1996 +++ xemacs-20.0-b26/src/elhash.h Mon Jul 8 14:36:27 1996 @@ -24,12 +24,11 @@ #define _XEMACS_ELHASH_H_ -DECLARE_LRECORD (hashtable, struct hashtable_struct); +DECLARE_LOBJECT_CLASS (hashtable, struct hashtable_struct); -#define XHASHTABLE(x) XRECORD (x, hashtable, struct hashtable_struct) -#define XSETHASHTABLE(x, p) XSETRECORD (x, p, hashtable) -#define HASHTABLEP(x) RECORDP (x, hashtable) -#define GC_HASHTABLEP(x) GC_RECORDP (x, hashtable) -#define CHECK_HASHTABLE(x) CHECK_RECORD (x, hashtable) -#define CONCHECK_HASHTABLE(x) CONCHECK_RECORD (x, hashtable) +#define XHASHTABLE(x) XOBJECT (x, hashtable, struct hashtable_struct) +#define XSETHASHTABLE(x, p) XSETLOBJECT (x, p, hashtable) +#define HASHTABLEP(x) OBJECT_CLASSP (x, hashtable) +#define CHECK_HASHTABLE(x) CHECK_OBJECT (x, hashtable) +#define CONCHECK_HASHTABLE(x) CONCHECK_OBJECT (x, hashtable) enum hashtable_type diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/emacs.c xemacs-20.0-b26/src/emacs.c --- xemacs-20.0-b26-orig/src/emacs.c Sat Jun 22 00:55:54 1996 +++ xemacs-20.0-b26/src/emacs.c Wed Jul 17 11:09:35 1996 @@ -645,4 +645,7 @@ init_alloc_once_early (); + /* Define the class of classes class_class */ + init_classes_once_early (); + /* Initialize Qnil, Qt, Qunbound, and the obarray. After this, symbols can be @@ -670,4 +673,7 @@ */ + syms_of_eval (); /* Have to be first */ + syms_of_classes (); /* Should be second */ + syms_of_abbrev (); syms_of_alloc (); @@ -695,5 +701,4 @@ syms_of_elhash (); syms_of_emacs (); - syms_of_eval (); syms_of_event_stream (); syms_of_events (); @@ -701,4 +706,7 @@ syms_of_faces (); syms_of_fileio (); +#ifdef HAVE_SHLIB + syms_of_shlib (); +#endif /* HAVE_SHLIB */ #ifdef CLASH_DETECTION syms_of_filelock (); @@ -717,7 +725,10 @@ syms_of_keymap (); syms_of_lread (); + syms_of_lstream (); syms_of_macros (); syms_of_marker (); +#ifndef MAKE_SHLIB_MD5 syms_of_md5 (); +#endif #ifdef HAVE_DATABASE syms_of_dbm (); @@ -977,5 +988,5 @@ make_int() make_extent() - alloc_lcrecord() + alloc_lobject() Fcons() listN() @@ -1018,4 +1029,7 @@ vars_of_faces (); vars_of_fileio (); +#ifdef HAVE_SHLIB + vars_of_shlib (); +#endif /* HAVE_SHLIB */ #ifdef CLASH_DETECTION vars_of_filelock (); @@ -1038,5 +1052,7 @@ vars_of_lstream (); vars_of_macros (); +#ifndef MAKE_SHLIB_MD5 vars_of_md5 (); +#endif #ifdef HAVE_DATABASE vars_of_dbm (); @@ -1313,4 +1329,7 @@ init_hpplay (); #endif +#ifdef HAVE_SHLIB + init_shlib (); /* Setup the shared library for the current process itself */ +#endif /* HAVE_SHLIB */ #ifdef HAVE_TTY init_device_tty (); @@ -1481,4 +1500,10 @@ abort (); /* Lisp_Object must fit in a word; check VALBITS and GCTYPEBITS */ + if ((argc > 1) && !strcmp (argv[1], "-sleep")) { + argv++; + argc--; + sleep (50); + } + if (!initialized) { @@ -1635,9 +1660,9 @@ to try to make the backtrace-determination process as foolproof as possible. */ - if (GC_STRINGP (Vinvocation_name)) + if (STRINGP (Vinvocation_name)) name = (char *) string_data (XSTRING (Vinvocation_name)); else name = "xemacs"; - if (GC_STRINGP (Vinvocation_directory)) + if (STRINGP (Vinvocation_directory)) dir = (char *) string_data (XSTRING (Vinvocation_directory)); if (!dir || dir[0] != '/') diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/emacsfns.h xemacs-20.0-b26/src/emacsfns.h --- xemacs-20.0-b26-orig/src/emacsfns.h Fri Jun 21 02:56:11 1996 +++ xemacs-20.0-b26/src/emacsfns.h Tue Jul 16 15:03:07 1996 @@ -32,4 +32,5 @@ /* Defined in alloc.c */ +void *allocate_lisp_storage (int size); void release_breathing_space (void); Lisp_Object Fcons (Lisp_Object car, Lisp_Object cdr); @@ -60,6 +61,4 @@ Lisp_Object Fmake_bit_vector (Lisp_Object length, Lisp_Object init); Lisp_Object Fmake_symbol (Lisp_Object name); -Lisp_Object Fmake_marker (void); -Lisp_Object noseeum_make_marker (void); Lisp_Object Fmake_string (Lisp_Object length, Lisp_Object init); void garbage_collect_1 (void); @@ -101,6 +100,4 @@ Lisp_Object make_uninit_string (Bytecount length); -Lisp_Object make_float (double float_value); - Lisp_Object Fmake_byte_code (int nargs, Lisp_Object *args); @@ -122,6 +119,4 @@ void mark_conses_in_list (Lisp_Object obj); -void free_marker (struct Lisp_Marker *ptr); - #ifdef LISP_FLOAT_TYPE Lisp_Object make_pure_float (double float_value); @@ -375,4 +370,9 @@ Lisp_Object Frem (Lisp_Object num1, Lisp_Object num2); +Lisp_Object Fweak_list_p(Lisp_Object obj); +Lisp_Object Fmake_weak_list(Lisp_Object type); +Lisp_Object Fweak_list_type(Lisp_Object weak); +Lisp_Object Fweak_list_list(Lisp_Object weak); +Lisp_Object Fset_weak_list_list(Lisp_Object weak, Lisp_Object new_list); /* Defined in device.c */ @@ -762,5 +762,4 @@ Lisp_Object Fdeallocate_event (Lisp_Object event); Lisp_Object Fcopy_event (Lisp_Object from, Lisp_Object to); -Lisp_Object allocate_event (void); int event_to_character (struct Lisp_Event *event, int allow_extra_modifiers, @@ -948,4 +947,5 @@ /* Defined in floatfns.c */ +Lisp_Object make_float (double float_value); double extract_float (Lisp_Object); Lisp_Object Ffloat (Lisp_Object n); @@ -1404,4 +1404,7 @@ Lisp_Object Fset_marker (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer); +Lisp_Object Fmake_marker (void); +Lisp_Object noseeum_make_marker (void); +void free_marker (struct Lisp_Marker *ptr); Lisp_Object Fmarker_position (Lisp_Object m); Lisp_Object Fmarker_buffer (Lisp_Object m); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/energize.c xemacs-20.0-b26/src/energize.c --- xemacs-20.0-b26-orig/src/energize.c Sun Apr 14 19:01:46 1996 +++ xemacs-20.0-b26/src/energize.c Mon Jul 8 14:36:28 1996 @@ -590,5 +590,5 @@ /* Lisp_Object extent = data_to_extent (ext); (will abort if marked) */ Lisp_Object extent = ext->extent; - assert (GC_EXTENTP (extent)); + assert (EXTENTP (extent)); ((*fmh->markobj) (extent)); } diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/energize.h xemacs-20.0-b26/src/energize.h --- xemacs-20.0-b26-orig/src/energize.h Wed Sep 6 17:51:31 1995 +++ xemacs-20.0-b26/src/energize.h Mon Jul 8 14:36:28 1996 @@ -53,5 +53,5 @@ /* Generic extent data and classes This "seal" junk is a completely bogus data type system that should be - replaced with something implemented using Lisp_Records. + replaced with something implemented using Lisp_LObject */ #define GDATA_CLASS_SEAL 0x12345678 diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/epoch.c xemacs-20.0-b26/src/epoch.c --- xemacs-20.0-b26-orig/src/epoch.c Sat Mar 30 16:41:52 1996 +++ xemacs-20.0-b26/src/epoch.c Tue Jul 9 09:17:08 1996 @@ -40,9 +40,8 @@ Lisp_Object Qx_resource_live_p; -#define XX_RESOURCE(x) XRECORD (x, x_resource, struct Lisp_X_Resource) -#define XSETX_RESOURCE(x, p) XSETRECORD (x, p, x_resource) -#define X_RESOURCEP(x) RECORDP (x, x_resource) -#define GC_X_RESOURCEP(x) GC_RECORDP (x, x_resource) -#define CHECK_X_RESOURCE(x) CHECK_RECORD (x, x_resource) +#define XX_RESOURCE(x) XOBJECT (x, x_resource, struct Lisp_X_Resource) +#define XSETX_RESOURCE(x, p) XSETLOBJECT (x, p, x_resource) +#define X_RESOURCEP(x) OBJECT_CLASSP (x, x_resource) +#define CHECK_X_RESOURCE(x) CHECK_OBJECT (x, x_resource) #define X_RESOURCE_LIVE_P(xr) (DEVICE_LIVE_P (XDEVICE ((xr)->device))) @@ -55,5 +54,5 @@ struct Lisp_X_Resource { - struct lcrecord_header header; + struct lobject_header header; XID xid; @@ -68,8 +67,8 @@ static int x_resource_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long x_resource_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("x-resource", x_resource, - mark_x_resource, print_x_resource, - finalize_x_resource, x_resource_equal, - x_resource_hash, struct Lisp_X_Resource); +DEFINE_LOBJECT_CLASS ("X-Resource", x_resource, 0, + mark_x_resource, print_x_resource, + finalize_x_resource, x_resource_equal, + x_resource_hash, struct Lisp_X_Resource); static Lisp_Object @@ -188,6 +187,5 @@ make_x_resource (XID xid, Atom type, Lisp_Object device) { - struct Lisp_X_Resource *xr = - alloc_lcrecord (sizeof (struct Lisp_X_Resource), lrecord_x_resource); + struct Lisp_X_Resource *xr = alloc_lobject (class_x_resource); Lisp_Object val; @@ -481,7 +479,7 @@ CHECK_LIVE_X_RESOURCE (type_obj); if ((XTYPE (*element) != XTYPE (type_obj)) - || (LRECORDP (type_obj) && - (XRECORD_LHEADER (*element)->implementation != - XRECORD_LHEADER (type_obj)->implementation)) + || (LOBJECTP (type_obj) && + (XOBJECT_CLASS (*element) != + XOBJECT_CLASS (type_obj))) || (X_RESOURCEP (type_obj) && (rtype != XX_RESOURCE (*element)->type @@ -516,7 +514,7 @@ CHECK_LIVE_X_RESOURCE (temp); if ((XTYPE (temp) != XTYPE (type_obj)) - || (LRECORDP (type_obj) && - (XRECORD_LHEADER (temp)->implementation != - XRECORD_LHEADER (type_obj)->implementation)) + || (LOBJECTP (type_obj) && + (XOBJECT_CLASS (temp) != + XOBJECT_CLASS (type_obj))) || (X_RESOURCEP (type_obj) && (rtype != XX_RESOURCE (temp)->type @@ -570,5 +568,5 @@ break; - case Lisp_Record: + case Lisp_LObject: if (X_RESOURCEP (v->contents[0])) { @@ -635,5 +633,5 @@ break; - case Lisp_Record: + case Lisp_LObject: if (X_RESOURCEP (Fcar (list))) { @@ -721,5 +719,5 @@ break; - case Lisp_Record: + case Lisp_LObject: if (X_RESOURCEP (value)) { @@ -1344,4 +1342,6 @@ syms_of_epoch (void) { + DEFCLASS (x_resource); + defsubr (&Sx_intern_atom); defsubr (&Sx_atom_name); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/eval.c xemacs-20.0-b26/src/eval.c --- xemacs-20.0-b26-orig/src/eval.c Sat Jun 22 18:25:47 1996 +++ xemacs-20.0-b26/src/eval.c Wed Jul 17 13:20:18 1996 @@ -39,5 +39,7 @@ #include "console.h" #include "opaque.h" - +#ifdef HAVE_SHLIB +#include "shlib.h" +#endif struct backtrace *backtrace_list; @@ -228,7 +230,7 @@ static void print_subr (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("subr", subr, - this_one_is_unmarkable, print_subr, 0, 0, 0, - struct Lisp_Subr); +DEFINE_LOBJECT_CLASS ("Subr", subr, LC_USEFROBBLOCKS, + 0, print_subr, 0, 0, 0, + struct Lisp_Subr); static void @@ -241,5 +243,5 @@ subr_name (subr)); - write_c_string (((subr->max_args == UNEVALLED) + write_c_string (((subr_max_args (subr) == UNEVALLED) ? "#prompt) ? " (interactive)>" : ">"), + write_c_string (((subr_prompt (subr)) ? " (interactive)>" : ">"), printcharfun); } @@ -257,10 +259,10 @@ static int compiled_function_equal (Lisp_Object, Lisp_Object, int); static unsigned long compiled_function_hash (Lisp_Object obj, int depth); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, - mark_compiled_function, - print_compiled_function, 0, - compiled_function_equal, - compiled_function_hash, - struct Lisp_Compiled_Function); +DEFINE_LOBJECT_CLASS ("Compiled-Function", compiled_function, LC_USEFROBBLOCKS, + mark_compiled_function, + print_compiled_function, 0, + compiled_function_equal, + compiled_function_hash, + struct Lisp_Compiled_Function); static Lisp_Object @@ -2546,5 +2548,5 @@ if (SUBRP (fun)) { - if (XSUBR (fun)->prompt) + if (subr_prompt (XSUBR (fun))) return Qt; else @@ -2726,5 +2728,6 @@ DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0 /* Define FUNCTION to autoload from FILE. -FUNCTION is a symbol; FILE is a file name string to pass to `load'. +FUNCTION is a symbol; FILE is either a file name string to pass to `load' +or a shared library object to use with load-shlib. Third arg DOCSTRING is documentation for the function. Fourth arg INTERACTIVE if non-nil says function can be called interactively. @@ -2743,5 +2746,5 @@ /* This function can GC */ CHECK_SYMBOL (function); - CHECK_STRING (file); + CHECK_STRING (file); /* ###TM###: can be shlibp */ /* If function is defined and not as an autoload, don't override */ @@ -2803,4 +2806,11 @@ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; +#ifdef HAVE_SHLIB + if (SHLIBP (Fcar (Fcdr (fundef)))) + { + /* ###TM###: autoload todo */ + } + else +#endif /* HAVE_SHLIB */ call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); @@ -2973,5 +2983,6 @@ { struct Lisp_Subr *subr = XSUBR (fun); - int max_args = subr->max_args; + CONST struct Lisp_Subr_Impl *impl = subr->impl; + int max_args = impl->max_args; Lisp_Object argvals[SUBR_MAX_ARGS]; Lisp_Object args_left; @@ -2980,5 +2991,5 @@ args_left = original_args; - if (nargs < subr->min_args + if (nargs < impl->min_args || (max_args >= 0 && max_args < nargs)) { @@ -3175,10 +3186,11 @@ { struct Lisp_Subr *subr = XSUBR (fun); - int max_args = subr->max_args; + CONST struct Lisp_Subr_Impl *impl = subr->impl; + int max_args = impl->max_args; if (max_args == UNEVALLED) return Fsignal (Qinvalid_function, list1 (fun)); - if (nargs < subr->min_args + if (nargs < impl->min_args || (max_args >= 0 && max_args < nargs)) { @@ -3431,7 +3443,8 @@ { struct Lisp_Subr *subr = XSUBR (fun); - int max_args = subr->max_args; + CONST struct Lisp_Subr_Impl *impl = subr->impl; + int max_args = impl->max_args; - if (numargs < subr->min_args + if (numargs < impl->min_args || (max_args >= 0 && max_args < numargs)) { @@ -3524,5 +3537,5 @@ funcall_subr (struct Lisp_Subr *subr, Lisp_Object args[]) { - return primitive_funcall (subr_function (subr), subr->max_args, args); + return primitive_funcall (subr_function (subr), subr_max_args(subr), args); } @@ -5144,4 +5157,7 @@ syms_of_eval (void) { + DEFCLASS (compiled_function); + DEFCLASS (subr); + defsymbol (&Qinhibit_quit, "inhibit-quit"); defsymbol (&Qautoload, "autoload"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/event-stream.c xemacs-20.0-b26/src/event-stream.c --- xemacs-20.0-b26-orig/src/event-stream.c Wed Jun 19 00:27:03 1996 +++ xemacs-20.0-b26/src/event-stream.c Tue Jul 9 09:17:07 1996 @@ -194,5 +194,5 @@ struct command_builder { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object console; /* back pointer to the console this command builder is for */ @@ -275,17 +275,16 @@ #define XCOMMAND_BUILDER(x) \ - XRECORD (x, command_builder, struct command_builder) -#define XSETCOMMAND_BUILDER(x, p) XSETRECORD (x, p, command_builder) -#define COMMAND_BUILDERP(x) RECORDP (x, command_builder) -#define GC_COMMAND_BUILDERP(x) GC_RECORDP (x, command_builder) -#define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder) + XOBJECT (x, command_builder, struct command_builder) +#define XSETCOMMAND_BUILDER(x, p) XSETLOBJECT (x, p, command_builder) +#define COMMAND_BUILDERP(x) OBJECT_CLASSP (x, command_builder) +#define CHECK_COMMAND_BUILDER(x) CHECK_OBJECT (x, command_builder) static Lisp_Object mark_command_builder (Lisp_Object obj, void (*markobj) (Lisp_Object)); static void finalize_command_builder (void *header, int for_disksave); -DEFINE_LRECORD_IMPLEMENTATION ("command-builder", command_builder, - mark_command_builder, internal_object_printer, - finalize_command_builder, 0, 0, - struct command_builder); +DEFINE_LOBJECT_CLASS ("Command-Builder", command_builder, 0, + mark_command_builder, internal_object_printer, + finalize_command_builder, 0, 0, + struct command_builder); static Lisp_Object @@ -329,7 +328,5 @@ { Lisp_Object builder_obj = Qnil; - struct command_builder *builder = - alloc_lcrecord (sizeof (struct command_builder), - lrecord_command_builder); + struct command_builder *builder = alloc_lobject (class_command_builder); builder->console = console; @@ -4041,4 +4038,6 @@ syms_of_event_stream (void) { + DEFCLASS (command_builder); + defsymbol (&Qdisabled, "disabled"); defsymbol (&Qcommand_event_p, "command-event-p"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/events.c xemacs-20.0-b26/src/events.c --- xemacs-20.0-b26-orig/src/events.c Sat Jun 15 17:22:27 1996 +++ xemacs-20.0-b26/src/events.c Tue Jul 9 09:17:07 1996 @@ -66,7 +66,7 @@ static int event_equal (Lisp_Object, Lisp_Object, int); static unsigned long event_hash (Lisp_Object obj, int depth); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("event", event, - mark_event, print_event, 0, event_equal, - event_hash, struct Lisp_Event); +DEFINE_LOBJECT_CLASS ("Event", event, LC_USEFROBBLOCKS, + mark_event, print_event, 0, event_equal, + event_hash, struct Lisp_Event); /* Make sure we lose quickly if we try to use this event */ @@ -77,9 +77,12 @@ struct Lisp_Event *event = XEVENT (ev); +#if 0 + /* ###TM###: dont work, now that the header have more information. */ for (i = 0; i < ((sizeof (struct Lisp_Event)) / sizeof (int)); i++) ((int *) event) [i] = 0xdeadbeef; +#endif + zero_lobject (event); event->event_type = dead_event; event->channel = Qnil; - set_lheader_implementation (&(event->lheader), lrecord_event); XSET_EVENT_NEXT (ev, Qnil); } @@ -89,6 +92,5 @@ zero_event (struct Lisp_Event *e) { - memset (e, 0, sizeof (*e)); - set_lheader_implementation (&(e->lheader), lrecord_event); + zero_lobject (e); e->event_type = empty_event; e->next = Qnil; @@ -405,5 +407,9 @@ else { - event = allocate_event (); + struct Lisp_Event *e; + + e = alloc_lobject(class_event); + + XSETEVENT (event, e); } zero_event (XEVENT (event)); @@ -1439,5 +1445,5 @@ /* #### pixel_to_glyph_translation() sometimes returns garbage... - The word has type Lisp_Record (presumably meaning `extent') but the + The word has type Lisp_LObject (presumably meaning `extent') but the pointer points to random memory, often filled with 0, sometimes not. */ @@ -1922,4 +1928,6 @@ syms_of_events (void) { + DEFCLASS (event); + defsubr (&Scharacter_to_event); defsubr (&Sevent_to_character); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/events.h xemacs-20.0-b26/src/events.h --- xemacs-20.0-b26-orig/src/events.h Mon May 13 14:34:28 1996 +++ xemacs-20.0-b26/src/events.h Mon Jul 8 14:36:29 1996 @@ -368,5 +368,5 @@ - Otherwise it's Qnil. */ - struct lrecord_header lheader; + struct lobject_header header; Lisp_Object next; emacs_event_type event_type; @@ -386,13 +386,12 @@ }; -DECLARE_LRECORD (event, struct Lisp_Event); -#define XEVENT(x) XRECORD (x, event, struct Lisp_Event) -#define XSETEVENT(x, p) XSETRECORD (x, p, event) -#define EVENTP(x) RECORDP (x, event) -#define GC_EVENTP(x) GC_RECORDP (x, event) -#define CHECK_EVENT(x) CHECK_RECORD (x, event) -#define CONCHECK_EVENT(x) CONCHECK_RECORD (x, event) +DECLARE_LOBJECT_CLASS (event, struct Lisp_Event); +#define XEVENT(x) XOBJECT (x, event, struct Lisp_Event) +#define XSETEVENT(x, p) XSETLOBJECT (x, p, event) +#define EVENTP(x) OBJECT_CLASSP (x, event) +#define CHECK_EVENT(x) CHECK_OBJECT (x, event) +#define CONCHECK_EVENT(x) CONCHECK_OBJECT (x, event) -DECLARE_LRECORD (command_builder, struct command_builder); +DECLARE_LOBJECT_CLASS (command_builder, struct command_builder); #define EVENT_CHANNEL(a) ((a)->channel) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/extents.c xemacs-20.0-b26/src/extents.c --- xemacs-20.0-b26-orig/src/extents.c Fri Jun 7 02:19:17 1996 +++ xemacs-20.0-b26/src/extents.c Tue Jul 9 09:17:06 1996 @@ -923,7 +923,7 @@ static Lisp_Object mark_extent_auxiliary (Lisp_Object obj, void (*markobj) (Lisp_Object)); -DEFINE_LRECORD_IMPLEMENTATION ("extent-auxiliary", extent_auxiliary, - mark_extent_auxiliary, internal_object_printer, - 0, 0, 0, struct extent_auxiliary); +DEFINE_LOBJECT_CLASS ("Extent-Auxiliary", extent_auxiliary, 0, + mark_extent_auxiliary, internal_object_printer, + 0, 0, 0, struct extent_auxiliary); static Lisp_Object @@ -945,9 +945,7 @@ { Lisp_Object extent_aux = Qnil; - struct extent_auxiliary *data = - alloc_lcrecord (sizeof (struct extent_auxiliary), - lrecord_extent_auxiliary); + struct extent_auxiliary *data = alloc_lobject (class_extent_auxiliary); - copy_lcrecord (data, &extent_auxiliary_defaults); + copy_lobject (data, &extent_auxiliary_defaults); XSETEXTENT_AUXILIARY (extent_aux, data); ext->plist = Fcons (extent_aux, ext->plist); @@ -988,8 +986,8 @@ void (*markobj) (Lisp_Object)); static void finalize_extent_info (void *header, int for_disksave); -DEFINE_LRECORD_IMPLEMENTATION ("extent-info", extent_info, - mark_extent_info, internal_object_printer, - finalize_extent_info, 0, 0, - struct extent_info); +DEFINE_LOBJECT_CLASS ("Extent-Info", extent_info, 0, + mark_extent_info, internal_object_printer, + finalize_extent_info, 0, 0, + struct extent_info); static Lisp_Object @@ -1050,7 +1048,5 @@ { Lisp_Object extent_info = Qnil; - struct extent_info *data = - alloc_lcrecord (sizeof (struct extent_info), - lrecord_extent_info); + struct extent_info *data = alloc_lobject (class_extent_info); XSETEXTENT_INFO (extent_info, data); @@ -1653,5 +1649,17 @@ make_extent_detached (Lisp_Object object) { - EXTENT extent = allocate_extent (); + EXTENT extent; + + extent = alloc_lobject (class_extent); + extent_object (extent) = Qnil; + set_extent_start (extent, -1); + set_extent_end (extent, -1); + extent->plist = Qnil; + + memset (&extent->flags, 0, sizeof (extent->flags)); + + extent_face (extent) = Qnil; + extent->flags.end_open = 1; /* default is for endpoints to behave like markers */ + extent->flags.detachable = 1; assert (NILP (object) || STRINGP (object) || @@ -2892,6 +2900,5 @@ /* These are the basic helper functions for handling the allocation of - extent objects. They are similar to the functions for other - lrecord objects. allocate_extent() is in alloc.c, not here. */ + extent objects. */ static Lisp_Object mark_extent (Lisp_Object, void (*) (Lisp_Object)); @@ -2906,16 +2913,16 @@ static Lisp_Object extent_plist (Lisp_Object obj); -DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("extent", extent, - mark_extent, - print_extent, - /* NOTE: If you declare a - finalization method here, - it will NOT be called. - Shaft city. */ - 0, - extent_equal, extent_hash, - extent_getprop, extent_putprop, - extent_remprop, extent_plist, - struct extent); +DEFINE_LOBJECT_CLASS_WITH_PROPS ("Extent", extent, 0, + mark_extent, + print_extent, + /* NOTE: If you declare a + finalization method here, + it will NOT be called. + Shaft city. */ + 0, + extent_equal, extent_hash, + extent_getprop, extent_putprop, + extent_remprop, extent_plist, + struct extent); static Lisp_Object @@ -3647,9 +3654,7 @@ this extent to share the same aux struct as the original one. */ - struct extent_auxiliary *data = - alloc_lcrecord (sizeof (struct extent_auxiliary), - lrecord_extent_auxiliary); + struct extent_auxiliary *data = alloc_lobject (class_extent_auxiliary); - copy_lcrecord (data, XEXTENT_AUXILIARY (XCAR (original->plist))); + copy_lobject (data, XEXTENT_AUXILIARY (XCAR (original->plist))); XSETEXTENT_AUXILIARY (XCAR (e->plist), data); } @@ -6711,4 +6716,8 @@ syms_of_extents (void) { + DEFCLASS (extent); + DEFCLASS (extent_info); + DEFCLASS (extent_auxiliary); + defsymbol (&Qextentp, "extentp"); defsymbol (&Qextent_live_p, "extent-live-p"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/extents.h xemacs-20.0-b26/src/extents.h --- xemacs-20.0-b26-orig/src/extents.h Sun Apr 14 19:02:04 1996 +++ xemacs-20.0-b26/src/extents.h Wed Jul 17 12:51:20 1996 @@ -24,15 +24,14 @@ #define _XEMACS_EXTENTS_H_ -DECLARE_LRECORD (extent, struct extent); -#define XEXTENT(x) XRECORD (x, extent, struct extent) -#define XSETEXTENT(x, p) XSETRECORD (x, p, extent) -#define EXTENTP(x) RECORDP (x, extent) -#define GC_EXTENTP(x) GC_RECORDP (x, extent) -#define CHECK_EXTENT(x) CHECK_RECORD (x, extent) -#define CONCHECK_EXTENT(x) CONCHECK_RECORD (x, extent) +DECLARE_LOBJECT_CLASS (extent, struct extent); +#define XEXTENT(x) XOBJECT (x, extent, struct extent) +#define XSETEXTENT(x, p) XSETLOBJECT (x, p, extent) +#define EXTENTP(x) OBJECT_CLASSP (x, extent) +#define CHECK_EXTENT(x) CHECK_OBJECT (x, extent) +#define CONCHECK_EXTENT(x) CONCHECK_OBJECT (x, extent) struct extent { - struct lrecord_header lheader; + struct lobject_header header; Memind start; @@ -116,5 +115,5 @@ struct extent_auxiliary { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object begin_glyph; @@ -141,16 +140,15 @@ extern struct extent_auxiliary extent_auxiliary_defaults; -DECLARE_LRECORD (extent_auxiliary, struct extent_auxiliary); +DECLARE_LOBJECT_CLASS (extent_auxiliary, struct extent_auxiliary); #define XEXTENT_AUXILIARY(x) \ - XRECORD (x, extent_auxiliary, struct extent_auxiliary) -#define XSETEXTENT_AUXILIARY(x, p) XSETRECORD (x, p, extent_auxiliary) -#define EXTENT_AUXILIARYP(x) RECORDP (x, extent_auxiliary) -#define GC_EXTENT_AUXILIARYP(x) GC_RECORDP (x, extent_auxiliary) -#define CHECK_EXTENT_AUXILIARY(x) CHECK_RECORD (x, extent_auxiliary) -#define CONCHECK_EXTENT_AUXILIARY(x) CONCHECK_RECORD (x, extent_auxiliary) + XOBJECT (x, extent_auxiliary, struct extent_auxiliary) +#define XSETEXTENT_AUXILIARY(x, p) XSETLOBJECT (x, p, extent_auxiliary) +#define EXTENT_AUXILIARYP(x) OBJECT_CLASSP (x, extent_auxiliary) +#define CHECK_EXTENT_AUXILIARY(x) CHECK_OBJECT (x, extent_auxiliary) +#define CONCHECK_EXTENT_AUXILIARY(x) CONCHECK_OBJECT (x, extent_auxiliary) struct extent_info { - struct lcrecord_header header; + struct lobject_header header; struct extent_list *extents; @@ -158,12 +156,11 @@ }; -DECLARE_LRECORD (extent_info, struct extent_info); +DECLARE_LOBJECT_CLASS (extent_info, struct extent_info); #define XEXTENT_INFO(x) \ - XRECORD (x, extent_info, struct extent_info) -#define XSETEXTENT_INFO(x, p) XSETRECORD (x, p, extent_info) -#define EXTENT_INFOP(x) RECORDP (x, extent_info) -#define GC_EXTENT_INFOP(x) GC_RECORDP (x, extent_info) -#define CHECK_EXTENT_INFO(x) CHECK_RECORD (x, extent_info) -#define CONCHECK_EXTENT_INFO(x) CONCHECK_RECORD (x, extent_info) + XOBJECT (x, extent_info, struct extent_info) +#define XSETEXTENT_INFO(x, p) XSETLOBJECT (x, p, extent_info) +#define EXTENT_INFOP(x) OBJECT_CLASSP (x, extent_info) +#define CHECK_EXTENT_INFO(x) CHECK_OBJECT (x, extent_info) +#define CONCHECK_EXTENT_INFO(x) CONCHECK_OBJECT (x, extent_info) void flush_cached_extent_info (Lisp_Object extent_info); @@ -351,7 +348,4 @@ #ifdef emacs /* things other than emacs want the structs */ - -/* from alloc.c */ -struct extent *allocate_extent (void); /* from extents.c */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/faces.c xemacs-20.0-b26/src/faces.c --- xemacs-20.0-b26-orig/src/faces.c Mon Jun 17 14:03:33 1996 +++ xemacs-20.0-b26/src/faces.c Tue Jul 9 09:17:05 1996 @@ -93,9 +93,9 @@ static int face_remprop (Lisp_Object obj, Lisp_Object prop); static Lisp_Object face_plist (Lisp_Object obj); -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("face", face, - mark_face, print_face, 0, face_equal, - face_hash, face_getprop, - face_putprop, face_remprop, - face_plist, struct Lisp_Face); +DEFINE_LOBJECT_CLASS_WITH_PROPS ("Face", face, 0, + mark_face, print_face, 0, face_equal, + face_hash, face_getprop, + face_putprop, face_remprop, + face_plist, struct Lisp_Face); static Lisp_Object @@ -419,6 +419,5 @@ allocate_face (void) { - struct Lisp_Face *result = - alloc_lcrecord (sizeof (struct Lisp_Face), lrecord_face); + struct Lisp_Face *result = alloc_lobject (class_face); reset_face (result); @@ -1840,4 +1839,5 @@ syms_of_faces (void) { + DEFCLASS (face); /* Qdefault defined in general.c */ defsymbol (&Qmodeline, "modeline"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/faces.h xemacs-20.0-b26/src/faces.h --- xemacs-20.0-b26-orig/src/faces.h Mon Jun 17 14:03:34 1996 +++ xemacs-20.0-b26/src/faces.h Mon Jul 8 14:36:30 1996 @@ -35,5 +35,5 @@ struct Lisp_Face { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object name; @@ -223,10 +223,9 @@ }; -DECLARE_LRECORD (face, struct Lisp_Face); -#define XFACE(x) XRECORD (x, face, struct Lisp_Face) -#define XSETFACE(x, p) XSETRECORD (x, p, face) -#define FACEP(x) RECORDP (x, face) -#define GC_FACEP(x) GC_RECORDP (x, face) -#define CHECK_FACE(x) CHECK_RECORD (x, face) +DECLARE_LOBJECT_CLASS (face, struct Lisp_Face); +#define XFACE(x) XOBJECT (x, face, struct Lisp_Face) +#define XSETFACE(x, p) XSETLOBJECT (x, p, face) +#define FACEP(x) OBJECT_CLASSP (x, face) +#define CHECK_FACE(x) CHECK_OBJECT (x, face) Lisp_Object ensure_face_cachel_contains_charset (struct face_cachel *cachel, diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/fileio.c xemacs-20.0-b26/src/fileio.c --- xemacs-20.0-b26-orig/src/fileio.c Sun Jun 9 17:48:56 1996 +++ xemacs-20.0-b26/src/fileio.c Mon Jul 8 14:36:30 1996 @@ -4335,5 +4335,5 @@ run_hook (Qauto_save_hook); - if (GC_STRINGP (Vauto_save_list_file_name)) + if (STRINGP (Vauto_save_list_file_name)) listfile = Fexpand_file_name (Vauto_save_list_file_name, Qnil); @@ -4351,5 +4351,5 @@ { for (tail = Vbuffer_alist; - GC_CONSP (tail); + CONSP (tail); tail = XCDR (tail)) { @@ -4357,5 +4357,5 @@ b = XBUFFER (buf); - if (!GC_NILP (current_only) + if (!NILP (current_only) && b != current_buffer) continue; @@ -4369,5 +4369,5 @@ and file changed since last auto save and file changed since last real save. */ - if (GC_STRINGP (b->auto_save_file_name) + if (STRINGP (b->auto_save_file_name) && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b) && b->auto_save_modified < BUF_MODIFF (b) @@ -4414,5 +4414,5 @@ } set_buffer_internal (b); - if (!auto_saved && GC_NILP (no_message)) + if (!auto_saved && NILP (no_message)) { static CONST unsigned char *msg @@ -4426,5 +4426,5 @@ We only do this now so that the file only exists if we actually auto-saved any files. */ - if (!auto_saved && GC_STRINGP (listfile) && listdesc < 0) + if (!auto_saved && STRINGP (listfile) && listdesc < 0) { #ifdef DOS_NT @@ -4500,5 +4500,5 @@ rather than before in case we get a crash attempting to autosave (in that case we'd still want the old one around). */ - if (listdesc < 0 && !auto_saved && GC_STRINGP (listfile)) + if (listdesc < 0 && !auto_saved && STRINGP (listfile)) unlink ((char *) string_data (XSTRING (listfile))); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/filelock.c xemacs-20.0-b26/src/filelock.c --- xemacs-20.0-b26-orig/src/filelock.c Sun Apr 7 20:35:08 1996 +++ xemacs-20.0-b26/src/filelock.c Mon Jul 8 14:36:30 1996 @@ -396,5 +396,5 @@ REGISTER struct buffer *b; - for (tail = Vbuffer_alist; GC_CONSP (tail); + for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail)) { diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/floatfns.c xemacs-20.0-b26/src/floatfns.c --- xemacs-20.0-b26-orig/src/floatfns.c Sun Jun 16 21:36:35 1996 +++ xemacs-20.0-b26/src/floatfns.c Tue Jul 9 09:17:04 1996 @@ -119,4 +119,16 @@ Fsignal (Qdomain_error, list3 (build_string ((op)), (a1), (a2))) +Lisp_Object +make_float (double float_value) +{ + Lisp_Object val; + struct Lisp_Float *f; + + f = alloc_lobject(class_float); + float_next (f) = ((struct Lisp_Float *) -1); + float_data (f) = float_value; + XSETFLOAT (val, f); + return (val); +} /* Convert float to Lisp_Int if it fits, else signal a range error @@ -165,7 +177,7 @@ static int float_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long float_hash (Lisp_Object obj, int depth); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, - mark_float, print_float, 0, float_equal, - float_hash, struct Lisp_Float); +DEFINE_LOBJECT_CLASS ("float", float, LC_USEFROBBLOCKS, + mark_float, print_float, 0, float_equal, + float_hash, struct Lisp_Float); static Lisp_Object @@ -190,6 +202,6 @@ -/* Extract a Lisp number as a `double', or signal an error. */ +/* Extract a Lisp number as a `double', or signal an error. */ double extract_float (Lisp_Object num) @@ -1018,4 +1030,5 @@ syms_of_floatfns (void) { + DEFCLASS (float); /* Trig functions. */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/fns.c xemacs-20.0-b26/src/fns.c --- xemacs-20.0-b26-orig/src/fns.c Thu Jun 6 19:16:40 1996 +++ xemacs-20.0-b26/src/fns.c Tue Jul 16 10:48:53 1996 @@ -53,8 +53,8 @@ static int bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long bit_vector_hash (Lisp_Object obj, int depth); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, - mark_bit_vector, print_bit_vector, 0, - bit_vector_equal, bit_vector_hash, - struct Lisp_Bit_Vector); +DEFINE_LOBJECT_CLASS ("Bit-Vector", bit_vector, 0, + mark_bit_vector, print_bit_vector, 0, + bit_vector_equal, bit_vector_hash, + struct Lisp_Bit_Vector); static Lisp_Object @@ -111,4 +111,108 @@ } +/* #### 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 = alloc_lobject_size (class_bit_vector, sizem); + + bit_vector_length (p) = sizei; + /* 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; + 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); +} + DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0 /* Return the argument unchanged. @@ -2824,16 +2928,15 @@ /* It's easiest to treat symbols specially because they may not - be an lrecord */ + be an LHEADER OBJECT */ if (SYMBOLP (object)) val = symbol_getprop (object, propname, defalt); else if (STRINGP (object)) val = string_getprop (XSTRING (object), propname, defalt); - else if (LRECORDP (object)) + else if (LOBJECTP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER (object)->implementation; - if (imp->getprop) + CONST Lisp_Class_Impl *impl = XLOBJECT_IMPL (object); + if (impl->getprop) { - val = (imp->getprop) (object, propname); + val = (impl->getprop) (object, propname); if (UNBOUNDP (val)) val = defalt; @@ -2874,11 +2977,10 @@ else if (STRINGP (object)) string_putprop (XSTRING (object), propname, value); - else if (LRECORDP (object)) + else if (LOBJECTP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER (object)->implementation; - if (imp->putprop) + CONST Lisp_Class_Impl *impl = XLOBJECT_IMPL (object); + if (impl->putprop) { - if (! (imp->putprop) (object, propname, value)) + if (! (impl->putprop) (object, propname, value)) signal_simple_error ("Can't set property on object", propname); } @@ -2920,11 +3022,10 @@ else if (STRINGP (object)) retval = string_remprop (XSTRING (object), propname); - else if (LRECORDP (object)) + else if (LOBJECTP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER (object)->implementation; - if (imp->remprop) + CONST Lisp_Class_Impl *impl = XLOBJECT_IMPL (object); + if (impl->remprop) { - retval = (imp->remprop) (object, propname); + retval = (impl->remprop) (object, propname); if (retval == -1) signal_simple_error ("Can't remove property from object", @@ -2957,10 +3058,9 @@ else if (STRINGP (object)) return string_plist (XSTRING (object)); - else if (LRECORDP (object)) + else if (LOBJECTP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER (object)->implementation; - if (imp->plist) - return (imp->plist) (object); + CONST Lisp_Class_Impl *impl = XLOBJECT_IMPL (object); + if (impl->plist) + return (impl->plist) (object); else signal_simple_error ("Object type has no properties", object); @@ -2994,5 +3094,5 @@ } -#ifndef LRECORD_VECTOR +#ifndef USE_LOBJECT_VECTOR else if (VECTORP (o1)) { @@ -3011,5 +3111,5 @@ return (1); } -#endif /* !LRECORD_VECTOR */ +#endif /* !USE_LOBJECT_VECTOR */ else if (STRINGP (o1)) { @@ -3021,16 +3121,15 @@ return (1); } - else if (LRECORDP (o1)) + else if (LOBJECTP (o1)) { - CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER (o1)->implementation, - *imp2 = XRECORD_LHEADER (o2)->implementation; - if (imp1 != imp2) + CONST Lisp_Class_Impl *impl1 = XLOBJECT_IMPL (o1); + CONST Lisp_Class_Impl *impl2 = XLOBJECT_IMPL (o2); + if (impl1 != impl2) return (0); - else if (imp1->equal == 0) + else if (impl1->equal == 0) /* EQ-ness of the objects was noticed above */ return (0); else - return ((imp1->equal) (o1, o2, depth)); + return ((impl1->equal) (o1, o2, depth)); } @@ -3064,5 +3163,5 @@ } -#ifndef LRECORD_VECTOR +#ifndef USE_LOBJECT_VECTOR else if (VECTORP (o1)) { @@ -3081,5 +3180,5 @@ return (1); } -#endif /* !LRECORD_VECTOR */ +#endif /* !USE_LOBJECT_VECTOR */ else if (STRINGP (o1)) { @@ -3091,16 +3190,15 @@ return (1); } - else if (LRECORDP (o1)) + else if (LOBJECTP (o1)) { - CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER (o1)->implementation, - *imp2 = XRECORD_LHEADER (o2)->implementation; - if (imp1 != imp2) + CONST Lisp_Class_Impl *impl1 = XLOBJECT_IMPL (o1); + CONST Lisp_Class_Impl *impl2 = XLOBJECT_IMPL (o2); + if (impl1 != impl2) return (0); - else if (imp1->equal == 0) + else if (impl1->equal == 0) /* EQ-ness of the objects was noticed above */ return (0); else - return ((imp1->equal) (o1, o2, depth)); + return ((impl1->equal) (o1, o2, depth)); } @@ -3516,8 +3614,12 @@ syms_of_fns (void) { + DEFCLASS (bit_vector); + defsymbol (&Qstring_lessp, "string-lessp"); defsymbol (&Qidentity, "identity"); defsymbol (&Qyes_or_no_p, "yes-or-no-p"); + defsubr (&Smake_bit_vector); + defsubr (&Sbit_vector); defsubr (&Sidentity); defsubr (&Srandom); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/frame.c xemacs-20.0-b26/src/frame.c --- xemacs-20.0-b26-orig/src/frame.c Fri Jun 21 23:47:42 1996 +++ xemacs-20.0-b26/src/frame.c Tue Jul 16 08:32:00 1996 @@ -128,7 +128,7 @@ static Lisp_Object mark_frame (Lisp_Object, void (*) (Lisp_Object)); static void print_frame (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("frame", frame, - mark_frame, print_frame, 0, 0, 0, - struct frame); +DEFINE_LOBJECT_CLASS ("Frame", frame, 0, + mark_frame, print_frame, 0, 0, 0, + struct frame); static Lisp_Object @@ -172,5 +172,5 @@ if (print_readably) error ("printing unreadable object #", - string_data (XSTRING (frm->name)), frm->header.uid); + string_data (XSTRING (frm->name)), LHEADER_UID (&frm->header)); sprintf (buf, "#<%s-frame ", !FRAME_LIVE_P (frm) ? "dead" : @@ -178,5 +178,5 @@ write_c_string (buf, printcharfun); print_internal (frm->name, printcharfun, 1); - sprintf (buf, " 0x%x>", frm->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&frm->header)); write_c_string (buf, printcharfun); } @@ -218,7 +218,7 @@ Lisp_Object frame = Qnil; Lisp_Object root_window; - struct frame *f = alloc_lcrecord (sizeof (struct frame), lrecord_frame); + struct frame *f = alloc_lobject (class_frame); - zero_lcrecord (f); + zero_lobject (f); nuke_all_frame_slots (f); XSETFRAME (frame, f); @@ -2872,4 +2872,6 @@ syms_of_frame (void) { + DEFCLASS (frame); + defsymbol (&Qdelete_frame_hook, "delete-frame-hook"); defsymbol (&Qselect_frame_hook, "select-frame-hook"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/frame.h xemacs-20.0-b26/src/frame.h --- xemacs-20.0-b26-orig/src/frame.h Sun Jun 9 17:49:22 1996 +++ xemacs-20.0-b26/src/frame.h Mon Jul 8 14:36:31 1996 @@ -46,5 +46,5 @@ struct frame { - struct lcrecord_header header; + struct lobject_header header; /* Methods for this frame's console. This can also be retrieved @@ -180,11 +180,10 @@ extern Lisp_Object Vframe_being_created; -DECLARE_LRECORD (frame, struct frame); -#define XFRAME(x) XRECORD (x, frame, struct frame) -#define XSETFRAME(x, p) XSETRECORD (x, p, frame) -#define FRAMEP(x) RECORDP (x, frame) -#define GC_FRAMEP(x) GC_RECORDP (x, frame) -#define CHECK_FRAME(x) CHECK_RECORD (x, frame) -#define CONCHECK_FRAME(x) CONCHECK_RECORD (x, frame) +DECLARE_LOBJECT_CLASS (frame, struct frame); +#define XFRAME(x) XOBJECT (x, frame, struct frame) +#define XSETFRAME(x, p) XSETLOBJECT (x, p, frame) +#define FRAMEP(x) OBJECT_CLASSP (x, frame) +#define CHECK_FRAME(x) CHECK_OBJECT (x, frame) +#define CONCHECK_FRAME(x) CONCHECK_OBJECT (x, frame) #define CHECK_LIVE_FRAME(x) \ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/glyphs-x.c xemacs-20.0-b26/src/glyphs-x.c --- xemacs-20.0-b26-orig/src/glyphs-x.c Thu Jun 20 17:31:05 1996 +++ xemacs-20.0-b26/src/glyphs-x.c Tue Jul 16 08:31:59 1996 @@ -3421,8 +3421,8 @@ static int subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long subwindow_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("subwindow", subwindow, - mark_subwindow, print_subwindow, - finalize_subwindow, subwindow_equal, - subwindow_hash, struct Lisp_Subwindow); +DEFINE_LOBJECT_CLASS ("Subwindow", subwindow, 0, + mark_subwindow, print_subwindow, + finalize_subwindow, subwindow_equal, + subwindow_hash, struct Lisp_Subwindow); static Lisp_Object @@ -3442,5 +3442,5 @@ if (print_readably) error ("printing unreadable object #", - sw->header.uid); + LHEADER_UID (&sw->header)); write_c_string ("#name, printcharfun, 1); - sprintf (buf, " 0x%x>", frm->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&frm->header)); write_c_string (buf, printcharfun); - sprintf (buf, ") 0x%x>", sw->header.uid); + sprintf (buf, ") 0x%x>", LHEADER_UID (&sw->header)); write_c_string (buf, printcharfun); } @@ -3474,5 +3474,11 @@ { struct Lisp_Subwindow *sw = (struct Lisp_Subwindow *) header; - if (for_disksave) finalose (sw); + if (for_disksave) { + Lisp_Object obj; + XSETLOBJECT (obj, sw, subwindow); + + signal_simple_error + ("Can't dump an emacs containing window system objects", obj); + } if (sw->subwindow) { @@ -3553,6 +3559,5 @@ { - struct Lisp_Subwindow *sw = alloc_lcrecord (sizeof (struct Lisp_Subwindow), - lrecord_subwindow); + struct Lisp_Subwindow *sw = alloc_lobject (class_subwindow); Lisp_Object val; sw->frame = frame; @@ -3709,4 +3714,6 @@ syms_of_glyphs_x (void) { + DEFCLASS (subwindow); + defsymbol (&Qsubwindowp, "subwindowp"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/glyphs-x.h xemacs-20.0-b26/src/glyphs-x.h --- xemacs-20.0-b26-orig/src/glyphs-x.h Sat Mar 30 18:19:06 1996 +++ xemacs-20.0-b26/src/glyphs-x.h Mon Jul 8 14:36:32 1996 @@ -77,14 +77,13 @@ ****************************************************************************/ -DECLARE_LRECORD (subwindow, struct Lisp_Subwindow); -#define XSUBWINDOW(x) XRECORD (x, subwindow, struct Lisp_Subwindow) -#define XSETSUBWINDOW(x, p) XSETRECORD (x, p, subwindow) -#define SUBWINDOWP(x) RECORDP (x, subwindow) -#define GC_SUBWINDOWP(x) GC_RECORDP (x, subwindow) -#define CHECK_SUBWINDOW(x) CHECK_RECORD (x, subwindow) +DECLARE_LOBJECT_CLASS (subwindow, struct Lisp_Subwindow); +#define XSUBWINDOW(x) XOBJECT (x, subwindow, struct Lisp_Subwindow) +#define XSETSUBWINDOW(x, p) XSETLOBJECT (x, p, subwindow) +#define SUBWINDOWP(x) OBJECT_CLASSP (x, subwindow) +#define CHECK_SUBWINDOW(x) CHECK_OBJECT (x, subwindow) struct Lisp_Subwindow { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object frame; Screen *xscreen; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/glyphs.c xemacs-20.0-b26/src/glyphs.c --- xemacs-20.0-b26-orig/src/glyphs.c Mon Jun 17 14:03:33 1996 +++ xemacs-20.0-b26/src/glyphs.c Tue Jul 16 08:31:58 1996 @@ -523,9 +523,9 @@ static int image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long image_instance_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance, - mark_image_instance, print_image_instance, - finalize_image_instance, image_instance_equal, - image_instance_hash, - struct Lisp_Image_Instance); +DEFINE_LOBJECT_CLASS ("Image-Instance", image_instance, 0, + mark_image_instance, print_image_instance, + finalize_image_instance, image_instance_equal, + image_instance_hash, + struct Lisp_Image_Instance); static Lisp_Object mark_image_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) @@ -569,5 +569,5 @@ if (print_readably) error ("printing unreadable object #", - ii->header.uid); + LHEADER_UID (&ii->header)); write_c_string ("#device), print_image_instance, (ii, printcharfun, escapeflag)); - sprintf (buf, " 0x%x>", ii->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&ii->header)); write_c_string (buf, printcharfun); } @@ -674,5 +674,11 @@ /* objects like this exist at dump time, so don't bomb out. */ return; - if (for_disksave) finalose (i); + if (for_disksave) { + Lisp_Object obj; + XSETLOBJECT (obj, i, image_instance); + + signal_simple_error + ("Can't dump an emacs containing window system objects", obj); + } MAYBE_DEVMETH (XDEVICE (i->device), finalize_image_instance, (i)); @@ -782,10 +788,8 @@ allocate_image_instance (Lisp_Object device) { - struct Lisp_Image_Instance *lp = - alloc_lcrecord (sizeof (struct Lisp_Image_Instance), - lrecord_image_instance); + struct Lisp_Image_Instance *lp = alloc_lobject (class_image_instance); Lisp_Object val = Qnil; - zero_lcrecord (lp); + zero_lobject (lp); lp->device = device; lp->type = IMAGE_NOTHING; @@ -1342,5 +1346,5 @@ new = allocate_image_instance (device); - copy_lcrecord (XIMAGE_INSTANCE (new), XIMAGE_INSTANCE (image_instance)); + copy_lobject (XIMAGE_INSTANCE (new), XIMAGE_INSTANCE (image_instance)); /* note that if this method returns non-zero, this method MUST copy any window-system resources, so that when one image instance is @@ -1973,10 +1977,10 @@ static int glyph_remprop (Lisp_Object obj, Lisp_Object prop); static Lisp_Object glyph_plist (Lisp_Object obj); -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("glyph", glyph, - mark_glyph, print_glyph, 0, - glyph_equal, glyph_hash, - glyph_getprop, glyph_putprop, - glyph_remprop, glyph_plist, - struct Lisp_Glyph); +DEFINE_LOBJECT_CLASS_WITH_PROPS ("Glyph", glyph, 0, + mark_glyph, print_glyph, 0, + glyph_equal, glyph_hash, + glyph_getprop, glyph_putprop, + glyph_remprop, glyph_plist, + struct Lisp_Glyph); static Lisp_Object @@ -2000,5 +2004,5 @@ if (print_readably) - error ("printing unreadable object #", glyph->header.uid); + error ("printing unreadable object #", LHEADER_UID (&glyph->header)); write_c_string ("#image, printcharfun, 1); - sprintf (buf, "0x%x>", glyph->header.uid); + sprintf (buf, "0x%x>", LHEADER_UID (&glyph->header)); write_c_string (buf, printcharfun); } @@ -2150,6 +2154,5 @@ { Lisp_Object obj = Qnil; - struct Lisp_Glyph *g = - alloc_lcrecord (sizeof (struct Lisp_Glyph), lrecord_glyph); + struct Lisp_Glyph *g = alloc_lobject (class_glyph); g->type = type; @@ -2795,4 +2798,7 @@ syms_of_glyphs (void) { + DEFCLASS (glyph); + DEFCLASS (image_instance); + /* image instantiators */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/glyphs.h xemacs-20.0-b26/src/glyphs.h --- xemacs-20.0-b26-orig/src/glyphs.h Mon May 13 14:33:48 1996 +++ xemacs-20.0-b26/src/glyphs.h Mon Jul 8 14:36:32 1996 @@ -235,12 +235,11 @@ *****************************************************************************/ -DECLARE_LRECORD (image_instance, struct Lisp_Image_Instance); +DECLARE_LOBJECT_CLASS (image_instance, struct Lisp_Image_Instance); #define XIMAGE_INSTANCE(x) \ - XRECORD (x, image_instance, struct Lisp_Image_Instance) -#define XSETIMAGE_INSTANCE(x, p) XSETRECORD (x, p, image_instance) -#define IMAGE_INSTANCEP(x) RECORDP (x, image_instance) -#define GC_IMAGE_INSTANCEP(x) GC_RECORDP (x, image_instance) -#define CHECK_IMAGE_INSTANCE(x) CHECK_RECORD (x, image_instance) -#define CONCHECK_IMAGE_INSTANCE(x) CONCHECK_RECORD (x, image_instance) + XOBJECT (x, image_instance, struct Lisp_Image_Instance) +#define XSETIMAGE_INSTANCE(x, p) XSETLOBJECT (x, p, image_instance) +#define IMAGE_INSTANCEP(x) OBJECT_CLASSP (x, image_instance) +#define CHECK_IMAGE_INSTANCE(x) CHECK_OBJECT (x, image_instance) +#define CONCHECK_IMAGE_INSTANCE(x) CONCHECK_OBJECT (x, image_instance) enum image_instance_type @@ -319,5 +318,5 @@ struct Lisp_Image_Instance { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object device; Lisp_Object name; @@ -411,5 +410,5 @@ struct Lisp_Glyph { - struct lcrecord_header header; + struct lobject_header header; enum glyph_type type; @@ -427,11 +426,10 @@ }; -DECLARE_LRECORD (glyph, struct Lisp_Glyph); -#define XGLYPH(x) XRECORD (x, glyph, struct Lisp_Glyph) -#define XSETGLYPH(x, p) XSETRECORD (x, p, glyph) -#define GLYPHP(x) RECORDP (x, glyph) -#define GC_GLYPHP(x) GC_RECORDP (x, glyph) -#define CHECK_GLYPH(x) CHECK_RECORD (x, glyph) -#define CONCHECK_GLYPH(x) CONCHECK_RECORD (x, glyph) +DECLARE_LOBJECT_CLASS (glyph, struct Lisp_Glyph); +#define XGLYPH(x) XOBJECT (x, glyph, struct Lisp_Glyph) +#define XSETGLYPH(x, p) XSETLOBJECT (x, p, glyph) +#define GLYPHP(x) OBJECT_CLASSP (x, glyph) +#define CHECK_GLYPH(x) CHECK_OBJECT (x, glyph) +#define CONCHECK_GLYPH(x) CONCHECK_OBJECT (x, glyph) extern Lisp_Object Qbuffer_glyph_p, Qpointer_glyph_p, Qicon_glyph_p; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/gui-x.c xemacs-20.0-b26/src/gui-x.c --- xemacs-20.0-b26-orig/src/gui-x.c Tue May 7 00:23:37 1996 +++ xemacs-20.0-b26/src/gui-x.c Tue Jul 9 09:17:01 1996 @@ -65,7 +65,7 @@ static Lisp_Object mark_popup_data (Lisp_Object obj, void (*markobj) (Lisp_Object)); -DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data, - mark_popup_data, internal_object_printer, - 0, 0, 0, struct popup_data); +DEFINE_LOBJECT_CLASS ("Popup-Data", popup_data, 0, + mark_popup_data, internal_object_printer, + 0, 0, 0, struct popup_data); struct mark_widget_value_closure @@ -122,5 +122,5 @@ assert (NILP (assq_no_quit (lid, Vpopup_callbacks))); - pdata = alloc_lcrecord (sizeof (struct popup_data), lrecord_popup_data); + pdata = alloc_lobject (class_popup_data); pdata->id = id; pdata->last_menubar_buffer = Qnil; @@ -594,4 +594,6 @@ syms_of_gui_x (void) { + DEFCLASS (popup_data); + #ifdef HAVE_POPUPS defsubr (&Spopup_up_p); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/gui-x.h xemacs-20.0-b26/src/gui-x.h --- xemacs-20.0-b26-orig/src/gui-x.h Sun Apr 14 21:03:32 1996 +++ xemacs-20.0-b26/src/gui-x.h Mon Jul 8 14:36:32 1996 @@ -36,12 +36,11 @@ /* Each frame has one of these, and they are also contained in - Vpopup_callbacks. - It doesn't really need to be an lrecord (it's not lisp-accessible) - but it makes marking slightly more modular. - */ + Vpopup_callbacks. It doesn't really need to be an lobject + (it's not lisp-accessible) but it makes marking slightly more + modular. */ struct popup_data { - struct lcrecord_header header; + struct lobject_header header; /* lwlib ID of the tree of widgets corresponding to this popup. @@ -61,10 +60,9 @@ }; -DECLARE_LRECORD (popup_data, struct popup_data); -#define XPOPUP_DATA(x) XRECORD (x, popup_data, struct popup_data) -#define XSETPOPUP_DATA(x, p) XSETRECORD (x, p, popup_data) -#define POPUP_DATAP(x) RECORDP (x, popup_data) -#define GC_POPUP_DATAP(x) GC_RECORDP (x, popup_data) -#define CHECK_POPUP_DATA(x) CHECK_RECORD (x, popup_data) +DECLARE_LOBJECT_CLASS (popup_data, struct popup_data); +#define XPOPUP_DATA(x) XOBJECT (x, popup_data, struct popup_data) +#define XSETPOPUP_DATA(x, p) XSETLOBJECT (x, p, popup_data) +#define POPUP_DATAP(x) OBJECT_CLASSP (x, popup_data) +#define CHECK_POPUP_DATA(x) CHECK_OBJECT (x, popup_data) void gcpro_popup_callbacks (LWLIB_ID id); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/keymap.c xemacs-20.0-b26/src/keymap.c --- xemacs-20.0-b26-orig/src/keymap.c Thu May 23 02:18:42 1996 +++ xemacs-20.0-b26/src/keymap.c Tue Jul 16 08:31:58 1996 @@ -148,5 +148,5 @@ struct keymap { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object parents; /* Keymaps to be searched after this one * An ordered list */ @@ -174,9 +174,4 @@ }; -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) -#define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) -#define KEYMAPP(x) RECORDP (x, keymap) -#define CHECK_KEYMAP(x) CHECK_RECORD (x, keymap) - #define MAKE_MODIFIER_HASH_KEY(modifier) make_int (modifier) #define MODIFIER_HASH_KEY_BITS(x) (INTP (x) ? XINT (x) : 0) @@ -240,7 +235,7 @@ static void print_keymap (Lisp_Object, Lisp_Object, int); /* No need for keymap_equal #### Why not? */ -DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap, - mark_keymap, print_keymap, 0, 0, 0, - struct keymap); +DEFINE_LOBJECT_CLASS ("Keymap", keymap, 0, + mark_keymap, print_keymap, 0, 0, 0, + struct keymap); static Lisp_Object mark_keymap (Lisp_Object obj, void (*markobj) (Lisp_Object)) @@ -264,5 +259,5 @@ int size = XINT (Fkeymap_fullness (obj)); if (print_readably) - error ("printing unreadable object #", keymap->header.uid); + error ("printing unreadable object #", LHEADER_UID (&keymap->header)); write_c_string ("#name)) @@ -272,5 +267,5 @@ size, ((size == 1) ? "y" : "ies"), - keymap->header.uid); + LHEADER_UID (&keymap->header)); write_c_string (buf, printcharfun); } @@ -743,6 +738,5 @@ { Lisp_Object result = Qnil; - struct keymap *keymap = alloc_lcrecord (sizeof (struct keymap), - lrecord_keymap); + struct keymap *keymap = alloc_lobject (class_keymap); XSETKEYMAP (result, keymap); @@ -4168,4 +4162,6 @@ syms_of_keymap (void) { + DEFCLASS (keymap); + defsymbol (&Qminor_mode_map_alist, "minor-mode-map-alist"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/keymap.h xemacs-20.0-b26/src/keymap.h --- xemacs-20.0-b26-orig/src/keymap.h Sat Mar 30 21:24:27 1996 +++ xemacs-20.0-b26/src/keymap.h Mon Jul 8 14:36:33 1996 @@ -25,11 +25,10 @@ #define _XEMACS_KEYMAP_H_ -DECLARE_LRECORD (keymap, struct keymap); -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) -#define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) -#define KEYMAPP(x) RECORDP (x, keymap) -#define GC_KEYMAPP(x) GC_RECORDP (x, keymap) -#define CHECK_KEYMAP(x) CHECK_RECORD (x, keymap) -#define CONCHECK_KEYMAP(x) CONCHECK_RECORD (x, keymap) +DECLARE_LOBJECT_CLASS (keymap, struct keymap); +#define XKEYMAP(x) XOBJECT (x, keymap, struct keymap) +#define XSETKEYMAP(x, p) XSETLOBJECT (x, p, keymap) +#define KEYMAPP(x) OBJECT_CLASSP (x, keymap) +#define CHECK_KEYMAP(x) CHECK_OBJECT (x, keymap) +#define CONCHECK_KEYMAP(x) CONCHECK_OBJECT (x, keymap) extern Lisp_Object get_keymap (Lisp_Object object, int errorp, int autoload); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/lisp-disunion.h xemacs-20.0-b26/src/lisp-disunion.h --- xemacs-20.0-b26-orig/src/lisp-disunion.h Sat Mar 30 16:43:46 1996 +++ xemacs-20.0-b26/src/lisp-disunion.h Mon Jul 8 14:36:33 1996 @@ -65,5 +65,4 @@ #define EQ(x,y) ((x) == (y)) -#define GC_EQ(x,y) (XGCTYPE (x) == XGCTYPE (y) && XPNTR (x) == XPNTR (y)) #if 0 @@ -173,5 +172,5 @@ #ifndef XUNMARK -/* no 'do {} while' because this is used in a mondo macro in lrecord.h */ +/* no 'do {} while' because this is used in a mondo macro in lrecord.h ###TM###: not any more */ # define XUNMARK(a) ((a) &= (~(MARKBIT))) #endif diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/lisp-union.h xemacs-20.0-b26/src/lisp-union.h --- xemacs-20.0-b26-orig/src/lisp-union.h Mon Apr 29 03:40:28 1996 +++ xemacs-20.0-b26/src/lisp-union.h Mon Jul 8 14:36:33 1996 @@ -109,5 +109,4 @@ #define EQ(x,y) ((x).v == (y).v) -#define GC_EQ(x,y) ((x).gu.val == (y).gu.val && (x).gu.type == (y).gu.type) #define XTYPE(a) ((enum Lisp_Type) (a).gu.type) @@ -191,5 +190,5 @@ #define XSETMARKBIT(a,b) do { (XMARKBIT (a) = (b)); } while (0) #define XMARK(a) do { XMARKBIT (a) = 1; } while (0) -/* no 'do {} while' because this is used in a mondo macro in lrecord.h */ +/* no 'do {} while' because this is used in a mondo macro in lrecord.h ###TM###: not any more */ #define XUNMARK(a) (XMARKBIT (a) = 0) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/lisp.h xemacs-20.0-b26/src/lisp.h --- xemacs-20.0-b26-orig/src/lisp.h Sun Jun 16 21:36:38 1996 +++ xemacs-20.0-b26/src/lisp.h Tue Jul 16 11:30:29 1996 @@ -607,8 +607,8 @@ /************************************************************************/ -/* There's not any particular reason not to use lrecords for these; some - objects get slightly larger, but we get 3 bit tags instead of 4. - */ -#define LRECORD_SYMBOL +/* There's not any particular reason not to use LHEADER OBJECTS for + these; some objects get slightly larger, but we get 3 bit tags + instead of 4. */ +#define USE_LOBJECT_SYMBOL @@ -622,18 +622,18 @@ Lisp_Int /* 0 DTP-FIXNUM */ - /* XRECORD_LHEADER (object) points to a struct lrecord_header - lheader->implementation determines the type (and GC behaviour) - of the object. */ - ,Lisp_Record /* 1 DTP-OTHER-POINTER */ + /* XLOBJECT_LHEADER (object) points to a struct lobject_header; + XLOBJECT_CLASS determines the type (and GC behaviour) of the + object. */ + ,Lisp_LObject /* 1 DTP-OTHER-POINTER */ /* Cons. XCONS (object) points to a struct Lisp_Cons. */ ,Lisp_Cons /* 2 DTP-LIST */ - /* LRECORD_STRING is NYI */ + /* USE_LOBJECT_STRING is NYI */ /* String. XSTRING (object) points to a struct Lisp_String. The length of the string, and its contents, are stored therein. */ ,Lisp_String /* 3 DTP-STRING */ -#ifndef LRECORD_VECTOR +#ifndef USE_LOBJECT_VECTOR /* Vector of Lisp objects. XVECTOR(object) points to a struct Lisp_Vector. The length of the vector, and its contents, are stored therein. */ @@ -641,8 +641,8 @@ #endif -#ifndef LRECORD_SYMBOL +#ifndef USE_LOBJECT_SYMBOL /* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */ ,Lisp_Symbol -#endif /* !LRECORD_SYMBOL */ +#endif /* !USE_LOBJECT_SYMBOL */ ,Lisp_Char /* 5 DTP-CHAR */ @@ -722,5 +722,8 @@ /************************************************************************/ -#include "lrecord.h" +/* ###TM###: doc */ +extern int gc_in_progress; + +#include "classes.h" /********** unbound ***********/ @@ -732,5 +735,4 @@ #define UNBOUNDP(val) EQ (val, Qunbound) -#define GC_UNBOUNDP(val) GC_EQ (val, Qunbound) /*********** cons ***********/ @@ -755,11 +757,10 @@ #endif -DECLARE_NONRECORD (cons, Lisp_Cons, struct Lisp_Cons); -#define XCONS(a) XNONRECORD (a, cons, Lisp_Cons, struct Lisp_Cons) +DECLARE_NONHEADER_CLASS (cons, Lisp_Cons, struct Lisp_Cons); +#define XCONS(a) XOBJECT (a, cons, struct Lisp_Cons) #define XSETCONS(c, p) XSETOBJ (c, Lisp_Cons, p) #define CONSP(x) (XTYPE (x) == Lisp_Cons) -#define GC_CONSP(x) (XGCTYPE (x) == Lisp_Cons) -#define CHECK_CONS(x) CHECK_NONRECORD (x, Lisp_Cons, Qconsp) -#define CONCHECK_CONS(x) CONCHECK_NONRECORD (x, Lisp_Cons, Qconsp) +#define CHECK_CONS(x) CHECK_NONOBJECT (x, Lisp_Cons, Qconsp) +#define CONCHECK_CONS(x) CONCHECK_NONOBJECT (x, Lisp_Cons, Qconsp) /* Define these because they're used in a few places, inside and @@ -769,5 +770,4 @@ #define NILP(x) EQ (x, Qnil) -#define GC_NILP(x) GC_EQ (x, Qnil) #define CHECK_LIST(x) \ do { if ((!CONSP (x)) && !NILP (x)) dead_wrong_type_argument (Qlistp, x); } while (0) @@ -823,6 +823,6 @@ struct Lisp_String { -#ifdef LRECORD_STRING - struct lrecord_header lheader; +#ifdef USE_LOBJECT_STRING + struct lobject_header header; #endif long _size; @@ -831,23 +831,21 @@ }; -#ifdef LRECORD_STRING +#ifdef USE_LOBJECT_STRING -DECLARE_LRECORD (string, struct Lisp_String); -#define XSTRING(x) XRECORD (x, string, struct Lisp_String) -#define XSETSTRING(x, p) XSETRECORD (x, p, string) -#define STRINGP(x) RECORDP (x, string) -#define GC_STRINGP(x) GC_RECORDP (x, string) -#define CHECK_STRING(x) CHECK_RECORD (x, string) -#define CONCHECK_STRING(x) CONCHECK_RECORD (x, string) +DECLARE_LOBJECT_CLASS (string, struct Lisp_String); +#define XSTRING(x) XOBJECT (x, string, struct Lisp_String) +#define XSETSTRING(x, p) XSETLOBJECT (x, p, string) +#define STRINGP(x) OBJECT_CLASSP (x, string) +#define CHECK_STRING(x) CHECK_OBJECT (x, string) +#define CONCHECK_STRING(x) CONCHECK_OBJECT (x, string) #else -DECLARE_NONRECORD (string, Lisp_String, struct Lisp_String); -#define XSTRING(x) XNONRECORD (x, string, Lisp_String, struct Lisp_String) +DECLARE_NONHEADER_CLASS (string, Lisp_String, struct Lisp_String); +#define XSTRING(x) XOBJECT (x, string, struct Lisp_String) #define XSETSTRING(x, p) XSETOBJ (x, Lisp_String, p) #define STRINGP(x) (XTYPE (x) == Lisp_String) -#define GC_STRINGP(x) (XGCTYPE (x) == Lisp_String) -#define CHECK_STRING(x) CHECK_NONRECORD (x, Lisp_String, Qstringp) -#define CONCHECK_STRING(x) CONCHECK_NONRECORD (x, Lisp_String, Qstringp) +#define CHECK_STRING(x) CHECK_NONOBJECT (x, Lisp_String, Qstringp) +#define CONCHECK_STRING(x) CONCHECK_NONOBJECT (x, Lisp_String, Qstringp) #endif @@ -901,6 +899,6 @@ struct Lisp_Vector { -#ifdef LRECORD_VECTOR - struct lrecord_header lheader; +#ifdef USE_LOBJECT_VECTOR + struct lobject_header header; #endif long size; @@ -911,23 +909,21 @@ }; -#ifdef LRECORD_VECTOR +#ifdef USE_LOBJECT_VECTOR -DECLARE_LRECORD (vector, struct Lisp_Vector); -#define XVECTOR(x) XRECORD (x, vector, struct Lisp_Vector) -#define XSETVECTOR(x, p) XSETRECORD (x, p, vector) -#define VECTORP(x) RECORDP (x, vector) -#define GC_VECTORP(x) GC_RECORDP (x, vector) -#define CHECK_VECTOR(x) CHECK_RECORD (x, vector) -#define CONCHECK_VECTOR(x) CONCHECK_RECORD (x, vector) +DECLARE_LOBJECT_CLASS (vector, struct Lisp_Vector); +#define XVECTOR(x) XOBJECT (x, vector, struct Lisp_Vector) +#define XSETVECTOR(x, p) XSETLOBJECT (x, p, vector) +#define VECTORP(x) OBJECT_CLASSP (x, vector) +#define CHECK_VECTOR(x) CHECK_OBJECT (x, vector) +#define CONCHECK_VECTOR(x) CONCHECK_OBJECT (x, vector) #else -DECLARE_NONRECORD (vector, Lisp_Vector, struct Lisp_Vector); -#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Vector, struct Lisp_Vector) +DECLARE_NONHEADER_CLASS (vector, Lisp_Vector, struct Lisp_Vector); +#define XVECTOR(x) XOBJECT (x, vector, struct Lisp_Vector) #define XSETVECTOR(x, p) XSETOBJ (x, Lisp_Vector, p) #define VECTORP(x) (XTYPE (x) == Lisp_Vector) -#define GC_VECTORP(x) (XGCTYPE (x) == Lisp_Vector) -#define CHECK_VECTOR(x) CHECK_NONRECORD (x, Lisp_Vector, Qvectorp) -#define CONCHECK_VECTOR(x) CONCHECK_NONRECORD (x, Lisp_Vector, Qvectorp) +#define CHECK_VECTOR(x) CHECK_NONOBJECT (x, Lisp_Vector, Qvectorp) +#define CONCHECK_VECTOR(x) CONCHECK_NONOBJECT (x, Lisp_Vector, Qvectorp) #endif @@ -956,20 +952,17 @@ struct Lisp_Bit_Vector { - struct lrecord_header lheader; - Lisp_Object next; + struct lobject_header header; long size; unsigned int bits[1]; }; -DECLARE_LRECORD (bit_vector, struct Lisp_Bit_Vector); -#define XBIT_VECTOR(x) XRECORD (x, bit_vector, struct Lisp_Bit_Vector) -#define XSETBIT_VECTOR(x, p) XSETRECORD (x, p, bit_vector) -#define BIT_VECTORP(x) RECORDP (x, bit_vector) -#define GC_BIT_VECTORP(x) GC_RECORDP (x, bit_vector) -#define CHECK_BIT_VECTOR(x) CHECK_RECORD (x, bit_vector) -#define CONCHECK_BIT_VECTOR(x) CONCHECK_RECORD (x, bit_vector) +DECLARE_LOBJECT_CLASS (bit_vector, struct Lisp_Bit_Vector); +#define XBIT_VECTOR(x) XOBJECT (x, bit_vector, struct Lisp_Bit_Vector) +#define XSETBIT_VECTOR(x, p) XSETLOBJECT (x, p, bit_vector) +#define BIT_VECTORP(x) OBJECT_CLASSP (x, bit_vector) +#define CHECK_BIT_VECTOR(x) CHECK_OBJECT (x, bit_vector) +#define CONCHECK_BIT_VECTOR(x) CONCHECK_OBJECT (x, bit_vector) #define BITP(x) (INTP (x) && (XINT (x) == 0 || XINT (x) == 1)) -#define GC_BITP(x) (GC_INTP (x) && (XINT (x) == 0 || XINT (x) == 1)) #define CHECK_BIT(x) \ @@ -979,5 +972,4 @@ #define bit_vector_length(v) ((v)->size) -#define bit_vector_next(v) ((v)->next) INLINE int bit_vector_bit (struct Lisp_Bit_Vector *v, int i); @@ -1013,6 +1005,6 @@ struct Lisp_Symbol { -#ifdef LRECORD_SYMBOL - struct lrecord_header lheader; +#ifdef USE_LOBJECT_SYMBOL + struct lobject_header header; #endif /* next symbol in this obarray bucket */ @@ -1027,23 +1019,21 @@ #define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj)) -#ifdef LRECORD_SYMBOL +#ifdef USE_LOBJECT_SYMBOL -DECLARE_LRECORD (symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XRECORD (x, symbol, struct Lisp_Symbol) -#define XSETSYMBOL(x, p) XSETRECORD (x, p, symbol) -#define SYMBOLP(x) RECORDP (x, symbol) -#define GC_SYMBOLP(x) GC_RECORDP (x, symbol) -#define CHECK_SYMBOL(x) CHECK_RECORD (x, symbol) -#define CONCHECK_SYMBOL(x) CONCHECK_RECORD (x, symbol) +DECLARE_LOBJECT_CLASS (symbol, struct Lisp_Symbol); +#define XSYMBOL(x) XOBJECT (x, symbol, struct Lisp_Symbol) +#define XSETSYMBOL(x, p) XSETLOBJECT (x, p, symbol) +#define SYMBOLP(x) OBJECT_CLASSP (x, symbol) +#define CHECK_SYMBOL(x) CHECK_OBJECT (x, symbol) +#define CONCHECK_SYMBOL(x) CONCHECK_OBJECT (x, symbol) #else -DECLARE_NONRECORD (symbol, Lisp_Symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Symbol, struct Lisp_Symbol) +DECLARE_NONHEADER_CLASS (symbol, Lisp_Symbol, struct Lisp_Symbol); +#define XSYMBOL(x) XOBJECT (x, symbol, struct Lisp_Symbol) #define XSETSYMBOL(s, p) XSETOBJ ((s), Lisp_Symbol, (p)) #define SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) -#define GC_SYMBOLP(x) (XGCTYPE (x) == Lisp_Symbol) -#define CHECK_SYMBOL(x) CHECK_NONRECORD (x, Lisp_Symbol, Qsymbolp) -#define CONCHECK_SYMBOL(x) CONCHECK_NONRECORD (x, Lisp_Symbol, Qsymbolp) +#define CHECK_SYMBOL(x) CHECK_NONOBJECT (x, Lisp_Symbol, Qsymbolp) +#define CONCHECK_SYMBOL(x) CONCHECK_NONOBJECT (x, Lisp_Symbol, Qsymbolp) #endif @@ -1057,7 +1047,5 @@ /*********** subr ***********/ -struct Lisp_Subr -{ - struct lrecord_header lheader; +struct Lisp_Subr_Impl { short min_args, max_args; CONST char *prompt; @@ -1067,14 +1055,23 @@ }; -DECLARE_LRECORD (subr, struct Lisp_Subr); -#define XSUBR(x) XRECORD (x, subr, struct Lisp_Subr) -#define XSETSUBR(x, p) XSETRECORD (x, p, subr) -#define SUBRP(x) RECORDP (x, subr) -#define GC_SUBRP(x) GC_RECORDP (x, subr) -#define CHECK_SUBR(x) CHECK_RECORD (x, subr) -#define CONCHECK_SUBR(x) CONCHECK_RECORD (x, subr) +struct Lisp_Subr +{ + struct lobject_header header; + CONST struct Lisp_Subr_Impl *impl; +}; -#define subr_function(subr) (subr)->subr_fn -#define subr_name(subr) (subr)->name +DECLARE_LOBJECT_CLASS (subr, struct Lisp_Subr); +#define XSUBR(x) XOBJECT (x, subr, struct Lisp_Subr) +#define XSETSUBR(x, p) XSETLOBJECT (x, p, subr) +#define SUBRP(x) OBJECT_CLASSP (x, subr) +#define CHECK_SUBR(x) CHECK_OBJECT (x, subr) +#define CONCHECK_SUBR(x) CONCHECK_OBJECT (x, subr) + +#define subr_min_args(subr) (subr)->impl->min_args +#define subr_max_args(subr) (subr)->impl->max_args +#define subr_prompt(subr) (subr)->impl->prompt +#define subr_doc(subr) (subr)->impl->doc +#define subr_name(subr) (subr)->impl->name +#define subr_function(subr) (subr)->impl->subr_fn /*********** marker ***********/ @@ -1082,5 +1079,5 @@ struct Lisp_Marker { - struct lrecord_header lheader; + struct lobject_header header; struct Lisp_Marker *next, *prev; struct buffer *buffer; @@ -1089,14 +1086,12 @@ }; -DECLARE_LRECORD (marker, struct Lisp_Marker); -#define XMARKER(x) XRECORD (x, marker, struct Lisp_Marker) -#define XSETMARKER(x, p) XSETRECORD (x, p, marker) -#define MARKERP(x) RECORDP (x, marker) -#define GC_MARKERP(x) GC_RECORDP (x, marker) -#define CHECK_MARKER(x) CHECK_RECORD (x, marker) -#define CONCHECK_MARKER(x) CONCHECK_RECORD (x, marker) +DECLARE_LOBJECT_CLASS (marker, struct Lisp_Marker); +#define XMARKER(x) XOBJECT (x, marker, struct Lisp_Marker) +#define XSETMARKER(x, p) XSETLOBJECT (x, p, marker) +#define MARKERP(x) OBJECT_CLASSP (x, marker) +#define CHECK_MARKER(x) CHECK_OBJECT (x, marker) +#define CONCHECK_MARKER(x) CONCHECK_OBJECT (x, marker) /* The second check was looking for GCed markers still in use */ -/* if (INTP (XMARKER (x)->lheader.next.v)) abort (); */ #define marker_next(m) ((m)->next) @@ -1105,6 +1100,6 @@ /*********** char ***********/ +DECLARE_DIRECT_CLASS (char, Lisp_Char, Emchar); #define CHARP(x) (XTYPE (x) == Lisp_Char) -#define GC_CHARP(x) (XGCTYPE (x) == Lisp_Char) #ifdef ERROR_CHECK_TYPECHECK @@ -1124,6 +1119,6 @@ #endif -#define CHECK_CHAR(x) CHECK_NONRECORD (x, Lisp_Char, Qcharacterp) -#define CONCHECK_CHAR(x) CONCHECK_NONRECORD (x, Lisp_Char, Qcharacterp) +#define CHECK_CHAR(x) CHECK_NONOBJECT (x, Lisp_Char, Qcharacterp) +#define CONCHECK_CHAR(x) CONCHECK_NONOBJECT (x, Lisp_Char, Qcharacterp) @@ -1134,15 +1129,14 @@ struct Lisp_Float { - struct lrecord_header lheader; + struct lobject_header header; union { double d; struct Lisp_Float *next; } data; }; -DECLARE_LRECORD (float, struct Lisp_Float); -#define XFLOAT(x) XRECORD (x, float, struct Lisp_Float) -#define XSETFLOAT(x, p) XSETRECORD (x, p, float) -#define FLOATP(x) RECORDP (x, float) -#define GC_FLOATP(x) GC_RECORDP (x, float) -#define CHECK_FLOAT(x) CHECK_RECORD (x, float) -#define CONCHECK_FLOAT(x) CONCHECK_RECORD (x, float) +DECLARE_LOBJECT_CLASS (float, struct Lisp_Float); +#define XFLOAT(x) XOBJECT (x, float, struct Lisp_Float) +#define XSETFLOAT(x, p) XSETLOBJECT (x, p, float) +#define FLOATP(x) OBJECT_CLASSP (x, float) +#define CHECK_FLOAT(x) CHECK_OBJECT (x, float) +#define CONCHECK_FLOAT(x) CONCHECK_OBJECT (x, float) #define float_next(f) ((f)->data.next) @@ -1185,5 +1179,4 @@ # define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x)) -# define GC_INT_OR_FLOATP(x) (GC_INTP (x) || GC_FLOATP (x)) #else /* not LISP_FLOAT_TYPE */ @@ -1192,5 +1185,4 @@ #define XSETFLOAT(x, p) --- error! No float support. --- #define FLOATP(x) 0 -#define GC_FLOATP(x) 0 #define CHECK_FLOAT(x) --- error! No float support. --- #define CONCHECK_FLOAT(x) --- error! No float support. --- @@ -1203,13 +1195,11 @@ CHECK_INT_COERCE_CHAR_OR_MARKER #define INT_OR_FLOATP(x) (INTP (x)) -# define GC_INT_OR_FLOATP(x) (GC_INTP (x)) #endif /* not LISP_FLOAT_TYPE */ +DECLARE_DIRECT_CLASS (integer, Lisp_Int, int); #define INTP(x) (XTYPE (x) == Lisp_Int) -#define GC_INTP(x) (XGCTYPE (x) == Lisp_Int) #define ZEROP(x) EQ (x, Qzero) -#define GC_ZEROP(x) GC_EQ (x, Qzero) #ifdef ERROR_CHECK_TYPECHECK @@ -1229,9 +1219,8 @@ #endif -#define CHECK_INT(x) CHECK_NONRECORD (x, Lisp_Int, Qintegerp) -#define CONCHECK_INT(x) CONCHECK_NONRECORD (x, Lisp_Int, Qintegerp) +#define CHECK_INT(x) CHECK_NONOBJECT (x, Lisp_Int, Qintegerp) +#define CONCHECK_INT(x) CONCHECK_NONOBJECT (x, Lisp_Int, Qintegerp) #define NATNUMP(x) (INTP (x) && XINT (x) >= 0) -#define GC_NATNUMP(x) (GC_INTP (x) && XINT (x) >= 0) #define CHECK_NATNUM(x) \ @@ -1329,5 +1318,5 @@ struct weak_list { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object list; /* don't mark through this! */ enum weak_list_type type; @@ -1335,11 +1324,10 @@ }; -DECLARE_LRECORD (weak_list, struct weak_list); -#define XWEAK_LIST(x) XRECORD (x, weak_list, struct weak_list) -#define XSETWEAK_LIST(x, p) XSETRECORD (x, p, weak_list) -#define WEAK_LISTP(x) RECORDP (x, weak_list) -#define GC_WEAK_LISTP(x) GC_RECORDP (x, weak_list) -#define CHECK_WEAK_LIST(x) CHECK_RECORD (x, weak_list) -#define CONCHECK_WEAK_LIST(x) CONCHECK_RECORD (x, weak_list) +DECLARE_LOBJECT_CLASS (weak_list, struct weak_list); +#define XWEAK_LIST(x) XOBJECT (x, weak_list, struct weak_list) +#define XSETWEAK_LIST(x, p) XSETLOBJECT (x, p, weak_list) +#define WEAK_LISTP(x) OBJECT_CLASSP (x, weak_list) +#define CHECK_WEAK_LIST(x) CHECK_OBJECT (x, weak_list) +#define CONCHECK_WEAK_LIST(x) CONCHECK_OBJECT (x, weak_list) #define weak_list_list(w) ((w)->list) @@ -1352,29 +1340,4 @@ void prune_weak_lists (int (*obj_marked_p) (Lisp_Object)); -/*********** lcrecord lists ***********/ - -struct lcrecord_list -{ - struct lcrecord_header header; - Lisp_Object free; - int size; - CONST struct lrecord_implementation *implementation; -}; - -DECLARE_LRECORD (lcrecord_list, struct lcrecord_list); -#define XLCRECORD_LIST(x) XRECORD (x, lcrecord_list, struct lcrecord_list) -#define XSETLCRECORD_LIST(x, p) XSETRECORD (x, p, lcrecord_list) -#define LCRECORD_LISTP(x) RECORDP (x, lcrecord_list) -#define GC_LCRECORD_LISTP(x) GC_RECORDP (x, lcrecord_list) -/* #define CHECK_LCRECORD_LIST(x) CHECK_RECORD (x, lcrecord_list) - Lcrecord lists should never escape to the Lisp level, so - functions should not be doing this. */ - -Lisp_Object make_lcrecord_list (int size, - CONST struct lrecord_implementation - *implementation); -Lisp_Object allocate_managed_lcrecord (Lisp_Object lcrecord_list); -void free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord); - /************************************************************************/ @@ -1411,8 +1374,8 @@ /* Can't be const, because then subr->doc is read-only and * FSnarf_documentation chokes */ -#define DEFUN(lname, fnname, sname, minargs, maxargs, prompt) \ - Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; /* See below */ \ - static struct Lisp_Subr sname \ - = { { lrecord_subr }, minargs, maxargs, prompt, 0, lname, fnname }; \ +#define DEFUN(lname, fnname, sname, minargs, maxargs, prompt) \ + Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; /* See below */ \ + CONST static struct Lisp_Subr_Impl sname \ + = { minargs, maxargs, prompt, 0, lname, fnname }; \ Lisp_Object fnname diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/lstream.c xemacs-20.0-b26/src/lstream.c --- xemacs-20.0-b26-orig/src/lstream.c Mon May 27 20:54:52 1996 +++ xemacs-20.0-b26/src/lstream.c Tue Jul 9 12:06:06 1996 @@ -137,8 +137,9 @@ static void finalize_lstream (void *header, int for_disksave); static unsigned int sizeof_lstream (CONST void *header); -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("stream", lstream, - mark_lstream, print_lstream, - finalize_lstream, 0, 0, - sizeof_lstream, Lstream); +DEFINE_LOBJECT_SEQUENCE_CLASS ("Stream", lstream, + LC_KEEPFREELIST, + mark_lstream, print_lstream, + finalize_lstream, 0, 0, + sizeof_lstream, Lstream); #define DEFAULT_BLOCK_BUFFERING_SIZE 512 @@ -211,31 +212,9 @@ } -static CONST Lstream_implementation *lstream_types[32]; -static Lisp_Object Vlstream_free_list[32]; -static int lstream_type_count; - Lstream * Lstream_new (CONST Lstream_implementation *imp, CONST char *mode) { - Lstream *p; - int i; - - for (i = 0; i < lstream_type_count; i++) - { - if (lstream_types[i] == imp) - break; - } + Lstream *p = alloc_lobject_size (class_lstream, sizeof (*p) + imp->size - 1); - if (i == lstream_type_count) - { - assert (lstream_type_count < countof (lstream_types)); - lstream_types[lstream_type_count] = imp; - Vlstream_free_list[lstream_type_count] = - make_lcrecord_list (sizeof (*p) + imp->size - 1, - lrecord_lstream); - lstream_type_count++; - } - - p = XLSTREAM (allocate_managed_lcrecord (Vlstream_free_list[i])); /* Zero it out, except the header. */ memset ((char *) p + sizeof (p->header), 0, @@ -268,14 +247,8 @@ XSETLSTREAM (val, lstr); - for (i = 0; i < lstream_type_count; i++) - { - if (lstream_types[i] == lstr->imp) - { - free_managed_lcrecord (Vlstream_free_list[i], val); - return; - } - } - - abort (); + /* This function can only be used in the cases where the + implementation keeps a free list */ + assert (XCLASS_IMPL (class_lstream)->flags & LC_KEEPFREELIST); + free_lobject (lstr); } @@ -1693,12 +1666,11 @@ void -vars_of_lstream (void) +syms_of_lstream (void) { - int i; + DEFCLASS (lstream); +} - for (i = 0; i < countof (Vlstream_free_list); i++) - { - Vlstream_free_list[i] = Qnil; - staticpro (&Vlstream_free_list[i]); - } +void +vars_of_lstream (void) +{ } diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/lstream.h xemacs-20.0-b26/src/lstream.h --- xemacs-20.0-b26-orig/src/lstream.h Sat Jun 1 20:49:28 1996 +++ xemacs-20.0-b26/src/lstream.h Mon Jul 8 14:36:34 1996 @@ -31,9 +31,9 @@ /************************************************************************/ -DECLARE_LRECORD (lstream, struct lstream); -#define XLSTREAM(x) XRECORD (x, lstream, struct lstream) -#define XSETLSTREAM(x, p) XSETRECORD (x, p, lstream) -#define LSTREAMP(x) RECORDP (x, lstream) -/* #define CHECK_LSTREAM(x) CHECK_RECORD (x, lstream) +DECLARE_LOBJECT_CLASS (lstream, struct lstream); +#define XLSTREAM(x) XOBJECT (x, lstream, struct lstream) +#define XSETLSTREAM(x, p) XSETLOBJECT (x, p, lstream) +#define LSTREAMP(x) OBJECT_CLASSP (x, lstream) +/* #define CHECK_LSTREAM(x) CHECK_OBJECT (x, lstream) Lstream pointers should never escape to the Lisp level, so functions should not be doing this. */ @@ -140,5 +140,5 @@ struct lstream { - struct lcrecord_header header; + struct lobject_header header; CONST Lstream_implementation *imp; /* methods for this stream */ Lstream_buffering buffering; /* type of buffering in use */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/m/alpha.h xemacs-20.0-b26/src/m/alpha.h --- xemacs-20.0-b26-orig/src/m/alpha.h Fri Jun 7 02:18:53 1996 +++ xemacs-20.0-b26/src/m/alpha.h Thu Jul 18 12:41:04 1996 @@ -193,4 +193,8 @@ #define UNEXEC unexalpha.o +/* The objects used for low-level access to shared libraries. */ + +#define SHLIB_LL_OBJS shlib-dlopen.o + #define PNTR_COMPARISON_TYPE unsigned long diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/marker.c xemacs-20.0-b26/src/marker.c --- xemacs-20.0-b26-orig/src/marker.c Sun Apr 14 21:02:28 1996 +++ xemacs-20.0-b26/src/marker.c Wed Jul 17 15:42:16 1996 @@ -36,12 +36,54 @@ #include "buffer.h" +#if 0 +/* This function a rather complete check of all markers */ +void +check_markers(void) +{ + struct lobject_frob_block *frob; + unsigned int i; + unsigned int a; + struct Lisp_Marker *m; + struct buffer *b; + + for (frob = class_marker->objects.frob.last_frob; + frob; frob = frob->next) { + for (i = 0; i < class_marker->objects.frob.objects_per_frob; i++) { + m = (struct Lisp_Marker *)((char *)frob->data+i*class_marker->impl->static_size); + + assert (LHEADER_TYPEP(&m->header, class_marker)); + if (m->header.free || m->header.finalized) continue; + + if (b = m->buffer) { + assert (BUFFER_LIVE_P (b)); + + if (marker_prev (m)) { + assert (LHEADER_TYPEP(&marker_prev (m)->header, class_marker)); + assert (marker_next (marker_prev (m)) == m); + } else { + assert (BUF_MARKERS (b) == m); + } + if (marker_next (m)) { + assert (LHEADER_TYPEP(&marker_next (m)->header, class_marker)); + assert (marker_prev (marker_next (m)) == m); + } + } else { + assert (!marker_prev (m)); + assert (!marker_next (m)); + } + } + } +} +#endif + static Lisp_Object mark_marker (Lisp_Object, void (*) (Lisp_Object)); static void print_marker (Lisp_Object, Lisp_Object, int); static int marker_equal (Lisp_Object, Lisp_Object, int); static unsigned long marker_hash (Lisp_Object obj, int depth); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("marker", marker, - mark_marker, print_marker, 0, - marker_equal, marker_hash, - struct Lisp_Marker); +static void finalize_marker(void *header, int for_disksave); +DEFINE_LOBJECT_CLASS ("Marker", marker, LC_USEFROBBLOCKS, + mark_marker, print_marker, finalize_marker, + marker_equal, marker_hash, + struct Lisp_Marker); static Lisp_Object @@ -82,4 +124,19 @@ } +/* 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). */ +static void +finalize_marker(void *header, int for_disksave) +{ + if (!for_disksave) { + Lisp_Object tem; + + XSETMARKER (tem, header); + unchain_marker (tem); + } +} + static int marker_equal (Lisp_Object o1, Lisp_Object o2, int depth) @@ -107,4 +164,45 @@ /* Operations on markers. */ +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; + + p = alloc_lobject (class_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; + + p = alloc_lobject (class_marker); + p->buffer = 0; + p->memind = 0; + marker_next (p) = 0; + marker_prev (p) = 0; + p->insertion_type = 0; + XSETMARKER (val, p); + return val; +} + +/* Explicitly free a marker. */ +void +free_marker (struct Lisp_Marker *ptr) +{ + free_lobject (ptr); +} + DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0 /* Return the buffer that MARKER points into, or nil if none. @@ -304,12 +402,17 @@ if (marker_next (marker)) marker_prev (marker_next (marker)) = marker_prev (marker); - if (marker_prev (marker)) + if (marker_prev (marker)) { + assert (marker != BUF_MARKERS (b)); marker_next (marker_prev (marker)) = marker_next (marker); - else + } else { + assert (marker == BUF_MARKERS (b)); BUF_MARKERS (b) = marker_next (marker); + } assert (marker != XMARKER (b->point_marker)); marker->buffer = 0; + marker_next (marker) = 0; + marker_prev (marker) = 0; } @@ -471,4 +574,7 @@ syms_of_marker (void) { + DEFCLASS (marker); + + defsubr (&Smake_marker); defsubr (&Smarker_position); defsubr (&Smarker_buffer); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/md5.c xemacs-20.0-b26/src/md5.c --- xemacs-20.0-b26-orig/src/md5.c Sun Jan 7 02:38:26 1996 +++ xemacs-20.0-b26/src/md5.c Thu Jul 18 11:07:54 1996 @@ -433,2 +433,27 @@ Fprovide (Qmd5); } + +#ifdef MAKE_SHLIB_MD5 +#include + +Lisp_Object +shlib_of_md5(Lisp_Object shlib, Lisp_Object function, Lisp_Object arg) +{ + Lisp_Shlib *shlibc = XSHLIB (shlib); + + if (EQ (function, Qload)) { + syms_of_md5 (); + vars_of_md5 (); + } else if (EQ (function, Qtest_unload)) { + return Qt; + } else if (EQ (function, Qunload)) { + return Qt; + } else if (EQ (function, Qget_unloadable)) { + return Qt; + } else if (EQ (function, Qget_version)) { + return make_int(SHLIB_VERSION); + } else { + signal_simple_error ("Illegal function", function); + } +} +#endif diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/menubar-x.c xemacs-20.0-b26/src/menubar-x.c --- xemacs-20.0-b26-orig/src/menubar-x.c Sun Jun 16 21:37:07 1996 +++ xemacs-20.0-b26/src/menubar-x.c Mon Jul 8 14:36:34 1996 @@ -492,6 +492,5 @@ if (NILP (FRAME_MENUBAR_DATA (f))) { - struct popup_data *mdata = - alloc_lcrecord (sizeof (struct popup_data), lrecord_popup_data); + struct popup_data *mdata = alloc_lobject (class_popup_data); mdata->id = new_lwlib_id (); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/mule-charset.c xemacs-20.0-b26/src/mule-charset.c --- xemacs-20.0-b26-orig/src/mule-charset.c Sun Apr 14 21:03:19 1996 +++ xemacs-20.0-b26/src/mule-charset.c Tue Jul 16 08:31:57 1996 @@ -370,7 +370,7 @@ static Lisp_Object mark_charset (Lisp_Object, void (*) (Lisp_Object)); static void print_charset (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("charset", charset, - mark_charset, print_charset, 0, 0, 0, - struct Lisp_Charset); +DEFINE_LOBJECT_CLASS ("Charset", charset, 0, + mark_charset, print_charset, 0, 0, 0, + struct Lisp_Charset); static Lisp_Object @@ -394,5 +394,5 @@ error ("printing unreadable object #", string_data (XSYMBOL (CHARSET_NAME (cs))->name), - cs->header.uid); + LHEADER_UID (&cs->header)); write_c_string ("#", cs->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&cs->header)); write_c_string (buf, printcharfun); } @@ -426,6 +426,5 @@ Lisp_Object obj = Qnil; - cs = (struct Lisp_Charset *) alloc_lcrecord (sizeof (struct Lisp_Charset), - lrecord_charset); + cs = alloc_lobject (class_charset); XSETCHARSET (obj, cs); @@ -1169,4 +1168,6 @@ syms_of_mule_charset (void) { + DEFCLASS (charset); + defsubr (&Scharsetp); defsubr (&Sfind_charset); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/mule-charset.h xemacs-20.0-b26/src/mule-charset.h --- xemacs-20.0-b26-orig/src/mule-charset.h Thu May 9 16:18:17 1996 +++ xemacs-20.0-b26/src/mule-charset.h Mon Jul 8 14:36:34 1996 @@ -442,5 +442,5 @@ struct Lisp_Charset { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object name; @@ -476,11 +476,10 @@ }; -DECLARE_LRECORD (charset, struct Lisp_Charset); -#define XCHARSET(x) XRECORD (x, charset, struct Lisp_Charset) -#define XSETCHARSET(x, p) XSETRECORD (x, p, charset) -#define CHARSETP(x) RECORDP (x, charset) -#define GC_CHARSETP(x) GC_RECORDP (x, charset) -#define CHECK_CHARSET(x) CHECK_RECORD (x, charset) -#define CONCHECK_CHARSET(x) CONCHECK_RECORD (x, charset) +DECLARE_LOBJECT_CLASS (charset, struct Lisp_Charset); +#define XCHARSET(x) XOBJECT (x, charset, struct Lisp_Charset) +#define XSETCHARSET(x, p) XSETLOBJECT (x, p, charset) +#define CHARSETP(x) OBJECT_CLASSP (x, charset) +#define CHECK_CHARSET(x) CHECK_OBJECT (x, charset) +#define CONCHECK_CHARSET(x) CONCHECK_OBJECT (x, charset) #define CHARSET_TYPE_94 0 /* This charset includes 94 characters. */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/mule-coding.c xemacs-20.0-b26/src/mule-coding.c --- xemacs-20.0-b26-orig/src/mule-coding.c Thu May 9 16:18:15 1996 +++ xemacs-20.0-b26/src/mule-coding.c Tue Jul 16 08:31:56 1996 @@ -213,8 +213,8 @@ static void finalize_coding_system (void *header, int for_disksave); -DEFINE_LRECORD_IMPLEMENTATION ("coding-system", coding_system, - mark_coding_system, print_coding_system, - finalize_coding_system, - 0, 0, struct Lisp_Coding_System); +DEFINE_LOBJECT_CLASS ("Coding-System", coding_system, 0, + mark_coding_system, print_coding_system, + finalize_coding_system, + 0, 0, struct Lisp_Coding_System); static Lisp_Object @@ -276,5 +276,5 @@ if (print_readably) error ("printing unreadable object #", - c->header.uid); + LHEADER_UID (&c->header)); write_c_string ("#name) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/objects.c xemacs-20.0-b26/src/objects.c --- xemacs-20.0-b26-orig/src/objects.c Mon Jun 17 14:03:35 1996 +++ xemacs-20.0-b26/src/objects.c Tue Jul 16 08:31:55 1996 @@ -40,14 +40,4 @@ /* Authors: Ben Wing, Chuck Thompson */ -void -finalose (void *ptr) -{ - Lisp_Object obj; - XSETOBJ (obj, Lisp_Record, ptr); - - signal_simple_error - ("Can't dump an emacs containing window system objects", obj); -} - /**************************************************************************** @@ -61,9 +51,9 @@ static int color_instance_equal (Lisp_Object, Lisp_Object, int depth); static unsigned long color_instance_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance, - mark_color_instance, print_color_instance, - finalize_color_instance, color_instance_equal, - color_instance_hash, - struct Lisp_Color_Instance); +DEFINE_LOBJECT_CLASS ("Color-Instance", color_instance, 0, + mark_color_instance, print_color_instance, + finalize_color_instance, color_instance_equal, + color_instance_hash, + struct Lisp_Color_Instance); static Lisp_Object @@ -86,5 +76,5 @@ if (print_readably) error ("printing unreadable object #", - c->header.uid); + LHEADER_UID (&c->header)); write_c_string ("#name, printcharfun, 0); @@ -94,5 +84,5 @@ MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, (c, printcharfun, escapeflag)); - sprintf (buf, " 0x%x>", c->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&c->header)); write_c_string (buf, printcharfun); } @@ -105,5 +95,11 @@ if (!NILP (c->device)) { - if (for_disksave) finalose (c); + if (for_disksave) { + Lisp_Object obj; + XSETLOBJECT (obj, c, color_instance); + + signal_simple_error + ("Can't dump an emacs containing window system objects", obj); + } MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); } @@ -161,6 +157,5 @@ XSETDEVICE (device, decode_device (device)); - c = alloc_lcrecord (sizeof (struct Lisp_Color_Instance), - lrecord_color_instance); + c = alloc_lobject (class_color_instance); c->name = name; c->device = device; @@ -251,8 +246,8 @@ static int font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth); static unsigned long font_instance_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance, - mark_font_instance, print_font_instance, - finalize_font_instance, font_instance_equal, - font_instance_hash, struct Lisp_Font_Instance); +DEFINE_LOBJECT_CLASS ("Font-Instance", font_instance, 0, + mark_font_instance, print_font_instance, + finalize_font_instance, font_instance_equal, + font_instance_hash, struct Lisp_Font_Instance); static Lisp_Object font_instance_truename_internal (Lisp_Object xfont, @@ -277,5 +272,5 @@ struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj); if (print_readably) - error ("printing unreadable object #", f->header.uid); + error ("printing unreadable object #", LHEADER_UID (&f->header)); write_c_string ("#name, printcharfun, 1); @@ -284,5 +279,5 @@ MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, (f, printcharfun, escapeflag)); - sprintf (buf, " 0x%x>", f->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&f->header)); write_c_string (buf, printcharfun); } @@ -295,5 +290,11 @@ if (!NILP (f->device)) { - if (for_disksave) finalose (f); + if (for_disksave) { + Lisp_Object obj; + XSETLOBJECT (obj, f, color_instance); + + signal_simple_error + ("Can't dump an emacs containing window system objects", obj); + } MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f)); } @@ -348,6 +349,5 @@ XSETDEVICE (device, decode_device (device)); - f = alloc_lcrecord (sizeof (struct Lisp_Font_Instance), - lrecord_font_instance); + f = alloc_lobject (class_font_instance); f->name = name; f->device = device; @@ -1038,4 +1038,7 @@ syms_of_objects (void) { + DEFCLASS (font_instance); + DEFCLASS (color_instance); + defsubr (&Scolor_specifier_p); defsubr (&Sfont_specifier_p); @@ -1105,6 +1108,5 @@ struct Lisp_Color_Instance *c; - c = alloc_lcrecord (sizeof (struct Lisp_Color_Instance), - lrecord_color_instance); + c = alloc_lobject (class_color_instance); c->name = Qnil; c->device = Qnil; @@ -1118,6 +1120,5 @@ struct Lisp_Font_Instance *f; - f = alloc_lcrecord (sizeof (struct Lisp_Font_Instance), - lrecord_font_instance); + f = alloc_lobject (class_font_instance); f->name = Qnil; f->device = Qnil; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/objects.h xemacs-20.0-b26/src/objects.h --- xemacs-20.0-b26-orig/src/objects.h Sat Mar 30 18:18:27 1996 +++ xemacs-20.0-b26/src/objects.h Mon Jul 8 14:36:35 1996 @@ -114,12 +114,11 @@ ****************************************************************************/ -DECLARE_LRECORD (color_instance, struct Lisp_Color_Instance); +DECLARE_LOBJECT_CLASS (color_instance, struct Lisp_Color_Instance); #define XCOLOR_INSTANCE(x) \ - XRECORD (x, color_instance, struct Lisp_Color_Instance) -#define XSETCOLOR_INSTANCE(x, p) XSETRECORD (x, p, color_instance) -#define COLOR_INSTANCEP(x) RECORDP (x, color_instance) -#define GC_COLOR_INSTANCEP(x) GC_RECORDP (x, color_instance) -#define CHECK_COLOR_INSTANCE(x) CHECK_RECORD (x, color_instance) -#define CONCHECK_COLOR_INSTANCE(x) CONCHECK_RECORD (x, color_instance) + XOBJECT (x, color_instance, struct Lisp_Color_Instance) +#define XSETCOLOR_INSTANCE(x, p) XSETLOBJECT (x, p, color_instance) +#define COLOR_INSTANCEP(x) OBJECT_CLASSP (x, color_instance) +#define CHECK_COLOR_INSTANCE(x) CHECK_OBJECT (x, color_instance) +#define CONCHECK_COLOR_INSTANCE(x) CONCHECK_OBJECT (x, color_instance) Lisp_Object Fmake_color_instance (Lisp_Object name, Lisp_Object device, @@ -132,5 +131,5 @@ struct Lisp_Color_Instance { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object name; Lisp_Object device; @@ -147,11 +146,10 @@ ****************************************************************************/ -DECLARE_LRECORD (font_instance, struct Lisp_Font_Instance); -#define XFONT_INSTANCE(x) XRECORD (x, font_instance, struct Lisp_Font_Instance) -#define XSETFONT_INSTANCE(x, p) XSETRECORD (x, p, font_instance) -#define FONT_INSTANCEP(x) RECORDP (x, font_instance) -#define GC_FONT_INSTANCEP(x) GC_RECORDP (x, font_instance) -#define CHECK_FONT_INSTANCE(x) CHECK_RECORD (x, font_instance) -#define CONCHECK_FONT_INSTANCE(x) CONCHECK_RECORD (x, font_instance) +DECLARE_LOBJECT_CLASS (font_instance, struct Lisp_Font_Instance); +#define XFONT_INSTANCE(x) XOBJECT (x, font_instance, struct Lisp_Font_Instance) +#define XSETFONT_INSTANCE(x, p) XSETLOBJECT (x, p, font_instance) +#define FONT_INSTANCEP(x) OBJECT_CLASSP (x, font_instance) +#define CHECK_FONT_INSTANCE(x) CHECK_OBJECT (x, font_instance) +#define CONCHECK_FONT_INSTANCE(x) CONCHECK_OBJECT (x, font_instance) int font_spec_matches_charset (struct device *d, Lisp_Object charset, @@ -170,5 +168,5 @@ struct Lisp_Font_Instance { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object name; Lisp_Object device; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/opaque.c xemacs-20.0-b26/src/opaque.c --- xemacs-20.0-b26-orig/src/opaque.c Sun Apr 28 23:10:14 1996 +++ xemacs-20.0-b26/src/opaque.c Tue Jul 9 09:16:57 1996 @@ -57,7 +57,7 @@ static void print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag); -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, - mark_opaque, print_opaque, 0, 0, 0, - sizeof_opaque, struct Lisp_Opaque); +DEFINE_LOBJECT_SEQUENCE_CLASS ("Opaque", opaque, 0, + mark_opaque, print_opaque, 0, 0, 0, + sizeof_opaque, struct Lisp_Opaque); static Lisp_Object @@ -109,6 +109,6 @@ make_opaque (int size, CONST void *data) { - struct Lisp_Opaque *p = alloc_lcrecord (sizeof (*p) + size - sizeof (int), - lrecord_opaque); + struct Lisp_Opaque *p = alloc_lobject_size (class_opaque, + sizeof (*p) + size - sizeof (int)); Lisp_Object val; @@ -124,7 +124,7 @@ static Lisp_Object mark_opaque_list (Lisp_Object, void (*) (Lisp_Object)); -DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list, - mark_opaque_list, internal_object_printer, - 0, 0, 0, struct Lisp_Opaque_List); +DEFINE_LOBJECT_CLASS ("Opaque-List", opaque_list, 0, + mark_opaque_list, internal_object_printer, + 0, 0, 0, struct Lisp_Opaque_List); static Lisp_Object @@ -142,6 +142,5 @@ void (*markobj) (Lisp_Object))) { - struct Lisp_Opaque_List *p = alloc_lcrecord (sizeof (*p), - lrecord_opaque_list); + struct Lisp_Opaque_List *p = alloc_lobject (class_opaque_list); Lisp_Object val = Qnil; @@ -217,4 +216,7 @@ init_opaque_once_early (void) { + DEFCLASS (opaque); + DEFCLASS (opaque_list); + Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0); staticpro (&Vopaque_ptr_free_list); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/opaque.h xemacs-20.0-b26/src/opaque.h --- xemacs-20.0-b26-orig/src/opaque.h Sat Mar 30 18:17:21 1996 +++ xemacs-20.0-b26/src/opaque.h Mon Jul 8 14:36:35 1996 @@ -29,5 +29,5 @@ struct Lisp_Opaque { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); /* An integral size for non-freed objects, an opaque or nil for @@ -42,5 +42,5 @@ struct Lisp_Opaque_List { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); Lisp_Object free; @@ -48,19 +48,17 @@ }; -DECLARE_LRECORD (opaque, struct Lisp_Opaque); -#define XOPAQUE(x) XRECORD (x, opaque, struct Lisp_Opaque) -#define XSETOPAQUE(x, p) XSETRECORD (x, p, opaque) -#define OPAQUEP(x) RECORDP (x, opaque) -#define GC_OPAQUEP(x) GC_RECORDP (x, opaque) -/* #define CHECK_OPAQUE(x) CHECK_RECORD (x, opaque) +DECLARE_LOBJECT_CLASS (opaque, struct Lisp_Opaque); +#define XOPAQUE(x) XOBJECT (x, opaque, struct Lisp_Opaque) +#define XSETOPAQUE(x, p) XSETLOBJECT (x, p, opaque) +#define OPAQUEP(x) OBJECT_CLASSP (x, opaque) +/* #define CHECK_OPAQUE(x) CHECK_OBJECT (x, opaque) Opaque pointers should never escape to the Lisp level, so functions should not be doing this. */ -DECLARE_LRECORD (opaque_list, struct Lisp_Opaque_List); -#define XOPAQUE_LIST(x) XRECORD (x, opaque_list, struct Lisp_Opaque_List) -#define XSETOPAQUE_LIST(x, p) XSETRECORD (x, p, opaque_list) -#define OPAQUE_LISTP(x) RECORDP (x, opaque_list) -#define GC_OPAQUE_LISTP(x) GC_RECORDP (x, opaque_list) -/* #define CHECK_OPAQUE_LIST(x) CHECK_RECORD (x, opaque_list) +DECLARE_LOBJECT_CLASS (opaque_list, struct Lisp_Opaque_List); +#define XOPAQUE_LIST(x) XOBJECT (x, opaque_list, struct Lisp_Opaque_List) +#define XSETOPAQUE_LIST(x, p) XSETLOBJECT (x, p, opaque_list) +#define OPAQUE_LISTP(x) OBJECT_CLASSP (x, opaque_list) +/* #define CHECK_OPAQUE_LIST(x) CHECK_OBJECT (x, opaque_list) Opaque lists should never escape to the Lisp level, so functions should not be doing this. */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/print.c xemacs-20.0-b26/src/print.c --- xemacs-20.0-b26-orig/src/print.c Sun Jun 16 21:36:48 1996 +++ xemacs-20.0-b26/src/print.c Tue Jul 16 13:02:52 1996 @@ -726,14 +726,14 @@ int escapeflag) { - struct lcrecord_header *header = - (struct lcrecord_header *) XPNTR (obj); + struct lobject_header *header = XLOBJECT_LHEADER (obj); + Lisp_Class *myclass = XLHEADER_CLASS (header); char buf[200]; if (print_readably) error ("printing unreadable object #<%s 0x%x>", - header->lheader.implementation->name, header->uid); + XCLASS_IMPL (myclass)->name, LHEADER_UID (header)); - sprintf (buf, "#<%s 0x%x>", header->lheader.implementation->name, - header->uid); + sprintf (buf, "#<%s 0x%x>", XCLASS_IMPL (myclass)->name, + LHEADER_UID (header)); write_c_string (buf, printcharfun); } @@ -745,5 +745,5 @@ char buf[200]; sprintf (buf, "#", - XRECORD_LHEADER (obj)->implementation->name, + XCLASS_IMPL (XOBJECT_CLASS (obj))->name, (EMACS_INT) XPNTR (obj)); write_c_string (buf, printcharfun); @@ -955,5 +955,5 @@ } -#ifndef LRECORD_VECTOR +#ifndef USE_LOBJECT_VECTOR case Lisp_Vector: { @@ -970,7 +970,7 @@ break; } -#endif /* !LRECORD_VECTOR */ +#endif /* !USE_LOBJECT_VECTOR */ -#ifndef LRECORD_SYMBOL +#ifndef USE_LOBJECT_SYMBOL case Lisp_Symbol: { @@ -978,15 +978,14 @@ break; } -#endif /* !LRECORD_SYMBOL */ +#endif /* !USE_LOBJECT_SYMBOL */ - case Lisp_Record: + case Lisp_LObject: { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); + Lisp_Class *myclass = XLOBJECT_CLASS (obj); struct gcpro gcpro1, gcpro2; GCPRO2 (obj, printcharfun); - if (lheader->implementation->printer) - ((lheader->implementation->printer) - (obj, printcharfun, escapeflag)); + if (XCLASS_IMPL (myclass)->printer) + ((XCLASS_IMPL (myclass)->printer) (obj, printcharfun, escapeflag)); else default_object_printer (obj, printcharfun, escapeflag); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/process.c xemacs-20.0-b26/src/process.c --- xemacs-20.0-b26-orig/src/process.c Thu Jun 20 17:14:30 1996 +++ xemacs-20.0-b26/src/process.c Tue Jul 9 09:16:56 1996 @@ -119,5 +119,5 @@ struct Lisp_Process { - struct lcrecord_header header; + struct lobject_header header; /* Name of this process */ Lisp_Object name; @@ -192,7 +192,7 @@ static void print_process (Lisp_Object, Lisp_Object, int); static void finalize_process (void *, int); -DEFINE_LRECORD_IMPLEMENTATION ("process", process, - mark_process, print_process, finalize_process, - 0, 0, struct Lisp_Process); +DEFINE_LOBJECT_CLASS ("Process", process, 0, + mark_process, print_process, finalize_process, + 0, 0, struct Lisp_Process); static Lisp_Object @@ -354,5 +354,5 @@ network_connection_p (Lisp_Object process) { - return (GC_CONSP (XPROCESS (process)->pid)); + return (CONSP (XPROCESS (process)->pid)); } #endif @@ -389,5 +389,5 @@ Lisp_Object tail; - if (GC_PROCESSP (name)) + if (PROCESSP (name)) return (name); @@ -397,5 +397,5 @@ CHECK_STRING (name); - for (tail = Vprocess_list; GC_CONSP (tail); tail = XCDR (tail)) + for (tail = Vprocess_list; CONSP (tail); tail = XCDR (tail)) { Lisp_Object proc = XCAR (tail); @@ -416,16 +416,16 @@ Lisp_Object buf, tail, proc; - if (GC_NILP (name)) return Qnil; + if (NILP (name)) return Qnil; buf = Fget_buffer (name); - if (GC_NILP (buf)) return Qnil; + if (NILP (buf)) return Qnil; #ifdef ENERGIZE { Lisp_Object p = energize_get_buffer_process (buf); - if (!GC_NILP (p)) return p; + if (!NILP (p)) return p; } #endif - for (tail = Vprocess_list; GC_CONSP (tail); tail = XCDR (tail)) + for (tail = Vprocess_list; CONSP (tail); tail = XCDR (tail)) { /* jwz: do not quit here - it isn't necessary, as there is no way for @@ -434,5 +434,5 @@ /* QUIT; */ proc = XCAR (tail); - if (GC_PROCESSP (proc) && EQ (XPROCESS (proc)->buffer, buf)) + if (PROCESSP (proc) && EQ (XPROCESS (proc)->buffer, buf)) return proc; } @@ -456,20 +456,20 @@ /* This may be called during a GC from process_send_signal() from kill_buffer_processes() if emacs decides to abort(). */ - if (GC_PROCESSP (name)) + if (PROCESSP (name)) return name; - if (GC_NILP (name)) + if (NILP (name)) proc = Fget_buffer_process (Fcurrent_buffer ()); else { proc = Fget_process (name); - if (GC_NILP (proc)) + if (NILP (proc)) proc = Fget_buffer_process (Fget_buffer (name)); } - if (!GC_NILP (proc)) + if (!NILP (proc)) return proc; - if (GC_NILP (name)) + if (NILP (name)) error ("Current buffer has no process"); else @@ -533,6 +533,5 @@ Lisp_Object val, name1; int i; - struct Lisp_Process *p - = alloc_lcrecord (sizeof (struct Lisp_Process), lrecord_process); + struct Lisp_Process *p = alloc_lobject (class_process); /* If name is already in use, modify it until it is unused. */ @@ -1812,5 +1811,5 @@ lstream = make_fixed_buffer_input_stream (nonrelocatable + start, len); - else if (GC_BUFFERP (relocatable)) + else if (BUFFERP (relocatable)) lstream = make_lisp_buffer_input_stream (XBUFFER (relocatable), start, start + len, 0); @@ -3222,10 +3221,10 @@ Lisp_Object tail; - for (tail = Vprocess_list; GC_CONSP (tail); + for (tail = Vprocess_list; CONSP (tail); tail = XCDR (tail)) { Lisp_Object proc = XCAR (tail); - if (GC_PROCESSP (proc) - && (GC_NILP (buffer) || GC_EQ (XPROCESS (proc)->buffer, buffer))) + if (PROCESSP (proc) + && (NILP (buffer) || EQ (XPROCESS (proc)->buffer, buffer))) { if (network_connection_p (proc)) @@ -3323,4 +3322,6 @@ syms_of_process (void) { + DEFCLASS (process); + defsymbol (&Qprocessp, "processp"); defsymbol (&Qrun, "run"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/process.h xemacs-20.0-b26/src/process.h --- xemacs-20.0-b26-orig/src/process.h Sat Jun 15 17:22:33 1996 +++ xemacs-20.0-b26/src/process.h Mon Jul 8 14:42:23 1996 @@ -43,10 +43,9 @@ struct Lisp_Process; -DECLARE_LRECORD (process, struct Lisp_Process); -#define XPROCESS(x) XRECORD (x, process, struct Lisp_Process) -#define XSETPROCESS(x, p) XSETRECORD (x, p, process) -#define PROCESSP(x) RECORDP (x, process) -#define GC_PROCESSP(x) GC_RECORDP (x, process) -#define CHECK_PROCESS(x) CHECK_RECORD (x, process) +DECLARE_LOBJECT_CLASS (process, struct Lisp_Process); +#define XPROCESS(x) XOBJECT (x, process, struct Lisp_Process) +#define XSETPROCESS(x, p) XSETLOBJECT (x, p, process) +#define PROCESSP(x) OBJECT_CLASSP (x, process) +#define CHECK_PROCESS(x) CHECK_OBJECT (x, process) #define PROCESS_LIVE_P(x) (XPROCESS(x)->infd >= 0) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/profile.c xemacs-20.0-b26/src/profile.c --- xemacs-20.0-b26-orig/src/profile.c Mon May 6 02:14:26 1996 +++ xemacs-20.0-b26/src/profile.c Mon Jul 8 14:36:36 1996 @@ -78,5 +78,5 @@ XUNMARK (fun); - if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun)) + if (!SYMBOLP (fun) && !COMPILED_FUNCTIONP (fun)) fun = QSunknown; } diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/rangetab.c xemacs-20.0-b26/src/rangetab.c --- xemacs-20.0-b26-orig/src/rangetab.c Mon May 6 02:14:25 1996 +++ xemacs-20.0-b26/src/rangetab.c Tue Jul 9 09:16:56 1996 @@ -41,15 +41,14 @@ struct Lisp_Range_Table { - struct lcrecord_header header; + struct lobject_header header; range_table_entry_dynarr *entries; }; -DECLARE_LRECORD (range_table, struct Lisp_Range_Table); +DECLARE_LOBJECT_CLASS (range_table, struct Lisp_Range_Table); #define XRANGE_TABLE(x) \ - XRECORD (x, range_table, struct Lisp_Range_Table) -#define XSETRANGE_TABLE(x, p) XSETRECORD (x, p, range_table) -#define RANGE_TABLEP(x) RECORDP (x, range_table) -#define GC_RANGE_TABLEP(x) GC_RECORDP (x, range_table) -#define CHECK_RANGE_TABLE(x) CHECK_RECORD (x, range_table) + XOBJECT (x, range_table, struct Lisp_Range_Table) +#define XSETRANGE_TABLE(x, p) XSETLOBJECT (x, p, range_table) +#define RANGE_TABLEP(x) OBJECT_CLASSP (x, range_table) +#define CHECK_RANGE_TABLE(x) CHECK_OBJECT (x, range_table) Lisp_Object Qrange_tablep; @@ -70,8 +69,8 @@ static int range_table_equal (Lisp_Object, Lisp_Object, int depth); static unsigned long range_table_hash (Lisp_Object obj, int depth); -DEFINE_LRECORD_IMPLEMENTATION ("range-table", range_table, - mark_range_table, print_range_table, 0, - range_table_equal, range_table_hash, - struct Lisp_Range_Table); +DEFINE_LOBJECT_CLASS ("Range-Table", range_table, 0, + mark_range_table, print_range_table, 0, + range_table_equal, range_table_hash, + struct Lisp_Range_Table); static Lisp_Object @@ -242,6 +241,5 @@ Lisp_Object obj; - rt = (struct Lisp_Range_Table *) - alloc_lcrecord (sizeof (struct Lisp_Range_Table), lrecord_range_table); + rt = alloc_lobject (class_range_table); rt->entries = Dynarr_new (struct range_table_entry); XSETRANGE_TABLE (obj, rt); @@ -261,6 +259,5 @@ CHECK_RANGE_TABLE (old_table); rt = XRANGE_TABLE (old_table); - rtnew = (struct Lisp_Range_Table *) - alloc_lcrecord (sizeof (struct Lisp_Range_Table), lrecord_range_table); + rtnew = alloc_lobject (class_range_table); rtnew->entries = Dynarr_new (struct range_table_entry); @@ -721,4 +718,6 @@ syms_of_rangetab (void) { + DEFCLASS (range_table); + defsymbol (&Qrange_tablep, "range-table-p"); defsymbol (&Qrange_table, "range-table"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/redisplay-tty.c xemacs-20.0-b26/src/redisplay-tty.c --- xemacs-20.0-b26-orig/src/redisplay-tty.c Sun Jun 16 21:37:06 1996 +++ xemacs-20.0-b26/src/redisplay-tty.c Mon Jul 8 14:36:37 1996 @@ -938,9 +938,9 @@ Lisp_Object dev = CONSOLE_SELECTED_DEVICE (c); - if (!GC_NILP (dev)) + if (!NILP (dev)) { Lisp_Object frm = DEVICE_SELECTED_FRAME (XDEVICE (dev)); - if (!GC_NILP (frm)) + if (!NILP (frm)) { struct frame *f = XFRAME (frm); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/redisplay-x.c xemacs-20.0-b26/src/redisplay-x.c --- xemacs-20.0-b26-orig/src/redisplay-x.c Sun Jun 16 21:36:45 1996 +++ xemacs-20.0-b26/src/redisplay-x.c Mon Jul 8 14:36:37 1996 @@ -807,6 +807,6 @@ int height; int len = Dynarr_length (buf); - unsigned char *text_storage = alloca (2 * len); - struct textual_run *runs = alloca (len * sizeof (struct textual_run)); + unsigned char *text_storage = (unsigned char *)alloca (2 * len); + struct textual_run *runs = (struct textual_run *)alloca (len * sizeof (struct textual_run)); int nruns; int i; diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/s/osf1.h xemacs-20.0-b26/src/s/osf1.h --- xemacs-20.0-b26-orig/src/s/osf1.h Sat Jun 1 20:47:57 1996 +++ xemacs-20.0-b26/src/s/osf1.h Mon Jul 8 14:36:38 1996 @@ -15,4 +15,7 @@ #define GETPGRP_NO_ARG +/* Don't try to use SIGIO even though it is defined. */ +#define BROKEN_SIGIO + #define INTERRUPTIBLE_OPEN #define INTERRUPTIBLE_CLOSE diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/shlib-dlopen.c xemacs-20.0-b26/src/shlib-dlopen.c --- xemacs-20.0-b26-orig/src/shlib-dlopen.c Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/src/shlib-dlopen.c Thu Jul 18 08:33:58 1996 @@ -0,0 +1,58 @@ +/* "Shared Library" primitives for dlopen family + Copyright (C) 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois + Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Written by Tonny Madsen. */ + +#include "shlib.h" + +#include +#include + +void +shlib_lowlevel_init() +{ +} + +void * +shlib_lowlevel_load(char *name) +{ + return dlopen (name, RTLD_NOW); +} + +void +shlib_lowlevel_unload(void *handle) +{ + dlclose (handle); +} + +void * +shlib_lowlevel_get(void *handle, char *name) +{ + return dlsym (handle, name); +} + +char * +shlib_lowlevel_error() +{ + return dlerror (); +} diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/shlib.c xemacs-20.0-b26/src/shlib.c --- xemacs-20.0-b26-orig/src/shlib.c Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/src/shlib.c Thu Jul 18 12:29:23 1996 @@ -0,0 +1,1000 @@ +/* C level function for "Shared Library" 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. */ + +/* Written by Tonny Madsen. */ + +#include +#include "lisp.h" +#include "emacsfns.h" + +#include "shlib.h" + + +/***************************************************************************** + Structures + ****************************************************************************/ + +typedef int (*shlib_init_func) (Lisp_Shlib*); + +static Lisp_Object mark_shlib (Lisp_Object, void (*) (Lisp_Object)); +static void print_shlib (Lisp_Object, Lisp_Object, int); +static Lisp_Object shlib_getprop (Lisp_Object obj, Lisp_Object prop); +static int shlib_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value); +static int shlib_remprop (Lisp_Object obj, Lisp_Object prop); +static Lisp_Object shlib_plist (Lisp_Object obj); +DEFINE_LOBJECT_CLASS_WITH_PROPS ("Shared-Lib", shlib, LC_PROTECTEDOBJECTS, + mark_shlib, print_shlib, 0, 0, + 0, shlib_getprop, + shlib_putprop, shlib_remprop, + shlib_plist, Lisp_Shlib); + + +/***************************************************************************** + Declaration of constants and symbols + ****************************************************************************/ + +Lisp_Object Qload; +Lisp_Object Qtest_unload; +Lisp_Object Qunload; +Lisp_Object Qget_unloadable; +Lisp_Object Qget_version; + +/* + * Symbols used for special properties + */ +Lisp_Object Qname; +Lisp_Object Qdeleted; +Lisp_Object Qloaded; +Lisp_Object Qunloading; +Lisp_Object Qunloadable; +Lisp_Object Qobjects; +Lisp_Object Qentry_name; +Lisp_Object Qversion; + +Lisp_Object Qbefore_load_hook; +Lisp_Object Qafter_load_hook; +Lisp_Object Qbefore_unload_hook; +Lisp_Object Qafter_unload_hook; + +Lisp_Object Qbefore_load_hook_name; +Lisp_Object Qafter_load_hook_name; +Lisp_Object Qbefore_unload_hook_name; +Lisp_Object Qafter_unload_hook_name; + +#if 0 /* ###IMP### */ +Lisp_Object Qimported_variables; + +Lisp_Object Qint; +Lisp_Object Qbool; +#endif + +Lisp_Object Qshlibp; + +Lisp_Object Qshlib_hook; + +/* + * The current shlib under load and unload + */ +Lisp_Object Vcurrent_shlib; + +/* ###TM###: add defmethod for object-list for objects */ + + +/***************************************************************************** + External lisp functions + ****************************************************************************/ + +extern Lisp_Object Frun_hook_with_args_until_failure(int nargs, Lisp_Object *args); + +/***************************************************************************** + Methods used by the record + ****************************************************************************/ + +static Lisp_Object +mark_shlib (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Shlib *shlib = XSHLIB (obj); + + ((markobj) (shlib->name)); + ((markobj) (shlib->entry_name)); + ((markobj) (shlib->version)); + + ((markobj) (shlib->before_load_hook)); + ((markobj) (shlib->after_load_hook)); + ((markobj) (shlib->before_unload_hook)); + ((markobj) (shlib->after_unload_hook)); + + ((markobj) (shlib->objects)); +#if 0 /* ###IMP### */ + ((markobj) (shlib->imported_variables)); +#endif + return (shlib->plist); +} + +static void +print_shlib (Lisp_Object shlib, Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Shlib *shlibc = XSHLIB (shlib); + Lisp_Class *myclass = XLHEADER_CLASS (&shlibc->header); + char buf[200]; + + if (print_readably) + error ("printing unreadable object #<%s %s 0x%x>", XCLASS_IMPL (myclass)->name, + (char *)string_data (XSTRING (shlibc->name)), LHEADER_UID (&shlibc->header)); + + sprintf (buf, "<%s ", XCLASS_IMPL (myclass)->name); + write_c_string (buf, printcharfun); + print_internal (shlibc->name, printcharfun, 1); + if (shlibc->flags & (SHLIB_deleted)) + write_c_string (" deleted", printcharfun); + if (shlibc->flags & (SHLIB_loaded)) + write_c_string (" loaded", printcharfun); + if (shlibc->flags & (SHLIB_unloading)) + write_c_string (" unloading", printcharfun); + if (shlibc->flags & (SHLIB_unloadable)) + write_c_string (" unloadable", printcharfun); + if (!NILP (shlibc->entry_name)) { + write_c_string (" entry-name ", printcharfun); + print_internal (shlibc->entry_name, printcharfun, 1); + } + if (!NILP (shlibc->version)) { + write_c_string (" version ", printcharfun); + print_internal (shlibc->version, printcharfun, 1); + } + sprintf (buf, " 0x%x>", LHEADER_UID (&shlibc->header)); + write_c_string (buf, printcharfun); +} + +static Lisp_Object +shlib_getprop (Lisp_Object obj, Lisp_Object prop) +{ + Lisp_Shlib *shlibc = XSHLIB (obj); + +#define FLAG(propprop) \ +do { \ + if (EQ (prop, Q##propprop)) \ + { \ + return (shlibc->flags & (SHLIB_##propprop)) ? Qt : Qnil; \ + } \ +} while (0) + +#define FROB(propprop) \ +do { \ + if (EQ (prop, Q##propprop)) \ + { \ + return shlibc->propprop; \ + } \ +} while (0) + +#define LIST(propprop) \ +do { \ + if (EQ (prop, Q##propprop)) \ + { \ + return Fcopy_sequence (shlibc->propprop); \ + } \ +} while (0) + + FROB (name); + FROB (entry_name); + FROB (version); + FLAG (deleted); + FLAG (loaded); + FLAG (unloading); + FLAG (unloadable); + FROB (before_load_hook); + FROB (after_load_hook); + FROB (before_unload_hook); + FROB (after_unload_hook); + if (EQ (prop, Qobjects)) { + Lisp_Object l = shlibc->objects; + return Fcopy_sequence (WEAK_LISTP (l) ? XWEAK_LIST_LIST (l) : l); + } +#if 0 /* ###IMP### */ + LIST (imported_variables); +#endif +#undef FROB +#undef FLAG +#undef LIST + + return internal_plist_get (shlibc->plist, prop); +} + +static int +shlib_putprop (Lisp_Object shlib, Lisp_Object prop, Lisp_Object value) +{ + Lisp_Shlib *shlibc = XSHLIB (shlib); + + if (shlibc->flags & SHLIB_deleted) + signal_simple_error ("Deleted", shlib); + +#define FROB(propprop) \ +do { \ + if (EQ (prop, Q##propprop)) \ + return 0; \ +} while (0) + + FROB (name); + FROB (version); + FROB (deleted); + FROB (loaded); + FROB (unloading); + FROB (unloadable); + FROB (before_load_hook); + FROB (after_load_hook); + FROB (before_unload_hook); + FROB (after_unload_hook); + FROB (objects); +#if 0 /* ###IMP### */ + FROB (imported_variables); +#endif + if (EQ (prop, Qentry_name)) { + if (shlibc->flags & SHLIB_loaded) + return 0; + if (!NILP (value)) + CHECK_STRING (value); + shlibc->entry_name = value; + return 1; + } + +#undef FROB + + internal_plist_put (&shlibc->plist, prop, value); + return 1; +} + +static int +shlib_remprop (Lisp_Object shlib, Lisp_Object prop) +{ + Lisp_Shlib *shlibc = XSHLIB (shlib); + +#define FROB(propprop) \ +do { \ + if (EQ (prop, Q##propprop)) \ + return -1; \ +} while (0) + + FROB (name); + if (EQ (prop, Qentry_name)) { + if (shlibc->flags & SHLIB_loaded) + return -1; + shlibc->entry_name = Qnil; + return 1; + } + FROB (version); + FROB (deleted); + FROB (loaded); + FROB (unloading); + FROB (unloadable); + FROB (before_load_hook); + FROB (after_load_hook); + FROB (before_unload_hook); + FROB (after_unload_hook); + FROB (objects); +#if 0 /* ###IMP### */ + FROB (imported_variables); +#endif +#undef FROB + + return internal_remprop (&shlibc->plist, prop); +} + +static Lisp_Object +shlib_plist (Lisp_Object shlib) +{ + Lisp_Shlib *shlibc = XSHLIB (shlib); + Lisp_Object result = Qnil; + struct gcpro gcpro1; + + GCPRO1 (result); + +#define FLAG(propprop) \ +do { \ + result = Fcons ((shlibc->flags & (SHLIB_##propprop)) ? Qt : Qnil, \ + Fcons (Q##propprop, result)); \ +} while (0) + +#define FROB(propprop) \ +do { \ + result = Fcons (shlibc->propprop, Fcons (Q##propprop, result)); \ +} while (0) + +#define LIST(propprop) \ +do { \ + result = Fcons (Fcopy_sequence (shlibc->propprop), Fcons (Q##propprop, result)); \ +} while (0) + + FROB (name); + FROB (entry_name); + FROB (version); + FLAG (deleted); + FLAG (loaded); + FLAG (unloading); + FLAG (unloadable); + FROB (before_load_hook); + FROB (after_load_hook); + FROB (before_unload_hook); + FROB (after_unload_hook); + { + Lisp_Object l = shlibc->objects; + result = Fcons (Fcopy_sequence (WEAK_LISTP (l) ? XWEAK_LIST_LIST (l) : l), + Fcons (Qobjects, result)); + } +#if 0 /* ###IMP### */ + LIST (imported_variables); +#endif +#undef FROB +#undef FLAG + result = nconc2 (Fnreverse (result), Fcopy_sequence (shlibc->plist)); + + UNGCPRO; + return result; +} + + +/***************************************************************************** + Public functions - object/symbol + ****************************************************************************/ + +DEFUN ("shlibp", Fshlibp, Sshlibp, 1, 1, 0 /* +Return non-nil if OBJECT is a shlib. +*/ ) + (object) + Lisp_Object object; +{ + return (SHLIBP (object) ? Qt : Qnil); +} + + +/***************************************************************************** + Public functions - search + ****************************************************************************/ + +DEFUN ("find-shlib", Ffind_shlib, Sfind_shlib, 1, 1, 0 /* +Retrieve the shlib of the given name. TODO +*/ ) + (name) + Lisp_Object name; +{ + Lisp_Shlib *shlibc; + + if (SHLIBP (name)) + return name; + CHECK_STRING (name); + + LOBJECT_INUSE_LOOP(class_shlib, Lisp_Shlib *, shlibc, + if (!NILP (Fstring_equal(name, shlibc->name))) { + Lisp_Object shlib; + XSETSHLIB(shlib, shlibc); + return shlib; + } + ) + return Qnil; +} + +DEFUN ("get-shlib", Fget_shlib, Sget_shlib, 1, 1, 0 /* +Retrieve the shlib of the given name. +Same as `find-shlib' except an error is signalled if there is no such +shlib instead of returning nil. +*/ ) + (name) + Lisp_Object name; +{ + Lisp_Object shlib = Ffind_shlib (name); + + if (NILP (shlib)) + signal_simple_error ("No such shlib", name); + return shlib; +} + +DEFUN ("shlib-list", Fshlib_list, Sshlib_list, 0, 0, 0 /* +Return a list with all defined shared libraries. +*/ ) + () +{ + return lobject_list(class_shlib); +} + + +/***************************************************************************** + Public functions - information + ****************************************************************************/ + +DEFUN ("shlib-name", Fshlib_name, Sshlib_name, 1, 1, 0 /* +Return the name of the given shlib. + +Also found as the name property. +*/ ) + (shlib) + Lisp_Object shlib; +{ + return (XSHLIB (Fget_shlib (shlib))->name); +} + + +/***************************************************************************** + Public functions - create and delete + ****************************************************************************/ + +/* + * Rest all state of the specified shlib. This function is used when + * - an shlib is created + * - an shlib is unloaded + * - when certain errors occur + * + * Note that during creation some fields must be cleared before this + * function is called. + */ +static void +reset_shlib(Lisp_Shlib *shlibc) +{ + shlibc->flags = 0; + if (shlibc->handle) { + shlib_lowlevel_unload(shlibc->handle); + shlibc->handle = 0; + } + shlibc->entry_func = 0; + shlibc->version = Qnil; + shlibc->objects = Qnil; +#if 0 /* ###IMP### */ + shlibc->imported_variables = Qnil; +#endif + shlibc->plist = Qnil; +} + +/* + * Version of reset_shlib that can be used as hfun of condition_case_1 + */ +static Lisp_Object +reset_shlib_cc(Lisp_Object val, Lisp_Object harg) +{ + reset_shlib(XSHLIB(harg)); + return Qnil; +} + +DEFUN ("make-shlib", Fmake_shlib, Smake_shlib, 1, 1, 0 /* +Creates and returns a new shared libary. +TODO: returns already existing with same name. +*/ ) + (name) + Lisp_Object name; +{ + Lisp_Shlib *shlibc; + Lisp_Object shlib; + char entry_name[200]; + char *end, *start; + + CHECK_STRING (name); + + shlib = Ffind_shlib (name); + if (!NILP (shlib)) + return shlib; + + shlibc = alloc_lobject (class_shlib); + SET_LOBJECT_PROTECTED(shlibc, 1); + XSETSHLIB (shlib, shlibc); + + shlibc->name = name; + + /* Construct the default entry name */ + start = (char *)string_data (XSTRING (name)); + if (strlen(start)) { + if (end = strrchr(start, '/')) + start = end+1; + if (!strncmp(start, "lib", 3)) + start += 3; + if (!strncmp(start, "emacs", 5)) + start += 5; + if (!(end = strchr(start, '.'))) + end = strchr(start, 0); + strcpy(entry_name, "shlib_of_"); + strncat(entry_name, start, end-start); + entry_name[11+end-start] = 0; + shlibc->entry_name = build_string(entry_name); + } else + shlibc->entry_name = Qnil; + + shlibc->handle = 0; + + /* Reuse names of property symbols*/ + shlibc->before_load_hook = Fmake_symbol (Qbefore_load_hook_name); + shlibc->after_load_hook = Fmake_symbol (Qafter_load_hook_name); + shlibc->before_unload_hook = Fmake_symbol (Qbefore_unload_hook_name); + shlibc->after_unload_hook = Fmake_symbol (Qafter_unload_hook_name); + + reset_shlib (shlibc); + + /* Run shlib_hook */ + va_run_hook_with_args (Qshlib_hook, 1, shlib); + + return shlib; +} + +DEFUN ("delete-shlib", Fdelete_shlib, Sdelete_shlib, 1, 1, 0 /* +Delete shared libary. +*/ ) + (shlib) + Lisp_Object shlib; +{ + Lisp_Shlib *shlibc; + + shlib = Fget_shlib (shlib); + shlibc = XSHLIB (shlib); + + if (shlibc->flags & SHLIB_deleted) + signal_simple_error ("Already deleted", shlib); + if (shlibc->flags & SHLIB_loaded) + signal_simple_error ("A loaded shared library can not be deleted", shlib); + + shlibc->flags = SHLIB_deleted; + SET_LOBJECT_PROTECTED(shlibc, 0); + + /* Run shlib_hook */ + va_run_hook_with_args (Qshlib_hook, 1, shlib); + + return Qnil; +} + + +/***************************************************************************** + Public functions - load/unload + ****************************************************************************/ + +/* The load and unload functions will call the entry function of the + * loaded shared library. + * + * This function can bug out in two very different ways: + * - it can return an error in the form of an error message + * - it can use signal to throw an exception + * + * To catch both these conditions, all calls of the entry function is + * protected with both unwind-protect and condition-case. + * + * The first three functions are used for this. + */ + +/* + * This function is used with record_unwind_protect to protect Vcurrent_shlib + */ +static Lisp_Object +shlib_restore_Vcurrent_shlib(Lisp_Object arg) +{ + return Vcurrent_shlib = arg; +} + +#define EH_RESET 0x0001 +#define EH_RESIGNAL 0x0002 + +static Lisp_Object +shlib_call_entry_bfun(Lisp_Object barg) +{ + return XSHLIB(Vcurrent_shlib)->entry_func(Vcurrent_shlib, XCAR(barg), XCDR(barg)); +} + +Lisp_Object +shlib_call_entry_hfun(Lisp_Object val, Lisp_Object harg) +{ + int error_handling = XREALINT(harg); + + if (error_handling & EH_RESET) + reset_shlib(XSHLIB(Vcurrent_shlib)); + + /* Resignal the error */ + if (error_handling & EH_RESIGNAL) + Fsignal(Fcar(val), Fcdr(val)); + + return Qnil; +} + +/* This function calls the entry function of the specified shlib. It + * uses unwind-protect and condition-case to protect the state of the + * caller. + * + * The handling of errors is specified in error_handling. It is the + * OR'ed values of + * EH_RESET - the shlib object is reset + * EH_RESIGNAL - the signal is resignaled + */ + +static Lisp_Object +shlib_call_entry(Lisp_Object shlib, Lisp_Object func, Lisp_Object arg, int error_handling) +{ + Lisp_Object result; + int speccount = specpdl_depth (); + + assert(XSHLIB(shlib)->entry_func); + + /* Protect Vcurrent_shlib */ + record_unwind_protect (shlib_restore_Vcurrent_shlib, Vcurrent_shlib); + Vcurrent_shlib = shlib; + + /* Pack the arguments are Lisp numbers */ + result = condition_case_1 (Qt, + shlib_call_entry_bfun, Fcons (func, arg), + shlib_call_entry_hfun, make_int (error_handling)); + + unbind_to(speccount, Qnil); + + return result; +} + +void +shlib_add_object(Lisp_Object obj) +{ + Lisp_Shlib *shlibc; + + assert(!NILP(Vcurrent_shlib)); + + shlibc = XSHLIB(Vcurrent_shlib); + + shlibc->objects = Fcons (obj, shlibc->objects); +} + +DEFUN ("load-shlib", Fload_shlib, Sload_shlib, 1, 1, 0 /* +Load shared libary. +*/ ) + (shlib) + Lisp_Object shlib; +{ + Lisp_Shlib *shlibc; + char *name; + char *result; + Lisp_Object version; + Lisp_Object args[2]; /* for Frun_hook... */ + int speccount = specpdl_depth (); + + shlib = Fget_shlib (shlib); + shlibc = XSHLIB (shlib); + + record_unwind_protect (shlib_restore_Vcurrent_shlib, Vcurrent_shlib); + Vcurrent_shlib = shlib; + + if (shlibc->flags & SHLIB_deleted) + signal_simple_error ("Deleted", shlib); + if (shlibc->flags & SHLIB_loaded) + signal_simple_error ("Already loaded", shlib); + + /* Run before_load_hook: abort if any of the hooks return a failure */ + /* Don't need to GC protect the following as they are both found + by other routes */ + args[0] = shlibc->before_load_hook; + args[1] = shlib; + if (NILP (Frun_hook_with_args_until_failure(2, args))) + signal_simple_error ("Load declined by hook", shlib); + + /**** Until this point, nothing has been done, that can not be undone easily */ + + /* Convert the null-string to a null-pointer, to indicate emacs itself. */ + name = (char*) string_data (XSTRING (shlibc->name)); + if (strlen (name) == 0) name = 0; + + /* Load the library using the low-level function */ + shlibc->handle = shlib_lowlevel_load (name); + if (!shlibc->handle) { + signal_simple_error (shlib_lowlevel_error (), shlib); + } + + /* Find the entry function using the low-level function */ + if (!NILP (shlibc->entry_name)) { + name = (char*) string_data (XSTRING (shlibc->entry_name)); + shlibc->entry_func = (Shlib_Entry_Func) shlib_lowlevel_get (shlibc->handle, name); + if (!shlibc->entry_func) { + reset_shlib (shlibc); + signal_simple_error (shlib_lowlevel_error (), shlib); + } + } + + /* Call the initialization function; abort of it returns a string */ + if (shlibc->entry_func) { + version = shlib_call_entry(shlib, Qget_version, Qnil, EH_RESET|EH_RESIGNAL); + if (!INTP (version)) { + reset_shlib (shlibc); + signal_simple_error ("Load aborted: entry function returns non-integer version", shlib); + } + /* Right now we accept all version as long as they are prior to the current version */ + if (XINT (version) > SHLIB_VERSION) { + reset_shlib (shlibc); + signal_simple_error ("Load aborted: shared library version is newer then Xemacs version", shlib); + } + shlibc->version = version; + + if (!NILP (shlib_call_entry(shlib, Qget_unloadable, Qnil, EH_RESET|EH_RESIGNAL))) + shlibc->flags |= SHLIB_unloadable; + + if (!NILP (shlib_call_entry(shlib, Qload, Qnil, EH_RESET|EH_RESIGNAL))) { + reset_shlib (shlibc); + signal_simple_error ("Load aborted: entry function returns nil", shlib); + } + } + + shlibc->flags |= SHLIB_loaded; + + /**** At this point the the library is completely loaded */ + + /* Run after_load_hook */ + va_run_hook_with_args (shlibc->after_load_hook, 1, shlib); + + return unbind_to(speccount, shlib); +} + +/* Try to finalize the unload of the shared library. */ +static void +unload_shlib_finalizer(Lisp_Shlib *shlibc) +{ + Lisp_Object shlib; + + if (!(shlibc->flags & SHLIB_unloading)) return; + + assert(WEAK_LISTP (shlibc->objects)); + + /* Check if there are more objects on the (weak) object list */ + if (!NILP (XWEAK_LIST_LIST (shlibc->objects))) return; + + /* Call the entry function, to unload the library */ + if (shlibc->entry_func) { + XSETSHLIB (shlib, shlibc); + shlib_call_entry(shlib, Qunload, Qnil, 0); + } + + reset_shlib (shlibc); + + /* Run after_load_hook */ + va_run_hook_with_args (shlibc->after_unload_hook, 1, shlib); +} + +DEFUN ("finalize-all-unload-shlib", Fshlib_finalize_unloads, Sshlib_finalize_unloads, 0, 0, 0 /* +Trye to finalize all unloads of shared libraries started with unload-shlib. +Ment to be called from post-gc-hook. +*/ ) + () +{ + LOBJECT_INUSE_LOOP(class_shlib, Lisp_Shlib *, shlibc, + unload_shlib_finalizer(shlibc); + ); +} + +DEFUN ("unload-shlib", Funload_shlib, Sunload_shlib, 1, 2, 0 /* +Unload shared libary. +If NOW is specified, do garbage-collect immediately. If the shared library +isn't unloaded immediately an error is signaled. +*/ ) + (shlib, now) + Lisp_Object shlib, now; +{ + Lisp_Shlib *shlibc; + Lisp_Object obj; + Lisp_Object wobjs = Qnil; + Lisp_Object args[2]; /* for Frun_hook... */ + + shlib = Fget_shlib (shlib); + shlibc = XSHLIB (shlib); + + if (shlibc->flags & SHLIB_deleted) + signal_simple_error ("Deleted", shlib); + if (shlibc->flags & SHLIB_unloading) + signal_simple_error ("Already unloading", shlib); + if (!(shlibc->flags & SHLIB_loaded)) + signal_simple_error ("Not loaded", shlib); + if (!(shlibc->flags & SHLIB_unloadable)) + signal_simple_error ("Not unloadable", shlib); + + /* Call the entry function, to see if the library can be unloaded */ + if (shlibc->entry_func) { + if (NILP (shlib_call_entry(shlib, Qtest_unload, Qnil, EH_RESIGNAL))) + signal_simple_error ("Unload aborted: entry function returns nil", shlib); + } + + /* Run before_unload_hook: abort if any of the hooks return a failure */ + /* Don't need to GC protect the following as they are both found + by other routes */ + args[0] = shlibc->before_unload_hook; + args[1] = shlib; + if (NILP (Frun_hook_with_args_until_failure(2, args))) + signal_simple_error ("Unload declined by hook", shlib); + + /**** Until this point, nothing has been done, but tests */ + + /* Go through all the imported objects and undefine the object if + possible; th objects, that can linger for some time yet, are put + on the weak list */ + for (obj = shlibc->objects; !NILP(obj); obj = XCDR (obj)) { + Lisp_Object o = Fcar (obj); + + if (CLASSP (o)) { + Lisp_Class *aclass = XCLASS (o); + defclass_uninstall_name(aclass); + wobjs = Fcons (o, wobjs); + } else if (SUBRP (o)) { + /* ###TM###: this should be put in undefsubr */ + Lisp_Object sym = intern (subr_name (XSUBR(o))); + + if (EQ(XSYMBOL(sym)->function, o)) Ffset (sym, Qunbound); + wobjs = Fcons (o, wobjs); + } else if (SYMBOL_VALUE_MAGIC_P (o)) { + /* ###TM###: Support for magic */ + wobjs = Fcons (o, wobjs); + } else { + /* We simply ignore all other objects */ + } + } + + /* Convert the object list into a weak list */ + shlibc->objects = Fmake_weak_list(Qnil); + Fset_weak_list_list (shlibc->objects, wobjs); + + shlibc->flags |= SHLIB_unloading; + + if (NILP (now)) { + unload_shlib_finalizer(shlibc); + } else { + garbage_collect_1(); + if (shlibc->flags & SHLIB_loaded) + signal_simple_error ("Unload cannot be finalized now", shlib); + } + + return shlib; +} + + +/***************************************************************************** + Public functions - variable access + ****************************************************************************/ + +#if 0 /* ###IMP### */ +DEFUN ("shlib-import-variable", Fshlib_import_variable, Sshlib_import_variable, 4, 4, 0 /* +Defines and returns a new variable. TODO +*/ ) + (shlib, lisp_name, c_name, type) + Lisp_Object shlib, lisp_name, c_name, type; +{ + Lisp_Shlib *shlibc; + Lisp_Object obj; + void *c_obj; + char *lisp_name_str; + + shlib = Fget_shlib (shlib); + CHECK_STRING (lisp_name); + CHECK_STRING (c_name); + CHECK_SYMBOL (type); + + shlibc = XSHLIB(shlib); + lisp_name_str = (char *)string_data (XSTRING (lisp_name)); + + if (shlibc->flags & SHLIB_deleted) + signal_simple_error ("Deleted", shlib); + if (!(shlibc->flags & SHLIB_loaded)) + signal_simple_error ("Not loaded", shlib); + + /* Get the object from the shared library */ + c_obj = shlib_lowlevel_get (shlibc->handle, (char *)string_data (XSTRING (c_name))); + if (!c_obj) { + signal_simple_error (shlib_lowlevel_error (), shlib); + } + +#if 0 + /* Make the lisp variable */ + if (EQ (type, Qint)) { + DEFVARINT (lisp_name_str, c_obj, ""); + } else if (EQ (type, Qbool)) { + DEFVARBOOL (lisp_name_str, c_obj, ""); + } else { + signal_simple_error ("Illegal type", type); + } +#endif + + /* Record the object in the shlib record */ + obj = intern (lisp_name_str); + shlibc->imported_variables = Fcons (obj, shlibc->imported_variables); + + return obj; +} +#endif + +/***************************************************************************** + Initialization code + ****************************************************************************/ + + +void +init_shlib (void) +{ + if (!initialized) + return; + + /* Initialize the low-level functions */ + shlib_lowlevel_init(); + + /* Create and load the shlib object for emacs itself */ + Fload_shlib (Fmake_shlib (build_string (""))); +} + +void +syms_of_shlib (void) +{ + DEFCLASS (shlib); + + defsubr (&Sshlibp); + + defsubr (&Sfind_shlib); + defsubr (&Sget_shlib); + defsubr (&Sshlib_list); + + defsubr (&Sshlib_name); + + defsubr (&Smake_shlib); + defsubr (&Sdelete_shlib); + defsubr (&Sload_shlib); + defsubr (&Sunload_shlib); + defsubr (&Sshlib_finalize_unloads); + +#if 0 /* ###IMP### */ + defsubr (&Sshlib_import_variable); +#endif + + defsymbol (&Qload, "load"); + defsymbol (&Qtest_unload, "test-unload"); + defsymbol (&Qunload, "unload"); + defsymbol (&Qget_unloadable, "get-unloadable"); + defsymbol (&Qget_version, "get-version"); + + /* identity */ + defsymbol (&Qname, "name"); + defsymbol (&Qentry_name, "entry-name"); + + /* flags */ + defsymbol (&Qdeleted, "deleted"); + defsymbol (&Qloaded, "loaded"); + defsymbol (&Qunloading, "unloading"); + defsymbol (&Qunloadable, "unloadable"); + defsymbol (&Qversion, "version"); + + /* hooks */ + defsymbol (&Qbefore_load_hook, "before-load-hook"); + defsymbol (&Qafter_load_hook, "after-load-hook"); + defsymbol (&Qbefore_unload_hook, "before-unload-hook"); + defsymbol (&Qafter_unload_hook, "after-unload-hook"); + + XSETSTRING(Qbefore_load_hook_name, XSYMBOL(Qbefore_load_hook)->name); + XSETSTRING(Qafter_load_hook_name, XSYMBOL(Qafter_load_hook)->name); + XSETSTRING(Qbefore_unload_hook_name, XSYMBOL(Qbefore_unload_hook)->name); + XSETSTRING(Qafter_unload_hook_name, XSYMBOL(Qafter_unload_hook)->name); + + /* imported stuff */ + defsymbol (&Qobjects, "objects"); +#if 0 /* ###IMP### */ + defsymbol (&Qimported_variables, "imported-variables"); + + /* misc */ + defsymbol (&Qint, "int"); + defsymbol (&Qbool, "bool"); +#endif + defsymbol (&Qshlibp, "shlibp"); + + defsymbol (&Qshlib_hook, "shlib-hook"); +} + +void +vars_of_shlib (void) +{ + Fprovide (intern ("shlib")); + + DEFVAR_CONST_LISP ("current-shlib", &Vcurrent_shlib /* +The current shlib object. Only set during load and unload of shlib objects. +*/ ); +} diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/shlib.h xemacs-20.0-b26/src/shlib.h --- xemacs-20.0-b26-orig/src/shlib.h Thu Jan 1 01:00:00 1970 +++ xemacs-20.0-b26/src/shlib.h Thu Jul 18 11:19:26 1996 @@ -0,0 +1,273 @@ +/* Shared library data structures. + Copyright (C) 1995 Board of Trustees, University of Illinois + Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +/* Synched up with: Not in FSF. */ + +#ifndef _XEMACS_SHLIB_H_ +#define _XEMACS_SHLIB_H_ + +/* This file contain the external interface to shlib - a module that + can load a shared library into a running emacs. The interface is + divided into three parts: + + - the interface from the rest of emacs. + + - the interface to the shared library itself, once it is loaded. + + - the interface to the low-level functions that manage the shared + libraries. + + The three interfaces are described below. + + *** Emacs interface to shlib *** + + *** Requirements of shared libraries *** + + A shared library must implement an shlib entry function. By + default, this function is named "shlib_func_", but it can be + set to any name using the entry-name property. + + The entry function has the propotype Shlib_Entry_Func (see below). + The entry function can just about everything (even load files and + signaling errors), except calling load and unload function on the + same shlib object. + + The argument arg can be any of the following + + signal_simple_error (result, Vcurrent_shlib); + + + *** Low-level interface to shared libraries *** + + shlib depends on a 5 low-level functions for the actual operations + on shared libraries. These functions must be defined in a separate + C file with the name "shlib-.c". describes the type of + the low-level interface and is defined in the relavant m/*.h header + files as the value of the preprocessor macro + SHLIB_TYPE. E.g. m/alpha.h contains the following lines. + + #define SHLIB_TYPE dlopen + + This line means that the interface for Digital Alpha machines is + found in the file shlib-dlopen.c + + The low-level functions are + + - void shlib_lowlevel_init() + + This function is called when XEmacs is started. It is *not* called + until Emacs is initialized (i.e. it is not called when emacs is + dumped). + + - void *shlib_lowlevel_load(char *name) + + This function loads the library with the specified name into the + running XEmacs and returns a handle for the library. If name == 0, + a handles should be returned for the running XEmacs itself. This + handle should be usable with the unload and get functions below. If + an error occur (library does not exist, library not loadable, etc) + a null-pointer should be returned and the next call of the error + function should return a string that describes the error condition. + + - void shlib_lowlevel_unload(void *handle) + + This function unloads a library previously loaded with the load + function. After this call, the handle will never be used again and + any memory allocated for the handle should be released. + + - void *shlib_lowlevel_get(void *handle, char *name) + + This function returns the address of the function or variable with + the specified name in the specified library previously loaded with + the load function. Currently this function will only be used once + for each library, but don't depend on this. If an error occur + (function or variable does not exist, etc) a null-pointer should be + returned and the next call of the error function should return a + string that describes the error condition. + + - char *shlib_lowlevel_error() + + This function should return a string that describes the last error + encountered with the load or get functions as described above. The + function will only be called if an error has occured. + + The following is the code corresponding to the dlopen library used + on Digital Alpha machines. + + void + shlib_lowlevel_init() + { + } + + void * + shlib_lowlevel_load(char *name) + { + return dlopen (name, RTLD_NOW); + } + + void + shlib_lowlevel_unload(void *handle) + { + dlclose (handle); + } + + void * + shlib_lowlevel_get(void *handle, char *name) + { + return dlsym (handle, name); + } + + char * + shlib_lowlevel_error() + { + return dlerror (); + } + + As it can be seen, this is real easy - at least for this architecture ;->. + + The following lowlevel interfaces are been defined so far: + + Interface Machines + ================================================== + dlopen OSF/1 + + + *** TODO List *** + + The are still a number of things that need to be done for this + version of shlib. + + - better documentation: I need documentation for all three interfaces. + + */ + +#include +#include + +/* Current version number of shlib */ +#define SHLIB_VERSION_MAJOR 0 +#define SHLIB_VERSION_MINOR 5 +#define SHLIB_VERSION ((SHLIB_VERSION_MAJOR)*100+SHLIB_VERSION_MINOR) + + +/***************************************************************************** + Structures and Typedef's + ****************************************************************************/ + +typedef struct Lisp_Shlib Lisp_Shlib; + +/* Prototype for shlib entry function */ +typedef Lisp_Object (*Shlib_Entry_Func)(Lisp_Object shlib, Lisp_Object function, Lisp_Object arg); + +/* This structure is used to chain Lisp_Class objects for the defclass + field. */ +struct Lisp_Shlib_class_element +{ + struct Lisp_Shlib_class_element *next; /* Next record */ + Lisp_Class *lr; +}; + +struct Lisp_Shlib +{ + struct lobject_header header; + + /* Name of library */ + Lisp_Object name; + + /* Name of shlib function in library */ + Lisp_Object entry_name; + + /* Address of entry_name in loaded library */ + Shlib_Entry_Func entry_func; + + /* Special flags and properties. See Below */ + int flags; + + /* The version of the library */ + Lisp_Object version; + + /* Handle used for the shared library, when loaded. */ + void *handle; + + /* Hooks for load and unload. */ + Lisp_Object before_load_hook; + Lisp_Object after_load_hook; + Lisp_Object before_unload_hook; + Lisp_Object after_unload_hook; + + /* List with objects registered with defclass, defsubr, defkeyword, + defmumble. While a shlib is loaded this is an ordinary list, but + when the shlib is unloaded it is converted into a weak-list. When + the weak-list is empty, the shlib is completely unloaded. */ + Lisp_Object objects; + +#if 0 /* ###IMP### */ + /* List with inported variables and functions. */ + Lisp_Object imported_variables; + Lisp_Object imported_functions; +#endif + /* Normal properties */ + Lisp_Object plist; +}; + +DECLARE_LOBJECT_CLASS (shlib, Lisp_Shlib); +#define XSHLIB(x) XOBJECT (x, shlib, Lisp_Shlib) +#define XSETSHLIB(x, p) XSETLOBJECT (x, p, shlib) +#define SHLIBP(x) OBJECT_CLASSP (x, shlib) +#define CHECK_SHLIB(x, i) CHECK_OBJECT (x, shlib) + +/* Possible Special Flags */ +#define SHLIB_deleted 0x0001 /* library has been deleted */ +#define SHLIB_loaded 0x0010 /* library is currently loaded */ +#define SHLIB_unloadable 0x0020 /* library can be unloaded */ +#define SHLIB_unloading 0x0040 /* library is begin unloaded */ + + +/***************************************************************************** + External Variables and Functions + ****************************************************************************/ + +/* The current shlib under load and unload */ +extern Lisp_Object Vcurrent_shlib; + +/* t and nil are used as the result of most entry function calls. */ +extern Lisp_Object Qnil; +extern Lisp_Object Qt; + +/* Possible values for function in shlib entry function */ +extern Lisp_Object Qload; /* load library */ +extern Lisp_Object Qtest_unload; /* test library can be unloaded */ +extern Lisp_Object Qunload; /* unload library */ +extern Lisp_Object Qget_unloadable; /* get unloadable flag */ +extern Lisp_Object Qget_version; /* get version number */ + +/* Add an object to the the shared-lib Vcurrent_shlib */ +extern void shlib_add_object(Lisp_Object obj); +/* Try to finalize unload's */ +extern void shlib_finalize_unloads(); + +/* Low-level shared library function defined in shlib-.c */ +extern void shlib_lowlevel_init(); +extern void *shlib_lowlevel_load(char *name); +extern void shlib_lowlevel_unload(void *handle); +extern void *shlib_lowlevel_get(void *handle, char *name); +extern char *shlib_lowlevel_error(); + +#endif /* _XEMACS_SHLIB_H_ */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/specifier.c xemacs-20.0-b26/src/specifier.c --- xemacs-20.0-b26-orig/src/specifier.c Mon Jun 17 14:03:35 1996 +++ xemacs-20.0-b26/src/specifier.c Tue Jul 16 08:31:55 1996 @@ -91,10 +91,10 @@ static unsigned int sizeof_specifier (CONST void *header); static void finalize_specifier (void *header, int for_disksave); -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier, - mark_specifier, print_specifier, - finalize_specifier, - specifier_equal, specifier_hash, - sizeof_specifier, - struct Lisp_Specifier); +DEFINE_LOBJECT_SEQUENCE_CLASS ("Specifier", specifier, 0, + mark_specifier, print_specifier, + finalize_specifier, + specifier_equal, specifier_hash, + sizeof_specifier, + struct Lisp_Specifier); /* Remove dead objects from the specified assoc list. */ @@ -226,5 +226,5 @@ for (rest = Vall_specifiers; - !GC_NILP (rest); + !NILP (rest); rest = XSPECIFIER (rest)->next_specifier) { @@ -232,5 +232,5 @@ { /* This specifier is garbage. Remove it from the list. */ - if (GC_NILP (prev)) + if (NILP (prev)) Vall_specifiers = XSPECIFIER (rest)->next_specifier; else @@ -251,5 +251,5 @@ if (print_readably) error ("printing unreadable object #<%s-specifier 0x%x>", - sp->methods->name, sp->header.uid); + sp->methods->name, LHEADER_UID (&sp->header)); sprintf (buf, "#<%s-specifier global=", sp->methods->name); @@ -269,5 +269,5 @@ } unbind_to (count, Qnil); - sprintf (buf, " 0x%x>", sp->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (&sp->header)); write_c_string (buf, printcharfun); } @@ -408,6 +408,7 @@ struct gcpro gcpro1; - sp = alloc_lcrecord (sizeof (struct Lisp_Specifier) + - spec_meths->extra_data_size - 1, lrecord_specifier); + sp = alloc_lobject_size (class_specifier, + sizeof (struct Lisp_Specifier) + + spec_meths->extra_data_size - 1); sp->methods = spec_meths; @@ -2980,4 +2981,6 @@ syms_of_specifier (void) { + DEFCLASS (specifier); + defsymbol (&Qspecifierp, "specifierp"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/specifier.h xemacs-20.0-b26/src/specifier.h --- xemacs-20.0-b26-orig/src/specifier.h Mon Jun 17 14:03:36 1996 +++ xemacs-20.0-b26/src/specifier.h Mon Jul 8 14:36:38 1996 @@ -88,5 +88,5 @@ struct Lisp_Specifier { - struct lcrecord_header header; + struct lobject_header header; struct specifier_methods *methods; @@ -117,11 +117,10 @@ }; -DECLARE_LRECORD (specifier, struct Lisp_Specifier); -#define XSPECIFIER(x) XRECORD (x, specifier, struct Lisp_Specifier) -#define XSETSPECIFIER(x, p) XSETRECORD (x, p, specifier) -#define SPECIFIERP(x) RECORDP (x, specifier) -#define GC_SPECIFIERP(x) GC_RECORDP (x, specifier) -#define CHECK_SPECIFIER(x) CHECK_RECORD (x, specifier) -#define CONCHECK_SPECIFIER(x) CONCHECK_RECORD (x, specifier) +DECLARE_LOBJECT_CLASS (specifier, struct Lisp_Specifier); +#define XSPECIFIER(x) XOBJECT (x, specifier, struct Lisp_Specifier) +#define XSETSPECIFIER(x, p) XSETLOBJECT (x, p, specifier) +#define SPECIFIERP(x) OBJECT_CLASSP (x, specifier) +#define CHECK_SPECIFIER(x) CHECK_OBJECT (x, specifier) +#define CONCHECK_SPECIFIER(x) CONCHECK_OBJECT (x, specifier) /***** Calling a specifier method *****/ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/symbols.c xemacs-20.0-b26/src/symbols.c --- xemacs-20.0-b26-orig/src/symbols.c Thu May 9 16:18:00 1996 +++ xemacs-20.0-b26/src/symbols.c Thu Jul 18 11:08:58 1996 @@ -57,4 +57,7 @@ #include "buffer.h" /* for Vbuffer_defaults */ #include "console.h" +#ifdef HAVE_SHLIB +#include "shlib.h" +#endif Lisp_Object Qad_advice_info, Qad_activate; @@ -87,11 +90,11 @@ -#ifdef LRECORD_SYMBOL +#ifdef USE_LOBJECT_SYMBOL static Lisp_Object mark_symbol (Lisp_Object, void (*) (Lisp_Object)); extern void print_symbol (Lisp_Object, Lisp_Object, int); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("symbol", symbol, - mark_symbol, print_symbol, 0, 0, 0, - struct Lisp_Symbol); +DEFINE_LOBJECT_CLASS ("Symbol", symbol, LC_USEFROBBLOCKS, + mark_symbol, print_symbol, 0, 0, 0, + struct Lisp_Symbol); static Lisp_Object @@ -117,5 +120,5 @@ } -#endif /* LRECORD_SYMBOL */ +#endif /* USE_LOBJECT_SYMBOL */ @@ -490,5 +493,5 @@ || (SYMBOL_VALUE_MAGIC_P (val) && (XSYMBOL_VALUE_MAGIC_TYPE (val) == - SYMVAL_CONST_OBJECT_FORWARD || + SYMVAL_CONST_LISP_FORWARD || XSYMBOL_VALUE_MAGIC_TYPE (val) == SYMVAL_CONST_SPECIFIER_FORWARD || @@ -704,6 +707,5 @@ symbol-value-forward is used for variables whose actual contents are stored in a C variable of some sort, and for Qunbound. The - lcheader.next field (which is only used to chain together free - lcrecords) holds a pointer to the actual C variable. Included + forward field holds a pointer to the actual C variable. Included in this type are "buffer-local" variables that are actually stored in the buffer object itself; in this case, the "pointer" @@ -712,5 +714,5 @@ The subtypes are as follows: - SYMVAL_OBJECT_FORWARD: + SYMVAL_LISP_FORWARD: (declare with DEFVAR_LISP) The value of this variable is stored in a C variable of type @@ -725,13 +727,13 @@ SYMVAL_BOOLEAN_FORWARD: (declare with DEFVAR_INT or DEFVAR_BOOL) - Similar to SYMVAL_OBJECT_FORWARD except that the C variable + Similar to SYMVAL_LISP_FORWARD except that the C variable is is of type "int" and is an integer or boolean, respectively. - SYMVAL_CONST_OBJECT_FORWARD: + SYMVAL_CONST_LISP_FORWARD: SYMVAL_CONST_FIXNUM_FORWARD: SYMVAL_CONST_BOOLEAN_FORWARD: (declare with DEFVAR_CONST_LISP, DEFVAR_CONST_INT, or DEFVAR_CONST_BOOL) - Similar to SYMVAL_OBJECT_FORWARD, SYMVAL_FIXNUM_FORWARD, or + Similar to SYMVAL_LISP_FORWARD, SYMVAL_FIXNUM_FORWARD, or SYMVAL_BOOLEAN_FORWARD, respectively, except that the value cannot be changed. @@ -739,5 +741,5 @@ SYMVAL_CONST_SPECIFIER_FORWARD: (declare with DEFVAR_SPECIFIER) - Exactly like SYMVAL_CONST_OBJECT_FORWARD except that error message + Exactly like SYMVAL_CONST_LISP_FORWARD except that error message you get when attempting to set the value says to use `set-specifier' instead. @@ -842,5 +844,5 @@ Note that only certain types of `symbol-value-forward' objects can find their way into the "current value" cell of a - `symbol-value-buffer-local' object: SYMVAL_OBJECT_FORWARD, + `symbol-value-buffer-local' object: SYMVAL_LISP_FORWARD, SYMVAL_FIXNUM_FORWARD, SYMVAL_BOOLEAN_FORWARD, and SYMVAL_UNBOUND_MARKER. The SYMVAL_CONST_*_FORWARD cannot @@ -872,30 +874,30 @@ void (*) (Lisp_Object)); -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward", - symbol_value_forward, - this_one_is_unmarkable, - print_symbol_value_magic, 0, 0, 0, - struct symbol_value_forward); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-buffer-local", - symbol_value_buffer_local, - mark_symbol_value_buffer_local, - print_symbol_value_magic, - 0, 0, 0, - struct symbol_value_buffer_local); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-lisp-magic", - symbol_value_lisp_magic, - mark_symbol_value_lisp_magic, - print_symbol_value_magic, - 0, 0, 0, - struct symbol_value_lisp_magic); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-varalias", - symbol_value_varalias, - mark_symbol_value_varalias, - print_symbol_value_magic, - 0, 0, 0, - struct symbol_value_varalias); +DEFINE_LOBJECT_CLASS ("Symbol-Value-Forward", + symbol_value_forward, 0, + 0, /* ###TM###*/ + print_symbol_value_magic, 0, 0, 0, + struct symbol_value_forward); + +DEFINE_LOBJECT_CLASS ("Symbol-Value-Buffer-Local", + symbol_value_buffer_local, 0, + mark_symbol_value_buffer_local, + print_symbol_value_magic, + 0, 0, 0, + struct symbol_value_buffer_local); + +DEFINE_LOBJECT_CLASS ("Symbol-Value-Lisp-Magic", + symbol_value_lisp_magic, 0, + mark_symbol_value_lisp_magic, + print_symbol_value_magic, + 0, 0, 0, + struct symbol_value_lisp_magic); + +DEFINE_LOBJECT_CLASS ("Symbol-Value-Varalias", + symbol_value_varalias, 0, + mark_symbol_value_varalias, + print_symbol_value_magic, + 0, 0, 0, + struct symbol_value_varalias); static Lisp_Object @@ -1001,6 +1003,6 @@ } - case SYMVAL_OBJECT_FORWARD: - case SYMVAL_CONST_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: + case SYMVAL_CONST_LISP_FORWARD: case SYMVAL_CONST_SPECIFIER_FORWARD: return (*((Lisp_Object *)symbol_value_forward_forward (fwd))); @@ -1190,5 +1192,5 @@ } - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: { if (magicfun) @@ -1579,5 +1581,5 @@ case SYMVAL_FIXNUM_FORWARD: case SYMVAL_BOOLEAN_FORWARD: - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: case SYMVAL_DEFAULT_BUFFER_FORWARD: case SYMVAL_DEFAULT_CONSOLE_FORWARD: @@ -1965,5 +1967,5 @@ case SYMVAL_FIXNUM_FORWARD: case SYMVAL_BOOLEAN_FORWARD: - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: case SYMVAL_UNBOUND_MARKER: break; @@ -1987,6 +1989,5 @@ { struct symbol_value_buffer_local *bfwd - = alloc_lcrecord (sizeof (struct symbol_value_buffer_local), - lrecord_symbol_value_buffer_local); + = alloc_lobject (class_symbol_value_buffer_local); Lisp_Object foo = Qnil; bfwd->magic.type = SYMVAL_BUFFER_LOCAL; @@ -1996,5 +1997,5 @@ bfwd->current_alist_element = Qnil; bfwd->current_buffer = Fcurrent_buffer (); - XSETSYMBOL_VALUE_MAGIC (foo, bfwd); + XSETSYMBOL_VALUE_BUFFER_LOCAL (foo, bfwd); *value_slot_past_magic (variable) = foo; #if 1 /* #### Yuck! FSFmacs bug-compatibility*/ @@ -2066,5 +2067,5 @@ case SYMVAL_FIXNUM_FORWARD: case SYMVAL_BOOLEAN_FORWARD: - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: case SYMVAL_UNBOUND_MARKER: break; @@ -2096,6 +2097,5 @@ /* Make sure variable is set up to hold per-buffer values */ - bfwd = alloc_lcrecord (sizeof (struct symbol_value_buffer_local), - lrecord_symbol_value_buffer_local); + bfwd = alloc_lobject (class_symbol_value_buffer_local); bfwd->magic.type = SYMVAL_SOME_BUFFER_LOCAL; @@ -2113,5 +2113,5 @@ #endif - XSETSYMBOL_VALUE_MAGIC (valcontents, bfwd); + XSETSYMBOL_VALUE_BUFFER_LOCAL (valcontents, bfwd); *value_slot_past_magic (variable) = valcontents; @@ -2155,5 +2155,5 @@ case SYMVAL_FIXNUM_FORWARD: case SYMVAL_BOOLEAN_FORWARD: - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: case SYMVAL_DEFAULT_BUFFER_FORWARD: set_up_buffer_local_cache (variable, bfwd, current_buffer); @@ -2495,8 +2495,8 @@ return Qconst_boolean; - case SYMVAL_OBJECT_FORWARD: + case SYMVAL_LISP_FORWARD: return Qobject; - case SYMVAL_CONST_OBJECT_FORWARD: + case SYMVAL_CONST_LISP_FORWARD: return Qconst_object; @@ -2870,6 +2870,5 @@ if (!SYMBOL_VALUE_LISP_MAGIC_P (valcontents)) { - bfwd = alloc_lcrecord (sizeof (struct symbol_value_lisp_magic), - lrecord_symbol_value_lisp_magic); + bfwd = alloc_lobject (class_symbol_value_lisp_magic); bfwd->magic.type = SYMVAL_LISP_MAGIC; for (i = 0; i < MAGIC_HANDLER_MAX; i++) @@ -2879,5 +2878,5 @@ } bfwd->shadowed = valcontents; - XSETSYMBOL_VALUE_MAGIC (XSYMBOL (variable)->value, bfwd); + XSETSYMBOL_VALUE_LISP_MAGIC (XSYMBOL (variable)->value, bfwd); } else @@ -3011,11 +3010,10 @@ reject_constant_symbols (variable, Qunbound, 0, Qt); - bfwd = alloc_lcrecord (sizeof (struct symbol_value_varalias), - lrecord_symbol_value_varalias); + bfwd = alloc_lobject (class_symbol_value_varalias); bfwd->magic.type = SYMVAL_VARALIAS; bfwd->aliasee = alias; bfwd->shadowed = valcontents; - XSETSYMBOL_VALUE_MAGIC (valcontents, bfwd); + XSETSYMBOL_VALUE_VARALIAS (valcontents, bfwd); XSYMBOL (variable)->value = valcontents; return Qnil; @@ -3088,9 +3086,15 @@ /* some losing systems can't have static vars at function scope... */ static struct symbol_value_magic guts_of_unbound_marker = - { { { lrecord_symbol_value_forward }, 0, 69}, SYMVAL_UNBOUND_MARKER }; + { { CLASS_SYMBOL_VALUE_FORWARD_ID, }, SYMVAL_UNBOUND_MARKER, }; void init_symbols_once_early (void) { + DEFCLASS (symbol); + DEFCLASS (symbol_value_forward); + DEFCLASS (symbol_value_buffer_local); + DEFCLASS (symbol_value_lisp_magic); + DEFCLASS (symbol_value_varalias); + Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1)); /* Bootstrapping problem: Qnil isn't set when make_pure_pname is @@ -3125,5 +3129,5 @@ struct symbol_value_magic *tem = &guts_of_unbound_marker; - XSETSYMBOL_VALUE_MAGIC (Qunbound, tem); + XSETSYMBOL_VALUE_FORWARD (Qunbound, tem); } if ((CONST void *) XPNTR (Qunbound) != @@ -3136,9 +3140,18 @@ struct symbol_value_magic *urk = xmalloc (sizeof (*urk)); memcpy (urk, &guts_of_unbound_marker, sizeof (*urk)); - XSETSYMBOL_VALUE_MAGIC (Qunbound, urk); + XSETSYMBOL_VALUE_FORWARD (Qunbound, urk); } XSYMBOL (Qnil)->function = Qunbound; + defclass_install_name (class_symbol); + defclass_install_name (class_symbol_value_forward); + defclass_install_name (class_symbol_value_buffer_local); + defclass_install_name (class_symbol_value_lisp_magic); + defclass_install_name (class_symbol_value_varalias); + +#ifdef HAVE_SHLIB + Vcurrent_shlib = Qnil; +#endif defsymbol (&Qt, "t"); XSYMBOL (Qt)->value = Qt; /* Veritas aetera */ @@ -3149,8 +3162,19 @@ defsymbol (Lisp_Object *location, CONST char *name) { - *location = Fintern (make_pure_pname ((CONST Bufbyte *) name, - strlen (name), 1), - Qnil); - staticpro (location); +#ifdef HAVE_SHLIB + if (NILP (Vcurrent_shlib)) { +#endif + *location = Fintern (make_pure_pname ((CONST Bufbyte *) name, + strlen (name), 1), + Qnil); + staticpro (location); +#ifdef HAVE_SHLIB + } else { + *location = Fintern (make_string ((CONST Bufbyte *) name, + strlen (name)), + Qnil); + shlib_add_object (*location); + } +#endif } @@ -3163,19 +3187,34 @@ void -defsubr (struct Lisp_Subr *subr) +defsubr (CONST struct Lisp_Subr_Impl *impl) { - Lisp_Object sym = intern (subr_name (subr)); + Lisp_Object sym = intern (impl->name); + struct Lisp_Subr *subr = alloc_lobject (class_subr); /* Check that nobody spazzed */ - if (subr->max_args != MANY && subr->max_args != UNEVALLED) + if (impl->max_args != MANY && impl->max_args != UNEVALLED) { - if (subr->max_args > SUBR_MAX_ARGS /* Need to fix eval.c if so */ - || subr->max_args < subr->min_args) + if (impl->max_args > SUBR_MAX_ARGS /* Need to fix eval.c if so */ + || impl->max_args < impl->min_args) abort (); } - if (subr->min_args < 0 || subr->min_args > SUBR_MAX_ARGS) + if (impl->min_args < 0 || impl->min_args > SUBR_MAX_ARGS) abort (); - if (!UNBOUNDP (XSYMBOL (sym)->function)) abort (); + subr->impl = impl; + +#ifdef HAVE_SHLIB + if (NILP(Vcurrent_shlib)) { +#endif + if (!UNBOUNDP (XSYMBOL (sym)->function)) abort (); +#ifdef HAVE_SHLIB + } else { + Lisp_Shlib *shlibc = XSHLIB(Vcurrent_shlib); + Lisp_Object o; + + XSETSUBR (o, subr); + shlib_add_object (o); + } +#endif XSETSUBR (XSYMBOL (sym)->function, subr); @@ -3290,5 +3329,5 @@ /* Check that magic points somewhere we can represent as a Lisp pointer */ - XSETOBJ (kludge, Lisp_Record, magic); + XSETOBJ (kludge, Lisp_LObject, magic); if (magic != (CONST void *) XPNTR (kludge)) { @@ -3298,8 +3337,8 @@ void *f = xmalloc (sizeof_magic); memcpy (f, magic, sizeof_magic); - XSETOBJ (XSYMBOL (sym)->value, Lisp_Record, f); + XSETOBJ (XSYMBOL (sym)->value, Lisp_LObject, f); } else - XSETOBJ (XSYMBOL (sym)->value, Lisp_Record, magic); + XSETOBJ (XSYMBOL (sym)->value, Lisp_LObject, magic); } diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/symeval.h xemacs-20.0-b26/src/symeval.h --- xemacs-20.0-b26-orig/src/symeval.h Sat Mar 30 16:43:54 1996 +++ xemacs-20.0-b26/src/symeval.h Tue Jul 16 11:30:29 1996 @@ -29,5 +29,5 @@ struct symbol_value_magic { - struct lcrecord_header lcheader; + struct lobject_header header; enum { @@ -38,6 +38,6 @@ SYMVAL_BOOLEAN_FORWARD, /* Forward C boolean ("int") */ SYMVAL_CONST_BOOLEAN_FORWARD, /* Same, but can't be set */ - SYMVAL_OBJECT_FORWARD, /* Forward C Lisp_Object */ - SYMVAL_CONST_OBJECT_FORWARD, /* Same, but can't be set */ + SYMVAL_LISP_FORWARD, /* Forward C Lisp_Object */ + SYMVAL_CONST_LISP_FORWARD, /* Same, but can't be set */ SYMVAL_CONST_SPECIFIER_FORWARD, /* Same, can't be set, but gives a different message when attempting @@ -79,10 +79,9 @@ }; #define SYMBOL_VALUE_MAGIC_P(x) \ - (LRECORDP (x) \ - && (XRECORD_LHEADER (x)->implementation->printer \ + (LOBJECTP (x) \ + && (XLOBJECT_IMPL (x)->printer \ == print_symbol_value_magic)) #define XSYMBOL_VALUE_MAGIC_TYPE(v) \ (((struct symbol_value_magic *) XPNTR (v))->type) -#define XSETSYMBOL_VALUE_MAGIC(s, p) XSETOBJ (s, Lisp_Record, p) extern void print_symbol_value_magic (Lisp_Object, Lisp_Object, int); @@ -100,10 +99,11 @@ */ -extern CONST_IF_NOT_DEBUG struct lrecord_implementation - lrecord_symbol_value_forward[]; +DECLARE_LOBJECT_CLASS(symbol_value_forward, struct symbol_value_forward); +#define XSETSYMBOL_VALUE_FORWARD(s, p) XSETLOBJECT (s, p, symbol_value_forward) struct symbol_value_forward { struct symbol_value_magic magic; - /* void *forward; -- use magic.lcheader.next instead */ + + void *forward; /* Function controlling magic behavior of this forward variable. @@ -147,11 +147,11 @@ #define XSYMBOL_VALUE_FORWARD(v) \ ((CONST struct symbol_value_forward *) XPNTR(v)) -#define symbol_value_forward_forward(m) ((void *)((m)->magic.lcheader.next)) +#define symbol_value_forward_forward(m) ((void *)((m)->forward)) #define symbol_value_forward_magicfun(m) ((m)->magicfun) /* 2. symbol-value-buffer-local */ -extern CONST_IF_NOT_DEBUG struct lrecord_implementation - lrecord_symbol_value_buffer_local[]; +DECLARE_LOBJECT_CLASS(symbol_value_buffer_local, struct symbol_value_buffer_local); +#define XSETSYMBOL_VALUE_BUFFER_LOCAL(s, p) XSETLOBJECT (s, p, symbol_value_buffer_local) struct symbol_value_buffer_local { @@ -242,6 +242,6 @@ /* 3. symbol-value-lisp-magic */ -extern CONST_IF_NOT_DEBUG struct lrecord_implementation - lrecord_symbol_value_lisp_magic[]; +DECLARE_LOBJECT_CLASS(symbol_value_lisp_magic, struct symbol_value_lisp_magic); +#define XSETSYMBOL_VALUE_LISP_MAGIC(s, p) XSETLOBJECT (s, p, symbol_value_lisp_magic) enum lisp_magic_handler { @@ -270,6 +270,6 @@ /* 4. symbol-value-varalias */ -extern CONST_IF_NOT_DEBUG struct lrecord_implementation - lrecord_symbol_value_varalias[]; +DECLARE_LOBJECT_CLASS(symbol_value_varalias, struct symbol_value_varalias); +#define XSETSYMBOL_VALUE_VARALIAS(s, p) XSETLOBJECT (s, p, symbol_value_varalias) struct symbol_value_varalias { @@ -288,5 +288,5 @@ /* defsubr (Sname); is how we define the symbol for function `name' at start-up time. */ -extern void defsubr (struct Lisp_Subr *); +extern void defsubr (CONST struct Lisp_Subr_Impl *); extern void defsymbol (Lisp_Object *location, CONST char *name); @@ -303,14 +303,14 @@ CONST void *magic, int sizeof_magic); -#define DEFVAR_HEADER(lname, c_location, forward_type) \ - static CONST struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, (void *) (c_location), 69 }, \ - forward_type }, 0 }; \ +#define DEFVAR_HEADER(lname, c_location, forward_type) \ + static CONST struct symbol_value_forward I_hate_C \ + = { { { CLASS_SYMBOL_VALUE_FORWARD_ID, 0, 0, 0, 0, }, \ + forward_type }, (void *) (c_location), 0 }; \ defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)) -#define DEFVAR_MAGIC_HEADER(lname, c_location, forward_type, magicfun) \ - static CONST struct symbol_value_forward I_hate_C \ - = { { { { lrecord_symbol_value_forward }, (void *) (c_location), 69 }, \ - forward_type }, magicfun }; \ +#define DEFVAR_MAGIC_HEADER(lname, c_location, forward_type, magicfun) \ + static CONST struct symbol_value_forward I_hate_C \ + = { { { CLASS_SYMBOL_VALUE_FORWARD_ID, }, \ + forward_type }, (void *) (c_location), magicfun }; \ defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)) @@ -319,9 +319,9 @@ #define DEFVAR_LISP(lname, c_location) \ - do { DEFVAR_HEADER (lname, c_location, SYMVAL_OBJECT_FORWARD); \ + do { DEFVAR_HEADER (lname, c_location, SYMVAL_LISP_FORWARD); \ staticpro (c_location); \ } while (0) #define DEFVAR_CONST_LISP(lname, c_location) \ - do { DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_OBJECT_FORWARD); \ + do { DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_LISP_FORWARD); \ staticpro (c_location); \ } while (0) @@ -345,5 +345,5 @@ #define DEFVAR_LISP_MAGIC(lname, c_location, magicfun) \ do { DEFVAR_MAGIC_HEADER (lname, c_location, \ - SYMVAL_OBJECT_FORWARD, magicfun); \ + SYMVAL_LISP_FORWARD, magicfun); \ staticpro (c_location); \ } while (0) diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/symsinit.h xemacs-20.0-b26/src/symsinit.h --- xemacs-20.0-b26-orig/src/symsinit.h Thu May 16 03:29:11 1996 +++ xemacs-20.0-b26/src/symsinit.h Wed Jul 17 15:16:12 1996 @@ -24,4 +24,9 @@ #define _XEMACS_SYMSINIT_H_ +#ifdef HAVE_SHLIB +/* ###TM###: add shlib stuff */ +#endif +/* ###TM###: add classes[ch] stuff */ + /* Earliest environment initializations (dump-time and run-time). */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/syntax.h xemacs-20.0-b26/src/syntax.h --- xemacs-20.0-b26-orig/src/syntax.h Thu Jun 6 19:18:43 1996 +++ xemacs-20.0-b26/src/syntax.h Mon Jul 8 14:36:39 1996 @@ -78,4 +78,11 @@ int *multi_p_out); +extern Lisp_Object Qsyntax_table_p; +Lisp_Object Fsyntax_table_p (Lisp_Object); +Lisp_Object Fsyntax_table (Lisp_Object); +Lisp_Object Fset_syntax_table (Lisp_Object, Lisp_Object); +enum syntaxcode charset_syntax (struct buffer *buf, Lisp_Object charset, + int *multi_p_out); + /* Return the syntax code for a particular character and mirror table. */ diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/toolbar.c xemacs-20.0-b26/src/toolbar.c --- xemacs-20.0-b26-orig/src/toolbar.c Sat Jun 1 20:00:52 1996 +++ xemacs-20.0-b26/src/toolbar.c Tue Jul 16 08:31:54 1996 @@ -64,7 +64,7 @@ } -DEFINE_LRECORD_IMPLEMENTATION ("toolbar-data", toolbar_data, - mark_toolbar_data, internal_object_printer, - 0, 0, 0, struct toolbar_data); +DEFINE_LOBJECT_CLASS ("Toolbar-Data", toolbar_data, 0, + mark_toolbar_data, internal_object_printer, + 0, 0, 0, struct toolbar_data); static Lisp_Object @@ -94,14 +94,14 @@ if (print_readably) error ("printing unreadable object #", - tb->header.uid); + LHEADER_UID (&tb->header)); - sprintf (buf, "#", tb->header.uid); + sprintf (buf, "#", LHEADER_UID (&tb->header)); write_c_string (buf, printcharfun); } -DEFINE_LRECORD_IMPLEMENTATION ("toolbar-button", toolbar_button, - mark_toolbar_button, print_toolbar_button, - 0, 0, 0, - struct toolbar_button); +DEFINE_LOBJECT_CLASS ("Toolbar-Button", toolbar_button, 0, + mark_toolbar_button, print_toolbar_button, + 0, 0, 0, + struct toolbar_button); DEFUN ("toolbar-button-p", Ftoolbar_button_p, Stoolbar_button_p, 1, 1, 0 /* @@ -325,6 +325,5 @@ if (!tb) { - tb = alloc_lcrecord (sizeof (struct toolbar_button), - lrecord_toolbar_button); + tb = alloc_lobject (class_toolbar_button); tb->next = Qnil; XSETFRAME (tb->frame, f); @@ -729,6 +728,5 @@ if (NILP (f->toolbar_data[pos])) { - struct toolbar_data *td = alloc_lcrecord (sizeof (struct toolbar_data), - lrecord_toolbar_data); + struct toolbar_data *td = alloc_lobject (class_toolbar_data); td->last_toolbar_buffer = Qnil; @@ -1324,4 +1322,7 @@ syms_of_toolbar (void) { + DEFCLASS (toolbar_button); + DEFCLASS (toolbar_data); + defsymbol (&Qtoolbar_buttonp, "toolbar-button-p"); defsymbol (&Q2D, "2D"); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/toolbar.h xemacs-20.0-b26/src/toolbar.h --- xemacs-20.0-b26-orig/src/toolbar.h Sat Mar 30 18:18:53 1996 +++ xemacs-20.0-b26/src/toolbar.h Mon Jul 8 14:36:39 1996 @@ -31,9 +31,9 @@ /* There are 4 of these per frame. They don't really need to be an - lrecord (they're not lisp-accessible) but it makes marking slightly + LOBJECT (they're not lisp-accessible) but it makes marking slightly more modular. */ struct toolbar_data { - struct lcrecord_header header; + struct lobject_header header; /* The last buffer for which the toolbars were displayed. */ @@ -44,11 +44,10 @@ }; -DECLARE_LRECORD (toolbar_data, struct toolbar_data); -#define XTOOLBAR_DATA(x) XRECORD (x, toolbar_data, struct toolbar_data) -#define XSETTOOLBAR_DATA(x, p) XSETRECORD (x, p, toolbar_data) -#define TOOLBAR_DATAP(x) RECORDP (x, toolbar_data) -#define GC_TOOLBAR_DATAP(x) GC_RECORDP (x, toolbar_data) -#define CHECK_TOOLBAR_DATA(x) CHECK_RECORD (x, toolbar_data) -#define CONCHECK_TOOLBAR_DATA(x) CONCHECK_RECORD (x, toolbar_data) +DECLARE_LOBJECT_CLASS (toolbar_data, struct toolbar_data); +#define XTOOLBAR_DATA(x) XOBJECT (x, toolbar_data, struct toolbar_data) +#define XSETTOOLBAR_DATA(x, p) XSETLOBJECT (x, p, toolbar_data) +#define TOOLBAR_DATAP(x) OBJECT_CLASSP (x, toolbar_data) +#define CHECK_TOOLBAR_DATA(x) CHECK_OBJECT (x, toolbar_data) +#define CONCHECK_TOOLBAR_DATA(x) CONCHECK_OBJECT (x, toolbar_data) #define FRAME_TOOLBAR_DATA(frame, position) \ @@ -58,9 +57,9 @@ /* These are chained together through toolbar_buttons in struct - toolbar_data. These don't need to be an lrecord either, but again, + toolbar_data. These don't need to be an LOBJECT either, but again, it makes marking easier. */ struct toolbar_button { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object next; @@ -89,11 +88,10 @@ }; -DECLARE_LRECORD (toolbar_button, struct toolbar_button); -#define XTOOLBAR_BUTTON(x) XRECORD (x, toolbar_button, struct toolbar_button) -#define XSETTOOLBAR_BUTTON(x, p) XSETRECORD (x, p, toolbar_button) -#define TOOLBAR_BUTTONP(x) RECORDP (x, toolbar_button) -#define GC_TOOLBAR_BUTTONP(x) GC_RECORDP (x, toolbar_button) -#define CHECK_TOOLBAR_BUTTON(x) CHECK_RECORD (x, toolbar_button) -#define CONCHECK_TOOLBAR_BUTTON(x) CONCHECK_RECORD (x, toolbar_button) +DECLARE_LOBJECT_CLASS (toolbar_button, struct toolbar_button); +#define XTOOLBAR_BUTTON(x) XOBJECT (x, toolbar_button, struct toolbar_button) +#define XSETTOOLBAR_BUTTON(x, p) XSETLOBJECT (x, p, toolbar_button) +#define TOOLBAR_BUTTONP(x) OBJECT_CLASSP (x, toolbar_button) +#define CHECK_TOOLBAR_BUTTON(x) CHECK_OBJECT (x, toolbar_button) +#define CONCHECK_TOOLBAR_BUTTON(x) CONCHECK_OBJECT (x, toolbar_button) extern void get_toolbar_coords (struct frame *f, enum toolbar_pos pos, int *x, diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/tooltalk.c xemacs-20.0-b26/src/tooltalk.c --- xemacs-20.0-b26-orig/src/tooltalk.c Sat Jun 1 20:49:08 1996 +++ xemacs-20.0-b26/src/tooltalk.c Tue Jul 16 08:31:54 1996 @@ -147,5 +147,5 @@ struct Lisp_Tooltalk_Message { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object plist_sym, callback; Tt_message m; @@ -154,8 +154,8 @@ static Lisp_Object mark_tooltalk_message (Lisp_Object, void (*) (Lisp_Object)); static void print_tooltalk_message (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message, - mark_tooltalk_message, print_tooltalk_message, - 0, 0, 0, - struct Lisp_Tooltalk_Message); +DEFINE_LOBJECT_CLASS ("Tooltalk-Message", tooltalk_message, 0, + mark_tooltalk_message, print_tooltalk_message, + 0, 0, 0, + struct Lisp_Tooltalk_Message); static Lisp_Object @@ -176,7 +176,7 @@ if (print_readably) error ("printing unreadable object #", - p->header.uid); + LHEADER_UID (&p->header)); - sprintf (buf, "#", (int) p->m, p->header.uid); + sprintf (buf, "#", (int) p->m, LHEADER_UID (&p->header)); write_c_string (buf, printcharfun); } @@ -186,6 +186,5 @@ { struct Lisp_Tooltalk_Message *msg - = alloc_lcrecord (sizeof (struct Lisp_Tooltalk_Message), - lrecord_tooltalk_message); + = alloc_lobject (class_tooltalk_message); Lisp_Object val; @@ -224,5 +223,5 @@ struct Lisp_Tooltalk_Pattern { - struct lcrecord_header header; + struct lobject_header header; Lisp_Object plist_sym, callback; Tt_pattern p; @@ -231,8 +230,8 @@ static Lisp_Object mark_tooltalk_pattern (Lisp_Object, void (*) (Lisp_Object)); static void print_tooltalk_pattern (Lisp_Object, Lisp_Object, int); -DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern, - mark_tooltalk_pattern, print_tooltalk_pattern, - 0, 0, 0, - struct Lisp_Tooltalk_Pattern); +DEFINE_LOBJECT_CLASS ("Tooltalk-Pattern", tooltalk_pattern, 0, + mark_tooltalk_pattern, print_tooltalk_pattern, + 0, 0, 0, + struct Lisp_Tooltalk_Pattern); static Lisp_Object @@ -253,7 +252,7 @@ if (print_readably) error ("printing unreadable object #", - p->header.uid); + LHEADER_UID (&p->header)); - sprintf (buf, "#", (int) p->p, p->header.uid); + sprintf (buf, "#", (int) p->p, LHEADER_UID (&p->header)); write_c_string (buf, printcharfun); } @@ -263,6 +262,5 @@ { struct Lisp_Tooltalk_Pattern *pat - = alloc_lcrecord (sizeof (struct Lisp_Tooltalk_Pattern), - lrecord_tooltalk_pattern); + = alloc_lobject (class_tooltalk_pattern); Lisp_Object val; @@ -1402,4 +1400,7 @@ syms_of_tooltalk (void) { + DEFCLASS (tooltalk_pattern); + DEFCLASS (tooltalk_message); + defsymbol (&Qtooltalk_messagep, "tooltalk-message-p"); defsubr (&Stooltalk_message_p); diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/tooltalk.h xemacs-20.0-b26/src/tooltalk.h --- xemacs-20.0-b26-orig/src/tooltalk.h Sat Mar 30 16:43:40 1996 +++ xemacs-20.0-b26/src/tooltalk.h Mon Jul 8 14:36:39 1996 @@ -27,18 +27,16 @@ struct Lisp_Tooltalk_Message; -DECLARE_LRECORD (tooltalk_message, struct Lisp_Tooltalk_Message); -#define XTOOLTALK_MESSAGE(x) XRECORD (x, tooltalk_message, struct Lisp_Tooltalk_Message) -#define XSETTOOLTALK_MESSAGE(x, p) XSETRECORD (x, p, tooltalk_message) -#define TOOLTALK_MESSAGEP(x) RECORDP (x, tooltalk_message) -#define GC_TOOLTALK_MESSAGEP(x) GC_RECORDP (x, tooltalk_message) -#define CHECK_TOOLTALK_MESSAGE(x) CHECK_RECORD (x, tooltalk_message) +DECLARE_LOBJECT_CLASS (tooltalk_message, struct Lisp_Tooltalk_Message); +#define XTOOLTALK_MESSAGE(x) XOBJECT (x, tooltalk_message, struct Lisp_Tooltalk_Message) +#define XSETTOOLTALK_MESSAGE(x, p) XSETLOBJECT (x, p, tooltalk_message) +#define TOOLTALK_MESSAGEP(x) OBJECT_CLASSP (x, tooltalk_message) +#define CHECK_TOOLTALK_MESSAGE(x) CHECK_OBJECT (x, tooltalk_message) struct Lisp_Tooltalk_Pattern; -DECLARE_LRECORD (tooltalk_pattern, struct Lisp_Tooltalk_Pattern); -#define XTOOLTALK_PATTERN(x) XRECORD (x, tooltalk_pattern, struct Lisp_Tooltalk_Pattern) -#define XSETTOOLTALK_PATTERN(x, p) XSETRECORD (x, p, tooltalk_pattern) -#define TOOLTALK_PATTERNP(x) RECORDP (x, tooltalk_pattern) -#define GC_TOOLTALK_PATTERNP(x) GC_RECORDP (x, tooltalk_pattern) -#define CHECK_TOOLTALK_PATTERN(x) CHECK_RECORD (x, tooltalk_pattern) +DECLARE_LOBJECT_CLASS (tooltalk_pattern, struct Lisp_Tooltalk_Pattern); +#define XTOOLTALK_PATTERN(x) XOBJECT (x, tooltalk_pattern, struct Lisp_Tooltalk_Pattern) +#define XSETTOOLTALK_PATTERN(x, p) XSETLOBJECT (x, p, tooltalk_pattern) +#define TOOLTALK_PATTERNP(x) OBJECT_CLASSP (x, tooltalk_pattern) +#define CHECK_TOOLTALK_PATTERN(x) CHECK_OBJECT (x, tooltalk_pattern) #define TOOLTALK_MESSAGE_KEY 100 diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/window.c xemacs-20.0-b26/src/window.c --- xemacs-20.0-b26-orig/src/window.c Wed Jun 19 00:27:21 1996 +++ xemacs-20.0-b26/src/window.c Tue Jul 16 10:38:44 1996 @@ -118,7 +118,4 @@ int next_screen_context_lines; -/* List of freed window configurations with 1 - 10 windows. */ -Lisp_Object Vwindow_configuration_free_list[10]; - #define SET_LAST_MODIFIED(w, cache_too) \ do { \ @@ -141,7 +138,7 @@ static void print_window (Lisp_Object, Lisp_Object, int); static void finalize_window (void *header, int for_disksave); -DEFINE_LRECORD_IMPLEMENTATION ("window", window, - mark_window, print_window, finalize_window, - 0, 0, struct window); +DEFINE_LOBJECT_CLASS ("Window", window, 0, + mark_window, print_window, finalize_window, + 0, 0, struct window); #define MARK_DISP_VARIABLE(field) \ @@ -224,5 +221,5 @@ if (print_readably) error ("printing unreadable object #", - XWINDOW (obj)->header.uid); + LHEADER_UID (& XWINDOW (obj)->header)); write_c_string ("#", XWINDOW (obj)->header.uid); + sprintf (buf, " 0x%x>", LHEADER_UID (& XWINDOW (obj)->header)); write_c_string (buf, printcharfun); } @@ -290,8 +287,7 @@ { Lisp_Object val = Qnil; - struct window *p = alloc_lcrecord (sizeof (struct window), - lrecord_window); + struct window *p = alloc_lobject (class_window); - zero_lcrecord (p); + zero_lobject (p); XSETWINDOW (val, p); @@ -3308,9 +3304,8 @@ Lisp_Object new = Qnil; struct window *o = XWINDOW (window); - struct window *p = alloc_lcrecord (sizeof (struct window), - lrecord_window); + struct window *p = alloc_lobject (class_window); XSETWINDOW (new, p); - copy_lcrecord (p, o); + copy_lobject (p, o); /* Don't copy the pointers to the line start cache or the face @@ -4602,5 +4597,5 @@ struct window_config { - struct lcrecord_header header; + struct lobject_header header; int frame_width; int frame_height; @@ -4629,16 +4624,16 @@ static unsigned int sizeof_window_config (CONST void *); -#define XWINDOW_CONFIGURATION(x) XRECORD (x, window_configuration, struct window_config) -#define XSETWINDOW_CONFIGURATION(x, p) XSETRECORD (x, p, window_configuration) -#define WINDOW_CONFIGURATIONP(x) RECORDP (x, window_configuration) -#define GC_WINDOW_CONFIGURATIONP(x) GC_RECORDP (x, window_configuration) -#define CHECK_WINDOW_CONFIGURATION(x) CHECK_RECORD (x, window_configuration) - -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("window-configuration", - window_configuration, - mark_window_config, - print_window_config, - 0, 0, 0, sizeof_window_config, - struct window_config); +#define XWINDOW_CONFIGURATION(x) XOBJECT (x, window_configuration, struct window_config) +#define XSETWINDOW_CONFIGURATION(x, p) XSETLOBJECT (x, p, window_configuration) +#define WINDOW_CONFIGURATIONP(x) OBJECT_CLASSP (x, window_configuration) +#define CHECK_WINDOW_CONFIGURATION(x) CHECK_OBJECT (x, window_configuration) + +DEFINE_LOBJECT_SEQUENCE_CLASS ("Window-Configuration", + window_configuration, + LC_KEEPFREELIST, + mark_window_config, + print_window_config, + 0, 0, 0, sizeof_window_config, + struct window_config); static Lisp_Object @@ -4690,7 +4685,7 @@ if (print_readably) error ("printing unreadable object #", - config->header.uid); + LHEADER_UID (&config->header)); write_c_string ("#", config->header.uid); + sprintf (buf, "0x%x>", LHEADER_UID (&config->header)); write_c_string (buf, printcharfun); } @@ -4846,8 +4841,8 @@ } - if (config->saved_windows_count <= countof (Vwindow_configuration_free_list)) - free_managed_lcrecord (Vwindow_configuration_free_list - [config->saved_windows_count - 1], - window_config); + /* This function can only be used in the cases where the + implementation keeps a free list */ + assert (XCLASS_IMPL (class_window_configuration)->flags & LC_KEEPFREELIST); + free_lobject (config); return Qnil; @@ -5365,13 +5360,6 @@ n_windows = count_windows (XWINDOW (FRAME_ROOT_WINDOW (f))); - if (n_windows <= countof (Vwindow_configuration_free_list)) - config = - XWINDOW_CONFIGURATION (allocate_managed_lcrecord - (Vwindow_configuration_free_list - [n_windows - 1])); - else - /* More than ten windows; just allocate directly */ - config = alloc_lcrecord (sizeof_window_config_for_n_windows (n_windows), - lrecord_window_configuration); + config = (struct window_config *) + alloc_lobject_size (class_window_configuration, sizeof_window_config_for_n_windows (n_windows)); XSETWINDOW_CONFIGURATION (result, config); @@ -5451,5 +5439,5 @@ fprintf (stderr, " on %s", string_data (XSTRING (b->name))); } - fprintf (stderr, " 0x%x>", XWINDOW (window)->header.uid); + fprintf (stderr, " 0x%x>", LHEADER_UID (& XWINDOW (window)->header)); while (!NILP (child)) @@ -5477,4 +5465,7 @@ syms_of_window (void) { + DEFCLASS (window_configuration); + DEFCLASS (window); + defsymbol (&Qwindowp, "windowp"); defsymbol (&Qwindow_live_p, "window-live-p"); @@ -5617,16 +5608,4 @@ */ ); window_min_width = 10; - - { - int i; - - for (i = 0; i < countof (Vwindow_configuration_free_list); i++) - { - Vwindow_configuration_free_list[i] = - make_lcrecord_list (sizeof_window_config_for_n_windows (i + 1), - lrecord_window_configuration); - staticpro (&Vwindow_configuration_free_list[i]); - } - } } diff --unified=2 --recursive --new-file xemacs-20.0-b26-orig/src/window.h xemacs-20.0-b26/src/window.h --- xemacs-20.0-b26-orig/src/window.h Sat Mar 30 18:17:36 1996 +++ xemacs-20.0-b26/src/window.h Mon Jul 8 14:36:40 1996 @@ -86,5 +86,5 @@ struct window { - struct lcrecord_header header; + struct lobject_header header; /* The frame this window is on. */ @@ -285,11 +285,10 @@ #ifdef emacs /* some things other than emacs want the structs */ -DECLARE_LRECORD (window, struct window); -#define XWINDOW(x) XRECORD (x, window, struct window) -#define XSETWINDOW(x, p) XSETRECORD (x, p, window) -#define WINDOWP(x) RECORDP (x, window) -#define GC_WINDOWP(x) GC_RECORDP (x, window) -#define CHECK_WINDOW(x) CHECK_RECORD (x, window) -#define CONCHECK_WINDOW(x) CONCHECK_RECORD (x, window) +DECLARE_LOBJECT_CLASS (window, struct window); +#define XWINDOW(x) XOBJECT (x, window, struct window) +#define XSETWINDOW(x, p) XSETLOBJECT (x, p, window) +#define WINDOWP(x) OBJECT_CLASSP (x, window) +#define CHECK_WINDOW(x) CHECK_OBJECT (x, window) +#define CONCHECK_WINDOW(x) CONCHECK_OBJECT (x, window) extern Lisp_Object Qwindow_live_p; @@ -328,5 +327,5 @@ #define WINDOW_WIN_P(w) FRAME_WIN_P (XFRAME ((w)->frame)) -DECLARE_LRECORD (window_configuration, struct window_config); +DECLARE_LOBJECT_CLASS (window_configuration, struct window_config); /* The minibuffer window of the selected frame.