From 0c68bbe838ff5eb973ed5d04f63ffdc59ba5d59e Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 12 Dec 2018 22:33:34 +0000
Subject: [PATCH] Make flonum comparison primitives raise exceptions in ucode.

---
 src/microcode/flonum.c | 40 ++++++++++++++++++++++++++++++----------
 1 file changed, 30 insertions(+), 10 deletions(-)

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)			\
 {									\
-- 
2.25.1