Mercurial > hg > xemacs-beta
changeset 5911:48386fd60fd0
GMP functions that take doubles choke on non-finite values, avoid that.
src/ChangeLog addition:
2015-05-10 Aidan Kehoe <kehoea@parhasard.net>
* floatfns.c (double_to_integer):
Rename this from float_to_int to fit our newer, bignum-compatible
terminology.
GMP can signal SIGFPE when asked to turn NaN or infinity into a
bignum, and we're not prepared to handle that signal if the OS float
library routines don't do that, so check for those values
explicitly.
* floatfns.c (ceiling_two_float):
* floatfns.c (ceiling_one_float):
* floatfns.c (floor_two_float):
* floatfns.c (floor_one_float):
* floatfns.c (round_two_float):
* floatfns.c (round_one_float):
* floatfns.c (truncate_two_float):
* floatfns.c (truncate_one_float):
Call double_to_integer() with its new name.
* number.c:
Don't use the {bignum,ratio,bigfloat}_set_double functions
directly here, with GMP they can choke when handed non-finite C
doubles, call Ftruncate() and the new float_to_bigfloat() from
floatfns.c. Maybe we should extend number-gmp.c with GMP-specific
implementations that check for non-finite values.
tests/ChangeLog addition:
2015-05-10 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Backslash a few parentheses in the first column for the sake of
fontification.
* automated/lisp-tests.el:
Check that the rounding functions signal Lisp errors correctly
when handed positive and negative infinity and NaN.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 10 May 2015 19:07:09 +0100 |
parents | eb1e15c9440b |
children | 47ffa085a9ad |
files | src/ChangeLog src/floatfns.c src/number.c tests/ChangeLog tests/automated/lisp-tests.el |
diffstat | 5 files changed, 166 insertions(+), 52 deletions(-) [+] |
line wrap: on
line diff
--- a/src/ChangeLog Sat May 09 10:50:32 2015 +0100 +++ b/src/ChangeLog Sun May 10 19:07:09 2015 +0100 @@ -1,3 +1,30 @@ +2015-05-10 Aidan Kehoe <kehoea@parhasard.net> + + * floatfns.c (double_to_integer): + Rename this from float_to_int to fit our newer, bignum-compatible + terminology. + GMP can signal SIGFPE when asked to turn NaN or infinity into a + bignum, and we're not prepared to handle that signal if the OS float + library routines don't do that, so check for those values + explicitly. + + * floatfns.c (ceiling_two_float): + * floatfns.c (ceiling_one_float): + * floatfns.c (floor_two_float): + * floatfns.c (floor_one_float): + * floatfns.c (round_two_float): + * floatfns.c (round_one_float): + * floatfns.c (truncate_two_float): + * floatfns.c (truncate_one_float): + Call double_to_integer() with its new name. + + * number.c: + Don't use the {bignum,ratio,bigfloat}_set_double functions + directly here, with GMP they can choke when handed non-finite C + doubles, call Ftruncate() and the new float_to_bigfloat() from + floatfns.c. Maybe we should extend number-gmp.c with GMP-specific + implementations that check for non-finite values. + 2015-05-09 Aidan Kehoe <kehoea@parhasard.net> * data.c (Flogand):
--- a/src/floatfns.c Sat May 09 10:50:32 2015 +0100 +++ b/src/floatfns.c Sun May 10 19:07:09 2015 +0100 @@ -112,38 +112,6 @@ #define domain_error2(op,a1,a2) \ Fsignal (Qdomain_error, list3 (build_msg_string (op), a1, a2)) - -/* Convert float to Lisp Integer if it fits, else signal a range - error using the given arguments. If bignums are available, range errors - are never signaled. */ -static Lisp_Object -float_to_int (double x, -#ifdef HAVE_BIGNUM - const char *UNUSED (name), Lisp_Object UNUSED (num), - Lisp_Object UNUSED (num2) -#else - const char *name, Lisp_Object num, Lisp_Object num2 -#endif - ) -{ -#ifdef HAVE_BIGNUM - bignum_set_double (scratch_bignum, x); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); -#else - REGISTER EMACS_INT result = (EMACS_INT) x; - - if (result > MOST_POSITIVE_FIXNUM || result < MOST_NEGATIVE_FIXNUM) - { - if (!UNBOUNDP (num2)) - range_error2 (name, num, num2); - else - range_error (name, num); - } - return make_fixnum (result); -#endif /* HAVE_BIGNUM */ -} - - static void in_float_error (void) { @@ -165,7 +133,65 @@ break; } } + +/* Convert X to a Lisp integer, using bignums if available. If X does not + fit--if it is not finite, or, on a build without bignum support, if it is + outside the range (<= most-negative-fixnum X most-positive-fixnum)--signal + a range error. */ +static Lisp_Object +double_to_integer (double x, const Ascbyte *operation, Lisp_Object num, + Lisp_Object num2) +{ +#ifdef HAVE_BIGNUM + if (isnan (x) || isinf (x)) + { + if (UNBOUNDP (num2)) + { + range_error (operation, num); + } + else + { + range_error2 (operation, num, num2); + } + } + bignum_set_double (scratch_bignum, x); + return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + REGISTER EMACS_INT result = (EMACS_INT) x; + + if (result > MOST_POSITIVE_FIXNUM || result < MOST_NEGATIVE_FIXNUM) + { + if (!UNBOUNDP (num2)) + range_error2 (operation, num, num2); + else + range_error (operation, num); + } + return make_fixnum (result); +#endif /* HAVE_BIGNUM */ +} + +#ifdef HAVE_BIGFLOAT +Lisp_Object float_to_bigfloat (const Ascbyte *operation, Lisp_Object num, + unsigned long precision); + +Lisp_Object +float_to_bigfloat (const Ascbyte *operation, Lisp_Object num, + unsigned long precision) +{ + double d = extract_float (num); + + if (isnan (d) || isinf (d)) + { + range_error (operation, num); + } + + bigfloat_set_prec (scratch_bigfloat, precision); + bigfloat_set_double (scratch_bigfloat, d); + + return make_bigfloat_bf (scratch_bigfloat); +} +#endif static Lisp_Object mark_float (Lisp_Object UNUSED (obj)) @@ -1252,7 +1278,7 @@ } else { - res0 = float_to_int (f0, MAYBE_EFF("ceiling"), number, divisor); + res0 = double_to_integer (f0, "ceiling", number, divisor); } return values2 (res0, make_float (remain)); @@ -1273,7 +1299,7 @@ } else { - res0 = float_to_int (d, MAYBE_EFF("ceiling"), number, Qunbound); + res0 = double_to_integer (d, "ceiling", number, Qunbound); } return values2 (res0, make_float (remain)); } @@ -1535,7 +1561,7 @@ return values2 (make_float (f0), make_float (remain)); } - return values2 (float_to_int (f0, MAYBE_EFF ("floor"), number, divisor), + return values2 (double_to_integer (f0, "floor", number, divisor), make_float (remain)); } @@ -1553,7 +1579,7 @@ } else { - return values2 (float_to_int (d, MAYBE_EFF ("floor"), number, Qunbound), + return values2 (double_to_integer (d, "floor", number, Qunbound), make_float (d1)); } } @@ -1939,7 +1965,7 @@ } else { - return values2 (float_to_int (f0, MAYBE_EFF("round"), number, divisor), + return values2 (double_to_integer (f0, "round", number, divisor), make_float (remain)); } } @@ -1958,8 +1984,7 @@ } else { - return values2 ((float_to_int (d, MAYBE_EFF ("round"), number, - Qunbound)), + return values2 ((double_to_integer (d, "round", number, Qunbound)), make_float (XFLOAT_DATA (number) - d)); } } @@ -2216,7 +2241,8 @@ if (f2 == 0.0) return arith_error2 ("truncate", number, divisor); - res0 = float_to_int (f1 / f2, MAYBE_EFF ("truncate"), number, Qunbound); + res0 = double_to_integer (f1 / f2, MAYBE_EFF ("truncate"), number, + Qunbound); f0 = extract_float (res0); IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("truncate"), number, divisor); @@ -2233,8 +2259,8 @@ truncate_one_float (Lisp_Object number, int return_float) { Lisp_Object res0 - = float_to_int (XFLOAT_DATA (number), MAYBE_EFF ("truncate"), - number, Qunbound); + = double_to_integer (XFLOAT_DATA (number), MAYBE_EFF ("truncate"), + number, Qunbound); if (return_float) { res0 = make_float ((double)XFIXNUM(res0));
--- a/src/number.c Sat May 09 10:50:32 2015 +0100 +++ b/src/number.c Sun May 10 19:07:09 2015 +0100 @@ -309,6 +309,9 @@ bigfloat_equal, bigfloat_hash, bigfloat_description, Lisp_Bigfloat); +extern Lisp_Object float_to_bigfloat (const Ascbyte *, Lisp_Object, + unsigned long); + #endif /* HAVE_BIGFLOAT */ Lisp_Object Qbigfloatp; @@ -601,15 +604,26 @@ return Ftruncate (number, Qnil); case BIGNUM_T: #ifdef HAVE_BIGNUM - bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); - return make_bignum_bg (scratch_bignum); + { + Lisp_Object truncate = Ftruncate (number, Qnil); + return FIXNUMP (truncate) ? + make_bignum (XREALFIXNUM (truncate)) : truncate; + } #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); + { + Lisp_Object truncate = Ftruncate (number, Qnil); + if (FIXNUMP (truncate)) + { + return make_ratio (XREALFIXNUM (truncate), 1UL); + } + + bignum_set_long (scratch_bignum, 1L); + return make_ratio_bg (XBIGNUM_DATA (truncate), scratch_bignum); + } #else ABORT (); #endif /* HAVE_RATIO */ @@ -617,9 +631,7 @@ 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); + return float_to_bigfloat ("coerce-number", number, precision); #else ABORT (); #endif /* HAVE_BIGFLOAT */
--- a/tests/ChangeLog Sat May 09 10:50:32 2015 +0100 +++ b/tests/ChangeLog Sun May 10 19:07:09 2015 +0100 @@ -1,3 +1,12 @@ +2015-05-10 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Backslash a few parentheses in the first column for the sake of + fontification. + * automated/lisp-tests.el: + Check that the rounding functions signal Lisp errors correctly + when handed positive and negative infinity and NaN. + 2015-05-08 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-reader-tests.el:
--- a/tests/automated/lisp-tests.el Sat May 09 10:50:32 2015 +0100 +++ b/tests/automated/lisp-tests.el Sun May 10 19:07:09 2015 +0100 @@ -1511,10 +1511,10 @@ "\ ;; Lisp should not be able to modify #$, which is ;; Vload_file_name_internal of lread.c. -(Check-Error setting-constant (aset #$ 0 ?\\ )) +\(Check-Error setting-constant (aset #$ 0 ?\\ )) ;; But modifying load-file-name should work: -(let ((new-char ?\\ ) +\(let ((new-char ?\\ ) old-char) (setq old-char (aref load-file-name 0)) (if (= new-char old-char) @@ -1523,7 +1523,7 @@ (Assert (= new-char (aref load-file-name 0)) \"Check that we can modify the string value of load-file-name\")) -(let* ((new-load-file-name \"hi there\") +\(let* ((new-load-file-name \"hi there\") (load-file-name new-load-file-name)) (Assert (eq new-load-file-name load-file-name) \"Checking that we can bind load-file-name successfully.\")) @@ -1535,6 +1535,46 @@ (load test-file-name nil t nil) (delete-file test-file-name)) +;; These used to crash with bignum support thanks to GMP: +(symbol-macrolet + ((positive-infinity + (expt (+ most-positive-fixnum 0.0) most-positive-fixnum)) + (negative-infinity + (expt (+ most-negative-fixnum 0.0) most-positive-fixnum)) + (not-a-number (expt -1 0.5))) + (Check-Error range-error (ceiling positive-infinity)) + (Check-Error range-error (ceiling negative-infinity)) + (Check-Error range-error (ceiling positive-infinity 1)) + (Check-Error range-error (ceiling negative-infinity 1)) + (Check-Error range-error (floor positive-infinity)) + (Check-Error range-error (floor negative-infinity)) + (Check-Error range-error (floor positive-infinity 1)) + (Check-Error range-error (floor negative-infinity 1)) + (Check-Error range-error (round positive-infinity)) + (Check-Error range-error (round negative-infinity)) + (Check-Error range-error (round positive-infinity 1)) + (Check-Error range-error (round negative-infinity 1)) + (Check-Error range-error (ceiling not-a-number)) + (Check-Error range-error (ceiling not-a-number 1)) + (Check-Error range-error (floor not-a-number)) + (Check-Error range-error (floor not-a-number 1)) + (Check-Error range-error (round not-a-number)) + (Check-Error range-error (round not-a-number 1)) + (Check-Error range-error (coerce positive-infinity 'fixnum)) + (Check-Error range-error (coerce negative-infinity 'fixnum)) + (Check-Error range-error (coerce not-a-number 'fixnum)) + (Check-Error range-error (coerce positive-infinity 'integer)) + (Check-Error range-error (coerce negative-infinity 'integer)) + (Check-Error range-error (coerce not-a-number 'integer)) + (when (ignore-errors (coerce 1 'ratio)) + (Check-Error range-error (coerce positive-infinity 'ratio)) + (Check-Error range-error (coerce negative-infinity 'ratio)) + (Check-Error range-error (coerce not-a-number 'ratio))) + (when (ignore-errors (coerce 1 'bigfloat)) + (Check-Error range-error (coerce positive-infinity 'bigfloat)) + (Check-Error range-error (coerce negative-infinity 'bigfloat)) + (Check-Error range-error (coerce not-a-number 'bigfloat)))) + (labels ((cl-floor (x &optional y) (let ((q (floor x y))) (list q (- x (if y (* y q) q)))))