commit: Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.

changeset: 4678:b5e1d4f6b66f user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Tue Aug 11 17:59:23 2009 +0100 files: lisp/ChangeLog lisp/cl-compat.el lisp/cl-extra.el man/ChangeLog man/lispref/numbers.texi src/ChangeLog src/bytecode.c src/doprnt.c src/floatfns.c src/lisp.h src/number.c src/number.h tests/ChangeLog tests/automated/lisp-tests.el description: Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. lisp/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-extra.el (ceiling*, floor*, round*, truncate*): Implement these in terms of the C functions; mark them as obsolete. (mod*, rem*): Use #'nth-value with the C functions, not #'nth with the CL emulation functions. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * lispref/numbers.texi (Bigfloat Basics): Correct this documentation (ignoring for the moment that it breaks off in mid-sentence). tests/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/lisp-tests.el: Test the new Common Lisp-compatible rounding functions available in C. (generate-rounding-output): Provide a function useful for generating the data for the rounding functions tests. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): New macros, used in the implementation of the rounding functions. (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) (floor_two_fixnum, floor_two_bignum, floor_two_ratio) (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) (floor_two_float, floor_one_mundane_arg, round_two_fixnum) (round_two_bignum_1, round_two_bignum, round_two_ratio) (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) (round_one_bigfloat, round_two_float, round_one_float) (round_one_mundane_arg, truncate_two_fixnum) (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) (truncate_one_float, truncate_one_mundane_arg): New functions, used in the implementation of the rounding functions. (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) (Ffround, Fftruncate): Revise to fully support Common Lisp conventions. This means: -- All functions have optional DIVISOR arguments -- All functions return multiple values; see #'values -- All functions do their arithmetic with the correct number types according to the contamination rules. -- #'round and #'fround always round towards the even number in ambiguous cases. * doprnt.c (emacs_doprnt_1): * number.c (internal_coerce_number): Call Ftruncate with two arguments, not one. * floatfns.c (Ffloat): Correct this, if NUMBER is a bignum. * lisp.h: Declare Ftruncate as taking two arguments. * number.c: Provide scratch_ratio2, init it appropriately. * number.h: Make scratch_ratio2 available. * number.h (BIGFLOAT_ARITH_RETURN): * number.h (BIGFLOAT_ARITH_RETURN1): Correct these functions. diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 16 20:55:49 2009 +0100 +++ b/lisp/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -9,6 +9,14 ＠＠ * minibuf.el (read-from-minibuffer): Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless of depth. + +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * cl-extra.el (ceiling*, floor*, round*, truncate*): + Implement these in terms of the C functions; mark them as + obsolete. + (mod*, rem*): Use #'nth-value with the C functions, not #'nth with + the CL emulation functions. 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/cl-compat.el --- a/lisp/cl-compat.el Sun Aug 16 20:55:49 2009 +0100 +++ b/lisp/cl-compat.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -82,12 +82,11 ＠＠ (if test-not (not (funcall test-not item elt)) (funcall (or test 'eql) item elt)))) -;;; Rounding functions with old-style multiple value returns. - -(defun cl-floor (a &optional b) (values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (values-list (ceiling* a b))) -(defun cl-round (a &optional b) (values-list (round* a b))) -(defun cl-truncate (a &optional b) (values-list (truncate* a b))) +;; The rounding functions in C now have all the functionality this package +;; used to: +(loop + for symbol in '(floor ceiling round truncate) + do (defalias (intern (format "cl-%s" symbol)) symbol)) (defun safe-idiv (a b) (let* ((q (/ (abs a) (abs b))) diff -r 8f1ee2d15784 -r b5e1d4f6b66f lisp/cl-extra.el --- a/lisp/cl-extra.el Sun Aug 16 20:55:49 2009 +0100 +++ b/lisp/cl-extra.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -394,55 +394,40 ＠＠ (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) (defalias 'expt 'cl-expt)) -(defun floor* (x &optional y) - "Return a list of the floor of X and the fractional part of X. -With two arguments, return floor and remainder of their quotient." - (let ((q (floor x y))) - (list q (- x (if y (* y q) q))))) +;; We can't use macrolet in this file; whence the literal macro +;; definition-and-call: +((macro . (lambda (&rest symbols) + "Make some old CL package truncate and round functions available. -(defun ceiling* (x &optional y) - "Return a list of the ceiling of X and the fractional part of X. -With two arguments, return ceiling and remainder of their quotient." - (let ((res (floor* x y))) - (if (= (car (cdr res)) 0) res - (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) - -(defun truncate* (x &optional y) - "Return a list of the integer part of X and the fractional part of X. -With two arguments, return truncation and remainder of their quotient." - (if (eq (>= x 0) (or (null y) (>= y 0))) - (floor* x y) (ceiling* x y))) - -(defun round* (x &optional y) - "Return a list of X rounded to the nearest integer and the remainder. -With two arguments, return rounding and remainder of their quotient." - (if y - (if (and (integerp x) (integerp y)) - (let* ((hy (/ y 2)) - (res (floor* (+ x hy) y))) - (if (and (= (car (cdr res)) 0) - (= (+ hy hy) y) - (/= (% (car res) 2) 0)) - (list (1- (car res)) hy) - (list (car res) (- (car (cdr res)) hy)))) - (let ((q (round (/ x y)))) - (list q (- x (* q y))))) - (if (integerp x) (list x 0) - (let ((q (round x))) - (list q (- x q)))))) +These functions are now implemented in C; their Lisp implementations in this +XEmacs are trivial, so we provide them and mark them obsolete." + (let (symbol result) + (while symbols + (setq symbol (car symbols) + symbols (cdr symbols)) + (push `(make-obsolete ',(intern (format "%s*" symbol)) + ',symbol "21.5.29") + result) + (push + `(defun ,(intern (format "%s*" symbol)) (number &optional divisor) + ,(format "See `%s'. This returns a list, not multiple values." + symbol) + (multiple-value-list (,symbol number divisor))) + result)) + (cons 'progn result)))) + ceiling floor round truncate) (defun mod* (x y) "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) + (nth-value 1 (floor x y))) (defun rem* (x y) "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) + (nth-value 1 (truncate x y))) (defun signum (a) "Return 1 if A is positive, -1 if negative, 0 if zero." (cond ((> a 0) 1) ((< a 0) -1) (t 0))) - ;; Random numbers. diff -r 8f1ee2d15784 -r b5e1d4f6b66f man/ChangeLog --- a/man/ChangeLog Sun Aug 16 20:55:49 2009 +0100 +++ b/man/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,9 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * lispref/numbers.texi (Bigfloat Basics): + Correct this documentation (ignoring for the moment that it breaks + off in mid-sentence). + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl.texi (Organization): diff -r 8f1ee2d15784 -r b5e1d4f6b66f man/lispref/numbers.texi --- a/man/lispref/numbers.texi Sun Aug 16 20:55:49 2009 +0100 +++ b/man/lispref/numbers.texi Tue Aug 11 17:59:23 2009 +0100 ＠＠ -410,7 +410,8 ＠＠ It is possible to make bigfloat the default floating point format by setting ＠code{default-float-precision} to a non-zero value. Precision -is given in bits, with a maximum precision of ＠code{bigfloat-max-prec}. +is given in bits, with a maximum precision of +＠code{bigfloat-maximum-precision}. ＠c #### is this true? Bigfloats are created automatically when a number with yes diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/ChangeLog --- a/src/ChangeLog Sun Aug 16 20:55:49 2009 +0100 +++ b/src/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,50 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) + (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) + (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) + (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) + (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): + New macros, used in the implementation of the rounding functions. + (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) + (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) + (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) + (floor_two_fixnum, floor_two_bignum, floor_two_ratio) + (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) + (floor_two_float, floor_one_mundane_arg, round_two_fixnum) + (round_two_bignum_1, round_two_bignum, round_two_ratio) + (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) + (round_one_bigfloat, round_two_float, round_one_float) + (round_one_mundane_arg, truncate_two_fixnum) + (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) + (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) + (truncate_one_float, truncate_one_mundane_arg): + New functions, used in the implementation of the rounding + functions. + (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) + (Ffround, Fftruncate): + Revise to fully support Common Lisp conventions. This means: + -- All functions have optional DIVISOR arguments + -- All functions return multiple values; see #'values + -- All functions do their arithmetic with the correct number types + according to the contamination rules. + -- #'round and #'fround always round towards the even number + in ambiguous cases. + * doprnt.c (emacs_doprnt_1): + * number.c (internal_coerce_number): + Call Ftruncate with two arguments, not one. + * floatfns.c (Ffloat): + Correct this, if NUMBER is a bignum. + * lisp.h: + Declare Ftruncate as taking two arguments. + * number.c: + Provide scratch_ratio2, init it appropriately. + * number.h: + Make scratch_ratio2 available. + * number.h (BIGFLOAT_ARITH_RETURN): + * number.h (BIGFLOAT_ARITH_RETURN1): + Correct these functions. + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; * bytecode.c (enum Opcode /* Byte codes */): diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/bytecode.c --- a/src/bytecode.c Sun Aug 16 20:55:49 2009 +0100 +++ b/src/bytecode.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -301,8 +301,8 ＠＠ #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); +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); #endif obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/doprnt.c --- a/src/doprnt.c Sun Aug 16 20:55:49 2009 +0100 +++ b/src/doprnt.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -638,7 +638,7 ＠＠ else { if (FLOATP (obj)) - obj = Ftruncate (obj); + obj = Ftruncate (obj, Qnil); #ifdef HAVE_BIGFLOAT else if (BIGFLOATP (obj)) { diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/floatfns.c --- a/src/floatfns.c Sun Aug 16 20:55:49 2009 +0100 +++ b/src/floatfns.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -769,7 +769,7 ＠＠ return make_float ((double) XINT (number)); #ifdef HAVE_BIGNUM - if (BIGFLOATP (number)) + if (BIGNUMP (number)) { #ifdef HAVE_BIGFLOAT if (ZEROP (Vdefault_float_precision)) ＠＠ -848,347 +848,1602 ＠＠ #endif /* ! HAVE_LOGB */ } -DEFUN ("ceiling", Fceiling, 1, 1, 0, /* -Return the smallest integer no less than NUMBER. (Round toward +inf.) -*/ - (number)) +#ifdef WITH_NUMBER_TYPES +#define ROUNDING_CONVERT(conversion, return_float) \ + CONVERT_WITH_NUMBER_TYPES(conversion, return_float) +#else +#define ROUNDING_CONVERT(conversion, return_float) \ + CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) +#endif + +#define CONVERT_WITH_NUMBER_TYPES(conversion, return_float) \ + if (!NILP (divisor)) \ + { \ + switch (promote_args (&number, &divisor)) \ + { \ + case FIXNUM_T: \ + return conversion##_two_fixnum (number, divisor, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + BIGNUM, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + RATIO, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + BIGFLOAT, \ + return_float); \ + default: /* FLOAT_T */ \ + return conversion##_two_float (number,divisor, \ + return_float); \ + } \ + } \ + \ + /* Try this first, the arg is probably a float: */ \ + if (FLOATP (number)) \ + return conversion##_one_float (number, return_float); \ + \ + MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \ + RATIO, return_float); \ + MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \ + BIGFLOAT, return_float); \ + return conversion##_one_mundane_arg (number, divisor, \ + return_float) + + +#define CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) \ + if (!NILP (divisor)) \ + { \ + /* The promote_args call if number types are available \ + does these conversions, we do them too for symmetry: */\ + if (CHARP (number)) \ + { \ + number = make_int (XCHAR (number)); \ + } \ + else if (MARKERP (number)) \ + { \ + number = make_int (marker_position (number)); \ + } \ + \ + if (CHARP (divisor)) \ + { \ + divisor = make_int (XCHAR (divisor)); \ + } \ + else if (MARKERP (divisor)) \ + { \ + divisor = make_int (marker_position (divisor)); \ + } \ + \ + CHECK_INT_OR_FLOAT (divisor); \ + if (INTP (number) && INTP (divisor)) \ + { \ + return conversion##_two_fixnum (number, divisor, \ + return_float); \ + } \ + else \ + { \ + return conversion##_two_float (number, divisor, \ + return_float); \ + } \ + } \ + \ + /* Try this first, the arg is probably a float: */ \ + if (FLOATP (number)) \ + return conversion##_one_float (number, return_float); \ + \ + return conversion##_one_mundane_arg (number, divisor, \ + return_float) \ + +#ifdef WITH_NUMBER_TYPES + +#ifdef HAVE_BIGNUM +#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) \ + case BIGNUM_T: \ + return conversion##_two_bignum (number, divisor, return_float) + +#define MAYBE_ONE_ARG_BIGNUM(converse, return_float) \ + if (BIGNUM_P (number)) \ + return conversion##_one_bignum (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) +#define MAYBE_ONE_ARG_BIGNUM(converse, return_float) +#endif + +#ifdef HAVE_RATIO +#define MAYBE_TWO_ARGS_RATIO(conversion, return_float) \ + case RATIO_T: \ + return conversion##_two_ratio (number, divisor, return_float) + +#define MAYBE_ONE_ARG_RATIO(conversion, return_float) \ + if (RATIOP (number)) \ + return conversion##_one_ratio (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_RATIO(conversion, return_float) +#define MAYBE_ONE_ARG_RATIO(converse, return_float) +#endif + +#ifdef HAVE_BIGFLOAT +#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) \ + case BIGFLOAT_T: \ + return conversion##_two_bigfloat (number, divisor, return_float) + +#define MAYBE_ONE_ARG_BIGFLOAT(conversion, return_float) \ + if (BIGFLOATP (number)) \ + return conversion##_one_bigfloat (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) +#define MAYBE_ONE_ARG_BIGFLOAT(converse, return_float) +#endif + +#define MAYBE_TWO_ARGS_WITH_NUMBER_TYPES(convers, upcase, return_float) \ + MAYBE_TWO_ARGS_##upcase(convers, return_float) + +#define MAYBE_ONE_ARG_WITH_NUMBER_TYPES(convers, upcase, return_float) \ + MAYBE_ONE_ARG_##upcase(convers, return_float) + +#endif /* WITH_NUMBER_TYPES */ + +#define MAYBE_EFF(str) (return_float ? "f" str : str) + +/* The WITH_NUMBER_TYPES code calls promote_args, which accepts chars and + markers as equivalent to ints. This block does the same for + single-argument calls. */ +#define MAYBE_CHAR_OR_MARKER(conversion) do { \ + if (CHARP (number)) \ + { \ + return conversion##_one_mundane_arg (make_int (XCHAR (number)), \ + divisor, return_float); \ + } \ + \ + if (MARKERP (number)) \ + { \ + return conversion##_one_mundane_arg (make_int \ + (marker_position(number)), \ + divisor, return_float); \ + } \ + } while (0) + + +/* The guts of the implementations of the various rounding functions: */ + +static Lisp_Object +ceiling_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) { - if (FLOATP (number)) + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i3 = 0, i4 = 0; + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* With C89's integer /, the result is implementation-defined if either + operand is negative, so use only nonnegative operands. Here we do + basically the opposite of what floor_two_fixnum does, we add one in the + non-negative case: */ + + /* Make sure we use the same signs for the modulus calculation as for the + quotient calculation: */ + if (i2 < 0) { - double d; - IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number); - return (float_to_int (d, "ceiling", number, Qunbound)); + if (i1 <= 0) + { + i3 = -i1 / -i2; + /* Quotient is positive; add one to give the figure for + ceiling. */ + if (0 != (-i1 % -i2)) + { + ++i3; + } + } + else + { + /* Quotient is negative; no need to add one. */ + i3 = -(i1 / -i2); + } + } + else + { + if (i1 < 0) + { + /* Quotient is negative; no need to add one. */ + i3 = -(-i1 / i2); + } + else + { + i3 = i1 / i2; + /* Quotient is positive; add one to give the figure for + ceiling. */ + if (0 != (i1 % i2)) + { + ++i3; + } + } } + i4 = i1 - (i3 * i2); + + if (!return_float) + { + return values2 (make_int (i3), make_int (i4)); + } + + return values2 (make_float ((double)i3), + make_int (i4)); +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +ceiling_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_ceil (scratch_bignum, XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor))) + { + res1 = Qzero; + } + else + { + bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum); + res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +ceiling_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + bignum_ceil (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio, scratch_bignum); + ratio_mul (scratch_ratio2, scratch_ratio, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +ceiling_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + 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_ceil (scratch_bigfloat, scratch_bigfloat); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat); + return values2 (res0, + Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat))); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +ceiling_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +ceiling_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + + res1 = make_bigfloat_bf (scratch_bigfloat2); + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +ceiling_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + Lisp_Object res0; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + IN_FLOAT2 (f0 = ceil (f1 / f2), MAYBE_EFF("ceiling"), number, divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF("ceiling"), number, divisor); + + if (return_float) + { + res0 = make_float(f0); + } + else + { + res0 = float_to_int (f0, MAYBE_EFF("ceiling"), number, divisor); + } + + return values2 (res0, make_float (remain)); +} + +static Lisp_Object +ceiling_one_float (Lisp_Object number, int return_float) +{ + double d, remain; + Lisp_Object res0; + + IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), MAYBE_EFF("ceiling"), number); + IN_FLOAT ((remain = XFLOAT_DATA (number) - d), MAYBE_EFF("ceiling"), number); + + if (return_float) + { + res0 = make_float (d); + } + else + { + res0 = float_to_int (d, MAYBE_EFF("ceiling"), number, Qunbound); + } + return values2 (res0, make_float (remain)); +} + +EXFUN (Fceiling, 2); +EXFUN (Ffceiling, 2); + +static Lisp_Object +ceiling_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + + if (return_float) + { + if (INTP (number)) + { + return values2 (make_float ((double) XINT (number)), Qzero); + } +#ifdef HAVE_BIGNUM + else if (BIGNUMP (number)) + { + return values2 (make_float + (bignum_to_double (XBIGNUM_DATA (number))), + Qzero); + } +#endif + } + else + { +#ifdef HAVE_BIGNUM + if (INTEGERP (number)) +#else + if (INTP (number)) +#endif + { + return values2 (number, Qzero); + } + } + + MAYBE_CHAR_OR_MARKER (ceiling); + + return Ffceiling (wrong_type_argument (Qnumberp, number), divisor); +} + +static Lisp_Object +floor_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i3 = 0, i4 = 0; + Lisp_Object res0; + + if (i2 == 0) + { + Fsignal (Qarith_error, Qnil); + } + + /* With C89's integer /, the result is implementation-defined if either + operand is negative, so use only nonnegative operands. Notice also that + we're forcing the quotient of any negative numbers towards minus + infinity. */ + i3 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) + : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); + + i4 = i1 - (i3 * i2); + + if (return_float) + { + res0 = make_float ((double)i3); + } + else + { + res0 = make_int (i3); + } + + return values2 (res0, make_int (i4)); +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +floor_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_floor (scratch_bignum, XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor))) + { + res1 = Qzero; + } + else + { + bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum); + res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +floor_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + 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)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio, scratch_bignum); + ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +floor_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + 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); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, + XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2); + + return values2 (res0, make_bigfloat_bf (scratch_bigfloat)); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +floor_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +floor_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + return values2 (res0, make_bigfloat_bf (scratch_bigfloat2)); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +floor_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + IN_FLOAT2 (f0 = floor (f1 / f2), MAYBE_EFF ("floor"), number, divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("floor"), number, divisor); + + if (return_float) + { + return values2 (make_float (f0), make_float (remain)); + } + + return values2 (float_to_int (f0, MAYBE_EFF ("floor"), number, divisor), + make_float (remain)); +} + +static Lisp_Object +floor_one_float (Lisp_Object number, int return_float) +{ + double d, d1; + + IN_FLOAT ((d = floor (XFLOAT_DATA (number))), MAYBE_EFF ("floor"), number); + IN_FLOAT ((d1 = XFLOAT_DATA (number) - d), MAYBE_EFF ("floor"), number); + + if (return_float) + { + return values2 (make_float (d), make_float (d1)); + } + else + { + return values2 (float_to_int (d, MAYBE_EFF ("floor"), number, Qunbound), + make_float (d1)); + } +} + +EXFUN (Ffloor, 2); +EXFUN (Fffloor, 2); + +static Lisp_Object +floor_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #ifdef HAVE_BIGNUM if (INTEGERP (number)) #else if (INTP (number)) #endif - return number; + { + if (return_float) + { + return values2 (make_float (extract_float (number)), Qzero); + } + else + { + return values2 (number, Qzero); + } + } -#ifdef HAVE_RATIO - if (RATIOP (number)) + MAYBE_CHAR_OR_MARKER (floor); + + if (return_float) { - 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)); -} - - -DEFUN ("floor", Ffloor, 1, 2, 0, /* -Return the largest integer no greater than NUMBER. (Round towards -inf.) -With optional second argument DIVISOR, return the largest integer no -greater than NUMBER/DIVISOR. -*/ - (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; + return Fffloor (wrong_type_argument (Qnumberp, number), divisor); } else { - CHECK_REAL (divisor); - switch (promote_args (&number, &divisor)) - { - case FIXNUM_T: - { - EMACS_INT i1 = XREALINT (number); - EMACS_INT i2 = XREALINT (divisor); + return Ffloor (wrong_type_argument (Qnumberp, number), divisor); + } +} - if (i2 == 0) - Fsignal (Qarith_error, Qnil); +/* Algorithm taken from cl-extra.el, now to be found as cl-round in + tests/automated/lisp-tests.el. */ +static Lisp_Object +round_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i0, hi2, flooring, floored, flsecond; - /* 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 -#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 - default: /* 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); - } - } - } -#else /* !WITH_NUMBER_TYPES */ - CHECK_INT_OR_FLOAT (number); - - if (! NILP (divisor)) + if (i2 == 0) { - EMACS_INT i1, i2; - - CHECK_INT_OR_FLOAT (divisor); - - if (FLOATP (number) || FLOATP (divisor)) - { - double f1 = extract_float (number); - double f2 = extract_float (divisor); - - if (f2 == 0) - Fsignal (Qarith_error, Qnil); - - IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor); - return float_to_int (f1, "floor", number, divisor); - } - - i1 = XINT (number); - i2 = XINT (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)); + Fsignal (Qarith_error, Qnil); } - if (FLOATP (number)) + hi2 = i2 < 0 ? -( -i2 / 2) : i2 / 2; + + flooring = hi2 + i1; + + floored = (i2 < 0 + ? (flooring <= 0 ? -flooring / -i2 : -1 - ((flooring - 1) / -i2)) + : (flooring < 0 ? -1 - ((-1 - flooring) / i2) : flooring / i2)); + + flsecond = flooring - (floored * i2); + + if (0 == flsecond + && (i2 == (hi2 + hi2)) + && (0 != (floored % 2))) { - double d; - IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number); - return (float_to_int (d, "floor", number, Qunbound)); + i0 = floored - 1; + return values2 (return_float ? make_float ((double)i0) : + make_int (i0), make_int (hi2)); + } + else + { + return values2 (return_float ? make_float ((double)floored) : + make_int (floored), + make_int (flsecond - hi2)); + } +} + +#ifdef HAVE_BIGNUM +static void +round_two_bignum_1 (bignum number, bignum divisor, + Lisp_Object *res, Lisp_Object *remain) +{ + bignum flooring, floored, hi2, flsecond; + + if (bignum_divisible_p (number, divisor)) + { + bignum_div (scratch_bignum, number, divisor); + *res = make_bignum_bg (scratch_bignum); + *remain = Qzero; + return; } - return number; -#endif /* WITH_NUMBER_TYPES */ + bignum_set_long (scratch_bignum, 2); + + bignum_div (scratch_bignum2, divisor, scratch_bignum); + + bignum_init (hi2); + bignum_set (hi2, scratch_bignum2); + + bignum_add (scratch_bignum, scratch_bignum2, number); + bignum_init (flooring); + bignum_set (flooring, scratch_bignum); + + bignum_floor (scratch_bignum, flooring, divisor); + bignum_init (floored); + bignum_set (floored, scratch_bignum); + + bignum_mul (scratch_bignum2, scratch_bignum, divisor); + bignum_sub (scratch_bignum, flooring, scratch_bignum2); + bignum_init (flsecond); + bignum_set (flsecond, scratch_bignum); + + bignum_set_long (scratch_bignum, 2); + bignum_mul (scratch_bignum2, scratch_bignum, hi2); + + if (bignum_sign (flsecond) == 0 + && bignum_eql (divisor, scratch_bignum2) + && (1 == bignum_testbit (floored, 0))) + { + bignum_set_long (scratch_bignum, 1); + bignum_sub (floored, floored, scratch_bignum); + *res = make_bignum_bg (floored); + *remain = make_bignum_bg (hi2); + } + else + { + bignum_sub (scratch_bignum, flsecond, + hi2); + *res = make_bignum_bg (floored); + *remain = make_bignum_bg (scratch_bignum); + } } -DEFUN ("round", Fround, 1, 1, 0, /* -Return the nearest integer to NUMBER. -*/ - (number)) +static Lisp_Object +round_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) { - if (FLOATP (number)) + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) { - double d; - /* Screw the prevailing rounding mode. */ - IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number); - return (float_to_int (d, "round", number, Qunbound)); + Fsignal (Qarith_error, Qnil); } + round_two_bignum_1 (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor), + &res0, &res1); + + if (return_float) + { + res0 = make_float (bignum_to_double (XBIGNUM_DATA (res0))); + } + else + { + res0 = Fcanonicalize_number (res0); + } + + return values2 (res0, Fcanonicalize_number (res1)); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +round_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + round_two_bignum_1 (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio), &res0, &res1); + + if (!ZEROP (res1)) + { + /* The numerator and denominator don't round exactly, calculate a + ratio remainder: */ + ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0)); + ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + res0 = return_float ? + make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) : + Fcanonicalize_number (res0); + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +/* This is the logic of emacs_rint above, no more and no less. */ +static Lisp_Object +round_one_bigfloat_1 (bigfloat number) +{ + Lisp_Object res0; + unsigned long prec = bigfloat_get_prec (number); + + assert ((bigfloat *)(&number) != (bigfloat *)&scratch_bigfloat + && (bigfloat *)(&number) != (bigfloat *)(&scratch_bigfloat2)); + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_set_double (scratch_bigfloat, 0.5); + bigfloat_add (scratch_bigfloat2, scratch_bigfloat, number); + bigfloat_floor (scratch_bigfloat, scratch_bigfloat2); + res0 = make_bigfloat_bf (scratch_bigfloat); + + bigfloat_sub (scratch_bigfloat2, scratch_bigfloat, number); + bigfloat_abs (scratch_bigfloat, scratch_bigfloat2); + + bigfloat_set_double (scratch_bigfloat2, 0.5); + + do { + if (!bigfloat_ge (scratch_bigfloat, scratch_bigfloat2)) + { + break; + } + + if (!bigfloat_gt (scratch_bigfloat, scratch_bigfloat2)) + { + bigfloat_set_double (scratch_bigfloat2, 2.0); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (res0), + scratch_bigfloat2); + bigfloat_floor (scratch_bigfloat2, scratch_bigfloat); + bigfloat_set_double (scratch_bigfloat, 2.0); + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat2, + scratch_bigfloat); + if (bigfloat_eql (scratch_bigfloat2, XBIGFLOAT_DATA (res0))) + { + break; + } + } + + if (bigfloat_lt (XBIGFLOAT_DATA (res0), number)) + { + bigfloat_set_double (scratch_bigfloat2, 1.0); + } + else + { + bigfloat_set_double (scratch_bigfloat2, -1.0); + } + + bigfloat_set (scratch_bigfloat, XBIGFLOAT_DATA (res0)); + + bigfloat_add (XBIGFLOAT_DATA (res0), scratch_bigfloat2, + scratch_bigfloat); + + } while (0); + + return res0; +} + +static Lisp_Object +round_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + bigfloat divided; + + unsigned long prec = max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor)); + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bigfloat_init (divided); + bigfloat_set_prec (divided, prec); + + bigfloat_div (divided, XBIGFLOAT_DATA (number), XBIGFLOAT_DATA (divisor)); + + res0 = round_one_bigfloat_1 (divided); + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (res0), + XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), + scratch_bigfloat); + + res1 = make_bigfloat_bf (scratch_bigfloat2); + + if (!return_float) + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (XBIGFLOAT_DATA (res0))); +#endif /* HAVE_BIGNUM */ + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +round_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + round_two_bignum_1 (XRATIO_NUMERATOR (number), XRATIO_DENOMINATOR (number), + &res0, &res1); + + if (!ZEROP (res1)) + { + ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + res0 = return_float ? + make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) : + Fcanonicalize_number (res0); + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +round_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0 = round_one_bigfloat_1 (XBIGFLOAT_DATA (number)); + Lisp_Object res1; + + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (res0)); + + res1 = make_bigfloat_bf (scratch_bigfloat); + + if (!return_float) + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long + (XBIGFLOAT_DATA (res0))); +#endif /* HAVE_BIGNUM */ + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +round_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + + if (f2 == 0.0) + Fsignal (Qarith_error, Qnil); + + IN_FLOAT2 ((f0 = emacs_rint (f1 / f2)), MAYBE_EFF ("round"), number, + divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("round"), number, divisor); + + if (return_float) + { + return values2 (make_float (f0), make_float (remain)); + } + else + { + return values2 (float_to_int (f0, MAYBE_EFF("round"), number, divisor), + make_float (remain)); + } +} + +static Lisp_Object +round_one_float (Lisp_Object number, int return_float) +{ + double d; + /* Screw the prevailing rounding mode. */ + IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), MAYBE_EFF ("round"), + number); + + if (return_float) + { + return values2 (make_float (d), make_float (XFLOAT_DATA (number) - d)); + } + else + { + return values2 ((float_to_int (d, MAYBE_EFF ("round"), number, + Qunbound)), + make_float (XFLOAT_DATA (number) - d)); + } +} + +EXFUN (Fround, 2); +EXFUN (Ffround, 2); + +static Lisp_Object +round_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #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))) + if (return_float) { - bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); + return values2 (make_float (extract_float (number)), Qzero); } else { - bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - bignum_div (scratch_bignum, scratch_bignum2, - XRATIO_DENOMINATOR (number)); + return values2 (number, Qzero); } - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); } + + MAYBE_CHAR_OR_MARKER (round); + + if (return_float) + { + return Ffround (wrong_type_argument (Qnumberp, number), divisor); + } + else + { + return Fround (wrong_type_argument (Qnumberp, number), divisor); + } +} + +static Lisp_Object +truncate_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i0; + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* We're truncating towards zero, so apart from avoiding the C89 + implementation-defined behaviour with truncation and negative numbers, + we don't need to do anything further: */ + i0 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -(i1 / -i2)) + : (i1 < 0 ? -(-i1 / i2) : i1 / i2)); + + if (return_float) + { + return values2 (make_float ((double)i0), make_int (i1 - (i0 * i2))); + } + else + { + return values2 (make_int (i0), make_int (i1 - (i0 * i2))); + } +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +truncate_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_div (scratch_bignum, XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = make_bignum_bg (scratch_bignum); + } + + if (bignum_divisible_p (XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor))) + { + return values2 (Fcanonicalize_number (res0), Qzero); + } + + bignum_mul (scratch_bignum2, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum2); + + return values2 (Fcanonicalize_number (res0), + Fcanonicalize_number (make_bignum_bg (scratch_bignum))); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +truncate_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + bignum_div (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + return values2 (res0, Qzero); + } + + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio2, XRATIO_DATA (number), scratch_ratio); + + return values2 (res0, Fcanonicalize_number (make_ratio_rt(scratch_ratio2))); +} #endif #ifdef HAVE_BIGFLOAT - if (BIGFLOATP (number)) +static Lisp_Object +truncate_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + unsigned long prec = max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor)); + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) { - 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); + Fsignal (Qarith_error, Qnil); + } + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (divisor)); + bigfloat_trunc (scratch_bigfloat, scratch_bigfloat); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { #ifdef HAVE_BIGNUM bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); #else - return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); #endif /* HAVE_BIGNUM */ } + + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2); + + return values2 (res0, make_bigfloat_bf (scratch_bigfloat)); +} #endif /* HAVE_BIGFLOAT */ - return Fround (wrong_type_argument (Qnumberp, number)); +#ifdef HAVE_RATIO +static Lisp_Object +truncate_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + if (ratio_sign (XRATIO_DATA (number)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + return values2 (res0, Qzero); + } + + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + + return values2 (res0, Fcanonicalize_number (make_ratio_rt (scratch_ratio))); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +truncate_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_set_prec (scratch_bigfloat2, XBIGFLOAT_GET_PREC (number)); + bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + + return + values2 (res0, + Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat2))); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +truncate_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + Lisp_Object res0; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + res0 = float_to_int (f1 / f2, MAYBE_EFF ("truncate"), number, Qunbound); + f0 = extract_float (res0); + + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("truncate"), number, divisor); + + if (return_float) + { + res0 = make_float (f0); + } + + return values2 (res0, make_float (remain)); } -DEFUN ("truncate", Ftruncate, 1, 1, 0, /* -Truncate a floating point number to an integer. -Rounds the value toward zero. -*/ - (number)) +static Lisp_Object +truncate_one_float (Lisp_Object number, int return_float) { - if (FLOATP (number)) - return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound); + Lisp_Object res0 + = float_to_int (XFLOAT_DATA (number), MAYBE_EFF ("truncate"), + number, Qunbound); + if (return_float) + { + res0 = make_float ((double)XINT(res0)); + return values2 (res0, make_float ((XFLOAT_DATA (number) + - XFLOAT_DATA (res0)))); + } + else + { + return values2 (res0, make_float (XFLOAT_DATA (number) + - XREALINT (res0))); + } +} +EXFUN (Fftruncate, 2); + +static Lisp_Object +truncate_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #ifdef HAVE_BIGNUM if (INTEGERP (number)) #else if (INTP (number)) #endif - return number; + { + if (return_float) + { + return values2 (make_float (extract_float (number)), Qzero); + } + else + { + return values2 (number, Qzero); + } + } -#ifdef HAVE_RATIO - if (RATIOP (number)) + MAYBE_CHAR_OR_MARKER (truncate); + + if (return_float) { - bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + return Fftruncate (wrong_type_argument (Qnumberp, number), divisor); } -#endif + else + { + return Ftruncate (wrong_type_argument (Qnumberp, number), divisor); + } +} + +/* Rounding functions that will not necessarily return floats: */ -#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 */ +DEFUN ("ceiling", Fceiling, 1, 2, 0, /* +Return the smallest integer no less than NUMBER. (Round toward +inf.) - return Ftruncate (wrong_type_argument (Qnumberp, number)); +With optional argument DIVISOR, return the smallest integer no less than +the quotient of NUMBER and DIVISOR. + +This function returns multiple values; see `multiple-value-bind' and +`multiple-value-call'. The second returned value is the remainder in the +calculation, which will be one minus the fractional part of NUMBER if DIVISOR +is omitted or one. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(ceiling, 0); +} + +DEFUN ("floor", Ffloor, 1, 2, 0, /* +Return the largest integer no greater than NUMBER. (Round towards -inf.) +With optional second argument DIVISOR, return the largest integer no +greater than the quotient of NUMBER and DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder in the +calculation, which will just be the fractional part if DIVISOR is omitted or +one. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(floor, 0); +} + +DEFUN ("round", Fround, 1, 2, 0, /* +Return the nearest integer to NUMBER. +If NUMBER is exactly halfway between two integers, return the one that +is even. + +Optional argument DIVISOR means return the nearest integer to NUMBER +divided by DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder +in the calculation. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(round, 0); +} + +DEFUN ("truncate", Ftruncate, 1, 2, 0, /* +Truncate a floating point number to an integer. +Rounds the value toward zero. + +Optional argument DIVISOR means truncate NUMBER divided by DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(truncate, 0); }  /* Float-rounding functions. */ -DEFUN ("fceiling", Ffceiling, 1, 1, 0, /* +DEFUN ("fceiling", Ffceiling, 1, 2, 0, /* Return the smallest integer no less than NUMBER, as a float. \(Round toward +inf.\) + +With optional argument DIVISOR, return the smallest integer no less than the +quotient of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = ceil (d), "fceiling", number); - return make_float (d); + ROUNDING_CONVERT(ceiling, 1); } -DEFUN ("ffloor", Fffloor, 1, 1, 0, /* +DEFUN ("ffloor", Fffloor, 1, 2, 0, /* Return the largest integer no greater than NUMBER, as a float. \(Round towards -inf.\) + +With optional argument DIVISOR, return the largest integer no greater than +the quotient of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = floor (d), "ffloor", number); - return make_float (d); + ROUNDING_CONVERT(floor, 1); } -DEFUN ("fround", Ffround, 1, 1, 0, /* +DEFUN ("fround", Ffround, 1, 2, 0, /* Return the nearest integer to NUMBER, as a float. +If NUMBER is exactly halfway between two integers, return the one that is +even. + +With optional argument DIVISOR, return the nearest integer to the quotient +of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = emacs_rint (d), "fround", number); - return make_float (d); + ROUNDING_CONVERT(round, 1); } -DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /* +DEFUN ("ftruncate", Fftruncate, 1, 2, 0, /* Truncate a floating point number to an integral float value. Rounds the value toward zero. + +With optional argument DIVISOR, truncate the quotient of NUMBER and DIVISOR, +to an integral float value. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - if (d >= 0.0) - IN_FLOAT (d = floor (d), "ftruncate", number); - else - IN_FLOAT (d = ceil (d), "ftruncate", number); - return make_float (d); + ROUNDING_CONVERT(truncate, 1); }  #ifdef FLOAT_CATCH_SIGILL diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/lisp.h --- a/src/lisp.h Sun Aug 16 20:55:49 2009 +0100 +++ b/src/lisp.h Tue Aug 11 17:59:23 2009 +0100 ＠＠ -4705,7 +4705,7 ＠＠ void unlock_buffer (struct buffer *); /* Defined in floatfns.c */ -EXFUN (Ftruncate, 1); +EXFUN (Ftruncate, 2); double extract_float (Lisp_Object); diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/number.c --- a/src/number.c Sun Aug 16 20:55:49 2009 +0100 +++ b/src/number.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -41,7 +41,7 ＠＠ bignum scratch_bignum, scratch_bignum2; #endif #ifdef HAVE_RATIO -ratio scratch_ratio; +ratio scratch_ratio, scratch_ratio2; #endif #ifdef HAVE_BIGFLOAT bigfloat scratch_bigfloat, scratch_bigfloat2; ＠＠ -561,7 +561,7 ＠＠ switch (type) { case FIXNUM_T: - return Ftruncate (number); + return Ftruncate (number, Qnil); case BIGNUM_T: #ifdef HAVE_BIGNUM bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); ＠＠ -853,6 +853,7 ＠＠ #ifdef HAVE_RATIO ratio_init (scratch_ratio); + ratio_init (scratch_ratio2); #endif #ifdef HAVE_BIGFLOAT diff -r 8f1ee2d15784 -r b5e1d4f6b66f src/number.h --- a/src/number.h Sun Aug 16 20:55:49 2009 +0100 +++ b/src/number.h Tue Aug 11 17:59:23 2009 +0100 ＠＠ -195,7 +195,7 ＠＠ 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; +extern ratio scratch_ratio, scratch_ratio2; #else /* !HAVE_RATIO */ ＠＠ -251,16 +251,16 ＠＠ #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); \ +#define BIGFLOAT_ARITH_RETURN(f,op) do \ +{ \ + Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \ 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); \ + Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \ bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f), arg); \ return retval; \ } while (0) diff -r 8f1ee2d15784 -r b5e1d4f6b66f tests/ChangeLog --- a/tests/ChangeLog Sun Aug 16 20:55:49 2009 +0100 +++ b/tests/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,11 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/lisp-tests.el: + Test the new Common Lisp-compatible rounding functions available in + C. + (generate-rounding-output): Provide a function useful for + generating the data for the rounding functions tests. + 2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/mule-tests.el: diff -r 8f1ee2d15784 -r b5e1d4f6b66f tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Aug 16 20:55:49 2009 +0100 +++ b/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1368,5 +1368,574 ＠＠ (load test-file-name nil t nil) (delete-file test-file-name)) +(flet ((cl-floor (x &optional y) + (let ((q (floor x y))) + (list q (- x (if y (* y q) q))))) + (cl-ceiling (x &optional y) + (let ((res (cl-floor x y))) + (if (= (car (cdr res)) 0) res + (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) + (cl-truncate (x &optional y) + (if (eq (>= x 0) (or (null y) (>= y 0))) + (cl-floor x y) (cl-ceiling x y))) + (cl-round (x &optional y) + (if y + (if (and (integerp x) (integerp y)) + (let* ((hy (/ y 2)) + (res (cl-floor (+ x hy) y))) + (if (and (= (car (cdr res)) 0) + (= (+ hy hy) y) + (/= (% (car res) 2) 0)) + (list (1- (car res)) hy) + (list (car res) (- (car (cdr res)) hy)))) + (let ((q (round (/ x y)))) + (list q (- x (* q y))))) + (if (integerp x) (list x 0) + (let ((q (round x))) + (list q (- x q)))))) + (Assert-rounding (first second &key + one-floor-result two-floor-result + one-ffloor-result two-ffloor-result + one-ceiling-result two-ceiling-result + one-fceiling-result two-fceiling-result + one-round-result two-round-result + one-fround-result two-fround-result + one-truncate-result two-truncate-result + one-ftruncate-result two-ftruncate-result) + (Assert (equal one-floor-result (multiple-value-list + (floor first))) + (format "checking (floor %S) gives %S" + first one-floor-result)) + (Assert (equal one-floor-result (multiple-value-list + (floor first 1))) + (format "checking (floor %S 1) gives %S" + first one-floor-result)) + (Check-Error arith-error (floor first 0)) + (Check-Error arith-error (floor first 0.0)) + (Assert (equal two-floor-result (multiple-value-list + (floor first second))) + (format + "checking (floor %S %S) gives %S" + first second two-floor-result)) + (Assert (equal (cl-floor first second) + (multiple-value-list (floor first second))) + (format + "checking (floor %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first))) + (format "checking (ffloor %S) gives %S" + first one-ffloor-result)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first 1))) + (format "checking (ffloor %S 1) gives %S" + first one-ffloor-result)) + (Check-Error arith-error (ffloor first 0)) + (Check-Error arith-error (ffloor first 0.0)) + (Assert (equal two-ffloor-result (multiple-value-list + (ffloor first second))) + (format "checking (ffloor %S %S) gives %S" + first second two-ffloor-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first))) + (format "checking (ceiling %S) gives %S" + first one-ceiling-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first 1))) + (format "checking (ceiling %S 1) gives %S" + first one-ceiling-result)) + (Check-Error arith-error (ceiling first 0)) + (Check-Error arith-error (ceiling first 0.0)) + (Assert (equal two-ceiling-result (multiple-value-list + (ceiling first second))) + (format "checking (ceiling %S %S) gives %S" + first second two-ceiling-result)) + (Assert (equal (cl-ceiling first second) + (multiple-value-list (ceiling first second))) + (format + "checking (ceiling %S %S) gives the same as the old code" + first second)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first))) + (format "checking (fceiling %S) gives %S" + first one-fceiling-result)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first 1))) + (format "checking (fceiling %S 1) gives %S" + first one-fceiling-result)) + (Check-Error arith-error (fceiling first 0)) + (Check-Error arith-error (fceiling first 0.0)) + (Assert (equal two-fceiling-result (multiple-value-list + (fceiling first second))) + (format "checking (fceiling %S %S) gives %S" + first second two-fceiling-result)) + (Assert (equal one-round-result (multiple-value-list + (round first))) + (format "checking (round %S) gives %S" + first one-round-result)) + (Assert (equal one-round-result (multiple-value-list + (round first 1))) + (format "checking (round %S 1) gives %S, types %S, actual %S, types %S" + first one-round-result (mapcar #'type-of one-round-result) + (multiple-value-list (round first 1)) + (mapcar #'type-of (multiple-value-list (round first 1))))) + (Check-Error arith-error (round first 0)) + (Check-Error arith-error (round first 0.0)) + (Assert (equal two-round-result (multiple-value-list + (round first second))) + (format "checking (round %S %S) gives %S" + first second two-round-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first))) + (format "checking (fround %S) gives %S" + first one-fround-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first 1))) + (format "checking (fround %S 1) gives %S" + first one-fround-result)) + (Check-Error arith-error (fround first 0)) + (Check-Error arith-error (fround first 0.0)) + (Assert (equal two-fround-result (multiple-value-list + (fround first second))) + (format "checking (fround %S %S) gives %S" + first second two-fround-result)) + (Assert (equal (cl-round first second) + (multiple-value-list (round first second))) + (format + "checking (round %S %S) gives the same as the old code" + first second)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first))) + (format "checking (truncate %S) gives %S" + first one-truncate-result)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first 1))) + (format "checking (truncate %S 1) gives %S" + first one-truncate-result)) + (Check-Error arith-error (truncate first 0)) + (Check-Error arith-error (truncate first 0.0)) + (Assert (equal two-truncate-result (multiple-value-list + (truncate first second))) + (format "checking (truncate %S %S) gives %S" + first second two-truncate-result)) + (Assert (equal (cl-truncate first second) + (multiple-value-list (truncate first second))) + (format + "checking (truncate %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first))) + (format "checking (ftruncate %S) gives %S" + first one-ftruncate-result)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first 1))) + (format "checking (ftruncate %S 1) gives %S" + first one-ftruncate-result)) + (Check-Error arith-error (ftruncate first 0)) + (Check-Error arith-error (ftruncate first 0.0)) + (Assert (equal two-ftruncate-result (multiple-value-list + (ftruncate first second))) + (format "checking (ftruncate %S %S) gives %S" + first second two-ftruncate-result))) + (Assert-rounding-floating (pie ee) + (let ((pie-type (type-of pie))) + (assert (eq pie-type (type-of ee)) t + "This code assumes the two arguments have the same type.") + (Assert-rounding pie ee +:one-floor-result (list 3 (- pie 3)) +:two-floor-result (list 1 (- pie (* 1 ee))) +:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) +:one-ceiling-result (list 4 (- pie 4)) +:two-ceiling-result (list 2 (- pie (* 2 ee))) +:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) +:two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee))) +:one-round-result (list 3 (- pie 3)) +:two-round-result (list 1 (- pie (* 1 ee))) +:one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) +:one-truncate-result (list 3 (- pie 3)) +:two-truncate-result (list 1 (- pie (* 1 ee))) +:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ftruncate-result (list (coerce 1 pie-type) + (- pie (* 1.0 ee)))) + (Assert-rounding pie (- ee) +:one-floor-result (list 3 (- pie 3)) +:two-floor-result (list -2 (- pie (* -2 (- ee)))) +:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ffloor-result (list (coerce -2 pie-type) + (- pie (* -2.0 (- ee)))) +:one-ceiling-result (list 4 (- pie 4)) +:two-ceiling-result (list -1 (- pie (* -1 (- ee)))) +:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) +:two-fceiling-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) +:one-round-result (list 3 (- pie 3)) +:two-round-result (list -1 (- pie (* -1 (- ee)))) +:one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) +:one-truncate-result (list 3 (- pie 3)) +:two-truncate-result (list -1 (- pie (* -1 (- ee)))) +:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ftruncate-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee))))) + (Assert-rounding (- pie) ee +:one-floor-result (list -4 (- (- pie) -4)) +:two-floor-result (list -2 (- (- pie) (* -2 ee))) +:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) +:two-ffloor-result (list (coerce -2 pie-type) + (- (- pie) (* -2.0 ee))) +:one-ceiling-result (list -3 (- (- pie) -3)) +:two-ceiling-result (list -1 (- (- pie) (* -1 ee))) +:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fceiling-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) +:one-round-result (list -3 (- (- pie) -3)) +:two-round-result (list -1 (- (- pie) (* -1 ee))) +:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) +:one-truncate-result (list -3 (- (- pie) -3)) +:two-truncate-result (list -1 (- (- pie) (* -1 ee))) +:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-ftruncate-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee)))) + (Assert-rounding (- pie) (- ee) +:one-floor-result (list -4 (- (- pie) -4)) +:two-floor-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) +:two-ffloor-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) +:one-ceiling-result (list -3 (- (- pie) -3)) +:two-ceiling-result (list 2 (- (- pie) (* 2 (- ee)))) +:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fceiling-result (list (coerce 2 pie-type) + (- (- pie) (* 2.0 (- ee)))) +:one-round-result (list -3 (- (- pie) -3)) +:two-round-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fround-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) +:one-truncate-result (list -3 (- (- pie) -3)) +:two-truncate-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-ftruncate-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee))))) + (Assert-rounding ee pie +:one-floor-result (list 2 (- ee 2)) +:two-floor-result (list 0 ee) +:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ffloor-result (list (coerce 0 pie-type) ee) +:one-ceiling-result (list 3 (- ee 3)) +:two-ceiling-result (list 1 (- ee pie)) +:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fceiling-result (list (coerce 1 pie-type) (- ee pie)) +:one-round-result (list 3 (- ee 3)) +:two-round-result (list 1 (- ee (* 1 pie))) +:one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie))) +:one-truncate-result (list 2 (- ee 2)) +:two-truncate-result (list 0 ee) +:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ftruncate-result (list (coerce 0 pie-type) ee)) + (Assert-rounding ee (- pie) +:one-floor-result (list 2 (- ee 2)) +:two-floor-result (list -1 (- ee (* -1 (- pie)))) +:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ffloor-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) +:one-ceiling-result (list 3 (- ee 3)) +:two-ceiling-result (list 0 ee) +:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fceiling-result (list (coerce 0 pie-type) ee) +:one-round-result (list 3 (- ee 3)) +:two-round-result (list -1 (- ee (* -1 (- pie)))) +:one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) +:one-truncate-result (list 2 (- ee 2)) +:two-truncate-result (list 0 ee) +:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ftruncate-result (list (coerce 0 pie-type) ee))))) + ;; First, two integers: + (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3) +:one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3) +:one-ceiling-result '(27 0) :two-ceiling-result '(4 -5) +:one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5) +:one-round-result '(27 0) :two-round-result '(3 3) +:one-fround-result '(27.0 0) :two-fround-result '(3.0 3) +:one-truncate-result '(27 0) :two-truncate-result '(3 3) +:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3)) + (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5) +:one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5) +:one-ceiling-result '(27 0) :two-ceiling-result '(-3 3) +:one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3) +:one-round-result '(27 0) :two-round-result '(-3 3) +:one-fround-result '(27.0 0) :two-fround-result '(-3.0 3) +:one-truncate-result '(27 0) :two-truncate-result '(-3 3) +:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3)) + (Assert-rounding -27 8 +:one-floor-result '(-27 0) :two-floor-result '(-4 5) +:one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5) +:one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3) +:one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3) +:one-round-result '(-27 0) :two-round-result '(-3 -3) +:one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3) +:one-truncate-result '(-27 0) :two-truncate-result '(-3 -3) +:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3)) + (Assert-rounding -27 -8 +:one-floor-result '(-27 0) :two-floor-result '(3 -3) +:one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3) +:one-ceiling-result '(-27 0) :two-ceiling-result '(4 5) +:one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5) +:one-round-result '(-27 0) :two-round-result '(3 -3) +:one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3) +:one-truncate-result '(-27 0) :two-truncate-result '(3 -3) +:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3)) + (Assert-rounding 8 27 +:one-floor-result '(8 0) :two-floor-result '(0 8) +:one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8) +:one-ceiling-result '(8 0) :two-ceiling-result '(1 -19) +:one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19) +:one-round-result '(8 0) :two-round-result '(0 8) +:one-fround-result '(8.0 0) :two-fround-result '(0.0 8) +:one-truncate-result '(8 0) :two-truncate-result '(0 8) +:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding 8 -27 +:one-floor-result '(8 0) :two-floor-result '(-1 -19) +:one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19) +:one-ceiling-result '(8 0) :two-ceiling-result '(0 8) +:one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8) +:one-round-result '(8 0) :two-round-result '(0 8) +:one-fround-result '(8.0 0) :two-fround-result '(0.0 8) +:one-truncate-result '(8 0) :two-truncate-result '(0 8) +:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding -8 27 +:one-floor-result '(-8 0) :two-floor-result '(-1 19) +:one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19) +:one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8) +:one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8) +:one-round-result '(-8 0) :two-round-result '(0 -8) +:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) +:one-truncate-result '(-8 0) :two-truncate-result '(0 -8) +:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding -8 -27 +:one-floor-result '(-8 0) :two-floor-result '(0 -8) +:one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8) +:one-ceiling-result '(-8 0) :two-ceiling-result '(1 19) +:one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19) +:one-round-result '(-8 0) :two-round-result '(0 -8) +:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) +:one-truncate-result '(-8 0) :two-truncate-result '(0 -8) +:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding 32 4 +:one-floor-result '(32 0) :two-floor-result '(8 0) +:one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0) +:one-ceiling-result '(32 0) :two-ceiling-result '(8 0) +:one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0) +:one-round-result '(32 0) :two-round-result '(8 0) +:one-fround-result '(32.0 0) :two-fround-result '(8.0 0) +:one-truncate-result '(32 0) :two-truncate-result '(8 0) +:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0)) + (Assert-rounding 32 -4 +:one-floor-result '(32 0) :two-floor-result '(-8 0) +:one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0) +:one-ceiling-result '(32 0) :two-ceiling-result '(-8 0) +:one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0) +:one-round-result '(32 0) :two-round-result '(-8 0) +:one-fround-result '(32.0 0) :two-fround-result '(-8.0 0) +:one-truncate-result '(32 0) :two-truncate-result '(-8 0) +:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0)) + (Assert-rounding 12 9 +:one-floor-result '(12 0) :two-floor-result '(1 3) +:one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3) +:one-ceiling-result '(12 0) :two-ceiling-result '(2 -6) +:one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6) +:one-round-result '(12 0) :two-round-result '(1 3) +:one-fround-result '(12.0 0) :two-fround-result '(1.0 3) +:one-truncate-result '(12 0) :two-truncate-result '(1 3) +:one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3)) + (Assert-rounding 10 4 +:one-floor-result '(10 0) :two-floor-result '(2 2) +:one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2) +:one-ceiling-result '(10 0) :two-ceiling-result '(3 -2) +:one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2) +:one-round-result '(10 0) :two-round-result '(2 2) +:one-fround-result '(10.0 0) :two-fround-result '(2.0 2) +:one-truncate-result '(10 0) :two-truncate-result '(2 2) +:one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2)) + (Assert-rounding 14 4 +:one-floor-result '(14 0) :two-floor-result '(3 2) +:one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2) +:one-ceiling-result '(14 0) :two-ceiling-result '(4 -2) +:one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2) +:one-round-result '(14 0) :two-round-result '(4 -2) +:one-fround-result '(14.0 0) :two-fround-result '(4.0 -2) +:one-truncate-result '(14 0) :two-truncate-result '(3 2) +:one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2)) + ;; Now, two floats: + (Assert-rounding-floating pi e) + (when (featurep 'bigfloat) + (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat))) + (when (featurep 'bignum) + (assert (not (evenp most-positive-fixnum)) t + "In the unlikely event that most-positive-fixnum is even, rewrite this.") + (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum) +:one-floor-result `(,(1+ most-positive-fixnum) 0) +:two-floor-result `(0 ,(1+ most-positive-fixnum)) +:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ffloor-result `(0.0 ,(1+ most-positive-fixnum)) +:one-ceiling-result `(,(1+ most-positive-fixnum) 0) +:two-ceiling-result `(1 ,(1+ (- most-positive-fixnum))) +:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum))) +:one-round-result `(,(1+ most-positive-fixnum) 0) +:two-round-result `(1 ,(1+ (- most-positive-fixnum))) +:one-fround-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fround-result `(1.0 ,(1+ (- most-positive-fixnum))) +:one-truncate-result `(,(1+ most-positive-fixnum) 0) +:two-truncate-result `(0 ,(1+ most-positive-fixnum)) +:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum)) +:one-floor-result `(,(1+ most-positive-fixnum) 0) +:two-floor-result `(-1 ,(1+ (- most-positive-fixnum))) +:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum))) +:one-ceiling-result `(,(1+ most-positive-fixnum) 0) +:two-ceiling-result `(0 ,(1+ most-positive-fixnum)) +:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fceiling-result `(0.0 ,(1+ most-positive-fixnum)) +:one-round-result `(,(1+ most-positive-fixnum) 0) +:two-round-result `(-1 ,(1+ (- most-positive-fixnum))) +:one-fround-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum))) +:one-truncate-result `(,(1+ most-positive-fixnum) 0) +:two-truncate-result `(0 ,(1+ most-positive-fixnum)) +:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum) +:one-floor-result `(,(- (1+ most-positive-fixnum)) 0) +:two-floor-result `(-1 ,(1- most-positive-fixnum)) +:one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-ffloor-result `(-1.0 ,(1- most-positive-fixnum)) +:one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0) +:two-ceiling-result `(0 ,(- (1+ most-positive-fixnum))) +:one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum))) +:one-round-result `(,(- (1+ most-positive-fixnum)) 0) +:two-round-result `(-1 ,(1- most-positive-fixnum)) +:one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-fround-result `(-1.0 ,(1- most-positive-fixnum)) +:one-truncate-result `(,(- (1+ most-positive-fixnum)) 0) +:two-truncate-result `(0 ,(- (1+ most-positive-fixnum))) +:one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum)))) + ;; Test the handling of values with .5: + (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2 +:one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-floor-result `(,most-positive-fixnum 1) +:one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; We can't just call #'float here; we must use code that converts a + ;; bignum with value most-positive-fixnum (the creation of which is + ;; not directly possible in Lisp) to a float, not code that converts + ;; the fixnum with value most-positive-fixnum to a float. The eval is + ;; to avoid compile-time optimisation that can break this. +:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1) +:one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-ceiling-result `(,(1+ most-positive-fixnum) -1) +:one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) +:two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1) +:one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-round-result `(,(1+ most-positive-fixnum) -1) +:one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) +:two-fround-result `(,(float (1+ most-positive-fixnum)) -1) +:one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-truncate-result `(,most-positive-fixnum 1) +:one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; See the comment above on :two-ffloor-result: +:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)) + (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2 +:one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-floor-result `(,(1- most-positive-fixnum) 1) +:one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above on float conversions. +:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) +:one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-ceiling-result `(,most-positive-fixnum -1) +:one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) +:two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1) +:one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-round-result `(,(1- most-positive-fixnum) 1) +:one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) +:two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) +:one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-truncate-result `(,(1- most-positive-fixnum) 1) +:one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above +:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) + 1))) + (when (featurep 'ratio) + (Assert-rounding (read "4/3") (read "8/7") +:one-floor-result '(1 1/3) :two-floor-result '(1 4/21) +:one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21) +:one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21) +:one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21) +:one-round-result '(1 1/3) :two-round-result '(1 4/21) +:one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21) +:one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21) +:one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21)) + (Assert-rounding (read "-4/3") (read "8/7") +:one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21) +:one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21) +:one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21) +:one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21) +:one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21) +:one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21) +:one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21) +:one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21)))) +;; Run this function in a Common Lisp with two arguments to get results that +;; we should compare against, above. Though note the dancing-around with the +;; bigfloats and bignums above, too; you can't necessarily just use the +;; output here. + +(defun generate-rounding-output (first second) + (let ((print-readably t)) + (princ first) + (princ " ") + (princ second) + (princ " :one-floor-result ") + (princ (list 'quote (multiple-value-list (floor first)))) + (princ " :two-floor-result ") + (princ (list 'quote (multiple-value-list (floor first second)))) + (princ " :one-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first)))) + (princ " :two-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first second)))) + (princ " :one-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first)))) + (princ " :two-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first second)))) + (princ " :one-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first)))) + (princ " :two-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first second)))) + (princ " :one-round-result ") + (princ (list 'quote (multiple-value-list (round first)))) + (princ " :two-round-result ") + (princ (list 'quote (multiple-value-list (round first second)))) + (princ " :one-fround-result ") + (princ (list 'quote (multiple-value-list (fround first)))) + (princ " :two-fround-result ") + (princ (list 'quote (multiple-value-list (fround first second)))) + (princ " :one-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first)))) + (princ " :two-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first second)))) + (princ " :one-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first)))) + (princ " :two-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first second)))))) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches