Mercurial > hg > xemacs-beta
changeset 1983:9c872f33ecbe
[xemacs-hg @ 2004-04-05 22:49:31 by james]
Add bignum, ratio, and bigfloat support.
| author | james |
|---|---|
| date | Mon, 05 Apr 2004 22:50:11 +0000 |
| parents | a748951fd4fb |
| children | 36760cdcb631 |
| files | lisp/ChangeLog lisp/cl-extra.el lisp/cl.el src/ChangeLog src/Makefile.in.in src/alloc.c src/bytecode.c src/config.h.in src/data.c src/depend src/doprnt.c src/emacs.c src/floatfns.c src/fns.c src/general-slots.h src/lisp.h src/lread.c src/lrecord.h src/number-gmp.c src/number-gmp.h src/number-mp.c src/number-mp.h src/number.c src/number.h src/symsinit.h src/sysdep.c tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 28 files changed, 4349 insertions(+), 59 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Mon Apr 05 21:50:47 2004 +0000 +++ b/lisp/ChangeLog Mon Apr 05 22:50:11 2004 +0000 @@ -1,3 +1,12 @@ +2004-04-05 Jerry James <james@xemacs.org> + + * cl-extra.el (coerce): Add support for general numeric conversions. + * cl.el (eql): Update for more number types. + * cl.el (cl-random-time): Ensure the result is a fixnum. + * cl.el (most-positive-fixnum): Do not define in Lisp if enhanced + number types are available. + * cl.el (most-negative-fixnum): Ditto. + 2004-03-23 Adrian Aichner <adrian@xemacs.org> * code-process.el (call-process-region): Correct start and end
--- a/lisp/cl-extra.el Mon Apr 05 21:50:47 2004 +0000 +++ b/lisp/cl-extra.el Mon Apr 05 22:50:11 2004 +0000 @@ -80,6 +80,9 @@ ((and (eq type 'character) (char-int-p x)) (int-char x)) ((and (eq type 'integer) (characterp x)) (char-int x)) ((eq type 'float) (float x)) + ((and (featurep 'number-types) + (memq type '(integer ratio bigfloat)) + (coerce-number x type))) ((eq type 'bit-vector) (if (bit-vector-p x) x (apply 'bit-vector (append x nil)))) ((eq type 'weak-list)
--- a/lisp/cl.el Mon Apr 05 21:50:47 2004 +0000 +++ b/lisp/cl.el Mon Apr 05 22:50:11 2004 +0000 @@ -151,10 +151,8 @@ (defun eql (a b) ; See compiler macro in cl-macs.el "Return t if the two args are the same Lisp object. Floating-point numbers of equal value are `eql', but they may not be `eq'." - (if (floatp a) - (equal a b) - (eq a b))) - + (or (eq a b) + (and (numberp a) (numberp b) (equal a b)))) ;;; Generalized variables. These macros are defined here so that they ;;; can safely be used in .emacs files. @@ -313,7 +311,9 @@ (defun cl-random-time () (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) + (if (featurep 'number-types) + (coerce-number v 'fixnum) + v))) (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) @@ -364,11 +364,13 @@ (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) +;; These constants are defined in C when 'number-types is provided. +(unless (featurep 'number-types) ;;; We use `eval' in case VALBITS differs from compile-time to load-time. -(defconst most-positive-fixnum (eval '(lsh -1 -1)) - "The integer closest in value to positive infinity.") -(defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1))) - "The integer closest in value to negative infinity.") + (defconst most-positive-fixnum (eval '(lsh -1 -1)) + "The integer closest in value to positive infinity.") + (defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1))) + "The integer closest in value to negative infinity.")) ;;; The following are set by code in cl-extra.el (defconst most-positive-float nil
--- a/src/ChangeLog Mon Apr 05 21:50:47 2004 +0000 +++ b/src/ChangeLog Mon Apr 05 22:50:11 2004 +0000 @@ -1,3 +1,89 @@ +2004-04-05 Jerry James <james@xemacs.org> + + * Makefile.in.in (number_objs): New. + * Makefile.in.in (objs): Use it. + * alloc.c: Make comment more precise. + * alloc.c (make_bignum): New function. + * alloc.c (make_bignum_bg): New function. + * alloc.c (make_ratio): New function. + * alloc.c (make_ratio_bg): New function. + * alloc.c (make_ratio_rt): New function. + * alloc.c (make_bigfloat): New function. + * alloc.c (make_bigfloat_bf): New function. + * alloc.c (sweep_bignums): New function. + * alloc.c (sweep_ratios): New function. + * alloc.c (sweep_bigfloats): New function. + * alloc.c (gc_sweep): Use the new sweep functions. + * alloc.c (Fgarbage_collect): Report collected number objects. + * alloc.c (common_init_alloc_early): Initialize number allocators. + * bytecode.c (bytecode_negate): Negate more number types. + * bytecode.c (bytecode_arithcompare): Compare more number types. + * bytecode.c (bytecode_arithop): Operate on more number types. + * bytecode.c (execute_optimized_program): Several changes in + support of the new number types. + * config.h.in: Add SIZEOF_DOUBLE, DOUBLE_BITS, WITH_NUMBER_TYPES, + WITH_GMP, WITH_MP, MP_PREFIX, and HAVE_MP_MOVE. + * data.c: Add symbol Qnonnegativep. + * data.c (Ffixnump): New function. + * data.c (Fnatnump): Work with bignums alos. + * data.c (Fnonnegativep): New function. + * data.c (Fnumberp): Return t for any number type. + * data.c (ARITHCOMPARE_MANY): Add cases for the new number types. + * data.c (Feqlsign): Work with the new number types. + * data.c (Flss): Ditto. + * data.c (Fgtr): Ditto. + * data.c (Fleq): Ditto. + * data.c (Fgeq): Ditto. + * data.c (Fneq): Ditto. + * data.c (Fzerop): Ditto. + * data.c (Fnumber_to_string): Ditto. + * data.c (Fstring_to_number): Ditto. + * data.c (Fplus): Ditto. + * data.c (Fminus): Ditto. + * data.c (Ftimes): Ditto. + * data.c (Fdiv): New function to produce ratios. + * data.c (Fquo): Work with the new number types. + * data.c (Fmax): Ditto. + * data.c (Fmin): Ditto. + * data.c (Flogand): Ditto. + * data.c (Flogior): Ditto. + * data.c (Flogxor): Ditto. + * data.c (Flognot): Ditto. + * data.c (Frem): Ditto. + * data.c (Fmod): Ditto. + * data.c (Fash): Ditto. + * data.c (Flsh): Ditto. + * data.c (Fadd1): Ditto. + * data.c (Fsub1): Ditto. + * data.c (syms_of_data): Declare new symbols and Lisp functions. + * depend: Regenerate. + * doprnt.c: Add converters for the new number types. + * doprnt.c (union printf_arg): Add new obj field. + * doprnt.c (get_doprnt_args): Use the new converters. + * doprnt.c (emacs_doprnt_1): Convert and print the new number types. + * emacs.c (main_1): Call syms_of_, vars_of_, and init_number. + * floatfns.c (float_to_int): Convert to bignums if necessary. + * floatfns.c (extract_float): Extract the new number types. + * floatfns.c (Fexpt): Work with bignums. + * floatfns.c (Fsqrt): Ditto. + * floatfns.c (Fabs): Work with the new number types. + * floatfns.c (Ffloat): Ditto. + * floatfns.c (Fceiling): Ditto. + * floatfns.c (Ffloor): Ditto. + * floatfns.c (Fround): Ditto. + * floatfns.c (Ftruncate): Ditto. + * fns.c (Frandom): Update docstring and accept bignum limits. + * fns.c (internal_equalp): Work with the new number types. + * general-slots.h: Add new type name symbols. + * lisp.h: Include number.h. Add isratio_string prototype. + Declare Qnonnegativep and Qnumberp. + * lread.c (read_atom): Read ratios. + * lread.c (parse_integer): Read bignums. + * lread.c (isratio_string): New functions. + * lrecord.h (lrecord_type): Add new number type values. + * symsinit.h: Declare syms_of_, vars_of_, and init_number. + * sysdep.c (seed_random): Set the bignum random seed. + 2004-03-30 Zajcev Evgeny <zevlg@yandex.ru> * window.c: Declare `allow_deletion_of_last_visible_frame' extern.
--- a/src/Makefile.in.in Mon Apr 05 21:50:47 2004 +0000 +++ b/src/Makefile.in.in Mon Apr 05 22:50:11 2004 +0000 @@ -204,6 +204,13 @@ mule_wnn_objs=mule-wnnfns.o #endif +#ifdef WITH_GMP +number_objs=number-gmp.o number.o +#endif +#ifdef WITH_MP +number_objs=number-mp.o number.o +#endif + #if defined(HAVE_POSTGRESQL) && !defined(HAVE_SHLIB) postgresql_objs=$(BLDMODULES)/postgresql/postgresql.o #endif @@ -268,8 +275,8 @@ hash.o imgproc.o indent.o insdel.o intl.o\ keymap.o $(RTC_patch_objs) line-number.o $(ldap_objs) lread.o lstream.o\ macros.o marker.o md5.o minibuf.o $(mswindows_objs) $(mswindows_gui_objs)\ - $(mule_objs) $(mule_canna_objs) $(mule_wnn_objs) objects.o opaque.o\ - $(postgresql_objs) print.o process.o $(process_objs) $(profile_objs)\ + $(mule_objs) $(mule_canna_objs) $(mule_wnn_objs) $(number_objs) objects.o\ + opaque.o $(postgresql_objs) print.o process.o $(process_objs) $(profile_objs)\ rangetab.o realpath.o redisplay.o redisplay-output.o regex.o\ search.o select.o $(sheap_objs) $(shlib_objs) signal.o sound.o\ specifier.o strftime.o $(sunpro_objs) symbols.o syntax.o sysdep.o\
--- a/src/alloc.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/alloc.c Mon Apr 05 22:50:11 2004 +0000 @@ -645,8 +645,8 @@ may be more efficient when there are only a small number of them. The types that are stored in these large blocks (or "frob blocks") - are cons, float, compiled-function, symbol, marker, extent, event, - and string. + are cons, all number types except fixnum, compiled-function, symbol, + marker, extent, event, and string. Note that strings are special in that they are actually stored in two parts: a structure containing information about the string, and @@ -1163,6 +1163,8 @@ /* Float allocation */ /************************************************************************/ +/*** With enhanced number support, these are short floats */ + DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 @@ -1184,6 +1186,124 @@ /************************************************************************/ +/* Enhanced number allocation */ +/************************************************************************/ + +/*** Bignum ***/ +#ifdef HAVE_BIGNUM +DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); +#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 + +/* WARNING: This function returns a bignum even if its argument fits into a + fixnum. See Fcanonicalize_number(). */ +Lisp_Object +make_bignum (long bignum_value) +{ + Lisp_Bignum *b; + + ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); + 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); +} +#endif /* HAVE_BIGNUM */ + +/*** Ratio ***/ +#ifdef HAVE_RATIO +DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio); +#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250 + +Lisp_Object +make_ratio (long numerator, unsigned long denominator) +{ + Lisp_Ratio *r; + + ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); + set_lheader_implementation (&r->lheader, &lrecord_ratio); + ratio_init (ratio_data (r)); + ratio_set_long_ulong (ratio_data (r), numerator, denominator); + ratio_canonicalize (ratio_data (r)); + return wrap_ratio (r); +} + +Lisp_Object +make_ratio_bg (bignum numerator, bignum denominator) +{ + Lisp_Ratio *r; + + ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); + set_lheader_implementation (&r->lheader, &lrecord_ratio); + ratio_init (ratio_data (r)); + ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); + ratio_canonicalize (ratio_data (r)); + return wrap_ratio (r); +} + +Lisp_Object +make_ratio_rt (ratio rat) +{ + Lisp_Ratio *r; + + ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); + set_lheader_implementation (&r->lheader, &lrecord_ratio); + ratio_init (ratio_data (r)); + ratio_set (ratio_data (r), rat); + return wrap_ratio (r); +} +#endif /* HAVE_RATIO */ + +/*** Bigfloat ***/ +#ifdef HAVE_BIGFLOAT +DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat); +#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250 + +/* This function creates a bigfloat with the default precision if the + PRECISION argument is zero. */ +Lisp_Object +make_bigfloat (double float_value, unsigned long precision) +{ + Lisp_Bigfloat *f; + + ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); + set_lheader_implementation (&f->lheader, &lrecord_bigfloat); + if (precision == 0UL) + bigfloat_init (bigfloat_data (f)); + else + bigfloat_init_prec (bigfloat_data (f), precision); + bigfloat_set_double (bigfloat_data (f), float_value); + return wrap_bigfloat (f); +} + +/* This function creates a bigfloat with the precision of its argument */ +Lisp_Object +make_bigfloat_bf (bigfloat float_value) +{ + Lisp_Bigfloat *f; + + ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); + set_lheader_implementation (&f->lheader, &lrecord_bigfloat); + bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); + bigfloat_set (bigfloat_data (f), float_value); + return wrap_bigfloat (f); +} +#endif /* HAVE_BIGFLOAT */ + +/************************************************************************/ /* Vector allocation */ /************************************************************************/ @@ -3786,6 +3906,39 @@ SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); } +#ifdef HAVE_BIGNUM +static void +sweep_bignums (void) +{ +#define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) +#define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) + + SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static void +sweep_ratios (void) +{ +#define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) +#define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) + + SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static void +sweep_bigfloats (void) +{ +#define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) +#define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) + + SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); +} +#endif + static void sweep_symbols (void) { @@ -4237,6 +4390,21 @@ /* Put all unmarked floats on free list */ sweep_floats (); +#ifdef HAVE_BIGNUM + /* Put all unmarked bignums on free list */ + sweep_bignums (); +#endif + +#ifdef HAVE_RATIO + /* Put all unmarked ratios on free list */ + sweep_ratios (); +#endif + +#ifdef HAVE_BIGFLOAT + /* Put all unmarked bigfloats on free list */ + sweep_bigfloats (); +#endif + /* Put all unmarked symbols on free list */ sweep_symbols (); @@ -4796,6 +4964,21 @@ 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); +#ifdef HAVE_BIGNUM + HACK_O_MATIC (bignum, "bignum-storage", pl); + pl = gc_plist_hack ("bignums-free", gc_count_num_bignum_freelist, pl); + pl = gc_plist_hack ("bignums-used", gc_count_num_bignum_in_use, pl); +#endif /* HAVE_BIGNUM */ +#ifdef HAVE_RATIO + HACK_O_MATIC (ratio, "ratio-storage", pl); + pl = gc_plist_hack ("ratios-free", gc_count_num_ratio_freelist, pl); + pl = gc_plist_hack ("ratios-used", gc_count_num_ratio_in_use, pl); +#endif /* HAVE_RATIO */ +#ifdef HAVE_BIGFLOAT + HACK_O_MATIC (bigfloat, "bigfloat-storage", pl); + pl = gc_plist_hack ("bigfloats-free", gc_count_num_bigfloat_freelist, pl); + pl = gc_plist_hack ("bigfloats-used", gc_count_num_bigfloat_in_use, pl); +#endif /* HAVE_BIGFLOAT */ HACK_O_MATIC (string, "string-header-storage", pl); pl = gc_plist_hack ("long-strings-total-length", gc_count_string_total_size @@ -5079,6 +5262,15 @@ init_symbol_alloc (); init_compiled_function_alloc (); init_float_alloc (); +#ifdef HAVE_BIGNUM + init_bignum_alloc (); +#endif +#ifdef HAVE_RATIO + init_ratio_alloc (); +#endif +#ifdef HAVE_BIGFLOAT + init_bigfloat_alloc (); +#endif init_marker_alloc (); init_extent_alloc (); init_event_alloc ();
--- a/src/bytecode.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/bytecode.c Mon Apr 05 22:50:11 2004 +0000 @@ -246,10 +246,19 @@ { retry: - if (INTP (obj)) return make_int (- XINT (obj)); + if (INTP (obj)) return make_integer (- XINT (obj)); if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); - if (CHARP (obj)) return make_int (- ((int) XCHAR (obj))); - if (MARKERP (obj)) return make_int (- ((int) marker_position (obj))); + if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj))); + if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj))); +#ifdef HAVE_BIGNUM + if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg); +#endif +#ifdef HAVE_RATIO + if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg); +#endif +#ifdef HAVE_BIG_FLOAT + if (BIGFLOAT_P (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); +#endif obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); goto retry; @@ -279,6 +288,33 @@ static int bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2) { +#ifdef WITH_NUMBER_TYPES + switch (promote_args (&obj1, &obj2)) + { + case FIXNUM_T: + { + EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); + return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; + } +#ifdef HAVE_BIGNUM + case BIGNUM_T: + return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); +#endif +#ifdef HAVE_RATIO + case RATIO_T: + return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); +#endif + case FLOAT_T: + { + double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); + return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; + } +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); +#endif + } +#else /* !WITH_NUMBER_TYPES */ retry: { @@ -324,11 +360,151 @@ return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; } +#endif /* WITH_NUMBER_TYPES */ } static Lisp_Object bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) { +#ifdef WITH_NUMBER_TYPES + switch (promote_args (&obj1, &obj2)) + { + case FIXNUM_T: + { + EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); + switch (opcode) + { + case Bplus: ival1 += ival2; break; + case Bdiff: ival1 -= ival2; break; + case Bmult: +#ifdef HAVE_BIGNUM + /* Due to potential overflow, we compute using bignums */ + bignum_set_long (scratch_bignum, ival1); + bignum_set_long (scratch_bignum2, ival2); + bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + ival1 *= ival2; break; +#endif + case Bquo: + if (ival2 == 0) Fsignal (Qarith_error, Qnil); + ival1 /= ival2; + break; + case Bmax: if (ival1 < ival2) ival1 = ival2; break; + case Bmin: if (ival1 > ival2) ival1 = ival2; break; + } + return make_integer (ival1); + } +#ifdef HAVE_BIGNUM + case BIGNUM_T: + switch (opcode) + { + case Bplus: + bignum_add (scratch_bignum, XBIGNUM_DATA (obj1), + XBIGNUM_DATA (obj2)); + break; + case Bdiff: + bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1), + XBIGNUM_DATA (obj2)); + break; + case Bmult: + bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1), + XBIGNUM_DATA (obj2)); + break; + case Bquo: + if (bignum_sign (XBIGNUM_DATA (obj2)) == 0) + Fsignal (Qarith_error, Qnil); + bignum_div (scratch_bignum, XBIGNUM_DATA (obj1), + XBIGNUM_DATA (obj2)); + break; + case Bmax: + return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) + ? obj1 : obj2; + case Bmin: + return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) + ? obj1 : obj2; + } + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#endif +#ifdef HAVE_RATIO + case RATIO_T: + switch (opcode) + { + case Bplus: + ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); + break; + case Bdiff: + ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); + break; + case Bmult: + ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); + break; + case Bquo: + if (ratio_sign (XRATIO_DATA (obj2)) == 0) + Fsignal (Qarith_error, Qnil); + ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); + break; + case Bmax: + return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) + ? obj1 : obj2; + case Bmin: + return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) + ? obj1 : obj2; + } + return make_ratio_rt (scratch_ratio); +#endif + case FLOAT_T: + { + double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); + switch (opcode) + { + case Bplus: dval1 += dval2; break; + case Bdiff: dval1 -= dval2; break; + case Bmult: dval1 *= dval2; break; + case Bquo: + if (dval2 == 0.0) Fsignal (Qarith_error, Qnil); + dval1 /= dval2; + break; + case Bmax: if (dval1 < dval2) dval1 = dval2; break; + case Bmin: if (dval1 > dval2) dval1 = dval2; break; + } + return make_float (dval1); + } +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1), + XBIGFLOAT_GET_PREC (obj2))); + switch (opcode) + { + case Bplus: + bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1), + XBIGFLOAT_DATA (obj2)); + break; + case Bdiff: + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1), + XBIGFLOAT_DATA (obj2)); + break; + case Bmult: + bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1), + XBIGFLOAT_DATA (obj2)); + break; + case Bquo: + if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0) + Fsignal (Qarith_error, Qnil); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1), + XBIGFLOAT_DATA (obj2)); + break; + case Bmax: + return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) + ? obj1 : obj2; + case Bmin: + return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) + ? obj1 : obj2; + } + return make_bigfloat_bf (scratch_bigfloat); +#endif + } +#else /* !WITH_NUMBER_TYPES */ EMACS_INT ival1, ival2; int float_p; @@ -390,6 +566,7 @@ } return make_float (dval1); } +#endif /* WITH_NUMBER_TYPES */ } @@ -806,11 +983,19 @@ break; case Bnumberp: +#ifdef WITH_NUMBER_TYPES + TOP = NUMBERP (TOP) ? Qt : Qnil; +#else TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; +#endif break; case Bintegerp: +#ifdef HAVE_BIGNUM + TOP = INTEGERP (TOP) ? Qt : Qnil; +#else TOP = INTP (TOP) ? Qt : Qnil; +#endif break; case Beq: @@ -907,11 +1092,19 @@ } case Bsub1: +#ifdef HAVE_BIGNUM + TOP = Fsub1 (TOP); +#else TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP); +#endif break; case Badd1: +#ifdef HAVE_BIGNUM + TOP = Fadd1 (TOP); +#else TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP); +#endif break; @@ -966,9 +1159,13 @@ { Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; +#ifdef HAVE_BIGNUM + TOP = bytecode_arithop (arg1, arg2, opcode); +#else TOP = INTP (arg1) && INTP (arg2) ? INT_PLUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); +#endif break; } @@ -976,9 +1173,13 @@ { Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; +#ifdef HAVE_BIGNUM + TOP = bytecode_arithop (arg1, arg2, opcode); +#else TOP = INTP (arg1) && INTP (arg2) ? INT_MINUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); +#endif break; }
--- a/src/config.h.in Mon Apr 05 21:50:47 2004 +0000 +++ b/src/config.h.in Mon Apr 05 22:50:11 2004 +0000 @@ -893,6 +893,7 @@ #undef SIZEOF_LONG #undef SIZEOF_LONG_LONG #undef SIZEOF_VOID_P +#undef SIZEOF_DOUBLE /* some systems (Cygwin) typedef u?intptr_t in <sys/types.h> but the standard is <inttypes.h> @@ -912,6 +913,14 @@ #define LONGBITS (SIZEOF_LONG * BITS_PER_CHAR) #define LONG_LONG_BITS (SIZEOF_LONG_LONG * BITS_PER_CHAR) #define VOID_P_BITS (SIZEOF_VOID_P * BITS_PER_CHAR) +#define DOUBLE_BITS (SIZEOF_DOUBLE * BITS_PER_CHAR) + +/* Enhanced numeric support */ +#undef WITH_NUMBER_TYPES +#undef WITH_GMP +#undef WITH_MP +#undef MP_PREFIX +#undef HAVE_MP_MOVE /* Use `INLINE_HEADER' to define inline functions in .h files. Use `inline static' to define inline functions in .c files.
--- a/src/data.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/data.c Mon Apr 05 22:50:11 2004 +0000 @@ -53,7 +53,7 @@ Lisp_Object Qtext_conversion_error; Lisp_Object Qarith_error, Qrange_error, Qdomain_error; Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error; -Lisp_Object Qintegerp, Qnatnump, Qsymbolp; +Lisp_Object Qintegerp, Qnatnump, Qnonnegativep, Qsymbolp; Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; Lisp_Object Qconsp, Qsubrp; Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; @@ -460,6 +460,16 @@ return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil; } +#ifdef HAVE_BIGNUM +/* In this case, integerp is defined in number.c. */ +DEFUN ("fixnump", Ffixnump, 1, 1, 0, /* +Return t if OBJECT is a fixnum. +*/ + (object)) +{ + return INTP (object) ? Qt : Qnil; +} +#else DEFUN ("integerp", Fintegerp, 1, 1, 0, /* Return t if OBJECT is an integer. */ @@ -467,6 +477,7 @@ { return INTP (object) ? Qt : Qnil; } +#endif DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /* Return t if OBJECT is an integer or a marker (editor pointer). @@ -497,7 +508,29 @@ */ (object)) { - return NATNUMP (object) ? Qt : Qnil; + return NATNUMP (object) +#ifdef HAVE_BIGNUM + || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) +#endif + ? Qt : Qnil; +} + +DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /* +Return t if OBJECT is a nonnegative number. +*/ + (object)) +{ + return NATNUMP (object) +#ifdef HAVE_BIGNUM + || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) +#endif +#ifdef HAVE_RATIO + || (RATIOP (object) && ratio_sign (XRATIO_DATA (object)) >= 0) +#endif +#ifdef HAVE_BIGFLOAT + || (BIGFLOATP (object) && bigfloat_sign (XBIGFLOAT_DATA (object)) >= 0) +#endif + ? Qt : Qnil; } DEFUN ("bitp", Fbitp, 1, 1, 0, /* @@ -513,7 +546,11 @@ */ (object)) { +#ifdef WITH_NUMBER_TYPES + return NUMBERP (object) ? Qt : Qnil; +#else return INT_OR_FLOATP (object) ? Qt : Qnil; +#endif } DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /* @@ -854,7 +891,66 @@ } } -#define ARITHCOMPARE_MANY(op) \ +#ifdef WITH_NUMBER_TYPES + +#ifdef HAVE_BIGNUM +#define BIGNUM_CASE(op) \ + case BIGNUM_T: \ + if (!bignum_##op (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) \ + return Qnil; \ + break; +#else +#define BIGNUM_CASE(op) +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +#define RATIO_CASE(op) \ + case RATIO_T: \ + if (!ratio_##op (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) \ + return Qnil; \ + break; +#else +#define RATIO_CASE(op) +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +#define BIGFLOAT_CASE(op) \ + case BIGFLOAT_T: \ + if (!bigfloat_##op (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) \ + return Qnil; \ + break; +#else +#define BIGFLOAT_CASE(op) +#endif /* HAVE_BIGFLOAT */ + +#define ARITHCOMPARE_MANY(c_op,op) \ +{ \ + REGISTER int i; \ + Lisp_Object obj1, obj2; \ + \ + for (i = 1; i < nargs; i++) \ + { \ + obj1 = args[i - 1]; \ + obj2 = args[i]; \ + switch (promote_args (&obj1, &obj2)) \ + { \ + case FIXNUM_T: \ + if (!(XREALINT (obj1) c_op XREALINT (obj2))) \ + return Qnil; \ + break; \ + BIGNUM_CASE (op) \ + RATIO_CASE (op) \ + case FLOAT_T: \ + if (!(XFLOAT_DATA (obj1) c_op XFLOAT_DATA (obj2))) \ + return Qnil; \ + break; \ + BIGFLOAT_CASE (op) \ + } \ + } \ + return Qt; \ +} +#else /* !WITH_NUMBER_TYPES */ +#define ARITHCOMPARE_MANY(c_op,op) \ { \ int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \ Lisp_Object *args_end = args + nargs; \ @@ -866,8 +962,8 @@ number_char_or_marker_to_int_or_double (*args++, q); \ \ if (!((p->int_p && q->int_p) ? \ - (p->c.ival op q->c.ival) : \ - ((p->int_p ? (double) p->c.ival : p->c.dval) op \ + (p->c.ival c_op q->c.ival) : \ + ((p->int_p ? (double) p->c.ival : p->c.dval) c_op \ (q->int_p ? (double) q->c.ival : q->c.dval)))) \ return Qnil; \ \ @@ -875,6 +971,7 @@ } \ return Qt; \ } +#endif /* WITH_NUMBER_TYPES */ DEFUN ("=", Feqlsign, 1, MANY, 0, /* Return t if all the arguments are numerically equal. @@ -882,7 +979,7 @@ */ (int nargs, Lisp_Object *args)) { - ARITHCOMPARE_MANY (==) + ARITHCOMPARE_MANY (==, eql) } DEFUN ("<", Flss, 1, MANY, 0, /* @@ -891,7 +988,7 @@ */ (int nargs, Lisp_Object *args)) { - ARITHCOMPARE_MANY (<) + ARITHCOMPARE_MANY (<, lt) } DEFUN (">", Fgtr, 1, MANY, 0, /* @@ -900,7 +997,7 @@ */ (int nargs, Lisp_Object *args)) { - ARITHCOMPARE_MANY (>) + ARITHCOMPARE_MANY (>, gt) } DEFUN ("<=", Fleq, 1, MANY, 0, /* @@ -909,7 +1006,7 @@ */ (int nargs, Lisp_Object *args)) { - ARITHCOMPARE_MANY (<=) + ARITHCOMPARE_MANY (<=, le) } DEFUN (">=", Fgeq, 1, MANY, 0, /* @@ -918,15 +1015,64 @@ */ (int nargs, Lisp_Object *args)) { - ARITHCOMPARE_MANY (>=) + ARITHCOMPARE_MANY (>=, ge) } +/* Unlike all the other comparisons, this is an O(N*N) algorithm. But who + cares? Inspection of all elisp code distributed by xemacs.org shows that + it is almost always called with 2 arguments, rarely with 3, and never with + more than 3. The constant factors of algorithms with better asymptotic + complexity are higher, which means that those algorithms will run SLOWER + than this one in the common case. Optimize the common case! */ DEFUN ("/=", Fneq, 1, MANY, 0, /* Return t if no two arguments are numerically equal. The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i, j; + Lisp_Object obj1, obj2; + + for (i = 0; i < nargs - 1; i++) + { + obj1 = args[i]; + for (j = i + 1; j < nargs; j++) + { + obj2 = args[j]; + switch (promote_args (&obj1, &obj2)) + { + case FIXNUM_T: + if (XREALINT (obj1) == XREALINT (obj2)) + return Qnil; + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) + return Qnil; + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) + return Qnil; + break; +#endif + case FLOAT_T: + if (XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2)) + return Qnil; + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) + return Qnil; + break; +#endif + } + } + } + return Qt; +#else /* !WITH_NUMBER_TYPES */ Lisp_Object *args_end = args + nargs; Lisp_Object *p, *q; @@ -949,6 +1095,7 @@ } } return Qt; +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("zerop", Fzerop, 1, 1, 0, /* @@ -959,8 +1106,20 @@ retry: if (INTP (number)) return EQ (number, Qzero) ? Qt : Qnil; +#ifdef HAVE_BIGNUM + else if (BIGNUMP (number)) + return bignum_sign (XBIGNUM_DATA (number)) == 0 ? Qt : Qnil; +#endif +#ifdef HAVE_RATIO + else if (RATIOP (number)) + return ratio_sign (XRATIO_DATA (number)) == 0 ? Qt : Qnil; +#endif else if (FLOATP (number)) return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil; +#ifdef HAVE_BIGFLOAT + else if (BIGFLOATP (number)) + return bigfloat_sign (XBIGFLOAT_DATA (number)) == 0 ? Qt : Qnil; +#endif else { number = wrong_type_argument (Qnumberp, number); @@ -1001,10 +1160,15 @@ Convert NUMBER to a string by printing it in decimal. Uses a minus sign if negative. NUMBER may be an integer or a floating point number. +If supported, it may also be a ratio. */ (number)) { +#ifdef WITH_NUMBER_TYPES + CHECK_NUMBER (number); +#else CHECK_INT_OR_FLOAT (number); +#endif if (FLOATP (number)) { @@ -1013,6 +1177,33 @@ float_to_string (pigbuf, XFLOAT_DATA (number)); return build_string (pigbuf); } +#ifdef HAVE_BIGNUM + if (BIGNUMP (number)) + { + char *str = bignum_to_string (XBIGNUM_DATA (number), 10); + Lisp_Object retval = build_string (str); + xfree (str, char *); + return retval; + } +#endif +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + char *str = ratio_to_string (XRATIO_DATA (number), 10); + Lisp_Object retval = build_string (str); + xfree (str, char *); + return retval; + } +#endif +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + char *str = bigfloat_to_string (XBIGFLOAT_DATA (number), 10); + Lisp_Object retval = build_string (str); + xfree (str, char *); + return retval; + } +#endif { char buffer[DECIMAL_PRINT_SIZE (long)]; @@ -1037,6 +1228,7 @@ DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /* Convert STRING to a number by parsing it as a number in base BASE. This parses both integers and floating point numbers. +If they are supported, it also reads ratios. It ignores leading spaces and tabs. If BASE is nil or omitted, base 10 is used. @@ -1067,8 +1259,36 @@ p++; if (isfloat_string (p) && b == 10) - return make_float (atof (p)); - + { +#ifdef HAVE_BIGFLOAT + if (ZEROP (Vdefault_float_precision)) +#endif + return make_float (atof (p)); +#ifdef HAVE_BIGFLOAT + else + { + bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ()); + bigfloat_set_string (scratch_bigfloat, p, b); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif + } + +#ifdef HAVE_RATIO + if (qxestrchr (p, '/') != NULL) + { + ratio_set_string (scratch_ratio, p, b); + return make_ratio_rt (scratch_ratio); + } +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGNUM + /* GMP bignum_set_string returns random values when fed an empty string */ + if (*p == '\0') + return make_int (0); + bignum_set_string (scratch_bignum, p, b); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else if (b == 10) { /* Use the system-provided functions for base 10. */ @@ -1101,6 +1321,7 @@ } return make_int (negative * v); } +#endif /* HAVE_BIGNUM */ } @@ -1110,6 +1331,49 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i; + Lisp_Object accum = make_int (0), addend; + + for (i = 0; i < nargs; i++) + { + addend = args[i]; + switch (promote_args (&accum, &addend)) + { + case FIXNUM_T: + accum = make_integer (XREALINT (accum) + XREALINT (addend)); + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + bignum_add (scratch_bignum, XBIGNUM_DATA (accum), + XBIGNUM_DATA (addend)); + accum = make_bignum_bg (scratch_bignum); + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + ratio_add (scratch_ratio, XRATIO_DATA (accum), + XRATIO_DATA (addend)); + accum = make_ratio_rt (scratch_ratio); + break; +#endif + case FLOAT_T: + accum = make_float (XFLOAT_DATA (accum) + XFLOAT_DATA (addend)); + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (addend), + XBIGFLOAT_GET_PREC (accum))); + bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (accum), + XBIGFLOAT_DATA (addend)); + accum = make_bigfloat_bf (scratch_bigfloat); + break; +#endif + } + } + return Fcanonicalize_number (accum); +#else /* !WITH_NUMBER_TYPES */ EMACS_INT iaccum = 0; Lisp_Object *args_end = args + nargs; @@ -1129,6 +1393,7 @@ } return make_int (iaccum); +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("-", Fminus, 1, MANY, 0, /* @@ -1138,6 +1403,87 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i; + Lisp_Object accum = args[0], subtrahend; + + if (nargs == 1) + { + if (CHARP (accum)) + accum = make_int (XCHAR (accum)); + else if (MARKERP (accum)) + accum = make_int (marker_position (accum)); + + /* Invert the sign of accum */ + CHECK_NUMBER (accum); + switch (get_number_type (accum)) + { + case FIXNUM_T: + return make_integer (-XREALINT (accum)); +#ifdef HAVE_BIGNUM + case BIGNUM_T: + bignum_neg (scratch_bignum, XBIGNUM_DATA (accum)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#endif +#ifdef HAVE_RATIO + case RATIO_T: + ratio_neg (scratch_ratio, XRATIO_DATA (accum)); + return make_ratio_rt (scratch_ratio); +#endif + case FLOAT_T: + return make_float (-XFLOAT_DATA (accum)); +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (accum)); + bigfloat_neg (scratch_bigfloat, XBIGFLOAT_DATA (accum)); + return make_bigfloat_bf (scratch_bigfloat); +#endif + } + } + else + { + /* Subtrace the remaining arguments from accum */ + for (i = 1; i < nargs; i++) + { + subtrahend = args[i]; + switch (promote_args (&accum, &subtrahend)) + { + case FIXNUM_T: + accum = make_integer (XREALINT (accum) - XREALINT (subtrahend)); + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + bignum_sub (scratch_bignum, XBIGNUM_DATA (accum), + XBIGNUM_DATA (subtrahend)); + accum = make_bignum_bg (scratch_bignum); + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + ratio_sub (scratch_ratio, XRATIO_DATA (accum), + XRATIO_DATA (subtrahend)); + accum = make_ratio_rt (scratch_ratio); + break; +#endif + case FLOAT_T: + accum = + make_float (XFLOAT_DATA (accum) - XFLOAT_DATA (subtrahend)); + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (subtrahend), + XBIGFLOAT_GET_PREC (accum))); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (accum), + XBIGFLOAT_DATA (subtrahend)); + accum = make_bigfloat_bf (scratch_bigfloat); + break; +#endif + } + } + } + return Fcanonicalize_number (accum); +#else /* !WITH_NUMBER_TYPES */ EMACS_INT iaccum; double daccum; Lisp_Object *args_end = args + nargs; @@ -1170,6 +1516,7 @@ for (; args < args_end; args++) daccum -= number_char_or_marker_to_double (*args); return make_float (daccum); +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("*", Ftimes, 0, MANY, 0, /* @@ -1178,6 +1525,47 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i; + /* Start with a bignum to avoid overflow */ + Lisp_Object accum = make_bignum (1L), multiplier; + + for (i = 0; i < nargs; i++) + { + multiplier = args[i]; + switch (promote_args (&accum, &multiplier)) + { +#ifdef HAVE_BIGNUM + case BIGNUM_T: + bignum_mul (scratch_bignum, XBIGNUM_DATA (accum), + XBIGNUM_DATA (multiplier)); + accum = make_bignum_bg (scratch_bignum); + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + ratio_mul (scratch_ratio, XRATIO_DATA (accum), + XRATIO_DATA (multiplier)); + accum = make_ratio_rt (scratch_ratio); + break; +#endif + case FLOAT_T: + accum = make_float (XFLOAT_DATA (accum) * XFLOAT_DATA (multiplier)); + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (multiplier), + XBIGFLOAT_GET_PREC (accum))); + bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (accum), + XBIGFLOAT_DATA (multiplier)); + accum = make_bigfloat_bf (scratch_bigfloat); + break; +#endif + } + } + return Fcanonicalize_number (accum); +#else /* !WITH_NUMBER_TYPES */ EMACS_INT iaccum = 1; Lisp_Object *args_end = args + nargs; @@ -1197,8 +1585,78 @@ } return make_int (iaccum); +#endif /* WITH_NUMBER_TYPES */ } +#ifdef HAVE_RATIO +DEFUN ("div", Fdiv, 1, MANY, 0, /* +Same as `/', but dividing integers creates a ratio instead of truncating. +Note that this is a departure from Common Lisp, where / creates ratios when +dividing integers. Having a separate function lets us avoid breaking existing +Emacs Lisp code that expects / to do integer division. +*/ + (int nargs, Lisp_Object *args)) +{ + REGISTER int i; + Lisp_Object accum, divisor; + + if (nargs == 1) + { + i = 0; + accum = make_int (1); + } + else + { + i = 1; + accum = args[0]; + } + for (; i < nargs; i++) + { + divisor = args[i]; + switch (promote_args (&accum, &divisor)) + { + case FIXNUM_T: + if (XREALINT (divisor) == 0) goto divide_by_zero; + bignum_set_long (scratch_bignum, XREALINT (accum)); + bignum_set_long (scratch_bignum2, XREALINT (divisor)); + accum = make_ratio_bg (scratch_bignum, scratch_bignum2); + break; + case BIGNUM_T: + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; + accum = make_ratio_bg (XBIGNUM_DATA (accum), XBIGNUM_DATA (divisor)); + break; + case RATIO_T: + if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; + ratio_div (scratch_ratio, XRATIO_DATA (accum), + XRATIO_DATA (divisor)); + accum = make_ratio_rt (scratch_ratio); + break; + case FLOAT_T: + if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; + accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + goto divide_by_zero; + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (divisor), + XBIGFLOAT_GET_PREC (accum))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), + XBIGFLOAT_DATA (divisor)); + accum = make_bigfloat_bf (scratch_bigfloat); + break; +#endif + } + } + return Fcanonicalize_number (accum); + + divide_by_zero: + Fsignal (Qarith_error, Qnil); + return Qnil; /* not (usually) reached */ +} +#endif /* HAVE_RATIO */ + DEFUN ("/", Fquo, 1, MANY, 0, /* Return first argument divided by all the remaining arguments. The arguments must be numbers, characters or markers. @@ -1206,6 +1664,65 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i; + Lisp_Object accum, divisor; + + if (nargs == 1) + { + i = 0; + accum = make_int (1); + } + else + { + i = 1; + accum = args[0]; + } + for (; i < nargs; i++) + { + divisor = args[i]; + switch (promote_args (&accum, &divisor)) + { + case FIXNUM_T: + if (XREALINT (divisor) == 0) goto divide_by_zero; + accum = make_integer (XREALINT (accum) / XREALINT (divisor)); + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; + bignum_div (scratch_bignum, XBIGNUM_DATA (accum), + XBIGNUM_DATA (divisor)); + accum = make_bignum_bg (scratch_bignum); + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; + ratio_div (scratch_ratio, XRATIO_DATA (accum), + XRATIO_DATA (divisor)); + accum = make_ratio_rt (scratch_ratio); + break; +#endif + case FLOAT_T: + if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; + accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + goto divide_by_zero; + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (divisor), + XBIGFLOAT_GET_PREC (accum))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), + XBIGFLOAT_DATA (divisor)); + accum = make_bigfloat_bf (scratch_bigfloat); + break; +#endif + } + } + return Fcanonicalize_number (accum); +#else /* !WITH_NUMBER_TYPES */ EMACS_INT iaccum; double daccum; Lisp_Object *args_end = args + nargs; @@ -1251,6 +1768,7 @@ daccum /= dval; } return make_float (daccum); +#endif /* WITH_NUMBER_TYPES */ divide_by_zero: Fsignal (Qarith_error, Qnil); @@ -1259,12 +1777,59 @@ DEFUN ("max", Fmax, 1, MANY, 0, /* Return largest of all the arguments. -All arguments must be numbers, characters or markers. +All arguments must be real numbers, characters or markers. The value is always a number; markers and characters are converted to numbers. */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i, maxindex = 0; + Lisp_Object comp1, comp2; + + while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) + args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); + if (CHARP (args[0])) + args[0] = make_int (XCHAR (args[0])); + else if (MARKERP (args[0])) + args[0] = make_int (marker_position (args[0])); + for (i = 1; i < nargs; i++) + { + retry: + comp1 = args[maxindex]; + comp2 = args[i]; + switch (promote_args (&comp1, &comp2)) + { + case FIXNUM_T: + if (XREALINT (comp1) < XREALINT (comp2)) + maxindex = i; + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_lt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2))) + maxindex = i; + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_lt (XRATIO_DATA (comp1), XRATIO_DATA (comp2))) + maxindex = i; + break; +#endif + case FLOAT_T: + if (XFLOAT_DATA (comp1) < XFLOAT_DATA (comp2)) + maxindex = i; + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_lt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2))) + maxindex = i; + break; +#endif + } + } + return args[maxindex]; +#else /* !WITH_NUMBER_TYPES */ EMACS_INT imax; double dmax; Lisp_Object *args_end = args + nargs; @@ -1303,6 +1868,7 @@ if (dmax < dval) dmax = dval; } return make_float (dmax); +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("min", Fmin, 1, MANY, 0, /* @@ -1313,6 +1879,52 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef WITH_NUMBER_TYPES + REGISTER int i, minindex = 0; + Lisp_Object comp1, comp2; + + while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) + args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); + if (CHARP (args[0])) + args[0] = make_int (XCHAR (args[0])); + else if (MARKERP (args[0])) + args[0] = make_int (marker_position (args[0])); + for (i = 1; i < nargs; i++) + { + comp1 = args[minindex]; + comp2 = args[i]; + switch (promote_args (&comp1, &comp2)) + { + case FIXNUM_T: + if (XREALINT (comp1) > XREALINT (comp2)) + minindex = i; + break; +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_gt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2))) + minindex = i; + break; +#endif +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_gt (XRATIO_DATA (comp1), XRATIO_DATA (comp2))) + minindex = i; + break; +#endif + case FLOAT_T: + if (XFLOAT_DATA (comp1) > XFLOAT_DATA (comp2)) + minindex = i; + break; +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_gt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2))) + minindex = i; + break; +#endif + } + } + return args[minindex]; +#else /* !WITH_NUMBER_TYPES */ EMACS_INT imin; double dmin; Lisp_Object *args_end = args + nargs; @@ -1351,6 +1963,7 @@ if (dmin > dval) dmin = dval; } return make_float (dmin); +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("logand", Flogand, 0, MANY, 0, /* @@ -1359,6 +1972,43 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef HAVE_BIGNUM + REGISTER int i; + Lisp_Object result, other; + + if (nargs == 0) + return make_int (~0); + + while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) + args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); + + result = args[0]; + if (CHARP (result)) + result = make_int (XCHAR (result)); + else if (MARKERP (result)) + result = make_int (marker_position (result)); + for (i = 1; i < nargs; i++) + { + while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) + args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); + other = args[i]; + switch (promote_args (&result, &other)) + { + case FIXNUM_T: + /* This looks evil, but it isn't. The bits identifying the objects + as fixnums will be present in both, so & will preserve them. + The only bits possibly turned off are the actual data bits. */ + result &= other; + break; + case BIGNUM_T: + bignum_and (scratch_bignum, XBIGNUM_DATA (result), + XBIGNUM_DATA (other)); + result = make_bignum_bg (scratch_bignum); + break; + } + } + return Fcanonicalize_number (result); +#else /* !HAVE_BIGNUM */ EMACS_INT bits = ~0; Lisp_Object *args_end = args + nargs; @@ -1366,6 +2016,7 @@ bits &= integer_char_or_marker_to_int (*args++); return make_int (bits); +#endif /* HAVE_BIGNUM */ } DEFUN ("logior", Flogior, 0, MANY, 0, /* @@ -1374,6 +2025,43 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef HAVE_BIGNUM + REGISTER int i; + Lisp_Object result, other; + + if (nargs == 0) + return make_int (0); + + while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) + args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); + + result = args[0]; + if (CHARP (result)) + result = make_int (XCHAR (result)); + else if (MARKERP (result)) + result = make_int (marker_position (result)); + for (i = 1; i < nargs; i++) + { + while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) + args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); + other = args[i]; + switch (promote_args (&result, &other)) + { + case FIXNUM_T: + /* This looks evil, but it isn't. The bits identifying the objects + as fixnums are the same in both, so | will preserve them. The + only bits possibly turned on are the actual data bits. */ + result |= other; + break; + case BIGNUM_T: + bignum_ior (scratch_bignum, XBIGNUM_DATA (result), + XBIGNUM_DATA (other)); + result = make_bignum_bg (scratch_bignum); + break; + } + } + return Fcanonicalize_number (result); +#else /* !HAVE_BIGNUM */ EMACS_INT bits = 0; Lisp_Object *args_end = args + nargs; @@ -1381,6 +2069,7 @@ bits |= integer_char_or_marker_to_int (*args++); return make_int (bits); +#endif /* HAVE_BIGNUM */ } DEFUN ("logxor", Flogxor, 0, MANY, 0, /* @@ -1389,6 +2078,39 @@ */ (int nargs, Lisp_Object *args)) { +#ifdef HAVE_BIGNUM + REGISTER int i; + Lisp_Object result, other; + + if (nargs == 0) + return make_int (0); + + while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) + args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); + + result = args[0]; + if (CHARP (result)) + result = make_int (XCHAR (result)); + else if (MARKERP (result)) + result = make_int (marker_position (result)); + for (i = 1; i < nargs; i++) + { + while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) + args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); + other = args[i]; + if (promote_args (&result, &other) == FIXNUM_T) + { + result = make_int (XREALINT (result) ^ XREALINT (other)); + } + else + { + bignum_xor (scratch_bignum, XBIGNUM_DATA (result), + XBIGNUM_DATA (other)); + result = make_bignum_bg (scratch_bignum); + } + } + return Fcanonicalize_number (result); +#else /* !HAVE_BIGNUM */ EMACS_INT bits = 0; Lisp_Object *args_end = args + nargs; @@ -1396,6 +2118,7 @@ bits ^= integer_char_or_marker_to_int (*args++); return make_int (bits); +#endif /* !HAVE_BIGNUM */ } DEFUN ("lognot", Flognot, 1, 1, 0, /* @@ -1404,6 +2127,13 @@ */ (number)) { +#ifdef HAVE_BIGNUM + if (BIGNUMP (number)) + { + bignum_not (scratch_bignum, XBIGNUM_DATA (number)); + return make_bignum_bg (scratch_bignum); + } +#endif /* HAVE_BIGNUM */ return make_int (~ integer_char_or_marker_to_int (number)); } @@ -1413,6 +2143,27 @@ */ (number1, number2)) { +#ifdef HAVE_BIGNUM + while (!(CHARP (number1) || MARKERP (number1) || INTEGERP (number1))) + number1 = wrong_type_argument (Qnumber_char_or_marker_p, number1); + while (!(CHARP (number2) || MARKERP (number2) || INTEGERP (number2))) + number2 = wrong_type_argument (Qnumber_char_or_marker_p, number2); + + if (promote_args (&number1, &number2) == FIXNUM_T) + { + if (XREALINT (number2) == 0) + Fsignal (Qarith_error, Qnil); + return make_int (XREALINT (number1) % XREALINT (number2)); + } + else + { + if (bignum_sign (XBIGNUM_DATA (number2)) == 0) + Fsignal (Qarith_error, Qnil); + bignum_mod (scratch_bignum, XBIGNUM_DATA (number1), + XBIGNUM_DATA (number2)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#else /* !HAVE_BIGNUM */ EMACS_INT ival1 = integer_char_or_marker_to_int (number1); EMACS_INT ival2 = integer_char_or_marker_to_int (number2); @@ -1420,6 +2171,7 @@ Fsignal (Qarith_error, Qnil); return make_int (ival1 % ival2); +#endif /* HAVE_BIGNUM */ } /* Note, ANSI *requires* the presence of the fmod() library routine. @@ -1445,6 +2197,62 @@ */ (x, y)) { +#ifdef WITH_NUMBER_TYPES + while (!(CHARP (x) || MARKERP (x) || REALP (x))) + x = wrong_type_argument (Qnumber_char_or_marker_p, x); + while (!(CHARP (y) || MARKERP (y) || REALP (y))) + y = wrong_type_argument (Qnumber_char_or_marker_p, y); + switch (promote_args (&x, &y)) + { + case FIXNUM_T: + { + EMACS_INT ival; + if (XREALINT (y) == 0) goto divide_by_zero; + ival = XREALINT (x) % XREALINT (y); + /* If the "remainder" comes out with the wrong sign, fix it. */ + if (XREALINT (y) < 0 ? ival > 0 : ival < 0) + ival += XREALINT (y); + return make_int (ival); + } +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_sign (XBIGNUM_DATA (y)) == 0) goto divide_by_zero; + bignum_mod (scratch_bignum, XBIGNUM_DATA (x), XBIGNUM_DATA (y)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#endif +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_sign (XRATIO_DATA (y)) == 0) goto divide_by_zero; + ratio_div (scratch_ratio, XRATIO_DATA (x), XRATIO_DATA (y)); + bignum_div (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + ratio_set_bignum (scratch_ratio, scratch_bignum); + ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (y)); + ratio_sub (scratch_ratio, XRATIO_DATA (x), scratch_ratio); + return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); +#endif + case FLOAT_T: + { + double dval; + if (XFLOAT_DATA (y) == 0.0) goto divide_by_zero; + dval = fmod (XFLOAT_DATA (x), XFLOAT_DATA (y)); + /* If the "remainder" comes out with the wrong sign, fix it. */ + if (XFLOAT_DATA (y) < 0 ? dval > 0 : dval < 0) + dval += XFLOAT_DATA (y); + return make_float (dval); + } +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (x), XBIGFLOAT_GET_PREC (y))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (x), XBIGFLOAT_DATA (y)); + bigfloat_trunc (scratch_bigfloat, scratch_bigfloat); + bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (y)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (x), scratch_bigfloat); + return make_bigfloat_bf (scratch_bigfloat); +#endif + } +#else /* !WITH_NUMBER_TYPES */ int_or_double iod1, iod2; number_char_or_marker_to_int_or_double (x, &iod1); number_char_or_marker_to_int_or_double (y, &iod2); @@ -1475,6 +2283,7 @@ return make_int (ival); } +#endif /* WITH_NUMBER_TYPES */ divide_by_zero: Fsignal (Qarith_error, Qnil); @@ -1485,6 +2294,8 @@ Return VALUE with its bits shifted left by COUNT. If COUNT is negative, shifting is actually to the right. In this case, the sign bit is duplicated. +This function cannot be applied to bignums, as there is no leftmost sign bit +to be duplicated. Use `lsh' instead. */ (value, count)) { @@ -1503,12 +2314,47 @@ */ (value, count)) { +#ifdef HAVE_BIGNUM + while (!(CHARP (value) || MARKERP (value) || INTEGERP (value))) + wrong_type_argument (Qnumber_char_or_marker_p, value); + CONCHECK_INTEGER (count); + + if (promote_args (&value, &count) == FIXNUM_T) + { + if (XREALINT (count) <= 0) + return make_int (XREALINT (value) >> -XREALINT (count)); + /* Use bignums to avoid overflow */ + bignum_set_long (scratch_bignum2, XREALINT (value)); + bignum_lshift (scratch_bignum, scratch_bignum2, XREALINT (count)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + else + { + if (bignum_sign (XBIGNUM_DATA (count)) <= 0) + { + bignum_neg (scratch_bignum, XBIGNUM_DATA (count)); + if (!bignum_fits_ulong_p (scratch_bignum)) + args_out_of_range (Qnumber_char_or_marker_p, count); + bignum_rshift (scratch_bignum2, XBIGNUM_DATA (value), + bignum_to_ulong (scratch_bignum)); + } + else + { + if (!bignum_fits_ulong_p (XBIGNUM_DATA (count))) + args_out_of_range (Qnumber_char_or_marker_p, count); + bignum_lshift (scratch_bignum2, XBIGNUM_DATA (value), + bignum_to_ulong (XBIGNUM_DATA (count))); + } + return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); + } +#else /* !HAVE_BIGNUM */ CHECK_INT_COERCE_CHAR (value); CONCHECK_INT (count); return make_int (XINT (count) > 0 ? XUINT (value) << XINT (count) : XUINT (value) >> -XINT (count)); +#endif /* HAVE_BIGNUM */ } DEFUN ("1+", Fadd1, 1, 1, 0, /* @@ -1519,10 +2365,37 @@ { retry: - if (INTP (number)) return make_int (XINT (number) + 1); - if (CHARP (number)) return make_int (XCHAR (number) + 1); - if (MARKERP (number)) return make_int (marker_position (number) + 1); + if (INTP (number)) return make_integer (XINT (number) + 1); + if (CHARP (number)) return make_integer (XCHAR (number) + 1); + if (MARKERP (number)) return make_integer (marker_position (number) + 1); if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); +#ifdef HAVE_BIGNUM + 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)); + } +#endif +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + ratio_set_long (scratch_ratio, 1L); + ratio_add (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + /* No need to canonicalize after adding 1 */ + return make_ratio_rt (scratch_ratio); + } +#endif +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_set_long (scratch_bigfloat, 1L); + bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (number), + scratch_bigfloat); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif number = wrong_type_argument (Qnumber_char_or_marker_p, number); goto retry; @@ -1536,10 +2409,37 @@ { retry: - if (INTP (number)) return make_int (XINT (number) - 1); - if (CHARP (number)) return make_int (XCHAR (number) - 1); - if (MARKERP (number)) return make_int (marker_position (number) - 1); + if (INTP (number)) return make_integer (XINT (number) - 1); + if (CHARP (number)) return make_integer (XCHAR (number) - 1); + if (MARKERP (number)) return make_integer (marker_position (number) - 1); if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0); +#ifdef HAVE_BIGNUM + if (BIGNUMP (number)) + { + bignum_set_long (scratch_bignum, 1L); + bignum_sub (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); + } +#endif +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + ratio_set_long (scratch_ratio, 1L); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + /* No need to canonicalize after subtracting 1 */ + return make_ratio_rt (scratch_ratio); + } +#endif +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_set_long (scratch_bigfloat, 1L); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), + scratch_bigfloat); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif number = wrong_type_argument (Qnumber_char_or_marker_p, number); goto retry; @@ -2487,6 +3387,7 @@ DEFSYMBOL (Qintegerp); DEFSYMBOL (Qcharacterp); DEFSYMBOL (Qnatnump); + DEFSYMBOL (Qnonnegativep); DEFSYMBOL (Qstringp); DEFSYMBOL (Qarrayp); DEFSYMBOL (Qsequencep); @@ -2508,6 +3409,9 @@ DEFSUBR (Fwrong_type_argument); +#ifdef HAVE_RATIO + DEFSUBR (Fdiv); +#endif DEFSUBR (Feq); DEFSUBR (Fold_eq); DEFSUBR (Fnull); @@ -2523,7 +3427,11 @@ DEFSUBR (Fchar_to_int); DEFSUBR (Fint_to_char); DEFSUBR (Fchar_or_char_int_p); +#ifdef HAVE_BIGNUM + DEFSUBR (Ffixnump); +#else DEFSUBR (Fintegerp); +#endif DEFSUBR (Finteger_or_marker_p); DEFSUBR (Finteger_or_char_p); DEFSUBR (Finteger_char_or_marker_p); @@ -2532,6 +3440,7 @@ DEFSUBR (Fnumber_char_or_marker_p); DEFSUBR (Ffloatp); DEFSUBR (Fnatnump); + DEFSUBR (Fnonnegativep); DEFSUBR (Fsymbolp); DEFSUBR (Fkeywordp); DEFSUBR (Fstringp);
--- a/src/depend Mon Apr 05 21:50:47 2004 +0000 +++ b/src/depend Mon Apr 05 22:50:11 2004 +0000 @@ -11,7 +11,7 @@ LISP_H= #else CONFIG_H=config.h -LISP_H=lisp.h compiler.h config.h dumper.h general-slots.h lrecord.h symeval.h symsinit.h text.h $(LISP_UNION_H) +LISP_H=lisp.h compiler.h config.h dumper.h general-slots.h lrecord.h number-gmp.h number-mp.h number.h symeval.h symsinit.h text.h $(LISP_UNION_H) #endif #if defined(HAVE_MS_WINDOWS) @@ -195,6 +195,9 @@ nt.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h ndir.h process.h sysdir.h sysfile.h sysproc.h syspwd.h syssignal.h systime.h syswindows.h ntheap.o: $(LISP_H) intl-auto-encap-win32.h sysdep.h syswindows.h ntplay.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h sound.h sysfile.h syswindows.h +number-gmp.o: $(LISP_H) +number-mp.o: $(LISP_H) +number.o: $(LISP_H) objects.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty.h console.h device-impl.h device.h devslots.h elhash.h faces.h frame.h glyphs.h objects-impl.h objects.h redisplay.h scrollbar.h specifier.h systty.h window-impl.h window.h winslots.h offix.o: offix-cursors.h offix-types.h offix.h xintrinsic.h opaque.o: $(LISP_H) opaque.h
--- a/src/doprnt.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/doprnt.c Mon Apr 05 22:50:11 2004 +0000 @@ -6,6 +6,7 @@ Rewritten by mly to use varargs.h. Rewritten from scratch by Ben Wing (February 1995) for Mule; expanded to full printf spec. + Support for bignums, ratios, and bigfloats added April 2004 by Jerry James. This file is part of XEmacs. @@ -33,11 +34,24 @@ #include "lstream.h" static const char * const valid_flags = "-+ #0"; -static const char * const valid_converters = "dic" "ouxX" "feEgG" "sS"; +static const char * const valid_converters = "dic" "ouxX" "feEgG" "sS" +#if defined(HAVE_BIGNUM) || defined(HAVE_RATIO) + "npyY" +#endif +#ifdef HAVE_BIGFLOAT + "FhHkK" +#endif + ; static const char * const int_converters = "dic"; static const char * const unsigned_int_converters = "ouxX"; static const char * const double_converters = "feEgG"; static const char * const string_converters = "sS"; +#if defined(HAVE_BIGNUM) || defined(HAVE_RATIO) +static const char * const bignum_converters = "npyY"; +#endif +#ifdef HAVE_BIGFLOAT +static const char * const bigfloat_converters = "FhHkK"; +#endif typedef struct printf_spec printf_spec; struct printf_spec @@ -70,6 +84,7 @@ unsigned long ul; double d; Ibyte *bp; + Lisp_Object obj; }; /* We maintain a list of all the % specs in the specification, @@ -385,6 +400,14 @@ arg.d = va_arg (vargs, double); else if (strchr (string_converters, ch)) arg.bp = va_arg (vargs, Ibyte *); +#if defined(HAVE_BIGNUM) || defined(HAVE_RATIO) + else if (strchr (bignum_converters, ch)) + arg.obj = va_arg (vargs, Lisp_Object); +#endif +#ifdef HAVE_BIGFLOAT + else if (strchr (bigfloat_converters, ch)) + arg.obj = va_arg (vargs, Lisp_Object); +#endif else abort (); Dynarr_add (args, arg); @@ -568,27 +591,121 @@ Lisp_Object obj = largs[spec->argnum - 1]; if (CHARP (obj)) obj = make_int (XCHAR (obj)); +#ifdef WITH_NUMBER_TYPES + if (!NUMBERP (obj)) +#else if (!INT_OR_FLOATP (obj)) +#endif { syntax_error ("format specifier %%%c doesn't match argument type", make_char (ch)); } else if (strchr (double_converters, ch)) - arg.d = XFLOATINT (obj); + { +#ifdef WITH_NUMBER_TYPES + if (INTP (obj) || FLOATP (obj)) + arg.d = XFLOATINT (obj); +#ifdef HAVE_BIGNUM + else if (BIGNUMP (obj)) + arg.d = bignum_to_double (XBIGNUM_DATA (obj)); +#endif +#ifdef HAVE_RATIO + else if (RATIOP (obj)) + arg.d = ratio_to_double (XRATIO_DATA (obj)); +#endif +#ifdef HAVE_BIGFLOAT + else if (BIGFLOATP (obj)) + { + arg.obj = obj; + switch (ch) + { + case 'f': ch = 'F'; break; + case 'e': ch = 'h'; break; + case 'E': ch = 'H'; break; + case 'g': ch = 'k'; break; + case 'G': ch = 'K'; break; + } + } +#endif +#else /* !WITH_NUMBER_TYPES */ + arg.d = XFLOATINT (obj); +#endif /* WITH_NUMBER_TYPES */ + } else { if (FLOATP (obj)) obj = Ftruncate (obj); - - if (strchr (unsigned_int_converters, ch)) - arg.ul = (unsigned long) XINT (obj); - else - arg.l = XINT (obj); +#ifdef HAVE_BIGFLOAT + else if (BIGFLOATP (obj)) + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, + XBIGFLOAT_DATA (obj)); + if (strchr (unsigned_int_converters, ch) && + bignum_sign (scratch_bignum) < 0) + dead_wrong_type_argument (Qnonnegativep, obj); + obj = + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else /* !HAVE_BIGNUM */ + obj = make_int (bigfloat_to_long (XBIGFLOAT_DATA (obj))); +#endif /* HAVE_BIGNUM */ + } +#endif /* HAVE_BIGFLOAT */ +#ifdef HAVE_RATIO + else if (RATIOP (obj)) + { + arg.obj = obj; + switch (ch) + { + case 'i': case 'd': ch = 'n'; break; + case 'o': ch = 'p'; break; + case 'x': ch = 'y'; break; + case 'X': ch = 'Y'; break; + default: /* ch == 'u' */ + if (strchr (unsigned_int_converters, ch) && + ratio_sign (XRATIO_DATA (obj)) < 0) + dead_wrong_type_argument (Qnonnegativep, obj); + else + ch = 'n'; + } + } +#endif +#ifdef HAVE_BIGNUM + if (BIGNUMP (obj)) + { + arg.obj = obj; + switch (ch) + { + case 'i': case 'd': ch = 'n'; break; + case 'o': ch = 'p'; break; + case 'x': ch = 'y'; break; + case 'X': ch = 'Y'; break; + default: /* ch == 'u' */ + if (strchr (unsigned_int_converters, ch) && + bignum_sign (XBIGNUM_DATA (obj)) < 0) + dead_wrong_type_argument (Qnatnump, obj); + else + ch = 'n'; + } + } +#endif + if (INTP (obj)) + { + if (strchr (unsigned_int_converters, ch)) + { +#ifdef HAVE_BIGNUM + if (XINT (obj) < 0) + dead_wrong_type_argument (Qnatnump, obj); +#endif + arg.ul = (unsigned long) XUINT (obj); + } + else + arg.l = XINT (obj); + } } } - if (ch == 'c') { Ichar a; @@ -605,6 +722,44 @@ doprnt_2 (stream, charbuf, charlen, spec->minwidth, -1, spec->minus_flag, spec->zero_flag); } +#if defined(HAVE_BIGNUM) || defined(HAVE_RATIO) + else if (strchr (bignum_converters, ch)) + { +#ifdef HAVE_BIGNUM + if (BIGNUMP (arg.obj)) + { + char *text_to_print = + bignum_to_string (XBIGNUM_DATA (arg.obj), + ch == 'n' ? 10 : + (ch == 'p' ? 8 : 16)); + doprnt_2 (stream, text_to_print, strlen (text_to_print), + spec->minwidth, -1, spec->minus_flag, + spec->zero_flag); + } +#endif +#ifdef HAVE_RATIO + if (RATIOP (arg.obj)) + { + char *text_to_print = + ratio_to_string (XRATIO_DATA (arg.obj), + ch == 'n' ? 10 : + (ch == 'p' ? 8 : 16)); + doprnt_2 (stream, text_to_print, strlen (text_to_print), + spec->minwidth, -1, spec->minus_flag, + spec->zero_flag); + } +#endif + } +#endif /* HAVE_BIGNUM || HAVE_RATIO */ +#ifdef HAVE_BIGFLOAT + else if (strchr (bigfloat_converters, ch)) + { + char *text_to_print = + bigfloat_to_string (XBIGFLOAT_DATA (arg.obj), 10); + doprnt_2 (stream, text_to_print, strlen (text_to_print), + spec->minwidth, -1, spec->minus_flag, spec->zero_flag); + } +#endif /* HAVE_BIGFLOAT */ else { /* ASCII Decimal representation uses 2.4 times as many
--- a/src/emacs.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/emacs.c Mon Apr 05 22:50:11 2004 +0000 @@ -1301,6 +1301,9 @@ #ifdef HAVE_SHLIB syms_of_module (); #endif +#ifdef WITH_NUMBER_TYPES + syms_of_number (); +#endif syms_of_objects (); syms_of_print (); #if !defined (NO_SUBPROCESSES) @@ -1816,6 +1819,9 @@ vars_of_dired_mswindows (); vars_of_nt (); #endif +#ifdef WITH_NUMBER_TYPES + vars_of_number (); +#endif vars_of_objects (); vars_of_print (); @@ -2275,6 +2281,12 @@ init_initial_directory (); /* get the directory to use for the "*scratch*" buffer, etc. */ +#ifdef WITH_NUMBER_TYPES + /* Set up bignums, ratios, bigfloats, complex numbers. + This must be done before the Lisp reader is set up. */ + init_number (); +#endif + init_lread (); /* Set up the Lisp reader. */ init_cmdargs (argc, (Extbyte **) argv, skip_args); /* Create list Vcommand_line_args */
--- a/src/floatfns.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/floatfns.c Mon Apr 05 22:50:11 2004 +0000 @@ -119,10 +119,15 @@ /* Convert float to Lisp Integer if it fits, else signal a range - error using the given arguments. */ + error using the given arguments. If bignums are available, range errors + are never signaled. */ static Lisp_Object float_to_int (double x, const char *name, Lisp_Object num, Lisp_Object num2) { +#ifdef HAVE_BIGNUM + bignum_set_double (scratch_bignum, x); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else if (x >= ((EMACS_INT) 1 << (VALBITS-1)) || x <= - ((EMACS_INT) 1 << (VALBITS-1)) - (EMACS_INT) 1) { @@ -132,6 +137,7 @@ range_error (name, num); } return (make_int ((EMACS_INT) x)); +#endif /* HAVE_BIGNUM */ } @@ -199,6 +205,21 @@ if (INTP (num)) return (double) XINT (num); +#ifdef HAVE_BIGNUM + if (BIGNUMP (num)) + return bignum_to_double (XBIGNUM_DATA (num)); +#endif + +#ifdef HAVE_RATIO + if (RATIOP (num)) + return ratio_to_double (XRATIO_DATA (num)); +#endif + +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (num)) + return bigfloat_to_double (XBIGFLOAT_DATA (num)); +#endif + return extract_float (wrong_type_argument (Qnumberp, num)); } @@ -421,6 +442,21 @@ */ (number1, number2)) { +#ifdef HAVE_BIGNUM + if (INTEGERP (number1) && INTP (number2)) + { + if (INTP (number1)) + { + bignum_set_long (scratch_bignum2, XREALINT (number1)); + bignum_pow (scratch_bignum, scratch_bignum2, XREALINT (number2)); + } + else + bignum_pow (scratch_bignum, XBIGNUM_DATA (number1), + XREALINT (number2)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif + if (INTP (number1) && /* common lisp spec */ INTP (number2)) /* don't promote, if both are ints */ { @@ -451,6 +487,23 @@ return make_int (retval); } +#if defined(HAVE_BIGFLOAT) && defined(bigfloat_pow) + if (BIGFLOATP (number1) && INTEGERP (number2)) + { + unsigned long exp; + +#ifdef HAVE_BIGNUM + if (BIGNUMP (number2)) + exp = bignum_to_ulong (XBIGNUM_DATA (number2)); + else +#endif + exp = XUINT (number2); + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number1)); + bigfloat_pow (scratch_bigfloat, XBIGFLOAT_DATA (number1), exp); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif + { double f1 = extract_float (number1); double f2 = extract_float (number2); @@ -516,7 +569,17 @@ */ (number)) { - double d = extract_float (number); + double d; + +#if defined(HAVE_BIGFLOAT) && defined(bigfloat_sqrt) + if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_sqrt (scratch_bigfloat, XBIGFLOAT_DATA (number)); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif /* HAVE_BIGFLOAT */ + d = extract_float (number); #ifdef FLOAT_CHECK_DOMAIN if (d < 0.0) domain_error ("sqrt", number); @@ -648,7 +711,43 @@ } if (INTP (number)) +#ifdef HAVE_BIGNUM + /* The most negative Lisp fixnum will overflow */ + return (XINT (number) >= 0) ? number : make_integer (- XINT (number)); +#else return (XINT (number) >= 0) ? number : make_int (- XINT (number)); +#endif + +#ifdef HAVE_BIGNUM + if (BIGNUMP (number)) + { + if (bignum_sign (XBIGNUM_DATA (number)) >= 0) + return number; + bignum_abs (scratch_bignum, XBIGNUM_DATA (number)); + return make_bignum_bg (scratch_bignum); + } +#endif + +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + if (ratio_sign (XRATIO_DATA (number)) >= 0) + return number; + ratio_abs (scratch_ratio, XRATIO_DATA (number)); + return make_ratio_rt (scratch_ratio); + } +#endif + +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + if (bigfloat_sign (XBIGFLOAT_DATA (number)) >= 0) + return number; + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_abs (scratch_bigfloat, XBIGFLOAT_DATA (number)); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif return Fabs (wrong_type_argument (Qnumberp, number)); } @@ -661,6 +760,29 @@ if (INTP (number)) return make_float ((double) XINT (number)); +#ifdef HAVE_BIGNUM + if (BIGFLOATP (number)) + { +#ifdef HAVE_BIGFLOAT + if (ZEROP (Vdefault_float_precision)) +#endif + return make_float (bignum_to_double (XBIGNUM_DATA (number))); +#ifdef HAVE_BIGFLOAT + else + { + bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ()); + bigfloat_set_bignum (scratch_bigfloat, XBIGNUM_DATA (number)); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif /* HAVE_BIGFLOAT */ + } +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO + if (RATIOP (number)) + make_float (ratio_to_double (XRATIO_DATA (number))); +#endif + if (FLOATP (number)) /* give 'em the same float back */ return number; @@ -730,9 +852,36 @@ return (float_to_int (d, "ceiling", number, Qunbound)); } +#ifdef HAVE_BIGNUM + if (INTEGERP (number)) +#else if (INTP (number)) +#endif return number; +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif + +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number)); +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } +#endif /* HAVE_BIGFLOAT */ + return Fceiling (wrong_type_argument (Qnumberp, number)); } @@ -744,6 +893,99 @@ */ (number, divisor)) { +#ifdef WITH_NUMBER_TYPES + CHECK_REAL (number); + if (NILP (divisor)) + { + if (FLOATP (number)) + { + double d; + IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number); + return (float_to_int (d, "floor", number, Qunbound)); + } +#ifdef HAVE_RATIO + else if (RATIOP (number)) + { + bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif +#ifdef HAVE_BIGFLOAT + else if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number)); + return make_bigfloat_bf (scratch_bigfloat); + } +#endif + return number; + } + else + { + CHECK_REAL (divisor); + switch (promote_args (&number, &divisor)) + { + case FIXNUM_T: + { + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* With C's /, the result is implementation-defined if either + operand is negative, so use only nonnegative operands. */ + i1 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) + : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); + + return make_int (i1); + } +#ifdef HAVE_BIGNUM + case BIGNUM_T: + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + Fsignal (Qarith_error, Qnil); + bignum_floor (scratch_bignum, XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#endif + case FLOAT_T: + { + double f1 = extract_float (number); + double f2 = extract_float (divisor); + + if (f2 == 0.0) + Fsignal (Qarith_error, Qnil); + + IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor); + return float_to_int (f1, "floor", number, divisor); + } +#ifdef HAVE_RATIO + case RATIO_T: + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + Fsignal (Qarith_error, Qnil); + ratio_div (scratch_ratio, XRATIO_DATA (number), + XRATIO_DATA (divisor)); + bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#endif +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + Fsignal (Qarith_error, Qnil); + bigfloat_set_prec (scratch_bigfloat, + max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (divisor)); + bigfloat_floor (scratch_bigfloat, scratch_bigfloat); + return make_bigfloat_bf (scratch_bigfloat); +#endif + } + } +#else /* !WITH_NUMBER_TYPES */ CHECK_INT_OR_FLOAT (number); if (! NILP (divisor)) @@ -787,6 +1029,7 @@ } return number; +#endif /* WITH_NUMBER_TYPES */ } DEFUN ("round", Fround, 1, 1, 0, /* @@ -802,9 +1045,51 @@ return (float_to_int (d, "round", number, Qunbound)); } +#ifdef HAVE_BIGNUM + if (INTEGERP (number)) +#else if (INTP (number)) +#endif return number; +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + } + else + { + bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + bignum_div (scratch_bignum, scratch_bignum2, + XRATIO_DENOMINATOR (number)); + } + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif + +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + unsigned long prec = XBIGFLOAT_GET_PREC (number); + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + bigfloat_set_double (scratch_bigfloat2, + bigfloat_sign (XBIGFLOAT_DATA (number)) * 0.5); + bigfloat_floor (scratch_bigfloat, scratch_bigfloat2); +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } +#endif /* HAVE_BIGFLOAT */ + return Fround (wrong_type_argument (Qnumberp, number)); } @@ -817,9 +1102,36 @@ if (FLOATP (number)) return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound); +#ifdef HAVE_BIGNUM + if (INTEGERP (number)) +#else if (INTP (number)) +#endif return number; +#ifdef HAVE_RATIO + if (RATIOP (number)) + { + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif + +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (number)) + { + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number)); +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } +#endif /* HAVE_BIGFLOAT */ + return Ftruncate (wrong_type_argument (Qnumberp, number)); }
--- a/src/fns.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/fns.c Mon Apr 05 22:50:11 2004 +0000 @@ -149,9 +149,9 @@ DEFUN ("random", Frandom, 0, 1, 0, /* Return a pseudo-random number. -All integers representable in Lisp are equally likely. - On most systems, this is 28 bits' worth. +All fixnums are equally likely. On most systems, this is 31 bits' worth. With positive integer argument N, return random number in interval [0,N). +N can be a bignum, in which case the range of possible values is extended. With argument t, set the random number seed from the current time and pid. */ (limit)) @@ -175,6 +175,13 @@ val = get_random () / denominator; while (val >= XINT (limit)); } +#ifdef HAVE_BIGNUM + else if (BIGNUMP (limit)) + { + bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } +#endif else val = get_random (); @@ -2840,8 +2847,33 @@ QUIT; if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; +#ifdef WITH_NUMBER_TYPES + if (NUMBERP (obj1) && NUMBERP (obj2)) + { + switch (promote_args (&obj1, &obj2)) + { + case FIXNUM_T: + return XREALINT (obj1) == XREALINT (obj2); +#ifdef HAVE_BIGNUM + case BIGNUM_T: + return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); +#endif +#ifdef HAVE_RATIO + case RATIO_T: + return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); +#endif + case FLOAT_T: + return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2); +#ifdef HAVE_BIGFLOAT + case BIGFLOAT_T: + return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); +#endif + } + } +#else if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2))) return extract_float (obj1) == extract_float (obj2); +#endif if (CHARP (obj1) && CHARP (obj2)) return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); if (XTYPE (obj1) != XTYPE (obj2))
--- a/src/general-slots.h Mon Apr 05 21:50:47 2004 +0000 +++ b/src/general-slots.h Mon Apr 05 22:50:11 2004 +0000 @@ -57,6 +57,7 @@ SYMBOL (Qautodetect); SYMBOL (Qbad_variable); SYMBOL (Qbefore); +SYMBOL (Qbigfloat); SYMBOL (Qbinary); SYMBOL (Qbitmap); SYMBOL (Qboolean); @@ -127,6 +128,8 @@ SYMBOL (Qfile); SYMBOL_MODULE_API (Qfile_name); SYMBOL_KEYWORD (Q_filter); +SYMBOL (Qfixnum); +SYMBOL (Qfloat); SYMBOL (Qfont); SYMBOL (Qframe); SYMBOL (Qframes); @@ -232,6 +235,7 @@ SYMBOL (Qradio); SYMBOL (Qrassoc); SYMBOL (Qrassq); +SYMBOL (Qratio); SYMBOL (Qredisplay); SYMBOL (Qremove_all); SYMBOL (Qrequire);
--- a/src/lisp.h Mon Apr 05 21:50:47 2004 +0000 +++ b/src/lisp.h Mon Apr 05 22:50:11 2004 +0000 @@ -3377,6 +3377,14 @@ /************************************************************************/ /************************************************************************/ +/* Other numeric types */ +/************************************************************************/ +#ifdef WITH_NUMBER_TYPES +#include "number.h" +#endif + + +/************************************************************************/ /* prototypes */ /************************************************************************/ @@ -4333,6 +4341,9 @@ int locate_file (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object *, int); EXFUN (Flocate_file_clear_hashing, 1); int isfloat_string (const char *); +#ifdef HAVE_RATIO +int isratio_string (const char *); +#endif /* Well, I've decided to enable this. -- ben */ /* And I've decided to make it work right. -- sb */ @@ -5062,8 +5073,8 @@ extern Lisp_Object Qmalformed_property_list, Qmark, Qmodule; extern Lisp_Object Qmono_pixmap_image_instance_p, Qmouse_leave_buffer_hook; extern Lisp_Object Qnative_layout, Qnatnump, Qnetwork_error, Qno_catch; -extern Lisp_Object Qnothing_image_instance_p, Qnumber_char_or_marker_p; -extern Lisp_Object Qnumberp, Qout_of_memory; +extern Lisp_Object Qnonnegativep, Qnothing_image_instance_p; +extern Lisp_Object Qnumber_char_or_marker_p, Qnumberp, Qout_of_memory; extern Lisp_Object Qoverflow_error, Qpoint, Qpointer_glyph_p; extern Lisp_Object Qpointer_image_instance_p, Qprint_length; extern Lisp_Object Qprint_string_length, Qprinting_unreadable_object;
--- a/src/lread.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/lread.c Mon Apr 05 22:50:11 2004 +0000 @@ -1848,6 +1848,14 @@ #endif } } +#ifdef HAVE_RATIO + if (isratio_string (read_ptr)) + { + ratio_set_string (scratch_ratio, read_ptr, 0); + ratio_canonicalize (scratch_ratio); + return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } +#endif if (isfloat_string (read_ptr)) return make_float (atof (read_ptr)); } @@ -1920,11 +1928,18 @@ return result; } overflow: +#ifdef HAVE_BIGNUM + { + bignum_set_string (scratch_bignum, buf, 0); + return make_bignum_bg (scratch_bignum); + } +#else return Fsignal (Qinvalid_read_syntax, list3 (build_msg_string ("Integer constant overflow in reader"), make_string (buf, len), make_int (base))); +#endif /* HAVE_BIGNUM */ loser: return Fsignal (Qinvalid_read_syntax, list3 (build_msg_string @@ -2653,6 +2668,39 @@ || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT) || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT))); } + +#ifdef HAVE_RATIO +int +isratio_string (const char *cp) +{ + /* Possible minus sign */ + if (*cp == '-') + cp++; + + /* Numerator */ + if (*cp < '0' || *cp > '9') + return 0; + + do { + cp++; + } while (*cp >= '0' && *cp <= '9'); + + /* Slash */ + if (*cp++ != '/') + return 0; + + /* Denominator */ + if (*cp < '0' || *cp > '9') + return 0; + + do { + cp++; + } while (*cp >= '0' && *cp <= '9'); + + return *cp == '\0' || *cp == ' ' || *cp =='\t' || *cp == '\n' || + *cp == '\r' || *cp == '\f'; +} +#endif static void * sequence_reader (Lisp_Object readcharfun,
--- a/src/lrecord.h Mon Apr 05 21:50:47 2004 +0000 +++ b/src/lrecord.h Mon Apr 05 22:50:11 2004 +0000 @@ -215,6 +215,9 @@ lrecord_type_emacs_gtk_boxed, lrecord_type_weak_box, lrecord_type_ephemeron, + lrecord_type_bignum, + lrecord_type_ratio, + lrecord_type_bigfloat, lrecord_type_free, /* only used for "free" lrecords */ lrecord_type_undefined, /* only used for debugging */ lrecord_type_last_built_in_type /* must be last */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number-gmp.c Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,105 @@ +/* Numeric types for XEmacs using the GNU MP library. + Copyright (C) 2004 Jerry James. + +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. */ + +#include <config.h> +#include <limits.h> +#include <math.h> +#include "lisp.h" + +static mpf_t float_print_min, float_print_max; +gmp_randstate_t random_state; + +CIbyte * +bigfloat_to_string(mpf_t f, int base) +{ + mp_exp_t expt; + CIbyte *str = mpf_get_str (NULL, &expt, base, 0, f); + const int sign = mpf_sgn (f); + const int neg = (sign < 0) ? 1 : 0; + int len = strlen (str) + 1; /* Count the null terminator */ + + if (sign == 0 || (mpf_cmp (float_print_min, f) <= 0 && + mpf_cmp (f, float_print_max) <= 0)) + { + /* Move digits down to insert a radix point */ + if (expt <= 0) + { + /* We need room for a radix point and leading zeroes */ + const int space = -expt + 2; + XREALLOC_ARRAY (str, CIbyte, len + space); + memmove (&str[space + neg], &str[neg], len - neg); + memset (&str[neg], '0', space); + str[neg + 1] = '.'; + len += space; + } + else + { + /* We just need room for a radix point */ + XREALLOC_ARRAY (str, CIbyte, len + 1); + memmove (&str[expt + neg + 1], &str[expt + neg], len - (expt + neg)); + str[expt + neg] = '.'; + len++; + } + } + else + { + /* Computerized scientific notation */ + /* We need room for a radix point, format identifier, and exponent */ + const int space = (expt < 0) + ? (int)(log (-expt) / log (base)) + 3 + : (int)(log (expt) / log (base)) + 2; + XREALLOC_ARRAY (str, CIbyte, len + space); + memmove (&str[neg + 2], &str[neg + 1], len - neg); + str[len + 1] = 'l'; + sprintf (&str[len + 2], "%ld", expt); + } + return str; +} + +/* We need the next two functions since GNU MP insists on giving us an extra + parameter. */ +static void *gmp_realloc (void *ptr, size_t old_size /* unused */, + size_t new_size) +{ + return xrealloc (ptr, new_size); +} + +static void gmp_free (void *ptr, size_t size /* unused */) +{ + xfree (ptr, void *); +} + +void +init_number_gmp () +{ + mp_set_memory_functions ((void *(*) (size_t))xmalloc, gmp_realloc, gmp_free); + + /* The smallest number that is printed without exponents */ + mpf_init_set_d (float_print_min, 0.001); + + /* The largest number that is printed without exponents */ + mpf_init_set_ui (float_print_max, 10000000UL); + + /* Prepare the bignum/bigfloat random number generator */ + gmp_randinit_default (random_state); + gmp_randseed_ui (random_state, qxe_getpid () + time (NULL)); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number-gmp.h Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,227 @@ +/* Definitions of numeric types for XEmacs using the GNU MP library. + Copyright (C) 2004 Jerry James. + +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. */ + +/* This library defines the following types: + bignum = mpz_t + ratio = mpq_t + bigfloat = mpf_t +*/ + +#ifndef INCLUDED_number_gmp_h_ +#define INCLUDED_number_gmp_h_ + +#include <gmp.h> + +typedef mpz_t bignum; +typedef mpq_t ratio; +typedef mpf_t bigfloat; + +extern void init_number_gmp(void); + + +/********************************* Bignums **********************************/ + +#define HAVE_BIGNUM 1 + +extern gmp_randstate_t random_state; + +/***** Bignum: basic functions *****/ +#define bignum_init(b) mpz_init (b) +#define bignum_fini(b) mpz_clear (b) +#define bignum_hashcode(b) mpz_get_ui (b) +#define bignum_sign(b) mpz_sgn (b) +#define bignum_evenp(b) mpz_even_p (b) +#define bignum_oddp(b) mpz_odd_p (b) + +/***** Bignum: size *****/ +#define bignum_fits_int_p(b) mpz_fits_sint_p (b) +#define bignum_fits_uint_p(b) mpz_fits_uint_p (b) +#define bignum_fits_long_p(b) mpz_fits_slong_p (b) +#define bignum_fits_ulong_p(b) mpz_fits_ulong_p (b) + +/***** Bignum: conversions *****/ +#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_uint(b) ((unsigned int) mpz_get_ui (b)) +#define bignum_to_long(b) mpz_get_si (b) +#define bignum_to_ulong(b) mpz_get_ui (b) +#define bignum_to_double(b) mpz_get_d (b) + +/***** Bignum: converting assignments *****/ +#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_set_ulong(b,l) mpz_set_ui (b, l) +#define bignum_set_double(b,f) mpz_set_d (b, f) +#define bignum_set_ratio(b,r) mpz_set_q (b, r) +#define bignum_set_bigfloat(b,f) mpz_set_f (b, f) + +/***** Bignum: comparisons *****/ +#define bignum_cmp(b1,b2) mpz_cmp (b1, b2) +#define bignum_lt(b1,b2) (mpz_cmp (b1, b2) < 0) +#define bignum_le(b1,b2) (mpz_cmp (b1, b2) <= 0) +#define bignum_eql(b1,b2) (mpz_cmp (b1, b2) == 0) +#define bignum_ge(b1,b2) (mpz_cmp (b1, b2) >= 0) +#define bignum_gt(b1,b2) (mpz_cmp (b1, b2) > 0) + +/***** Bignum: arithmetic *****/ +#define bignum_neg(b,b2) mpz_neg (b, b2) +#define bignum_abs(b,b2) mpz_abs (b, b2) +#define bignum_add(b,b1,b2) mpz_add (b, b1, b2) +#define bignum_sub(b,b1,b2) mpz_sub (b, b1, b2) +#define bignum_mul(b,b1,b2) mpz_mul (b, b1, b2) +#define bignum_divisible_p(b1,b2) mpz_divisible_p (b1, b2) +#define bignum_div(b,b1,b2) mpz_tdiv_q (b, b1, b2) +#define bignum_ceil(b,b1,b2) mpz_cdiv_q (b, b1, b2) +#define bignum_floor(b,b1,b2) mpz_fdiv_q (b, b1, b2) +#define bignum_mod(b,b1,b2) mpz_mod (b, b1, b2) +#define bignum_pow(res,b,pow) mpz_pow_ui (res, b, pow) +#define bignum_gcd(res,b1,b2) mpz_gcd (res, b1, b2) +#define bignum_lcm(res,b1,b2) mpz_lcm (res, b1, b2) + +/***** Bignum: bit manipulations *****/ +#define bignum_and(res,b1,b2) mpz_and (res, b1, b2) +#define bignum_ior(res,b1,b2) mpz_ior (res, b1, b2) +#define bignum_xor(res,b1,b2) mpz_xor (res, b1, b2) +#define bignum_not(res,b) mpz_com (res, b) +#define bignum_setbit(b,bit) mpz_setbit (b, bit) +#define bignum_clrbit(b,bit) mpz_clrbit (b, bit) +#define bignum_testbit(b,bit) mpz_tstbit (b, bit) +#define bignum_lshift(res,b,bits) mpz_mul_2exp (res, b, bits) +#define bignum_rshift(res,b,bits) mpz_fdiv_q_2exp (res, b, bits) + +/***** Bignum: random numbers *****/ +#define bignum_random_seed(seed) gmp_randseed_ui (random_state, seed) +#define bignum_random(res,limit) mpz_urandomm (res, random_state, limit) + + +/********************************** Ratios **********************************/ + +#define HAVE_RATIO 1 + +/***** Ratio: basic functions *****/ +#define ratio_init(r) mpq_init (r) +#define ratio_fini(r) mpq_clear (r) +#define ratio_hashcode(r) \ + (mpz_get_ui (mpq_denref (r)) * mpz_get_ui (mpq_numref (r))) +#define ratio_sign(r) mpq_sgn (r) +#define ratio_numerator(r) mpq_numref (r) +#define ratio_denominator(r) mpq_denref (r) +#define ratio_canonicalize(r) mpq_canonicalize (r) + +/***** Ratio: conversions *****/ +#define ratio_to_string(r,base) mpq_get_str (NULL, base, r) +#define ratio_to_int(r) ((int) (mpq_get_d (r))) +#define ratio_to_uint(r) ((unsigned int) (mpq_get_d (r))) +#define ratio_to_long(r) ((long) (mpq_get_d (r))) +#define ratio_to_ulong(r) ((unsigned long) (mpq_get_d (r))) +#define ratio_to_double(r) mpq_get_d (r) + +/***** Ratio: converting assignments *****/ +#define ratio_set(r1,r2) mpq_set (r1, r2) +#define ratio_set_string(r,s,base) mpq_set_str (r, s, base) +#define ratio_set_long(r,l) mpq_set_si (r, l, 1UL) +#define ratio_set_ulong(r,l) mpq_set_ui (r, l, 1UL) +#define ratio_set_double(r,f) mpq_set_d (r, f) +#define ratio_set_bignum(r,b) mpq_set_z (r, b) +#define ratio_set_bigfloat(r,f) mpq_set_f (r, f) +#define ratio_set_long_ulong(r,num,den) mpq_set_si (r, num, den) +#define ratio_set_ulong_ulong(r,num,den) mpq_set_ui (r, num, den) +#define ratio_set_bignum_bignum(r,num,den) do { \ + mpz_set (mpq_numref (r), num); \ + mpz_set (mpq_denref (r), den); \ + mpq_canonicalize (r); \ + } while (0) + +/***** Ratio: comparisons *****/ +#define ratio_cmp(r1,r2) mpq_cmp (r1, r2) +#define ratio_lt(r1,r2) (mpq_cmp (r1, r2) < 0) +#define ratio_le(r1,r2) (mpq_cmp (r1, r2) <= 0) +#define ratio_eql(r1,r2) mpq_equal (r1, r2) +#define ratio_ge(r1,r2) (mpq_cmp (r1, r2) >= 0) +#define ratio_gt(r1,r2) (mpq_cmp (r1, r2) > 0) + +/***** Ratio: arithmetic *****/ +#define ratio_neg(q,q2) mpq_neg (q, q2) +#define ratio_abs(q,q2) mpq_abs (q, q2) +#define ratio_inv(q,q2) mpq_inv (q, q2) +#define ratio_add(res,q1,q2) mpq_add (res, q1, q2) +#define ratio_sub(res,q1,q2) mpq_sub (res, q1, q2) +#define ratio_mul(res,q1,q2) mpq_mul (res, q1, q2) +#define ratio_div(res,q1,q2) mpq_div (res, q1, q2) + + +/******************************** Bigfloats *********************************/ + +#define HAVE_BIGFLOAT 1 + +/***** Bigfloat: basic functions *****/ +#define bigfloat_init(f) mpf_init (f) +#define bigfloat_init_prec(f,prec) mpf_init2 (f, prec) +#define bigfloat_fini(f) mpf_clear (f) +#define bigfloat_hashcode(f) mpf_get_ui (f) +#define bigfloat_sign(f) mpf_sgn (f) +#define bigfloat_get_prec(f) mpf_get_prec (f) +#define bigfloat_set_prec(f, prec) mpf_set_prec (f, prec) +#define bigfloat_set_default_prec(prec) mpf_set_default_prec(prec) +#define bigfloat_get_default_prec() mpf_get_default_prec () + +/***** Bigfloat: conversions *****/ +extern CIbyte *bigfloat_to_string (bigfloat f, int base); +#define bigfloat_to_int(f) ((int) mpf_get_si (f)) +#define bigfloat_to_uint(f) ((unsigned int) mpf_get_ui (f)) +#define bigfloat_to_long(f) mpf_get_si (f) +#define bigfloat_to_ulong(f) mpf_get_ui (f) +#define bigfloat_to_double(f) mpf_get_d (f) + +/***** Bigfloat: converting assignments *****/ +#define bigfloat_set(f1,f2) mpf_set (f1, f2) +#define bigfloat_set_string(f,str,base) mpf_set_str (f, str, base) +#define bigfloat_set_long(f,l) mpf_set_si (f, l) +#define bigfloat_set_ulong(f,l) mpf_set_ui (f, l) +#define bigfloat_set_double(d,f) mpf_set_d (d, f) +#define bigfloat_set_bignum(f,b) mpf_set_z (f, b) +#define bigfloat_set_ratio(f,r) mpf_set_q (f, r) + +/***** Bigfloat: comparisons *****/ +#define bigfloat_cmp(f1,f2) mpf_cmp (f1, f2) +#define bigfloat_lt(f1,f2) (mpf_cmp (f1, f2) < 0) +#define bigfloat_le(f1,f2) (mpf_cmp (f1, f2) <= 0) +#define bigfloat_eql(f1,f2) (mpf_cmp (f1, f2) == 0) +#define bigfloat_eql_bits(f1,f2,bits) mpf_eq (f1, f2, bits) +#define bigfloat_ge(f1,f2) (mpf_cmp (f1, f2) >= 0) +#define bigfloat_gt(f1,f2) (mpf_cmp (f1, f2) > 0) + +/***** Bigfloat: arithmetic *****/ +#define bigfloat_neg(f,f2) mpf_neg (f, f2) +#define bigfloat_abs(f,f2) mpf_abs (f, f2) +#define bigfloat_add(res,f1,f2) mpf_add (res, f1, f2) +#define bigfloat_sub(res,f1,f2) mpf_sub (res, f1, f2) +#define bigfloat_mul(res,f1,f2) mpf_mul (res, f1, f2) +#define bigfloat_div(res,f1,f2) mpf_div (res, f1, f2) +#define bigfloat_ceil(res,f) mpf_ceil (res, f) +#define bigfloat_floor(res,f) mpf_floor (res, f) +#define bigfloat_trunc(res,f) mpf_trunc (res, f) +#define bigfloat_sqrt(res,f) mpf_sqrt (res, f) +#define bigfloat_pow(res,f,exp) mpf_pow_ui (res, f, exp) + +#endif /* INCLUDED_number_gmp_h_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number-mp.c Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,509 @@ +/* Numeric types for XEmacs using the MP library. + Copyright (C) 2004 Jerry James. + +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. */ + +#include <config.h> +#include <limits.h> +#include <math.h> +#include "lisp.h" + +static MINT *bignum_bytesize, *bignum_long_sign_bit, *bignum_one, *bignum_two; +MINT *bignum_zero, *intern_bignum; +MINT *bignum_min_int, *bignum_max_int, *bignum_max_uint; +MINT *bignum_min_long, *bignum_max_long, *bignum_max_ulong; +short div_rem; + +char * +bignum_to_string (bignum b, int base) +{ + REGISTER unsigned int i; + unsigned int bufsize = 128U, index = 0U; + int sign; + char *buffer = xnew_array (char, 128), *retval; + MINT *quo = MP_ITOM (0); + short rem; + + /* FIXME: signal something if base is < 2 or doesn't fit into a short. */ + + /* Save the sign for later */ + sign = MP_MCMP (b, bignum_zero); + + if (sign == 0) + { + XREALLOC_ARRAY (buffer, char, 2); + buffer[0] = '0'; + buffer[1] = '\0'; + return buffer; + } + /* Copy abs(b) into quo for destructive modification */ + else if (sign < 0) + MP_MSUB (bignum_zero, b, quo); + else + MP_MOVE (b, quo); + + quo = MP_ITOM (0); + + /* Loop over the digits of b (in BASE) and place each one into buffer */ + for (i = 0U; MP_MCMP(quo, bignum_zero) > 0; i++) + { + MP_SDIV (quo, base, quo, &rem); + if (index == bufsize) + { + bufsize <<= 1; + XREALLOC_ARRAY (buffer, char, bufsize); + } + buffer[index++] = rem < 10 ? rem + '0' : rem - 10 + 'a'; + } + MP_MFREE (quo); + + /* Reverse the digits, maybe add a minus sign, and add a null terminator */ + bufsize = index + (sign < 0 ? 1 : 0) + 1; + retval = xnew_array (char, bufsize); + if (sign < 0) + { + retval[0] = '-'; + i = 1; + } + else + i = 0; + for (; i < bufsize - 1; i++) + retval[i] = buffer[--index]; + retval[bufsize - 1] = '\0'; + xfree (buffer, char *); + return retval; +} + +#define BIGNUM_TO_TYPE(type,accumtype) do { \ + MP_MULT (b, quo, quo); \ + for (i = 0U; i < sizeof(type); i++) \ + { \ + MP_SDIV (quo, 256, quo, &rem); \ + retval |= ((accumtype) rem) << (8 * i); \ + } \ + MP_MFREE (quo); \ +} while (0) + +int +bignum_to_int (bignum b) +{ + short rem, sign; + unsigned int retval = 0; + REGISTER unsigned int i; + MINT *quo; + + sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; + quo = MP_ITOM (sign); + BIGNUM_TO_TYPE (int, unsigned int); + return ((int) retval) * sign; +} + +unsigned int +bignum_to_uint (bignum b) +{ + short rem; + unsigned int retval = 0U; + REGISTER unsigned int i; + MINT *quo; + + quo = MP_ITOM (MP_MCMP (b, bignum_zero) < 0 ? -1 : 1); + BIGNUM_TO_TYPE (unsigned int, unsigned int); + return retval; +} + +long +bignum_to_long (bignum b) +{ + short rem, sign; + unsigned long retval = 0L; + REGISTER unsigned int i; + MINT *quo; + + sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; + quo = MP_ITOM (sign); + BIGNUM_TO_TYPE (long, unsigned long); + return ((long) retval) * sign; +} + +unsigned long +bignum_to_ulong (bignum b) +{ + short rem; + unsigned long retval = 0UL; + REGISTER unsigned int i; + MINT *quo; + + quo = MP_ITOM (MP_MCMP (b, bignum_zero) < 0 ? -1 : 1); + BIGNUM_TO_TYPE (unsigned long, unsigned long); + return retval; +} + +double +bignum_to_double (bignum b) +{ + short rem, sign; + double retval = 0.0; + REGISTER unsigned int i; + MINT *quo; + + sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; + quo = MP_ITOM (sign); + MP_MULT (b, quo, quo); + for (i = 0U; MP_MCMP(quo, bignum_zero) > 0; i++) + { + MP_SDIV (quo, 256, quo, &rem); + retval += rem * i * 256; + } + MP_MFREE (quo); + return retval * sign; +} + +static short +char_to_number (char c) +{ + if (c >= '0' && c <= '9') + return c - '0'; + if (c >= 'a' && c <= 'z') + return c - 'a' + 10; + if (c >= 'A' && c <= 'Z') + return c - 'A' + 10; + return -1; +} + +int +bignum_set_string (bignum b, const char *s, int base) +{ + MINT *mbase; + short digit; + + if (base == 0) + { + if (s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) + { + base = 16; + s += 2; + } + else if (*s == '0') + { + base = 8; + s++; + } + else + base = 10; + } + + /* FIXME: signal something if base is < 2 or doesn't fit into a short. */ + + mbase = MP_ITOM ((short) base); + MP_MOVE (bignum_zero, b); + + for (digit = char_to_number (*s); digit >= 0 && digit < base; + digit = char_to_number (*++s)) + { + MINT *temp; + + MP_MULT (b, mbase, b); + temp = MP_ITOM (digit); + MP_MADD (b, temp, b); + MP_MFREE (temp); + } + + return (digit >= 0) ? -1 : 0; +} + +void +bignum_set_long (MINT *b, long l) +{ + /* Negative l is hard, not least because -LONG_MIN == LONG_MIN. We pretend + that l is unsigned, then subtract off the amount equal to the sign bit. */ + bignum_set_ulong (b, (unsigned long) l); + if (l < 0L) + MP_MSUB (b, bignum_long_sign_bit, b); +} + +void +bignum_set_ulong (bignum b, unsigned long l) +{ + REGISTER unsigned int i; + MINT *multiplier = MP_ITOM (1); + + MP_MOVE (bignum_zero, b); + for (i = 0UL; l > 0UL; l >>= 8, i++) + { + MINT *temp = MP_ITOM ((short) (l & 255)); + MP_MULT (multiplier, temp, temp); + MP_MADD (b, temp, b); + MP_MULT (multiplier, bignum_bytesize, multiplier); + MP_MFREE (temp); + } + MP_MFREE (multiplier); +} + +void +bignum_set_double (bignum b, double d) +{ + REGISTER unsigned int i; + int negative = (d < 0) ? 1 : 0; + MINT *multiplier = MP_ITOM (1); + + MP_MOVE (bignum_zero, b); + if (negative) + d = -d; + for (i = 0UL; d > 0.0; d /= 256, i++) + { + MINT *temp = MP_ITOM ((short) fmod (d, 256.0)); + MP_MULT (multiplier, temp, temp); + MP_MADD (b, temp, b); + MP_MULT (multiplier, bignum_bytesize, multiplier); + MP_MFREE (temp); + } + MP_MFREE (multiplier); + if (negative) + MP_MSUB (bignum_zero, b, b); +} + +/* Return nonzero if b1 is exactly divisible by b2 */ +int +bignum_divisible_p (bignum b1, bignum b2) +{ + int retval; + MINT *rem = MP_ITOM (0); + MP_MDIV (b1, b2, intern_bignum, rem); + retval = (MP_MCMP (rem, bignum_zero) == 0); + MP_MFREE (rem); + return retval; +} + +void bignum_ceil (bignum quotient, bignum N, bignum D) +{ + MP_MDIV (N, D, quotient, intern_bignum); + if (MP_MCMP (intern_bignum, bignum_zero) > 0 && + MP_MCMP (quotient, bignum_zero) > 0) + MP_MADD (quotient, bignum_one, quotient); +} + +void bignum_floor (bignum quotient, bignum N, bignum D) +{ + MP_MDIV (N, D, quotient, intern_bignum); + if (MP_MCMP (intern_bignum, bignum_zero) > 0 && + MP_MCMP (quotient, bignum_zero) < 0) + MP_MSUB (quotient, bignum_one, quotient); +} + +/* RESULT = N to the POWth power */ +void +bignum_pow (bignum result, bignum n, unsigned long pow) +{ + MP_MOVE (bignum_one, result); + for ( ; pow > 0UL; pow--) + MP_MULT (result, n, result); +} + +/* lcm(b1,b2) = b1 * b2 / gcd(b1, b2) */ +void +bignum_lcm (bignum result, bignum b1, bignum b2) +{ + MP_MULT (b1, b2, result); + MP_GCD (b1, b2, intern_bignum); + MP_MDIV (result, intern_bignum, result, intern_bignum); +} + +/* FIXME: We can't handle negative args, so right now we just make them + positive before doing anything else. How should we really handle negative + args? */ +#define bignum_bit_op(result, b1, b2, op) \ + REGISTER unsigned int i; \ + MINT *multiplier = MP_ITOM (1), *n1 = MP_ITOM (0), *n2 = MP_ITOM (0); \ + \ + if (MP_MCMP (bignum_zero, b1) > 0) \ + MP_MSUB (bignum_zero, b1, n1); \ + else \ + MP_MOVE (b1, n1); \ + if (MP_MCMP (bignum_zero, b2) > 0) \ + MP_MSUB (bignum_zero, b2, n2); \ + else \ + MP_MOVE (b2, n2); \ + \ + MP_MOVE (bignum_zero, result); \ + \ + for (i = 0UL; MP_MCMP (bignum_zero, n1) < 0 && \ + MP_MCMP (bignum_zero, n2) < 0; i++) \ + { \ + short byte1, byte2; \ + MINT *temp; \ + \ + MP_SDIV (n1, 256, n1, &byte1); \ + MP_SDIV (n2, 256, n2, &byte2); \ + temp = MP_ITOM (byte1 op byte2); \ + MP_MULT (multiplier, temp, temp); \ + MP_MADD (result, temp, result); \ + MP_MULT (multiplier, bignum_bytesize, multiplier); \ + MP_MFREE (temp); \ + } \ + MP_MFREE (n2); \ + MP_MFREE (n1); \ + MP_MFREE (multiplier) + +void +bignum_and (bignum result, bignum b1, bignum b2) +{ + bignum_bit_op (result, b1, b2, &); +} + +void +bignum_ior (bignum result, bignum b1, bignum b2) +{ + bignum_bit_op (result, b1, b2, |); +} + +void +bignum_xor (bignum result, bignum b1, bignum b2) +{ + bignum_bit_op (result, b1, b2, ^); +} + +/* NOT is not well-defined for bignums ... where do you stop flipping bits? + We just flip until we see the last one. This is probably a bad idea. */ +void +bignum_not (bignum result, bignum b) +{ + REGISTER unsigned int i; + MINT *multiplier = MP_ITOM (1), *n = MP_ITOM (0); + + if (MP_MCMP (bignum_zero, b) > 0) + MP_MSUB (bignum_zero, b, n); + else + MP_MOVE (b, n); + + MP_MOVE (bignum_zero, result); + + for (i = 0UL; MP_MCMP (bignum_zero, n) < 0; i++) + { + short byte; + MINT *temp; + + MP_SDIV (n, 256, n, &byte); + temp = MP_ITOM (~byte); + MP_MULT (multiplier, temp, temp); + MP_MADD (result, temp, result); + MP_MULT (multiplier, bignum_bytesize, multiplier); + MP_MFREE (temp); + } + MP_MFREE (n); + MP_MFREE (multiplier); +} + +void +bignum_setbit (bignum b, unsigned long bit) +{ + bignum_pow (intern_bignum, bignum_two, bit); + bignum_ior (b, b, intern_bignum); +} + +/* This is so evil, even I feel queasy. */ +void +bignum_clrbit (bignum b, unsigned long bit) +{ + MINT *num = MP_ITOM (0); + + /* See if the bit is already set, and subtract it off if not */ + MP_MOVE (b, intern_bignum); + bignum_pow (num, bignum_two, bit); + bignum_ior (intern_bignum, intern_bignum, num); + if (MP_MCMP (b, intern_bignum) == 0) + MP_MSUB (b, num, b); + MP_MFREE (num); +} + +int +bignum_testbit (bignum b, unsigned long bit) +{ + bignum_pow (intern_bignum, bignum_two, bit); + bignum_and (intern_bignum, b, intern_bignum); + return MP_MCMP (intern_bignum, bignum_zero); +} + +void +bignum_lshift (bignum result, bignum b, unsigned long bits) +{ + bignum_pow (intern_bignum, bignum_two, bits); + MP_MULT (b, intern_bignum, result); +} + +void +bignum_rshift (bignum result, bignum b, unsigned long bits) +{ + bignum_pow (intern_bignum, bignum_two, bits); + MP_MDIV (b, intern_bignum, result, intern_bignum); +} + +void bignum_random_seed(unsigned long seed) +{ + /* FIXME: Implement me */ +} + +void bignum_random(bignum result, bignum limit) +{ + /* FIXME: Implement me */ + MP_MOVE (bignum_zero, result); +} + +void +init_number_mp () +{ + REGISTER unsigned int i; + + bignum_zero = MP_ITOM (0); + bignum_one = MP_ITOM (1); + bignum_two = MP_ITOM (2); + + /* intern_bignum holds throwaway values from macro expansions in + number-mp.h. Its value is immaterial. */ + intern_bignum = MP_ITOM (0); + + /* bignum_bytesize holds the number of bits in a byte. */ + bignum_bytesize = MP_ITOM (256); + + /* bignum_long_sign_bit holds an adjustment for negative longs. */ + bignum_long_sign_bit = MP_ITOM (256); + for (i = 1UL; i < sizeof (long); i++) + MP_MULT (bignum_bytesize, bignum_long_sign_bit, bignum_long_sign_bit); + + /* The MP interface only supports turning short ints into MINTs, so we have + to set these the hard way. */ + + bignum_min_int = MP_ITOM (0); + bignum_set_long (bignum_min_int, INT_MIN); + + bignum_max_int = MP_ITOM (0); + bignum_set_long (bignum_max_int, INT_MAX); + + bignum_max_uint = MP_ITOM (0); + bignum_set_ulong (bignum_max_uint, UINT_MAX); + + bignum_min_long = MP_ITOM (0); + bignum_set_long (bignum_min_long, LONG_MIN); + + bignum_max_long = MP_ITOM (0); + bignum_set_long (bignum_max_long, LONG_MAX); + + bignum_max_ulong = MP_ITOM (0); + bignum_set_ulong (bignum_max_ulong, ULONG_MAX); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number-mp.h Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,161 @@ +/* Definitions of numeric types for XEmacs using the MP library. + Copyright (C) 2004 Jerry James. + +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. */ + +/* This library defines the following types: + bignum = MINT + + The MP library does not include support for ratios or bigfloats. +*/ + +#ifndef INCLUDED_number_mp_h_ +#define INCLUDED_number_mp_h_ + +/* BSD MP libraries without MP_PREFIX define a function named pow in mp.h that + has a different prototype from the one in math.h. We don't use that + function anyway, so we do this for safety purposes. However, this means + that number-mp.h must always be included before math.h. */ +#define pow mp_pow +#include <mp.h> +#undef pow + +#ifdef MP_PREFIX +#define MP_GCD mp_gcd +#define MP_ITOM mp_itom +#define MP_MADD mp_madd +#define MP_MCMP mp_mcmp +#define MP_MDIV mp_mdiv +#define MP_MFREE mp_mfree +#define MP_MSUB mp_msub +#define MP_MULT mp_mult +#define MP_SDIV mp_sdiv +#ifdef HAVE_MP_MOVE +#define MP_MOVE(x,y) mp_move (x, y) +#else +#define MP_MOVE(x,y) mp_madd (x, bignum_zero, y) +#endif +#else +#define MP_GCD gcd +#define MP_ITOM itom +#define MP_MADD madd +#define MP_MCMP mcmp +#define MP_MDIV mdiv +#define MP_MFREE mfree +#define MP_MSUB msub +#define MP_MULT mult +#define MP_SDIV sdiv +#ifdef HAVE_MP_MOVE +#define MP_MOVE(x,y) move (x, y) +#else +#define MP_MOVE(x,y) madd (x, bignum_zero, y) +#endif +#endif + +typedef MINT *bignum; + +extern void init_number_mp(void); + + +/********************************* Bignums **********************************/ + +#define HAVE_BIGNUM 1 + +extern MINT *bignum_zero, *intern_bignum; +extern MINT *bignum_min_int, *bignum_max_int, *bignum_max_uint; +extern MINT *bignum_min_long, *bignum_max_long, *bignum_max_ulong; +extern short div_rem; + +/***** Bignum: basic functions *****/ +#define bignum_init(b) (b = MP_ITOM (0)) +#define bignum_fini(b) MP_MFREE (b) +#define bignum_hashcode(b) bignum_to_uint (b) +#define bignum_sign(b) MP_MCMP (b, bignum_zero) +#define bignum_evenp(b) (MP_SDIV (b, 2, intern_bignum, &div_rem), \ + div_rem == 0) +#define bignum_oddp(b) (MP_SDIV (b, 2, intern_bignum, &div_rem), \ + div_rem != 0) + +/***** Bignum: size *****/ +#define bignum_fits_int_p(b) (MP_MCMP (b, bignum_min_int) >= 0 && \ + MP_MCMP (b, bignum_max_int) <= 0) +#define bignum_fits_uint_p(b) (MP_MCMP (b, bignum_zero) >= 0 && \ + MP_MCMP (b, bignum_max_uint) <= 0) +#define bignum_fits_long_p(b) (MP_MCMP (b, bignum_min_long) >= 0 && \ + MP_MCMP (b, bignum_max_long) <= 0) +#define bignum_fits_ulong_p(b) (MP_MCMP (b, bignum_zero) >= 0 && \ + MP_MCMP (b, bignum_max_ulong) <= 0) + +/***** Bignum: conversions *****/ +extern char *bignum_to_string(bignum, int); +extern int bignum_to_int(bignum); +extern unsigned int bignum_to_uint(bignum); +extern long bignum_to_long(bignum); +extern unsigned long bignum_to_ulong(bignum); +extern double bignum_to_double(bignum); + +/***** Bignum: converting assignments *****/ +#define bignum_set(b1, b2) MP_MOVE (b2, b1) +extern int bignum_set_string(bignum, const char *, int); +extern void bignum_set_long(bignum, long); +extern void bignum_set_ulong(bignum, unsigned long); +extern void bignum_set_double(bignum, double); + +/***** Bignum: comparisons *****/ +#define bignum_cmp(b1,b2) MP_MCMP (b1, b2) +#define bignum_lt(b1,b2) (MP_MCMP (b1, b2) < 0) +#define bignum_le(b1,b2) (MP_MCMP (b1, b2) <= 0) +#define bignum_eql(b1,b2) (MP_MCMP (b1, b2) == 0) +#define bignum_ge(b1,b2) (MP_MCMP (b1, b2) >= 0) +#define bignum_gt(b1,b2) (MP_MCMP (b1, b2) > 0) + +/***** Bignum: arithmetic *****/ +#define bignum_neg(b,b2) MP_MSUB (bignum_zero, b2, b) +#define bignum_abs(b,b2) (MP_MCMP (b2, bignum_zero) < 0 \ + ? MP_MSUB (bignum_zero, b2, b) \ + : MP_MADD (bignum_zero, b2, b)) +#define bignum_add(b,b1,b2) MP_MADD (b1, b2, b) +#define bignum_sub(b,b1,b2) MP_MSUB (b1, b2, b) +#define bignum_mul(b,b1,b2) MP_MULT (b1, b2, b) +extern int bignum_divisible_p(bignum, bignum); +#define bignum_div(b,b1,b2) MP_MDIV (b1, b2, b, intern_bignum) +extern void bignum_ceil(bignum, bignum, bignum); +extern void bignum_floor(bignum, bignum, bignum); +#define bignum_mod(b,b1,b2) MP_MDIV (b1, b2, intern_bignum, b) +extern void bignum_pow(bignum, bignum, unsigned long); +#define bignum_gcd(res,b1,b2) MP_GCD (b1, b2, res) +extern void bignum_lcm(bignum, bignum, bignum); + +/***** Bignum: bit manipulations *****/ +extern void bignum_and(bignum, bignum, bignum); +extern void bignum_ior(bignum, bignum, bignum); +extern void bignum_xor(bignum, bignum, bignum); +extern void bignum_not(bignum, bignum); +extern void bignum_setbit(bignum, unsigned long); +extern void bignum_clrbit(bignum, unsigned long); +extern int bignum_testbit(bignum, unsigned long); +extern void bignum_lshift(bignum, bignum, unsigned long); +extern void bignum_rshift(bignum, bignum, unsigned long); + +/***** Bignum: random numbers *****/ +extern void bignum_random_seed(unsigned long); +extern void bignum_random(bignum, bignum); + +#endif /* INCLUDED_number_mp_h_ */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number.c Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,812 @@ +/* Numeric types for XEmacs. + Copyright (C) 2004 Jerry James. + +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. */ + +#include <config.h> +#include <limits.h> +#include "lisp.h" + +Lisp_Object Qintegerp, Qrationalp, Qfloatingp, Qrealp, Qnumberp; +Lisp_Object Vdefault_float_precision; +Fixnum Vmost_negative_fixnum, Vmost_positive_fixnum; +static Lisp_Object Qunsupported_type; +static Lisp_Object Vbigfloat_max_prec; +static int number_initialized; + +#ifdef HAVE_BIGNUM +bignum scratch_bignum, scratch_bignum2; +#endif +#ifdef HAVE_RATIO +ratio scratch_ratio; +#endif +#ifdef HAVE_BIGFLOAT +bigfloat scratch_bigfloat, scratch_bigfloat2; +#endif + +/********************************* Bignums **********************************/ +#ifdef HAVE_BIGNUM +static void +bignum_print (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + CIbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10); + write_c_string (printcharfun, bstr); + xfree (bstr, CIbyte *); +} + +static void +bignum_finalize (void *header, int for_disksave) +{ + if (for_disksave) + invalid_operation ("Can't dump an XEmacs containing bignum objects", + VOID_TO_LISP (header)); + bignum_fini (((Lisp_Bignum *)header)->data); +} + +static int +bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); +} + +static Hashcode +bignum_hash (Lisp_Object obj, int depth) +{ + return bignum_hashcode (XBIGNUM_DATA (obj)); +} + +static const struct memory_description bignum_description[] = { + { XD_OPAQUE_PTR, offsetof (Lisp_Bignum, data) }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("bignum", bignum, 0, 0, + bignum_print, bignum_finalize, bignum_equal, + bignum_hash, bignum_description, Lisp_Bignum); + +Lisp_Object +string_to_bignum(const Ibyte *str, Bytecount len, int base) +{ + Lisp_Object b = make_bignum (0L); + return (bignum_set_string (XBIGNUM_DATA (b), str, base) < 0) + ? Fsignal (Qinvalid_read_syntax, + list3 (build_msg_string + ("Invalid integer constant in reader"), + make_string (str, len), + make_int (10))) + : b; +} + +#else /* !HAVE_BIGNUM */ + +Lisp_Object Qbignump; + +#endif /* HAVE_BIGNUM */ + +DEFUN ("bignump", Fbignump, 1, 1, 0, /* +Return t if OBJECT is a bignum, nil otherwise. +*/ + (object)) +{ + return BIGNUMP (object) ? Qt : Qnil; +} + + +/********************************* Integers *********************************/ +DEFUN ("integerp", Fintegerp, 1, 1, 0, /* +Return t if OBJECT is an integer, nil otherwise. +*/ + (object)) +{ + return INTEGERP (object) ? Qt : Qnil; +} + +DEFUN ("evenp", Fevenp, 1, 1, 0, /* +Return t if INTEGER is even, nil otherwise. +*/ + (integer)) +{ + CONCHECK_INTEGER (integer); + return BIGNUMP (integer) + ? bignum_evenp (XBIGNUM_DATA (integer)) + : XTYPE (integer) == Lisp_Type_Int_Even; +} + +DEFUN ("odd", Foddp, 1, 1, 0, /* +Return t if INTEGER is odd, nil otherwise. +*/ + (integer)) +{ + CONCHECK_INTEGER (integer); + return BIGNUMP (integer) + ? bignum_oddp (XBIGNUM_DATA (integer)) + : XTYPE (integer) == Lisp_Type_Int_Odd; +} + + +/********************************** Ratios **********************************/ +#ifdef HAVE_RATIO +static void +ratio_print (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + CIbyte *rstr = ratio_to_string (XRATIO_DATA (obj), 10); + write_c_string (printcharfun, rstr); + xfree (rstr, CIbyte *); +} + +static void +ratio_finalize (void *header, int for_disksave) +{ + if (for_disksave) + invalid_operation ("Can't dump an XEmacs containing ratio objects", + VOID_TO_LISP (header)); + ratio_fini (((Lisp_Ratio *)header)->data); +} +; + +static int +ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); +} + +static Hashcode +ratio_hash (Lisp_Object obj, int depth) +{ + return ratio_hashcode (XRATIO_DATA (obj)); +} + +static const struct memory_description ratio_description[] = { + { XD_OPAQUE_PTR, offsetof (Lisp_Ratio, data) }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("ratio", ratio, 0, 0, + ratio_print, ratio_finalize, ratio_equal, + ratio_hash, ratio_description, Lisp_Ratio); + +#else /* !HAVE_RATIO */ + +Lisp_Object Qratiop; + +#endif /* HAVE_RATIO */ + +DEFUN ("ratiop", Fratiop, 1, 1, 0, /* +Return t if OBJECT is a ratio, nil otherwise. +*/ + (object)) +{ + return RATIOP (object) ? Qt : Qnil; +} + + +/******************************** Rationals *********************************/ +DEFUN ("rationalp", Frationalp, 1, 1, 0, /* +Return t if OBJECT is a rational, nil otherwise. +*/ + (object)) +{ + return RATIONALP (object) ? Qt : Qnil; +} + +DEFUN ("numerator", Fnumerator, 1, 1, 0, /* +Return the numerator of the canonical form of RATIONAL. +If RATIONAL is an integer, RATIONAL is returned. +*/ + (rational)) +{ + CONCHECK_RATIONAL (rational); +#ifdef HAVE_RATIO + return RATIOP (rational) + ? make_bignum_bg (XRATIO_NUMERATOR (rational)) + : rational; +#else + return rational; +#endif +} + +DEFUN ("denominator", Fdenominator, 1, 1, 0, /* +Return the denominator of the canonical form of RATIONAL. +If RATIONAL is an integer, 1 is returned. +*/ + (rational)) +{ + CONCHECK_RATIONAL (rational); +#ifdef HAVE_RATIO + return RATIOP (rational) + ? make_bignum_bg (XRATIO_DENOMINATOR (rational)) + : make_int (1); +#else + return rational; +#endif +} + + +/******************************** Bigfloats *********************************/ +#ifdef HAVE_BIGFLOAT +static void +bigfloat_print (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + CIbyte *fstr = bigfloat_to_string (XBIGFLOAT_DATA (obj), 10); + write_c_string (printcharfun, fstr); + xfree (fstr, CIbyte *); +} + +static void +bigfloat_finalize (void *header, int for_disksave) +{ + if (for_disksave) + invalid_operation ("Can't dump an XEmacs containing bigfloat objects", + VOID_TO_LISP (header)); + bigfloat_fini (((Lisp_Bigfloat *)header)->bf); +} + +static int +bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); +} + +static Hashcode +bigfloat_hash (Lisp_Object obj, int depth) +{ + return bigfloat_hashcode (XBIGFLOAT_DATA (obj)); +} + +static const struct memory_description bigfloat_description[] = { + { XD_OPAQUE_PTR, offsetof (Lisp_Bigfloat, bf) }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("bigfloat", bigfloat, 1, 0, + bigfloat_print, bigfloat_finalize, + bigfloat_equal, bigfloat_hash, + bigfloat_description, Lisp_Bigfloat); + +#else /* !HAVE_BIGFLOAT */ + +Lisp_Object Qbigfloatp; + +#endif /* HAVE_BIGFLOAT */ + +DEFUN ("bigfloatp", Fbigfloatp, 1, 1, 0, /* +Return t if OBJECT is a bigfloat, nil otherwise. +*/ + (object)) +{ + return BIGFLOATP (object) ? Qt : Qnil; +} + +static int +default_float_precision_changed (Lisp_Object sym, Lisp_Object *val, + Lisp_Object in_object, int flags) +{ + unsigned long prec; + + CONCHECK_INTEGER (*val); +#ifdef HAVE_BIGFLOAT + if (INTP (*val)) + prec = XINT (*val); + else + { + if (!bignum_fits_ulong_p (XBIGNUM_DATA (*val))) + args_out_of_range_3 (*val, Qzero, Vbigfloat_max_prec); + prec = bignum_to_ulong (XBIGNUM_DATA (*val)); + } + if (prec != 0UL) + bigfloat_set_default_prec (prec); +#endif + return 0; +} + + +/********************************* Floating *********************************/ +Lisp_Object +make_floating (double d) +{ +#ifdef HAVE_BIGFLOAT + if (ZEROP (Vdefault_float_precision)) +#endif + return make_float (d); +#ifdef HAVE_BIGFLOAT + else + return make_bigfloat (d, 0UL); +#endif +} + +DEFUN ("floatingp", Ffloatingp, 1, 1, 0, /* +Return t if OBJECT is a floating point number of any kind, nil otherwise. +*/ + (object)) +{ + return FLOATINGP (object) ? Qt : Qnil; +} + + +/********************************** Reals ***********************************/ +DEFUN ("realp", Frealp, 1, 1, 0, /* +Return t if OBJECT is a real, nil otherwise. +*/ + (object)) +{ + return REALP (object) ? Qt : Qnil; +} + + +/********************************* Numbers **********************************/ +DEFUN ("canonicalize-number", Fcanonicalize_number, 1, 1, 0, /* +Return the canonical form of NUMBER. +*/ + (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. */ +#ifdef HAVE_RATIO + if (RATIOP (number) && + bignum_fits_long_p (XRATIO_DENOMINATOR (number)) && + bignum_to_long (XRATIO_DENOMINATOR (number)) == 1L) + number = make_bignum_bg (XRATIO_NUMERATOR (number)); +#endif +#ifdef HAVE_BIGNUM + 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); + } +#endif + return number; +} + +enum number_type +get_number_type (Lisp_Object arg) +{ + if (INTP (arg)) + return FIXNUM_T; +#ifdef HAVE_BIGNUM + if (BIGNUMP (arg)) + return BIGNUM_T; +#endif +#ifdef HAVE_RATIO + if (RATIOP (arg)) + return RATIO_T; +#endif + if (FLOATP (arg)) + return FLOAT_T; +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (arg)) + return BIGFLOAT_T; +#endif + /* Catch unintentional bad uses of this function */ + abort (); +} + +/* Convert NUMBER to type TYPE. If TYPE is BIGFLOAT_T then use the indicated + PRECISION; otherwise, PRECISION is ignored. */ +static Lisp_Object +internal_coerce_number (Lisp_Object number, enum number_type type, + unsigned long precision) +{ + enum number_type current_type; + + if (CHARP (number)) + number = make_int (XCHAR (number)); + else if (MARKERP (number)) + number = make_int (marker_position (number)); + + /* Note that CHECK_NUMBER ensures that NUMBER is a supported type. Hence, + we abort() in the #else sections below, because it shouldn't be possible + to arrive there. */ + CHECK_NUMBER (number); + current_type = get_number_type (number); + switch (current_type) + { + case FIXNUM_T: + switch (type) + { + case FIXNUM_T: + return number; + case BIGNUM_T: +#ifdef HAVE_BIGNUM + return make_bignum (XREALINT (number)); +#else + abort (); +#endif /* HAVE_BIGNUM */ + case RATIO_T: +#ifdef HAVE_RATIO + return make_ratio (XREALINT (number), 1UL); +#else + abort (); +#endif /* HAVE_RATIO */ + case FLOAT_T: + return make_float (XREALINT (number)); + case BIGFLOAT_T: +#ifdef HAVE_BIGFLOAT + return make_bigfloat (XREALINT (number), precision); +#else + abort (); +#endif /* HAVE_BIGFLOAT */ + } + case BIGNUM_T: +#ifdef HAVE_BIGNUM + switch (type) + { + case FIXNUM_T: + return make_int (bignum_to_long (XBIGNUM_DATA (number))); + case BIGNUM_T: + return number; + case RATIO_T: +#ifdef HAVE_RATIO + bignum_set_long (scratch_bignum, 1L); + return make_ratio_bg (XBIGNUM_DATA (number), scratch_bignum); +#else + abort (); +#endif /* HAVE_RATIO */ + case FLOAT_T: + return make_float (bignum_to_double (XBIGNUM_DATA (number))); + case BIGFLOAT_T: +#ifdef HAVE_BIGFLOAT + { + Lisp_Object temp; + temp = make_bigfloat (0.0, precision); + bigfloat_set_bignum (XBIGFLOAT_DATA (temp), XBIGNUM_DATA (number)); + return temp; + } +#else + abort (); +#endif /* HAVE_BIGFLOAT */ + } +#else + abort (); +#endif /* HAVE_BIGNUM */ + case RATIO_T: +#ifdef HAVE_RATIO + switch (type) + { + case FIXNUM_T: + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + return make_int (bignum_to_long (scratch_bignum)); + case BIGNUM_T: + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + return make_bignum_bg (scratch_bignum); + case RATIO_T: + return number; + case FLOAT_T: + return make_float (ratio_to_double (XRATIO_DATA (number))); + case BIGFLOAT_T: +#ifdef HAVE_BIGFLOAT + { + Lisp_Object temp; + temp = make_bigfloat (0.0, precision); + bigfloat_set_ratio (XBIGFLOAT_DATA (temp), XRATIO_DATA (number)); + return temp; + } +#else + abort (); +#endif /* HAVE_BIGFLOAT */ + } +#else + abort (); +#endif /* HAVE_RATIO */ + case FLOAT_T: + switch (type) + { + case FIXNUM_T: + return Fround (number); + case BIGNUM_T: +#ifdef HAVE_BIGNUM + bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); + return make_bignum_bg (scratch_bignum); +#else + abort (); +#endif /* HAVE_BIGNUM */ + case RATIO_T: +#ifdef HAVE_RATIO + ratio_set_double (scratch_ratio, XFLOAT_DATA (number)); + return make_ratio_rt (scratch_ratio); +#else + abort (); +#endif /* HAVE_RATIO */ + case FLOAT_T: + return number; + case BIGFLOAT_T: +#ifdef HAVE_BIGFLOAT + bigfloat_set_prec (scratch_bigfloat, precision); + bigfloat_set_double (scratch_bigfloat, XFLOAT_DATA (number)); + return make_bigfloat_bf (scratch_bigfloat); +#else + abort (); +#endif /* HAVE_BIGFLOAT */ + } + case BIGFLOAT_T: +#ifdef HAVE_BIGFLOAT + switch (type) + { + case FIXNUM_T: + return make_int (bigfloat_to_long (XBIGFLOAT_DATA (number))); + case BIGNUM_T: +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (number)); + return make_bignum_bg (scratch_bignum); +#else + abort (); +#endif /* HAVE_BIGNUM */ + case RATIO_T: +#ifdef HAVE_RATIO + ratio_set_bigfloat (scratch_ratio, XBIGFLOAT_DATA (number)); + return make_ratio_rt (scratch_ratio); +#else + abort (); +#endif + case FLOAT_T: + return make_float (bigfloat_to_double (XBIGFLOAT_DATA (number))); + case BIGFLOAT_T: + /* FIXME: Do we need to change the precision? */ + return number; + } +#else + abort (); +#endif /* HAVE_BIGFLOAT */ + } + abort (); +} + +/* This function promotes its arguments as necessary to make them both the + same type. It destructively modifies its arguments to do so. Characters + and markers are ALWAYS converted to integers. */ +enum number_type +promote_args (Lisp_Object *arg1, Lisp_Object *arg2) +{ + enum number_type type1, type2; + + if (CHARP (*arg1)) + *arg1 = make_int (XCHAR (*arg1)); + else if (MARKERP (*arg1)) + *arg1 = make_int (marker_position (*arg1)); + if (CHARP (*arg2)) + *arg2 = make_int (XCHAR (*arg2)); + else if (MARKERP (*arg2)) + *arg2 = make_int (marker_position (*arg2)); + + CHECK_NUMBER (*arg1); + CHECK_NUMBER (*arg2); + + type1 = get_number_type (*arg1); + type2 = get_number_type (*arg2); + + if (type1 < type2) + { + *arg1 = internal_coerce_number (*arg1, type2, +#ifdef HAVE_BIGFLOAT + type2 == BIGFLOAT_T + ? XBIGFLOAT_GET_PREC (*arg2) : +#endif + 0UL); + return type2; + } + + if (type2 < type1) + { + *arg2 = internal_coerce_number (*arg2, type1, +#ifdef HAVE_BIGFLOAT + type1 == BIGFLOAT_T + ? XBIGFLOAT_GET_PREC (*arg1) : +#endif + 0UL); + return type1; + } + + /* No conversion necessary */ + return type1; +} + +DEFUN ("coerce-number", Fcoerce_number, 2, 3, 0, /* +Convert NUMBER to the indicated type, possibly losing information. +Do not call this function. Use `coerce' instead. + +TYPE is one of the symbols 'fixnum, 'integer, 'ratio, 'float, or 'bigfloat. +Not all of these types may be supported. + +PRECISION is the number of bits of precision to use when converting to +bigfloat; it is ignored otherwise. If nil, the default precision is used. + +Note that some conversions lose information. No error is signaled in such +cases; the information is silently lost. +*/ + (number, type, precision)) +{ + CHECK_SYMBOL (type); + if (EQ (type, Qfixnum)) + return internal_coerce_number (number, FIXNUM_T, 0UL); + else if (EQ (type, Qinteger)) + { + /* If bignums are available, we always convert to one first, then + downgrade to a fixnum if possible. */ +#ifdef HAVE_BIGNUM + return Fcanonicalize_number + (internal_coerce_number (number, BIGNUM_T, 0UL)); +#else + return internal_coerce_number (number, FIXNUM_T, 0UL); +#endif + } +#ifdef HAVE_RATIO + else if (EQ (type, Qratio)) + return internal_coerce_number (number, RATIO_T, 0UL); +#endif + else if (EQ (type, Qfloat)) + return internal_coerce_number (number, FLOAT_T, 0UL); +#ifdef HAVE_BIGFLOAT + else if (EQ (type, Qbigfloat)) + { + unsigned long prec; + + if (NILP (precision)) + prec = bigfloat_get_default_prec (); + else + { + CHECK_INTEGER (precision); +#ifdef HAVE_BIGNUM + if (INTP (precision)) +#endif /* HAVE_BIGNUM */ + prec = (unsigned long) XREALINT (precision); +#ifdef HAVE_BIGNUM + else + { + if (!bignum_fits_ulong_p (XBIGNUM_DATA (precision))) + args_out_of_range (precision, Vbigfloat_max_prec); + prec = bignum_to_ulong (XBIGNUM_DATA (precision)); + } +#endif /* HAVE_BIGNUM */ + } + return internal_coerce_number (number, BIGFLOAT_T, prec); + } +#endif /* HAVE_BIGFLOAT */ + + Fsignal (Qunsupported_type, type); + /* NOTREACHED */ + return Qnil; +} + + +void +syms_of_number (void) +{ +#ifdef HAVE_BIGNUM + INIT_LRECORD_IMPLEMENTATION (bignum); +#endif +#ifdef HAVE_RATIO + INIT_LRECORD_IMPLEMENTATION (ratio); +#endif +#ifdef HAVE_BIGFLOAT + INIT_LRECORD_IMPLEMENTATION (bigfloat); +#endif + + /* Type predicates */ + DEFSYMBOL (Qintegerp); + DEFSYMBOL (Qrationalp); + DEFSYMBOL (Qfloatingp); + DEFSYMBOL (Qrealp); + DEFSYMBOL (Qnumberp); +#ifndef HAVE_BIGNUM + DEFSYMBOL (Qbignump); +#endif +#ifndef HAVE_RATIO + DEFSYMBOL (Qratiop); +#endif +#ifndef HAVE_BIGFLOAT + DEFSYMBOL (Qbigfloatp); +#endif + + /* Functions */ + DEFSUBR (Fbignump); + DEFSUBR (Fintegerp); + DEFSUBR (Fevenp); + DEFSUBR (Foddp); + DEFSUBR (Fratiop); + DEFSUBR (Frationalp); + DEFSUBR (Fnumerator); + DEFSUBR (Fdenominator); + DEFSUBR (Fbigfloatp); + DEFSUBR (Frealp); + DEFSUBR (Fcanonicalize_number); + DEFSUBR (Fcoerce_number); + + /* Errors */ + DEFERROR_STANDARD (Qunsupported_type, Qwrong_type_argument); +} + +void +vars_of_number (void) +{ + /* This variable is a Lisp variable rather than a number variable so that we + can put bignums in it. */ + DEFVAR_LISP_MAGIC ("default-float-precision", &Vdefault_float_precision, /* +The default floating-point precision for newly created floating point values. +This should be 0 for the precision of the machine-supported floating point +type (the C double type), or an unsigned integer no greater than +bigfloat-max-prec (currently the size of a C unsigned long). +*/ default_float_precision_changed); + Vdefault_float_precision = make_int (0); + + DEFVAR_CONST_LISP ("bigfloat-max-prec", &Vbigfloat_max_prec /* +The maximum number of bits of precision a bigfloat can have. +This is currently the value of ULONG_MAX on the target machine. +*/); + + DEFVAR_CONST_INT ("most-negative-fixnum", &Vmost_negative_fixnum /* +The fixnum closest in value to negative infinity. +*/); + Vmost_negative_fixnum = EMACS_INT_MIN; + + DEFVAR_CONST_INT ("most-positive-fixnum", &Vmost_positive_fixnum /* +The fixnum closest in value to positive infinity. +*/); + Vmost_positive_fixnum = EMACS_INT_MAX; + + Fprovide (intern ("number-types")); +#ifdef HAVE_BIGNUM + Fprovide (intern ("bignum")); +#endif +#ifdef HAVE_RATIO + Fprovide (intern ("ratio")); +#endif +#ifdef HAVE_BIGFLOAT + Fprovide (intern ("bigfloat")); +#endif +} + +void +init_number (void) +{ + if (!number_initialized) + { + number_initialized = 1; + +#ifdef WITH_GMP + init_number_gmp (); +#endif +#ifdef WITH_MP + init_number_mp (); +#endif + +#if defined(BIGNUM) && defined(BIGFLOAT) + Vbigfloat_max_prec = make_bignum (0L); + bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX); +#endif + +#ifdef HAVE_BIGNUM + bignum_init (scratch_bignum); + bignum_init (scratch_bignum2); +#endif + +#ifdef HAVE_RATIO + ratio_init (scratch_ratio); +#endif + +#ifdef HAVE_BIGFLOAT + bigfloat_init (scratch_bigfloat); + bigfloat_init (scratch_bigfloat2); +#endif + } +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number.h Mon Apr 05 22:50:11 2004 +0000 @@ -0,0 +1,329 @@ +/* Definitions of numeric types for XEmacs. + Copyright (C) 2004 Jerry James. + +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 INCLUDED_number_h_ +#define INCLUDED_number_h_ + +/* The following types are always defined in the same manner: + fixnum = whatever fits in the Lisp_Object type + integer = union (fixnum, bignum) + rational = union (integer, ratio) + float = C double + floating = union(float, bigfloat) Anybody got a better name? + real = union (rational, floating) + number = real (should be union(real, complex) but no complex yet) + + It is up to the library-specific code to define the remaining types, + namely: bignum, ratio, and bigfloat. Not all of these types may be + available. The top-level configure script should define the symbols + HAVE_BIGNUM, HAVE_RATIO, and HAVE_BIGFLOAT to indicate which it provides. + If some type is not defined by the library, this is what happens: + + - bignum: bignump(x) is false for all x; any attempt to create a bignum + causes an error to be raised. + + - ratio: we define our own structure consisting of two Lisp_Objects, which + are presumed to be integers (i.e., either fixnums or bignums). We do our + own GCD calculation, which is bound to be slow, to keep the ratios + reduced to canonical form. (FIXME: Not yet implemented.) + + - bigfloat: bigfloat(x) is false for all x; any attempt to create a + bigfloat causes an error to be raised. + + We (provide) the following symbols, so that Lisp code has some hope of + using this correctly: + + - (provide 'bignum) if HAVE_BIGNUM + - (provde 'ratio) if HAVE_RATIO + - (provide 'bigfloat) if HAVE_BIGFLOAT +*/ + +/* Load the library definitions */ +#ifdef WITH_GMP +#include "number-gmp.h" +#endif +#ifdef WITH_MP +#include "number-mp.h" +#endif + + +/********************************* Bignums **********************************/ +#ifdef HAVE_BIGNUM + +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 CHECK_BIGNUM(x) CHECK_RECORD (x, bignum) +#define CONCHECK_BIGNUM(x) CONCHECK_RECORD (x, bignum) + +#define bignum_data(b) (b)->data +#define XBIGNUM_DATA(x) bignum_data (XBIGNUM (x)) + +#define BIGNUM_ARITH_RETURN(b,op) do \ +{ \ + Lisp_Object retval = make_bignum (0); \ + bignum_##op (XBIGNUM_DATA (retval), XBIGNUM_DATA (b)); \ + return Fcanonicalize_number (retval); \ +} while (0) + +#define BIGNUM_ARITH_RETURN1(b,op,arg) do \ +{ \ + Lisp_Object retval = make_bignum(0); \ + bignum_##op (XBIGNUM_DATA (retval), XBIGNUM_DATA (b), arg); \ + return Fcanonicalize_number (retval); \ +} while (0) + +extern Lisp_Object make_bignum (long); +extern Lisp_Object make_bignum_bg (bignum); +extern bignum scratch_bignum, scratch_bignum2; + +#else /* !HAVE_BIGNUM */ + +extern Lisp_Object Qbignump; +#define BIGNUMP(x) 0 +#define CHECK_BIGNUM(x) dead_wrong_type_argument (Qbignump, x) +#define CONCHECK_BIGNUM(x) dead_wrong_type_argument (Qbignump, x) +typedef void bignum; +#define make_bignum(l) This XEmacs does not support bignums +#define make_bignum_bg(b) This XEmacs does not support bignums + +#endif /* HAVE_BIGNUM */ + +EXFUN (Fbignump, 1); + + +/********************************* Integers *********************************/ +extern Lisp_Object Qintegerp; + +#define INTEGERP(x) (INTP(x) || BIGNUMP(x)) +#define CHECK_INTEGER(x) do { \ + if (!INTEGERP (x)) \ + dead_wrong_type_argument (Qintegerp, x); \ + } while (0) +#define CONCHECK_INTEGER(x) do { \ + if (!INTEGERP (x)) \ + x = wrong_type_argument (Qintegerp, x); \ +} while (0) + +#ifdef HAVE_BIGNUM +#define make_integer(x) \ + (NUMBER_FITS_IN_AN_EMACS_INT (x) ? make_int (x) : make_bignum (x)) +#else +#define make_integer(x) make_int (x) +#endif + +extern Fixnum Vmost_negative_fixnum, Vmost_positive_fixnum; +EXFUN (Fintegerp, 1); +EXFUN (Fevenp, 1); +EXFUN (Foddp, 1); + + +/********************************** Ratios **********************************/ +#ifdef HAVE_RATIO + +struct Lisp_Ratio +{ + struct lrecord_header lheader; + ratio data; +}; +typedef struct Lisp_Ratio Lisp_Ratio; + +DECLARE_LRECORD (ratio, Lisp_Ratio); +#define XRATIO(x) XRECORD (x, ratio, Lisp_Ratio) +#define wrap_ratio(p) wrap_record (p, ratio) +#define RATIOP(x) RECORDP (x, ratio) +#define CHECK_RATIO(x) CHECK_RECORD (x, ratio) +#define CONCHECK_RATIO(x) CONCHECK_RECORD (x, ratio) + +#define ratio_data(r) (r)->data + +#define XRATIO_DATA(r) ratio_data (XRATIO (r)) +#define XRATIO_NUMERATOR(r) ratio_numerator (XRATIO_DATA (r)) +#define XRATIO_DENOMINATOR(r) ratio_denominator (XRATIO_DATA (r)) + +#define RATIO_ARITH_RETURN(r,op) do \ +{ \ + Lisp_Object retval = make_ratio (0L, 1UL); \ + ratio_##op (XRATIO_DATA (retval), XRATIO_DATA (r)); \ + return Fcanonicalize_number (retval); \ +} while (0) + +#define RATIO_ARITH_RETURN1(r,op,arg) do \ +{ \ + Lisp_Object retval = make_ratio (0L, 1UL); \ + ratio_##op (XRATIO_DATA (retval), XRATIO_DATA (r), arg); \ + return Fcanonicalize_number (retval); \ +} while (0) + +extern Lisp_Object make_ratio (long, unsigned long); +extern Lisp_Object make_ratio_bg (bignum, bignum); +extern Lisp_Object make_ratio_rt (ratio); +extern ratio scratch_ratio; + +#else /* !HAVE_RATIO */ + +extern Lisp_Object Qratiop; +#define RATIOP(x) 0 +#define CHECK_RATIO(x) dead_wrong_type_argument (Qratiop, x) +#define CONCHECK_RATIO(x) dead_wrong_type_argument (Qratiop, x) +typedef void ratio; +#define make_ratio(n,d) This XEmacs does not support ratios +#define make_ratio_bg(n,d) This XEmacs does not support ratios + +#endif /* HAVE_RATIO */ + +EXFUN (Fratiop, 1); + + +/******************************** Rationals *********************************/ +extern Lisp_Object Qrationalp; + +#define RATIONALP(x) (INTEGERP(x) || RATIOP(x)) +#define CHECK_RATIONAL(x) do { \ + if (!RATIONALP (x)) \ + dead_wrong_type_argument (Qrationalp, x); \ + } while (0) +#define CONCHECK_RATIONAL(x) do { \ + if (!RATIONALP (x)) \ + x = wrong_type_argument (Qrationalp, x); \ +} while (0) + +EXFUN (Frationalp, 1); +EXFUN (Fnumerator, 1); +EXFUN (Fdenominator, 1); + + +/******************************** Bigfloats *********************************/ +#ifdef HAVE_BIGFLOAT +struct Lisp_Bigfloat +{ + struct lrecord_header lheader; + bigfloat bf; +}; +typedef struct Lisp_Bigfloat Lisp_Bigfloat; + +DECLARE_LRECORD (bigfloat, Lisp_Bigfloat); +#define XBIGFLOAT(x) XRECORD (x, bigfloat, Lisp_Bigfloat) +#define wrap_bigfloat(p) wrap_record (p, bigfloat) +#define BIGFLOATP(x) RECORDP (x, bigfloat) +#define CHECK_BIGFLOAT(x) CHECK_RECORD (x, bigfloat) +#define CONCHECK_BIGFLOAT(x) CONCHECK_RECORD (x, bigfloat) + +#define bigfloat_data(f) ((f)->bf) +#define XBIGFLOAT_DATA(x) bigfloat_data (XBIGFLOAT (x)) +#define XBIGFLOAT_GET_PREC(x) bigfloat_get_prec (XBIGFLOAT_DATA (x)) +#define XBIGFLOAT_SET_PREC(x,p) bigfloat_set_prec (XBIGFLOAT_DATA (x), p) + +#define BIGFLOAT_ARITH_RETURN(f,op) do \ +{ \ + Lisp_Object retval = make_bigfloat_bf (f); \ + bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f)); \ + return retval; \ +} while (0) + +#define BIGFLOAT_ARITH_RETURN1(f,op,arg) do \ +{ \ + Lisp_Object retval = make_bigfloat_bf (f); \ + bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f), arg); \ + return retval; \ +} while (0) + +extern Lisp_Object make_bigfloat (double, unsigned long); +extern Lisp_Object make_bigfloat_bf (bigfloat); +extern Lisp_Object Vdefault_float_precision; +extern bigfloat scratch_bigfloat, scratch_bigfloat2; + +#else /* !HAVE_BIGFLOAT */ + +extern Lisp_Object Qbigfloatp; +#define BIGFLOATP(x) 0 +#define CHECK_BIGFLOAT(x) dead_wrong_type_argument (Qbigfloatp, x) +#define CONCHECK_BIGFLOAT(x) dead_wrong_type_argument (Qbigfloatp, x) +typedef void bigfloat; +#define make_bigfloat(f) This XEmacs does not support bigfloats +#define make_bigfloat_bf(f) This XEmacs does not support bigfloast + +#endif /* HAVE_BIGFLOAT */ + +EXFUN (Fbigfloatp, 1); + +/********************************* Floating *********************************/ +extern Lisp_Object Qfloatingp, Qbigfloat; +extern Lisp_Object Qread_default_float_format, Vread_default_float_format; + +#define FLOATINGP(x) (FLOATP (x) || BIGFLOATP (x)) +#define CHECK_FLOATING(x) do { \ + if (!FLOATINGP (x)) \ + dead_wrong_type_argument (Qfloatingp, x); \ + } while (0) +#define CONCHECK_FLOATING(x) do { \ + if (!FLOATINGP (x)) \ + x = wrong_type_argument (Qfloating, x); \ +} while (0) + +EXFUN (Ffloatp, 1); + + +/********************************** Reals ***********************************/ +extern Lisp_Object Qrealp; + +#define REALP(x) (RATIONALP (x) || FLOATINGP (x)) +#define CHECK_REAL(x) do { \ + if (!REALP (x)) \ + dead_wrong_type_argument (Qrealp, x); \ + } while (0) +#define CONCHECK_REAL(x) do { \ + if (!REALP (x)) \ + x = wrong_type_argument (Qrealp, x); \ +} while (0) + +EXFUN (Frealp, 1); + + +/********************************* Numbers **********************************/ +extern Lisp_Object Qnumberp; + +#define NUMBERP(x) REALP (x) +#define CHECK_NUMBER(x) do { \ + if (!NUMBERP (x)) \ + dead_wrong_type_argument (Qnumberp, x); \ +} while (0) +#define CONCHECK_NUMBER(x) do { \ + if (!NUMBERP (x)) \ + x = wrong_type_argument (Qnumberp, x); \ +} while (0) + +EXFUN (Fcanonicalize_number, 1); + +enum number_type {FIXNUM_T, BIGNUM_T, RATIO_T, FLOAT_T, BIGFLOAT_T}; + +extern enum number_type promote_args (Lisp_Object *, Lisp_Object *); + +#endif /* INCLUDED_number_h_ */
--- a/src/symsinit.h Mon Apr 05 21:50:47 2004 +0000 +++ b/src/symsinit.h Mon Apr 05 22:50:11 2004 +0000 @@ -151,6 +151,7 @@ void syms_of_mule_coding (void); void syms_of_mule_wnn (void); void syms_of_nt (void); +void syms_of_number (void); void syms_of_objects (void); void syms_of_objects_mswindows (void); void syms_of_objects_tty (void); @@ -391,6 +392,7 @@ void vars_of_mule_wnn (void); void reinit_vars_of_mule_wnn (void); void vars_of_nt (void); +void vars_of_number (void); void vars_of_objects (void); void reinit_vars_of_objects (void); void vars_of_objects_tty (void); @@ -548,4 +550,8 @@ void init_event_gtk_late (void); void console_type_create_select_gtk (void); +/* Enhanced number initialization: must be done only at runtime due to complex + interactions with the supporting libraries. */ +void init_number (void); + #endif /* INCLUDED_symsinit_h_ */
--- a/src/sysdep.c Mon Apr 05 21:50:47 2004 +0000 +++ b/src/sysdep.c Mon Apr 05 22:50:11 2004 +0000 @@ -3635,6 +3635,9 @@ srand ((unsigned int)arg); # endif #endif +#ifdef HAVE_BIGNUM + bignum_random_seed ((unsigned long) arg); +#endif } /*
--- a/tests/ChangeLog Mon Apr 05 21:50:47 2004 +0000 +++ b/tests/ChangeLog Mon Apr 05 22:50:11 2004 +0000 @@ -1,3 +1,7 @@ +2004-04-05 Jerry James <james@xemacs.org> + + * automated/lisp-tests.el: Add bignum and ratio tests. + 2004-03-22 Stephen J. Turnbull <stephen@xemacs.org> * XEmacs 21.5.17 "chayote" is released.
--- a/tests/automated/lisp-tests.el Mon Apr 05 21:50:47 2004 +0000 +++ b/tests/automated/lisp-tests.el Mon Apr 05 22:50:11 2004 +0000 @@ -229,8 +229,27 @@ (Assert (= (+ 1.0 1) 2.0)) (Assert (= (+ 1.0 1 1) 3.0)) (Assert (= (+ 1 1 1.0) 3.0)) -(Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) -(Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum)) +(if (featurep 'bignum) + (progn + (Assert (bignump (1+ most-positive-fixnum))) + (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) + (Assert (bignump (+ most-positive-fixnum 1))) + (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) + (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) + (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) + 3)))) + (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) + (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) + +(when (featurep 'ratio) + (let ((threefourths (read "3/4")) + (threehalfs (read "3/2")) + (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) + (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) + (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) + (Assert (= negone -1)) + (Assert (= threehalfs (+ threefourths threefourths))) + (Assert (zerop (+ bigpos bigneg))))) ;; Test `-' (Check-Error wrong-number-of-arguments (-)) @@ -257,8 +276,28 @@ (Assert (= (- 1.5 1) .5)) (Assert (= (- 1 1.5) (- .5))) -(Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) -(Assert (eq (- most-negative-fixnum 1) most-positive-fixnum)) +(if (featurep 'bignum) + (progn + (Assert (bignump (1- most-negative-fixnum))) + (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) + (Assert (bignump (- most-negative-fixnum 1))) + (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) + (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) + (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) + (* 2 most-positive-fixnum)) + 1))) + (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) + (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) + +(when (featurep 'ratio) + (let ((threefourths (read "3/4")) + (threehalfs (read "3/2")) + (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) + (bigneg (div most-positive-fixnum most-negative-fixnum)) + (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) + (Assert (= (- negone) 1)) + (Assert (= threefourths (- threehalfs threefourths))) + (Assert (= (- bigpos bigneg) 2)))) ;; Test `/' @@ -286,6 +325,28 @@ (dolist (two '(2 2.0 ?\02)) (Assert (= (/ 3.0 two) 1.5))) +(when (featurep 'bignum) + (let* ((million 1000000) + (billion (* million 1000)) ;; American, not British, billion + (trillion (* billion 1000))) + (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) + (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) + (Assert (= (/ trillion 1000) billion 1000000000.0)) + (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) + (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) + (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) + +(when (featurep 'ratio) + (let ((half (div 1 2)) + (fivefourths (div 5 4)) + (fivehalfs (div 5 2))) + (Assert (= half (read "3000000000/6000000000"))) + (Assert (= (/ fivehalfs fivefourths) 2)) + (Assert (= (/ fivefourths fivehalfs) half)) + (Assert (= (- half) (read "-3000000000/6000000000"))) + (Assert (= (/ fivehalfs (- fivefourths)) -2)) + (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) + ;; Test `*' (Assert (= 1 (*))) @@ -306,6 +367,19 @@ (dolist (five '(5 5.0 ?\05)) (Assert (= 30 (* five two three)))))) +(when (featurep 'bignum) + (let ((64K 65536)) + (Assert (= (* 64K 64K) (read "4294967296"))) + (Assert (= (* (- 64K) 64K) (read "-4294967296"))) + (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) + +(when (featurep 'ratio) + (let ((half (div 1 2)) + (fivefourths (div 5 4)) + (twofifths (div 2 5))) + (Assert (= (* fivefourths twofifths) half)) + (Assert (= (* half twofifths) (read "3/15"))))) + ;; Test `+' (Assert (= 0 (+))) @@ -337,6 +411,20 @@ (Assert (= two (max one two two))) (Assert (= two (max two two one))))) +(when (featurep 'bignum) + (let ((big (1+ most-positive-fixnum)) + (small (1- most-negative-fixnum))) + (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) + (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) + +(when (featurep 'ratio) + (let* ((big (1+ most-positive-fixnum)) + (small (1- most-negative-fixnum)) + (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) + (smallr (- bigr))) + (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) + (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) + ;; The byte compiler has special handling for these constructs: (let ((three 3) (five 5)) (Assert (= (+ three five 1) 9)) @@ -476,7 +564,13 @@ (division-test ?\07) (division-test (Int-to-Marker 7))) - +(when (featurep 'bignum) + (let ((big (+ (* 7 most-positive-fixnum 6))) + (negbig (- (* 7 most-negative-fixnum 6)))) + (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) + (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) + (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) + (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) ;;----------------------------------------------------- ;; Arithmetic comparison operations @@ -567,6 +661,42 @@ (Assert (= 1 (Int-to-Marker 1))) (Assert (= (point) (point-marker))) +(when (featurep 'bignum) + (let ((big1 (1+ most-positive-fixnum)) + (big2 (* 10 most-positive-fixnum)) + (small1 (1- most-negative-fixnum)) + (small2 (* 10 most-negative-fixnum))) + (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 + big2)) + (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 + big2)) + (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 + small2)) + (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 + small2)) + (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 + big2)))) + +(when (featurep 'ratio) + (let ((big1 (div (* 10 most-positive-fixnum) 4)) + (big2 (div (* 5 most-positive-fixnum) 2)) + (big3 (div (* 7 most-positive-fixnum) 2)) + (small1 (div (* 10 most-negative-fixnum) 4)) + (small2 (div (* 5 most-negative-fixnum) 2)) + (small3 (div (* 7 most-negative-fixnum) 2))) + (Assert (= big1 big2)) + (Assert (= small1 small2)) + (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 + big3)) + (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum + big1 big2 big3)) + (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 + small3)) + (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum + small1 small2 small3)) + (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 + small3)))) + ;;----------------------------------------------------- ;; testing list-walker functions ;;----------------------------------------------------- @@ -1135,10 +1265,16 @@ ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. ;;; What to do if "%u" is used with a negative number? -;;; The most reasonable thing seems to be to print an un-read-able number. -;;; The printed value might be useful to a human, if not to Emacs Lisp. -(Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) -(Check-Error invalid-read-syntax (read (format "%u" -1))) +;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an +;;; un-read-able number. The printed value might be useful to a human, if not +;;; to Emacs Lisp. +;;; For bignum XEmacsen, we make %u with a negative value throw an error. +(if (featurep 'bignum) + (progn + (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) + (Check-Error wrong-type-argument (format "%u" -1))) + (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) + (Check-Error invalid-read-syntax (read (format "%u" -1)))) ;; Check all-completions ignore element start with space. (Assert (not (all-completions "" '((" hidden" . "object")))))