Fix various problems with flonum infinities.

diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c
index 57de7c5279f41881ef966522f0ab834ec04ac6f8..9c5b450f6791200e6b5e04bb07cc6747e510e344 100644 (file)
--- a/src/microcode/artutl.c
+++ b/src/microcode/artutl.c
@@ -158,6 +158,27 @@ bignum_to_flonum (SCHEME_OBJECT bignum)
      : SHARP_F);
 }
 \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 122f09d337ab987d3b526ab63fd4d84c638a4a18..6041adbff4cefa32485051b27bb096a982c07688 100644 (file)
--- 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 476dd469d41764a1f0784df09f6ed4338205fbd8..a0299ea78e6bc5bd661217e2fce205aa2314a63a 100644 (file)
--- 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 c83dba224f8c298f6dc01c1fb95a293188b130e3..7b89720f1fb79fd74bff976b1fceed9c182ed686 100644 (file)
--- 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 f2e691efa47acd11d3283d1a461782fbd5f4c5a5..3e2bffa6fef846f7476ac0f05aa930886ac33317 100644 (file)
--- 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