#include #include #include #include #include #include #ifndef UNUSED_ARG # define UNUSED_ARG(decl) unused_##decl #endif #ifndef UNUSED # if defined(__GNUC__) && !defined(__cplusplus) && !defined(__INTEL_COMPILER) # define ATTRIBUTE_UNUSED __attribute__ ((unused)) # else # define ATTRIBUTE_UNUSED # endif # define UNUSED(decl) UNUSED_ARG (decl) ATTRIBUTE_UNUSED #endif /* UNUSED */ /*** Stuff from config.h ***/ #define USE_ASSERTIONS 1 #define ERROR_CHECK_TYPES 1 #define USE_KKCC 1 #define SIZEOF_SHORT 2 #define SIZEOF_INT 4 #define SIZEOF_LONG 4 #define SIZEOF_LONG_LONG 8 #define SIZEOF_VOID_P 4 #define SIZEOF_DOUBLE 8 #ifndef BITS_PER_CHAR #define BITS_PER_CHAR 8 #endif #if defined (__cplusplus) || ! defined (__GNUC__) # define INLINE_HEADER inline static #elif defined (DONT_EXTERN_INLINE_HEADER_FUNCTIONS) # define INLINE_HEADER inline #else # define INLINE_HEADER inline extern #endif #define DECLARE_INLINE_HEADER(header) \ INLINE_HEADER header ; INLINE_HEADER header #ifdef __GNUC__ #define enum_field(enumeration_type) enum enumeration_type #else #define enum_field(enumeration_type) unsigned int #endif /*** Stuff from lisp.h ***/ #ifdef ERROR_CHECK_TYPES #define type_checking_assert(assertion) assert (assertion) #define type_checking_assert_at_line(assertion, file, line) \ assert_at_line (assertion, file, line) #define type_checking_assert_with_message(assertion, msg) \ assert_with_message (assertion, msg) #else #define type_checking_assert(assertion) #define type_checking_assert_at_line(assertion, file, line) #define type_checking_assert_with_message(assertion, msg) #endif #ifndef SIZEOF_EMACS_INT # define SIZEOF_EMACS_INT SIZEOF_VOID_P #endif #ifndef EMACS_INT # if SIZEOF_EMACS_INT == SIZEOF_LONG # define EMACS_INT long # elif SIZEOF_EMACS_INT == SIZEOF_INT # define EMACS_INT int # elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG # define EMACS_INT long long # else # error Unable to determine suitable type for EMACS_INT # endif #endif #ifndef EMACS_UINT # define EMACS_UINT unsigned EMACS_INT #endif #define BITS_PER_EMACS_INT (SIZEOF_EMACS_INT * BITS_PER_CHAR) typedef unsigned char Ibyte; typedef char CIbyte; typedef char Ascbyte; typedef unsigned char UAscbyte; typedef int Ichar; typedef EMACS_INT Bytecount; typedef EMACS_INT Charbpos; typedef EMACS_INT Membpos; typedef unsigned long Hashcode; # define DO_NOTHING do {} while (0) #ifdef USE_ASSERTIONS void assert_failed (const char *, int, const char *); # define abort() (assert_failed (__FILE__, __LINE__, "abort()")) # define assert(x) ((x) ? (void) 0 : assert_failed (__FILE__, __LINE__, #x)) # define assert_with_message(x, msg) \ ((x) ? (void) 0 : assert_failed (__FILE__, __LINE__, msg)) # define assert_at_line(x, file, line) \ ((x) ? (void) 0 : assert_failed (file, line, #x)) #else # ifdef DEBUG_XEMACS # define assert(x) ((x) ? (void) 0 : (void) abort ()) # define assert_with_message(x, msg) ((x) ? (void) 0 : (void) abort ()) # define assert_at_line(x, file, line) assert (x) # else # define assert(x) ((void) 0) # define assert_with_message(x, msg) # define assert_at_line(x, file, line) assert (x) # endif #endif #define countof(x) ((int) (sizeof(x)/sizeof((x)[0]))) #define xzero(lvalue) ((void) memset (&(lvalue), '\0', sizeof (lvalue))) void *xmalloc (Bytecount size) __attribute__ ((malloc)); enum Lisp_Type { Lisp_Type_Record, Lisp_Type_Int_Even, Lisp_Type_Char, Lisp_Type_Int_Odd }; #define GCMARKBITS 0 #define GCTYPEBITS 2 #define GCBITS 2 #define INT_GCBITS 1 #define INT_VALBITS (BITS_PER_EMACS_INT - INT_GCBITS) #define VALBITS (BITS_PER_EMACS_INT - GCBITS) #define EMACS_INT_MAX ((EMACS_INT) ((1UL << (INT_VALBITS - 1)) -1UL)) #define EMACS_INT_MIN (-(EMACS_INT_MAX) - 1) /* WARNING: evaluates its arg twice. */ #define NUMBER_FITS_IN_AN_EMACS_INT(num) \ ((num) <= EMACS_INT_MAX && (num) >= EMACS_INT_MIN) /*** Stuff from lisp-union.h ***/ typedef union Lisp_Object { /* non-valbits are at higher addresses */ struct { enum_field (Lisp_Type) type : GCTYPEBITS; EMACS_UINT val : VALBITS; } gu; struct { unsigned int bits : INT_GCBITS; signed EMACS_INT val : INT_VALBITS; } s; struct { unsigned int bits : INT_GCBITS; EMACS_UINT val : INT_VALBITS; } u; EMACS_UINT ui; signed EMACS_INT i; /* This was formerly declared 'void *v' etc. but that causes GCC to accept any (yes, any) pointer as the argument of a function declared to accept a Lisp_Object. */ struct nosuchstruct *v; } Lisp_Object; #define XCHARVAL(x) ((x).gu.val) #define XPNTRVAL(x) ((x).ui) #define XREALINT(x) ((x).s.val) #define XTYPE(x) ((x).gu.type) #define EQ(x,y) ((x).v == (y).v) DECLARE_INLINE_HEADER ( Lisp_Object make_int (EMACS_INT val) ) { Lisp_Object obj; obj.s.bits = 1; obj.s.val = val; return obj; } DECLARE_INLINE_HEADER ( Lisp_Object make_char_1 (Ichar val) ) { Lisp_Object obj; obj.gu.type = Lisp_Type_Char; obj.gu.val = val; return obj; } DECLARE_INLINE_HEADER ( Lisp_Object wrap_pointer_1 (const void *ptr) ) { Lisp_Object obj; obj.ui = (EMACS_UINT) ptr; return obj; } #define INTP(x) ((x).s.bits) /*** More stuff from lisp.h ***/ #define XPNTR(x) ((void *) XPNTRVAL(x)) /*** Stuff from lrecord.h ***/ struct lrecord_header { /* Index into lrecord_implementations_table[]. Objects that have been explicitly freed using e.g. free_cons() have lrecord_type_free in this field. */ unsigned int type :8; /* If `mark' is 0 after the GC mark phase, the object will be freed during the GC sweep phase. There are 2 ways that `mark' can be 1: - by being referenced from other objects during the GC mark phase - because it is permanently on, for c_readonly objects */ unsigned int mark :1; /* 1 if the object resides in logically read-only space, and does not reference other non-c_readonly objects. Invariant: if (c_readonly == 1), then (mark == 1 && lisp_readonly == 1) */ unsigned int c_readonly :1; /* 1 if the object is readonly from lisp */ unsigned int lisp_readonly :1; unsigned int unused :21; }; struct lrecord_implementation; int lrecord_type_index (const struct lrecord_implementation *implementation); #define set_lheader_implementation(header,imp) do { \ struct lrecord_header* SLI_header = (header); \ SLI_header->type = (imp)->lrecord_type_index; \ SLI_header->mark = 0; \ SLI_header->c_readonly = 0; \ SLI_header->lisp_readonly = 0; \ } while (0) enum lrecord_type { /* This is not the real list; we only use a few of the real items. */ lrecord_type_float, lrecord_type_bignum, lrecord_type_last_built_in_type /* must be last */ }; struct lrecord_implementation { const char *name; /* information for the dumper: is the object dumpable and should it be dumped. */ unsigned int dumpable :1; /* `marker' 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. NOTE NOTE NOTE: This is not used by KKCC (which uses the data description below instead), unless the data description is missing. Yes, this currently means there is logic duplication. Eventually the mark methods will be removed. */ Lisp_Object (*marker) (Lisp_Object); /* `printer' converts the object to a printed representation. This can be NULL; in this case default_object_printer() will be used instead. */ void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag); /* `finalizer' 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 `finalizer' is called at dump time even though the object is not being freed. */ void (*finalizer) (void *header, int for_disksave); /* This can be NULL, meaning compare objects with EQ(). */ int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth); /* `hash' generates hash values for use with hash tables that have `equal' as their test function. This can be NULL, meaning use the Lisp_Object itself as the hash. But, you must still satisfy the constraint that if two objects are `equal', then they *must* hash to the same value in order for hash tables to work properly. This means that `hash' can be NULL only if the `equal' method is also NULL. */ unsigned long (*hash) (Lisp_Object, int); /* Data layout description for your object. See long comment below. */ const struct memory_description *description; /* These functions allow any object type to have builtin property lists that can be manipulated from the lisp level with `get', `put', `remprop', and `object-plist'. */ 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); /* Only one of `static_size' and `size_in_bytes_method' is non-0. If both are 0, this type is not instantiable by basic_alloc_lcrecord(). */ Bytecount static_size; Bytecount (*size_in_bytes_method) (const void *header); /* The (constant) index into lrecord_implementations_table */ enum lrecord_type lrecord_type_index; /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e. one that does not have an lcrecord_header at the front and which is (usually) allocated in frob blocks. */ unsigned int basic_p :1; }; #define MODULE_DEFINABLE_TYPE_COUNT 32 const struct lrecord_implementation * lrecord_implementations_table[lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; #define XRECORD_LHEADER_IMPLEMENTATION(obj) \ LHEADER_IMPLEMENTATION (XRECORD_LHEADER (obj)) #define LHEADER_IMPLEMENTATION(lh) lrecord_implementations_table[(lh)->type] #define C_READONLY_RECORD_HEADER_P(lheader) ((lheader)->c_readonly) #define LISP_READONLY_RECORD_HEADER_P(lheader) ((lheader)->lisp_readonly) #define SET_C_READONLY_RECORD_HEADER(lheader) do { \ struct lrecord_header *SCRRH_lheader = (lheader); \ SCRRH_lheader->c_readonly = 1; \ SCRRH_lheader->lisp_readonly = 1; \ SCRRH_lheader->mark = 1; \ } while (0) #define SET_LISP_READONLY_RECORD_HEADER(lheader) \ ((void) ((lheader)->lisp_readonly = 1)) #ifdef USE_KKCC #define RECORD_DESCRIPTION(lheader) lrecord_memory_descriptions[(lheader)->type] #else /* not USE_KKCC */ #define RECORD_MARKER(lheader) lrecord_markers[(lheader)->type] #endif /* not USE_KKCC */ #define RECORD_DUMPABLE(lheader) (lrecord_implementations_table[(lheader)->type])->dumpable enum memory_description_type { XD_LISP_OBJECT_ARRAY, XD_LISP_OBJECT, XD_LO_LINK, XD_OPAQUE_PTR, XD_OPAQUE_PTR_CONVERTIBLE, XD_OPAQUE_DATA_CONVERTIBLE, XD_STRUCT_PTR, XD_STRUCT_ARRAY, XD_OPAQUE_DATA_PTR, XD_UNION, XD_UNION_DYNAMIC_SIZE, XD_C_STRING, XD_DOC_STRING, XD_INT_RESET, XD_BYTECOUNT, XD_ELEMCOUNT, XD_HASHCODE, XD_INT, XD_LONG, XD_END }; enum data_description_entry_flags { /* If set, KKCC does not process this entry. (1) One obvious use is with things that pdump saves but which do not get marked normally -- for example the next and prev fields in a marker. The marker chain is weak, with its entries removed when they are finalized. (2) This can be set on structures not containing any Lisp objects, or (more usefully) on structures that contain Lisp objects but where the objects always occur in another structure as well. For example, the extent lists kept by a buffer keep the extents in two lists, one sorted by the start of the extent and the other by the end. There's no point in marking both, since each contains the same objects as the other; but when dumping (if we were to dump such a structure), when computing memory size, etc., it's crucial to tag both sides. */ XD_FLAG_NO_KKCC = 1, /* If set, pdump does not process this entry. */ XD_FLAG_NO_PDUMP = 2, /* Indicates that this is a "default" entry in a union map. */ XD_FLAG_UNION_DEFAULT_ENTRY = 4, /* Indicates that this is a free Lisp object we're marking. Only relevant for ERROR_CHECK_GC. This occurs when we're marking lcrecord-lists, where the objects have had their type changed to lrecord_type_free and also have had their free bit set, but we mark them as normal. */ XD_FLAG_FREE_LISP_OBJECT = 8 #if 0 , /* Suggestions for other possible flags: */ /* Eliminate XD_UNION_DYNAMIC_SIZE and replace it with a flag, like this. */ XD_FLAG_UNION_DYNAMIC_SIZE = 16, /* Require that everyone who uses a description map has to flag it, so that it's easy to tell, when looking through the code, where the description maps are and who's using them. This might also become necessary if for some reason the format of the description map is expanded and we need to stick a pointer in the second slot (although we could still ensure that the second slot in the first entry was NULL or <0). */ XD_FLAG_DESCRIPTION_MAP = 32 #endif }; union memory_contents_description { /* The first element is used by static initializers only. We always read from one of the other two pointers. */ const void *write_only; const struct sized_memory_description *descr; const struct opaque_convert_functions *funcs; }; struct memory_description { enum memory_description_type type; Bytecount offset; EMACS_INT data1; union memory_contents_description data2; /* Indicates which subsystems process this entry, plus (potentially) other flags that apply to this entry. */ int flags; }; struct sized_memory_description { Bytecount size; const struct memory_description *description; }; struct opaque_convert_functions { /* Used by XD_OPAQUE_PTR_CONVERTIBLE and XD_OPAQUE_DATA_CONVERTIBLE */ /* Converter to external representation, for those objects from external libraries that can't be directly dumped as opaque data because they contain pointers. This is called at dump time to convert to an opaque, pointer-less representation. This function must put a pointer to the opaque result in *data and its size in *size. */ void (*convert)(const void *object, void **data, Bytecount *size); /* Post-conversion cleanup. Optional (null if not provided). When provided it will be called post-dumping to free any storage allocated for the conversion results. */ void (*convert_free)(const void *object, void *data, Bytecount size); /* De-conversion. At reload time, rebuilds the object from the converted form. "object" is 0 for the PTR case, return is ignored in the DATA case. */ void *(*deconvert)(void *object, void *data, Bytecount size); }; extern const struct sized_memory_description lisp_object_description; #define XD_INDIRECT(val, delta) (-1 - (Bytecount) ((val) | ((delta) << 8))) #define XD_IS_INDIRECT(code) ((code) < 0) #define XD_INDIRECT_VAL(code) ((-1 - (code)) & 255) #define XD_INDIRECT_DELTA(code) ((-1 - (code)) >> 8) #define XD_DYNARR_DESC(base_type, sub_desc) \ { XD_STRUCT_PTR, offsetof (base_type, base), XD_INDIRECT(1, 0), sub_desc }, \ { XD_INT, offsetof (base_type, cur) }, \ { XD_INT_RESET, offsetof (base_type, max), XD_INDIRECT(1, 0) } \ #define XD_CVFUNCTS(functs) 0, (const struct sized_memory_description *)&(functs) #define DEFINE_BASIC_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,structtype) \ DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype) #define DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \ MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof(structtype),0,1,structtype) #define MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \ const struct lrecord_implementation lrecord_##c_name = \ { name, dumpable, marker, printer, nuker, equal, hash, desc, \ getprop, putprop, remprop, plist, size, sizer, \ lrecord_type_##c_name, basic_p } #ifdef USE_KKCC const struct memory_description *lrecord_memory_descriptions[3]; #define INIT_LRECORD_IMPLEMENTATION(type) do { \ lrecord_implementations_table[lrecord_type_##type] = &lrecord_##type; \ lrecord_memory_descriptions[lrecord_type_##type] = \ lrecord_implementations_table[lrecord_type_##type]->description; \ } while (0) #else /* not USE_KKCC */ extern Lisp_Object (*lrecord_markers[]) (Lisp_Object); #define INIT_LRECORD_IMPLEMENTATION(type) do { \ lrecord_implementations_table[lrecord_type_##type] = &lrecord_##type; \ lrecord_markers[lrecord_type_##type] = \ lrecord_implementations_table[lrecord_type_##type]->marker; \ } while (0) #endif /* not USE_KKCC */ #define LRECORDP(a) (XTYPE (a) == Lisp_Type_Record) #define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a)) #define RECORD_TYPEP(x, ty) \ (LRECORDP (x) && (XRECORD_LHEADER (x)->type == (unsigned int) (ty))) #ifdef ERROR_CHECK_TYPES # define DECLARE_LRECORD(c_name, structtype) \ extern const struct lrecord_implementation lrecord_##c_name; \ DECLARE_INLINE_HEADER ( \ structtype * \ error_check_##c_name (Lisp_Object obj, const char *file, int line) \ ) \ { \ assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p # define XRECORD(x, c_name, structtype) \ error_check_##c_name (x, __FILE__, __LINE__) DECLARE_INLINE_HEADER ( Lisp_Object wrap_record_1 (const void *ptr, enum lrecord_type ty, const char *file, int line) ) { Lisp_Object obj = wrap_pointer_1 (ptr); assert_at_line (RECORD_TYPEP (obj, ty), file, line); return obj; } #define wrap_record(ptr, ty) \ wrap_record_1 (ptr, lrecord_type_##ty, __FILE__, __LINE__) #else /* not ERROR_CHECK_TYPES */ # define DECLARE_LRECORD(c_name, structtype) \ extern Lisp_Object Q##c_name##p; \ extern const struct lrecord_implementation lrecord_##c_name # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x)) /* wrap_pointer_1 is so named as a suggestion not to use it unless you know what you're doing. */ #define wrap_record(ptr, ty) wrap_pointer_1 (ptr) #endif /* not ERROR_CHECK_TYPES */ #define RECORDP(x, c_name) RECORD_TYPEP (x, lrecord_type_##c_name) /*** Yet more stuff from lisp.h ***/ static Lisp_Object Qnil; #define CHARP(x) (XTYPE (x) == Lisp_Type_Char) #ifdef ERROR_CHECK_TYPES DECLARE_INLINE_HEADER ( Ichar XCHAR_1 (Lisp_Object obj, const char *file, int line) ) { assert_at_line (CHARP (obj), file, line); return XCHARVAL (obj); } #define XCHAR(x) XCHAR_1 (x, __FILE__, __LINE__) #else /* no error checking */ #define XCHAR(x) ((Ichar) XCHARVAL (x)) #endif /* no error checking */ #ifdef ERROR_CHECK_TYPES #define XCHAR_OR_INT(x) XCHAR_OR_INT_1 (x, __FILE__, __LINE__) #define XINT(x) XINT_1 (x, __FILE__, __LINE__) DECLARE_INLINE_HEADER ( EMACS_INT XINT_1 (Lisp_Object obj, const char *file, int line) ) { assert_at_line (INTP (obj), file, line); return XREALINT (obj); } DECLARE_INLINE_HEADER ( EMACS_INT XCHAR_OR_INT_1 (Lisp_Object obj, const char *file, int line) ) { assert_at_line (INTP (obj) || CHARP (obj), file, line); return CHARP (obj) ? XCHAR (obj) : XINT (obj); } #else /* no error checking */ #define XINT(obj) XREALINT (obj) #define XCHAR_OR_INT(obj) (CHARP (obj) ? XCHAR (obj) : XINT (obj)) #endif /* no error checking */ /*------------------------------ float ---------------------------------*/ /* Note: the 'unused_next_' field exists only to ensure that the `next' pointer fits within the structure, for the purposes of the free list. This makes a difference in the unlikely case of sizeof(double) being smaller than sizeof(void *). */ struct Lisp_Float { struct lrecord_header lheader; union { double d; struct Lisp_Float *unused_next_; } data; }; typedef struct Lisp_Float Lisp_Float; DECLARE_LRECORD (float, Lisp_Float); #define XFLOAT(x) XRECORD (x, float, Lisp_Float) #define wrap_float(p) wrap_record (p, float) #define FLOATP(x) RECORDP (x, float) #define CHECK_FLOAT(x) CHECK_RECORD (x, float) #define CONCHECK_FLOAT(x) CONCHECK_RECORD (x, float) #define float_data(f) ((f)->data.d) #define XFLOAT_DATA(x) float_data (XFLOAT (x)) #define XFLOATINT(n) extract_float (n) #define CHECK_INT_OR_FLOAT(x) do { \ if (!INT_OR_FLOATP (x)) \ dead_wrong_type_argument (Qnumberp, x); \ } while (0) #define CONCHECK_INT_OR_FLOAT(x) do { \ if (!INT_OR_FLOATP (x)) \ x = wrong_type_argument (Qnumberp, x); \ } while (0) # define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x)) /*** Stuff from text.h ***/ int non_ascii_valid_ichar_p (Ichar UNUSED (ch)) { /* We do not need the actual implementation */ return 1; } DECLARE_INLINE_HEADER ( int valid_ichar_p (Ichar ch) ) { return (! (ch & ~0xFF)) || non_ascii_valid_ichar_p (ch); } DECLARE_INLINE_HEADER ( Lisp_Object make_char (Ichar val) ) { type_checking_assert (valid_ichar_p (val)); return make_char_1 (val); } /*** Stuff from number-gmp.h ***/ typedef mpz_t bignum; #define bignum_init(b) mpz_init (b) #define bignum_hashcode(b) mpz_get_ui (b) #define bignum_fits_int_p(b) mpz_fits_sint_p (b) #define bignum_to_string(b,base) mpz_get_str (NULL, base, b) #define bignum_to_int(b) ((int) mpz_get_si (b)) #define bignum_to_double(b) mpz_get_d (b) #define bignum_set(b1,b2) mpz_set (b1, b2) #define bignum_set_string(b,s,base) mpz_set_str (b, s, base) #define bignum_set_long(b,l) mpz_set_si (b, l) #define bignum_add(b,b1,b2) mpz_add (b, b1, b2) #define bignum_eql(b1,b2) (mpz_cmp (b1, b2) == 0) /*** Stuff from number.h ***/ struct Lisp_Bignum { struct lrecord_header lheader; bignum data; }; typedef struct Lisp_Bignum Lisp_Bignum; DECLARE_LRECORD (bignum, Lisp_Bignum); #define XBIGNUM(x) XRECORD (x, bignum, Lisp_Bignum) #define wrap_bignum(p) wrap_record (p, bignum) #define BIGNUMP(x) RECORDP (x, bignum) #define bignum_data(b) (b)->data #define XBIGNUM_DATA(x) bignum_data (XBIGNUM (x)) #define INTEGERP(x) (INTP(x) || BIGNUMP(x)) bignum scratch_bignum, scratch_bignum2; #define make_integer(x) \ (NUMBER_FITS_IN_AN_EMACS_INT (x) ? make_int (x) : make_bignum (x)) /*** Stuff from number.c ***/ static void bignum_print (Lisp_Object obj, Lisp_Object UNUSED (printcharfun), int UNUSED (escapeflag)) { /* Not the real implementation */ CIbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10); printf (bstr); free (bstr); } static int bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) { return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); } static Hashcode bignum_hash (Lisp_Object obj, int UNUSED (depth)) { return bignum_hashcode (XBIGNUM_DATA (obj)); } static void bignum_convert (const void *object, void **data, Bytecount *size) { CIbyte *bstr = bignum_to_string (*(bignum *)object, 10); *data = bstr; *size = strlen(bstr)+1; } static void bignum_convfree (const void * UNUSED (object), void *data, Bytecount UNUSED (size)) { free (data); } static void * bignum_deconvert (void *object, void *data, Bytecount UNUSED (size)) { bignum *b = (bignum *) object; bignum_init(*b); bignum_set_string(*b, (const char *) data, 10); return object; } static const struct opaque_convert_functions bignum_opc = { bignum_convert, bignum_convfree, bignum_deconvert }; static const struct memory_description bignum_description[] = { { XD_OPAQUE_DATA_CONVERTIBLE, offsetof (Lisp_Bignum, data), 0, { &bignum_opc }, XD_FLAG_NO_KKCC }, { XD_END, 0, 0, { 0 }, 0 } }; DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bignum", bignum, 1, 0, bignum_print, 0, bignum_equal, bignum_hash, bignum_description, Lisp_Bignum); Lisp_Object Fcanonicalize_number (Lisp_Object number) { /* The tests should go in order from larger, more expressive, or more complex types to smaller, less expressive, or simpler types so that a number can cascade all the way down to the simplest type if appropriate. */ /* Actually handle ratios here */ if (BIGNUMP (number) && bignum_fits_int_p (XBIGNUM_DATA (number))) { int n = bignum_to_int (XBIGNUM_DATA (number)); if (NUMBER_FITS_IN_AN_EMACS_INT (n)) number = make_int (n); } return number; } /*** Stuff from floatfns.c ***/ double extract_float (Lisp_Object num) { if (FLOATP (num)) return XFLOAT_DATA (num); if (INTP (num)) return (double) XINT (num); return 0.0; } static Lisp_Object mark_float (Lisp_Object UNUSED (obj)) { return Qnil; } static int float_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) { return (extract_float (obj1) == extract_float (obj2)); } static Hashcode float_hash (Lisp_Object obj, int UNUSED (depth)) { /* mod the value down to 32-bit range */ /* #### change for 64-bit machines */ return (unsigned long) fmod (extract_float (obj), 4e9); } static const struct memory_description float_description[] = { { XD_END, 0, 0, { 0 }, 0 } }; DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, 1, /*dumpable-flag*/ mark_float, 0, 0, float_equal, float_hash, float_description, Lisp_Float); /*** Stuff from alloc.c ***/ /* Not the real memory_full function */ static void memory_full (void) { fprintf (stderr, "Out of memory!\n"); exit (1); } static void malloc_after (void *val, Bytecount size) { if (!val && size != 0) memory_full (); } void * xmalloc (Bytecount size) { void *val = malloc (size); malloc_after (val, size); return val; } static void * allocate_lisp_storage (Bytecount size) { void *val = xmalloc (size); memset (val, 0, size); return val; } #define MALLOC_OVERHEAD 0 #ifdef ALLOC_NO_POOLS # define TYPE_ALLOC_SIZE(type, structtype) 1 #else # define TYPE_ALLOC_SIZE(type, structtype) \ ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ / sizeof (structtype)) #endif /* ALLOC_NO_POOLS */ #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ \ struct type##_block \ { \ struct type##_block *prev; \ structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ }; \ \ static struct type##_block *current_##type##_block; \ static int current_##type##_block_index; \ \ static Lisp_Free *type##_free_list; \ static Lisp_Free *type##_free_list_tail; \ \ static void \ init_##type##_alloc (void) \ { \ current_##type##_block = 0; \ current_##type##_block_index = \ countof (current_##type##_block->block); \ type##_free_list = 0; \ type##_free_list_tail = 0; \ } \ \ static int gc_count_num_##type##_in_use; \ static int gc_count_num_##type##_freelist #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ if (current_##type##_block_index \ == countof (current_##type##_block->block)) \ { \ struct type##_block *AFTFB_new = (struct type##_block *) \ allocate_lisp_storage (sizeof (struct type##_block)); \ AFTFB_new->prev = current_##type##_block; \ current_##type##_block = AFTFB_new; \ current_##type##_block_index = 0; \ } \ (result) = \ &(current_##type##_block->block[current_##type##_block_index++]); \ } while (0) #define ALLOCATE_FIXED_TYPE(type, structtype, result) do { \ if (type##_free_list) \ { \ result = (structtype *) type##_free_list; \ type##_free_list = type##_free_list->chain; \ } \ else \ ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ MARK_LRECORD_AS_NOT_FREE (result); \ } while (0) /* Lisp_Free is the type to represent a free list member inside a frob block of any lisp object type. */ typedef struct Lisp_Free { struct lrecord_header lheader; struct Lisp_Free *chain; } Lisp_Free; #define LRECORD_FREE_P(ptr) \ (((struct lrecord_header *) ptr)->type == lrecord_type_free) #define MARK_LRECORD_AS_FREE(ptr) \ ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free)) #ifdef ERROR_CHECK_GC #define MARK_LRECORD_AS_NOT_FREE(ptr) \ ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined)) #else #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING #endif DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 Lisp_Object make_float (double float_value) { Lisp_Float *f; ALLOCATE_FIXED_TYPE (float, Lisp_Float, f); /* Avoid dump-time `uninitialized memory read' purify warnings. */ if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) xzero (*f); set_lheader_implementation (&f->lheader, &lrecord_float); float_data (f) = float_value; return wrap_float (f); } DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 Lisp_Object make_bignum (long bignum_value) { Lisp_Bignum *b = (Lisp_Bignum *) calloc (1, sizeof (Lisp_Bignum)); set_lheader_implementation (&b->lheader, &lrecord_bignum); bignum_init (bignum_data (b)); bignum_set_long (bignum_data (b), bignum_value); return wrap_bignum (b); } /* WARNING: This function returns a bignum even if its argument fits into a fixnum. See Fcanonicalize_number(). */ Lisp_Object make_bignum_bg (bignum bg) { Lisp_Bignum *b; ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); set_lheader_implementation (&b->lheader, &lrecord_bignum); bignum_init (bignum_data (b)); bignum_set (bignum_data (b), bg); return wrap_bignum (b); } /*** The stuff that illustrates the bug ***/ Lisp_Object Qnumber_char_or_marker_p; void assert_failed (const char *file, int line, const char *expr) { /* This is not the actual implementation (unnecessary) */ fprintf (stderr, "Assertion failure: %s, line %d, %s\n", file, line, expr); exit (-1); } Lisp_Object wrong_type_argument (Lisp_Object UNUSED (predicate), Lisp_Object value) { /* Not the actual implementation. We really want to force the user to give us a new value. */ return value; } Lisp_Object Fadd1 (Lisp_Object number) { retry: if (INTP (number)) return make_integer (XINT (number) + 1); if (CHARP (number)) return make_integer (XCHAR (number) + 1); if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); if (BIGNUMP (number)) { bignum_set_long (scratch_bignum, 1L); bignum_add (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); } /* Actually handle ratios and bigfloats here */ number = wrong_type_argument (Qnumber_char_or_marker_p, number); goto retry; } int main () { int i; INIT_LRECORD_IMPLEMENTATION (float); INIT_LRECORD_IMPLEMENTATION (bignum); bignum_init (scratch_bignum); bignum_init (scratch_bignum2); Qnumber_char_or_marker_p = make_int (-1); init_float_alloc (); for (i = 0; i < 20; i++) { Lisp_Object obj; printf ("If I add 1 to %d, I get ", i); obj = Fadd1 (make_char (i)); if (BIGNUMP (obj)) { puts ("a bignum."); } else { printf ("%ld.\n", XINT (obj)); } } return 0; }