From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 12 Dec 2018 22:33:34 +0000 (+0000)
Subject: Make flonum comparison primitives raise exceptions in ucode.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~35^2~23
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0c68bbe838ff5eb973ed5d04f63ffdc59ba5d59e;p=mit-scheme.git

Make flonum comparison primitives raise exceptions in ucode.
---

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index a4bfbb1d7..b1668ca11 100644
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -131,31 +131,51 @@ DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0)
   }
 }
 
-#define FLONUM_BINARY_PREDICATE(operator)				\
+static void
+invalid_if_unordered (double x, double y)
+{
+  if (isunordered (x, y))
+    {
+#if (defined (HAVE_FERAISEEXCEPT)) && (defined (FE_INVALID))
+      feraiseexcept (FE_INVALID);
+#endif
+    }
+}
+
+#define FLONUM_ORDERED_BINARY_PREDICATE(operator)			\
 {									\
   PRIMITIVE_HEADER (2);							\
-  BOOLEAN_RESULT ((arg_flonum (1)) operator (arg_flonum (2)));		\
+  {									\
+    double x = (arg_flonum (1));					\
+    double y = (arg_flonum (2));					\
+    invalid_if_unordered (x, y);					\
+    BOOLEAN_RESULT (x operator y);					\
+  }									\
 }
 
 DEFINE_PRIMITIVE ("FLONUM-EQUAL?", Prim_flonum_equal_p, 2, 2, 0)
-     FLONUM_BINARY_PREDICATE (==)
+     FLONUM_ORDERED_BINARY_PREDICATE (==)
 DEFINE_PRIMITIVE ("FLONUM-LESS?", Prim_flonum_less_p, 2, 2, 0)
-     FLONUM_BINARY_PREDICATE (<)
+     FLONUM_ORDERED_BINARY_PREDICATE (<)
 DEFINE_PRIMITIVE ("FLONUM-GREATER?", Prim_flonum_greater_p, 2, 2, 0)
-     FLONUM_BINARY_PREDICATE (>)
+     FLONUM_ORDERED_BINARY_PREDICATE (>)
 
-#define FLONUM_UNARY_PREDICATE(operator)				\
+#define FLONUM_ORDERED_UNARY_PREDICATE(operator)			\
 {									\
   PRIMITIVE_HEADER (1);							\
-  BOOLEAN_RESULT ((arg_flonum (1)) operator 0);				\
+  {									\
+    double x = (arg_flonum (1));					\
+    invalid_if_unordered (x, 0);					\
+    BOOLEAN_RESULT (x operator 0);					\
+  }									\
 }
 
 DEFINE_PRIMITIVE ("FLONUM-ZERO?", Prim_flonum_zero_p, 1, 1, 0)
-     FLONUM_UNARY_PREDICATE (==)
+     FLONUM_ORDERED_UNARY_PREDICATE (==)
 DEFINE_PRIMITIVE ("FLONUM-POSITIVE?", Prim_flonum_positive_p, 1, 1, 0)
-     FLONUM_UNARY_PREDICATE (>)
+     FLONUM_ORDERED_UNARY_PREDICATE (>)
 DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0)
-     FLONUM_UNARY_PREDICATE (<)
+     FLONUM_ORDERED_UNARY_PREDICATE (<)
 
 #define SIMPLE_TRANSCENDENTAL_FUNCTION(function)			\
 {									\