From cbc0bbb556f281b219ddbc9a6728afc71fbeaca3 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 12 Mar 2019 06:23:11 -0700
Subject: float: turn out-of-range calculations into exceptions.

On platforms that have the C99 fpclassify, we can use it to
banish infinity and NaN representations. If such a thing
arises, we throw an exception rather than producing an object
that prints as #<bad-float>.

* configure: add detection for fpclassify.

* lib.c (bad_float): New inline function and macro.
(flo): If the argument is other than zero, a normal
value or a subnormal, then throw an exception.  We thereby
refuse to admit such objects into our numeric object
system.
---
 configure | 27 +++++++++++++++++++++++++++
 lib.c     | 28 ++++++++++++++++++++++++----
 2 files changed, 51 insertions(+), 4 deletions(-)

diff --git a/configure b/configure
index b3930704..f5046877 100755
--- a/configure
+++ b/configure
@@ -1432,6 +1432,33 @@ else
   printf "no\n"
 fi
 
+printf "Checking for fpclassify ..."
+
+cat > conftest.c <<!
+#include <math.h>
+
+int main(void)
+{
+  double x = 3.14;
+  switch (fpclassify(x)) {
+  case FP_ZERO:
+  case FP_NORMAL:
+  case FP_SUBNORMAL:
+  case FP_INFINITE:
+  case FP_NAN:
+  default:
+    break;
+  }
+  return 0;
+}
+!
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_FPCLASSIFY 1\n" >> config.h
+else
+  printf "no\n"
+fi
+
 #
 # Valgrind
 #
diff --git a/lib.c b/lib.c
index f23e40df..658a17a6 100644
--- a/lib.c
+++ b/lib.c
@@ -3268,12 +3268,32 @@ cnum c_fixnum(val num, val self)
   }
 }
 
+#if HAVE_FPCLASSIFY
+INLINE int bad_float(double d)
+{
+  switch fpclassify(d) {
+  case FP_ZERO:
+  case FP_NORMAL:
+  case FP_SUBNORMAL:
+    return 0;
+  default:
+    return 1;
+  }
+}
+#else
+#define bad_float(d) (0)
+#endif
+
 val flo(double n)
 {
-  val obj = make_obj();
-  obj->fl.type = FLNUM;
-  obj->fl.n = n;
-  return obj;
+  if (bad_float(n)) {
+    uw_throw(numeric_error_s, lit("out-of-range floating-point result"));
+  } else {
+    val obj = make_obj();
+    obj->fl.type = FLNUM;
+    obj->fl.n = n;
+    return obj;
+  }
 }
 
 double c_flo(val num, val self)
-- 
cgit v1.2.3