Correct floating point on old MSVC

Visual Studio 6 and earlier have somewhat insane handling of comparisons
with nan values. Provide alternate (slower) versions of float comparison
functions using isnan rather than standardized comparison behaviour.

3 files changed, 62 insertions, 16 deletions

diff --git a/byterun/compare.c b/byterun/compare.c
index 42384a47a6..3822018cdc 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -21,6 +21,10 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 
+#if defined(LACKS_SANE_NAN) && !defined(isnan)
+#define isnan _isnan
+#endif
+
 /* Structural comparison on trees. */
 
 struct compare_item { value * v1, * v2; mlsize_t count; };
@@ -174,8 +178,19 @@ static intnat compare_val(value v1, value v2, int total)
     case Double_tag: {
       double d1 = Double_val(v1);
       double d2 = Double_val(v2);
+#ifdef LACKS_SANE_NAN
+      if (isnan(d2)) {
+        if (! total) return UNORDERED;
+        if (isnan(d1)) break;
+        return GREATER;
+      } else if (isnan(d1)) {
+        if (! total) return UNORDERED;
+        return LESS;
+      }
+#endif
       if (d1 < d2) return LESS;
       if (d1 > d2) return GREATER;
+#ifndef LACKS_SANE_NAN
       if (d1 != d2) {
         if (! total) return UNORDERED;
         /* One or both of d1 and d2 is NaN.  Order according to the
@@ -184,6 +199,7 @@ static intnat compare_val(value v1, value v2, int total)
         if (d2 == d2) return LESS;    /* d2 is not NaN, d1 is NaN */
         /* d1 and d2 are both NaN, thus equal: continue comparison */
       }
+#endif
       break;
     }
     case Double_array_tag: {
@@ -194,14 +210,26 @@ static intnat compare_val(value v1, value v2, int total)
       for (i = 0; i < sz1; i++) {
         double d1 = Double_field(v1, i);
         double d2 = Double_field(v2, i);
+#ifdef LACKS_SANE_NAN
+        if (isnan(d2)) {
+          if (! total) return UNORDERED;
+          if (isnan(d1)) break;
+          return GREATER;
+        } else if (isnan(d1)) {
+          if (! total) return UNORDERED;
+          return LESS;
+        }
+#endif
         if (d1 < d2) return LESS;
         if (d1 > d2) return GREATER;
+#ifndef LACKS_SANE_NAN
         if (d1 != d2) {
           if (! total) return UNORDERED;
           /* See comment for Double_tag case */
           if (d1 == d1) return GREATER;
           if (d2 == d2) return LESS;
         }
+#endif
       }
       break;
     }
diff --git a/byterun/floats.c b/byterun/floats.c
index 41204da28d..a36df89a72 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -555,34 +555,41 @@ CAMLprim value caml_copysign_float(value f, value g)
   return caml_copy_double(caml_copysign(Double_val(f), Double_val(g)));
 }
 
-CAMLprim value caml_eq_float(value f, value g)
-{
-  return Val_bool(Double_val(f) == Double_val(g));
-}
+#ifdef LACKS_SANE_NAN
 
-CAMLprim value caml_neq_float(value f, value g)
+CAMLprim value caml_neq_float(value vf, value vg)
 {
-  return Val_bool(Double_val(f) != Double_val(g));
+  double f = Double_val(vf);
+  double g = Double_val(vg);
+  return Val_bool(isnan(f) || isnan(g) || f != g);
 }
 
-CAMLprim value caml_le_float(value f, value g)
-{
-  return Val_bool(Double_val(f) <= Double_val(g));
+#define DEFINE_NAN_CMP(op) (value vf, value vg) \
+{ \
+  double f = Double_val(vf); \
+  double g = Double_val(vg); \
+  return Val_bool(!isnan(f) && !isnan(g) && f op g); \
 }
 
-CAMLprim value caml_lt_float(value f, value g)
+intnat caml_float_compare_unboxed(double f, double g)
 {
-  return Val_bool(Double_val(f) < Double_val(g));
+  /* Insane => nan == everything && nan < everything && nan > everything */
+  if (isnan(f) && isnan(g)) return 0;
+  if (!isnan(g) && f < g) return -1;
+  if (f != g) return 1;
+  return 0;
 }
 
-CAMLprim value caml_ge_float(value f, value g)
+#else
+
+CAMLprim value caml_neq_float(value f, value g)
 {
-  return Val_bool(Double_val(f) >= Double_val(g));
+  return Val_bool(Double_val(f) != Double_val(g));
 }
 
-CAMLprim value caml_gt_float(value f, value g)
-{
-  return Val_bool(Double_val(f) > Double_val(g));
+#define DEFINE_NAN_CMP(op) (value f, value g) \
+{ \
+  return Val_bool(Double_val(f) op Double_val(g)); \
 }
 
 intnat caml_float_compare_unboxed(double f, double g)
@@ -594,6 +601,14 @@ intnat caml_float_compare_unboxed(double f, double g)
   return (f > g) - (f < g) + (f == f) - (g == g);
 }
 
+#endif
+
+CAMLprim value caml_eq_float DEFINE_NAN_CMP(==)
+CAMLprim value caml_le_float DEFINE_NAN_CMP(<=)
+CAMLprim value caml_lt_float DEFINE_NAN_CMP(<)
+CAMLprim value caml_ge_float DEFINE_NAN_CMP(>=)
+CAMLprim value caml_gt_float DEFINE_NAN_CMP(>)
+
 CAMLprim value caml_float_compare(value vf, value vg)
 {
   return Val_int(caml_float_compare_unboxed(Double_val(vf),Double_val(vg)));
diff --git a/config/s-nt.h b/config/s-nt.h
index 79a716f279..1f4d14cdae 100644
--- a/config/s-nt.h
+++ b/config/s-nt.h
@@ -34,3 +34,6 @@
 #define HAS_IPV6
 #define HAS_NICE
 #define SUPPORT_DYNAMIC_LINKING
+#if defined(_MSC_VER) && _MSC_VER < 1300
+#define LACKS_SANE_NAN
+#endif