infnan: add nan_is_signaling

4 files changed, 38 insertions, 0 deletions

diff --git a/embed.fnc b/embed.fnc
index 1be794bbe8..b7a37d1bb1 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -821,6 +821,7 @@ Apd	|UV	|grok_oct	|NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV
 Apdn	|UV	|grok_atou	|NN const char* pv|NULLOK const char** endptr
 Apd	|U8*	|nan_hibyte|NN NV *nvp|NN U8* mask
 Apd	|void	|nan_signaling_set|NN NV *nvp|bool signaling
+Apd	|int	|nan_is_signaling|NV nv
 : These are all indirectly referenced by globals.c. This is somewhat annoying.
 p	|int	|magic_clearenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clear_all_env|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index 330542fec7..332b2ccc45 100644
--- a/embed.h
+++ b/embed.h
@@ -357,6 +357,7 @@
 #define my_strerror(a)		Perl_my_strerror(aTHX_ a)
 #define my_strftime(a,b,c,d,e,f,g,h,i,j)	Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j)
 #define nan_hibyte(a,b)		Perl_nan_hibyte(aTHX_ a,b)
+#define nan_is_signaling(a)	Perl_nan_is_signaling(aTHX_ a)
 #define nan_signaling_set(a,b)	Perl_nan_signaling_set(aTHX_ a,b)
 #define newANONATTRSUB(a,b,c,d)	Perl_newANONATTRSUB(aTHX_ a,b,c,d)
 #define newANONHASH(a)		Perl_newANONHASH(aTHX_ a)
diff --git a/numeric.c b/numeric.c
index c20c85e58d..37a102915e 100644
--- a/numeric.c
+++ b/numeric.c
@@ -629,6 +629,41 @@ Perl_nan_signaling_set(NV *nvp, bool signaling)
 }
 
 /*
+=for apidoc nan_is_signaling
+
+Returns true if the nv is a NaN is a signaling NaN.
+
+=cut
+*/
+int
+Perl_nan_is_signaling(NV nv)
+{
+    /* Quiet NaN bit pattern (64-bit doubles, ignore endianness):
+     * x86    00 00 00 00 00 00 f8 7f
+     * sparc  7f ff ff ff ff ff ff ff
+     * mips   7f f7 ff ff ff ff ff ff
+     * hppa   7f f4 00 00 00 00 00 00
+     * The "7ff" is the exponent.  The most significant bit of the NaN
+     * (note: here, not the most significant bit of the byte) is of
+     * interest: in the x86 style (also in sparc) the bit on means
+     * 'quiet', in the mips style the bit off means 'quiet'. */
+#ifdef Perl_fp_classify_snan
+    return Perl_fp_classify_snan(nv);
+#else
+    if (Perl_isnan(nv)) {
+        U8 mask;
+        U8 *hibyte = Perl_nan_hibyte(&nv, &mask);
+        /* Hoping NV_NAN is a quiet nan - this might be a false hope.
+         * XXX Configure test */
+        const NV nan = NV_NAN;
+        return (*hibyte & mask) != (((U8*)&nan)[hibyte - (U8*)&nv] & mask);
+    } else {
+        return 0;
+    }
+#endif
+}
+
+/*
 =for apidoc grok_infnan
 
 Helper for grok_number(), accepts various ways of spelling "infinity"
diff --git a/proto.h b/proto.h
index 0fdceeaf63..2ea10d858f 100644
--- a/proto.h
+++ b/proto.h
@@ -2844,6 +2844,7 @@ PERL_CALLCONV U8*	Perl_nan_hibyte(pTHX_ NV *nvp, U8* mask)
 #define PERL_ARGS_ASSERT_NAN_HIBYTE	\
 	assert(nvp); assert(mask)
 
+PERL_CALLCONV int	Perl_nan_is_signaling(pTHX_ NV nv);
 PERL_CALLCONV void	Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_NAN_SIGNALING_SET	\