From c5a2878f97177d2fd41c730ce3a58c778116fee8 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 24 Aug 2009 20:17:23 -0700
Subject: [PATCH] Fix various problems with flonum infinities.

---
 src/microcode/artutl.c | 21 +++++++++++++++++++++
 src/microcode/bigprm.c |  2 +-
 src/microcode/extern.h |  3 +++
 src/microcode/flonum.c | 20 +++++++++++++-------
 src/microcode/utils.c  |  7 ++++++-
 5 files changed, 44 insertions(+), 9 deletions(-)

diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c
index 57de7c527..9c5b450f6 100644
--- a/src/microcode/artutl.c
+++ b/src/microcode/artutl.c
@@ -158,6 +158,27 @@ bignum_to_flonum (SCHEME_OBJECT bignum)
      : SHARP_F);
 }
 
+bool
+finite_flonum_p (SCHEME_OBJECT x)
+{
+  return ((FLONUM_P (x)) && (flonum_is_finite_p (x)));
+}
+
+bool
+flonum_is_finite_p (SCHEME_OBJECT x)
+{
+  return double_is_finite_p (FLONUM_TO_DOUBLE (x));
+}
+
+bool
+double_is_finite_p (double x)
+{
+  return
+    (((x > 1.0) || (x < -1.0))
+     ? (x != (x / 2.0))
+     : ((x <= 1.0) && (x >= -1.0)));
+}
+
 bool
 flonum_integer_p (SCHEME_OBJECT x)
 {
diff --git a/src/microcode/bigprm.c b/src/microcode/bigprm.c
index 122f09d33..6041adbff 100644
--- a/src/microcode/bigprm.c
+++ b/src/microcode/bigprm.c
@@ -146,7 +146,7 @@ DEFINE_PRIMITIVE ("BIGNUM->FIXNUM", Prim_bignum_to_fixnum, 1, 1, 0)
 DEFINE_PRIMITIVE ("FLONUM->BIGNUM", Prim_flonum_to_bignum, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
-  CHECK_ARG (1, FLONUM_P);
+  CHECK_ARG (1, finite_flonum_p);
   PRIMITIVE_RETURN (FLONUM_TO_BIGNUM (ARG_REF (1)));
 }
 
diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index 476dd469d..a0299ea78 100644
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -208,6 +208,8 @@ extern double double_round (double);
 extern SCHEME_OBJECT bignum_to_fixnum (SCHEME_OBJECT);
 extern SCHEME_OBJECT bignum_to_integer (SCHEME_OBJECT);
 extern SCHEME_OBJECT bignum_to_flonum (SCHEME_OBJECT);
+extern bool finite_flonum_p (SCHEME_OBJECT);
+extern bool flonum_is_finite_p (SCHEME_OBJECT);
 extern bool flonum_integer_p (SCHEME_OBJECT);
 extern SCHEME_OBJECT flonum_floor (SCHEME_OBJECT);
 extern SCHEME_OBJECT flonum_ceiling (SCHEME_OBJECT);
@@ -232,6 +234,7 @@ extern SCHEME_OBJECT integer_remainder (SCHEME_OBJECT, SCHEME_OBJECT);
 extern SCHEME_OBJECT integer_length_in_bits (SCHEME_OBJECT);
 extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long);
 
+extern bool double_is_finite_p (double);
 extern SCHEME_OBJECT double_to_flonum (double);
 extern bool real_number_to_double_p (SCHEME_OBJECT);
 extern double real_number_to_double (SCHEME_OBJECT);
diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index c83dba224..7b89720f1 100644
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -33,7 +33,7 @@ double
 arg_flonum (int arg_number)
 {
   SCHEME_OBJECT argument = (ARG_REF (arg_number));
-  if (! (FLONUM_P (argument)))
+  if (!FLONUM_P (argument))
     error_wrong_type_arg (arg_number);
   return (FLONUM_TO_DOUBLE (argument));
 }
@@ -194,14 +194,20 @@ DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   CHECK_ARG (1, FLONUM_P);
-  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1))));
+  PRIMITIVE_RETURN
+    ((flonum_is_finite_p (ARG_REF (1)))
+     ? (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1))))
+     : false);
 }
 
 #define FLONUM_CONVERSION(converter)					\
 {									\
   PRIMITIVE_HEADER (1);							\
   CHECK_ARG (1, FLONUM_P);						\
-  PRIMITIVE_RETURN (converter (ARG_REF (1)));				\
+  PRIMITIVE_RETURN							\
+    ((flonum_is_finite_p (ARG_REF (1)))					\
+     ? (converter (ARG_REF (1)))					\
+     : (ARG_REF (1)));							\
 }
 
 DEFINE_PRIMITIVE ("FLONUM-FLOOR", Prim_flonum_floor, 1, 1, 0)
@@ -216,14 +222,14 @@ DEFINE_PRIMITIVE ("FLONUM-ROUND", Prim_flonum_round, 1, 1, 0)
 DEFINE_PRIMITIVE ("FLONUM-TRUNCATE->EXACT", Prim_flonum_truncate_to_exact, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
-  CHECK_ARG (1, FLONUM_P);
+  CHECK_ARG (1, finite_flonum_p);
   PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1)));
 }
 
 #define FLONUM_EXACT_CONVERSION(converter)				\
 {									\
   PRIMITIVE_HEADER (1);							\
-  CHECK_ARG (1, FLONUM_P);						\
+  CHECK_ARG (1, finite_flonum_p);					\
   PRIMITIVE_RETURN (FLONUM_TO_INTEGER (converter (ARG_REF (1))));	\
 }
 DEFINE_PRIMITIVE ("FLONUM-FLOOR->EXACT", Prim_flonum_floor_to_exact, 1, 1, 0)
@@ -236,14 +242,14 @@ DEFINE_PRIMITIVE ("FLONUM-ROUND->EXACT", Prim_flonum_round_to_exact, 1, 1, 0)
 DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
-  CHECK_ARG (1, FLONUM_P);
+  CHECK_ARG (1, finite_flonum_p);
   PRIMITIVE_RETURN (flonum_normalize (ARG_REF (1)));
 }
 
 DEFINE_PRIMITIVE ("FLONUM-DENORMALIZE", Prim_flonum_denormalize, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
-  CHECK_ARG (1, FLONUM_P);
+  CHECK_ARG (1, finite_flonum_p);
   CHECK_ARG (2, INTEGER_P);
   PRIMITIVE_RETURN (flonum_denormalize ((ARG_REF (1)), (ARG_REF (2))));
 }
diff --git a/src/microcode/utils.c b/src/microcode/utils.c
index f2e691efa..3e2bffa6f 100644
--- a/src/microcode/utils.c
+++ b/src/microcode/utils.c
@@ -440,7 +440,12 @@ arg_ulong_integer_in_range (int arg_number,
 bool
 real_number_to_double_p (SCHEME_OBJECT x)
 {
-  return ((! (BIGNUM_P (x))) || (BIGNUM_TO_DOUBLE_P (x)));
+  return
+    ((BIGNUM_P (x))
+     ? (BIGNUM_TO_DOUBLE_P (x))
+     : (FLONUM_P (x))
+     ? (flonum_is_finite_p (x))
+     : true);
 }
 
 double
-- 
2.25.1