Bignum support still broken on powerpc (ping: Jerry James)
Jerry James
Jerry.James at xemacs.org
Mon Apr 10 18:35:33 EDT 2006
robert delius royar <xemacs at frinabulax.org> wrote:
> OK, I simply removed the 'if (__GMP_ULONG_MAX <= GMP_NUMB_MASK)' from line
> 1595 of gmp.h. That stopped the warnings. Now, my loadup/dump fails with the
> same type error
> Requiring disp-table.el...*** Error in XEmacs initialization
> (wrong-type-argument integer-or-char-p 225)
I wonder if you are triggering a similar bug to the icc bug that bit me.
Let's see. I am attaching the test case I sent Intel a couple of years
ago. You'll have to edit the Makefile a bit, but try it out and see if
the test program reports that you are getting bignum results. You
shouldn't be.
-------------- next part --------------
# ICC flags
ICC_WARN_FLAGS = -Wall -w1 -we147
ICC_OPT_FLAGS = -O3 -Ob2
ICC_ARCH_FLAGS = -tpp7 -xN
ICC_DEBUG_FLAGS = -g -fp
ICC_CFLAGS = $(ICC_WARN_FLAGS) $(ICC_OPT_FLAGS) $(ICC_ARCH_FLAGS) $(ICC_DEBUG_FLAGS)
ICC_LDFLAGS = -lgmp -Xlinker -rpath -Xlinker /opt/intel/cc/9.0/lib
# GCC flags
GCC_WARN_FLAGS = -Wall -Wextra
GCC_OPT_FLAGS = -Os
GCC_ARCH_FLAGS = -march=prescott
GCC_DEBUG_FLAGS = -g3
GCC_CFLAGS = $(GCC_WARN_FLAGS) $(GCC_OPT_FLAGS) $(GCC_ARCH_FLAGS) $(GCC_DEBUG_FLAGS)
GCC_LDFLAGS = -lgmp -lm
all: test test-gcc
test: test.c
icc $(ICC_CFLAGS) $< $(ICC_LDFLAGS) -o $@
test-gcc: test.c
gcc $(GCC_CFLAGS) $< $(GCC_LDFLAGS) -o $@
-------------- next part --------------
#include <math.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gmp.h>
#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;
}
-------------- next part --------------
--
Jerry James, Assistant Professor james at xemacs.org
Computer Science Department http://www.cs.usu.edu/~jerry/
Utah State University
More information about the XEmacs-Beta
mailing list
