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)))))