infnan: add nan_payload_set

diff --git a/embed.fnc b/embed.fnc
index b7a37d1..83252e5 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -822,6 +822,7 @@ 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
+Apdn   |void   |nan_payload_set|NN NV *nvp|NN const void *bytes|STRLEN byten|bool signaling
 : 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 332b2cc..fd452a7 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -358,6 +358,7 @@
 #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_payload_set                Perl_nan_payload_set
 #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 37a1029..8a9a3a0 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -663,6 +663,89 @@ Perl_nan_is_signaling(NV nv)
 #endif
 }
 
+/* The largest known floating point numbers are the IEEE quadruple
+ * precision of 128 bits. */
+#define MAX_NV_BYTES (128/8)
+
+static const char nan_payload_error[] = "NaN payload error";
+
+/*
+
+=for apidoc nan_payload_set
+
+Set the NaN payload of the nv.
+
+The first byte is the highest order byte of the payload (big-endian).
+
+The signaling flag, if true, turns the generated NaN into a signaling one.
+In most platforms this means turning _off_ the most significant bit of the
+NaN.  Note the _most_ - some platforms have the opposite semantics.
+Do not assume any portability of the NaN semantics.
+
+=cut
+*/
+void
+Perl_nan_payload_set(NV *nvp, const void *bytes, STRLEN byten, bool signaling)
+{
+    /* How many bits we can set in the payload.
+     *
+     * Note that whether the most signicant bit is a quiet or
+     * signaling NaN is actually unstandardized.  Most platforms use
+     * it as the 'quiet' bit.  The known exceptions to this are older
+     * MIPS, and HPPA.
+     *
+     * Yet another unstandardized area is what does the difference
+     * actually mean - if it exists: some platforms do not even have
+     * signaling NaNs.
+     *
+     * C99 nan() is supposed to generate quiet NaNs. */
+    int bits = NV_MANT_REAL_DIG - 1;
+
+    STRLEN i, nvi;
+    bool error = FALSE;
+
+    /* XXX None of this works for doubledouble platforms, or for mixendians. */
+
+    PERL_ARGS_ASSERT_NAN_PAYLOAD_SET;
+
+    *nvp = NV_NAN;
+
+#ifdef NV_BIG_ENDIAN
+    nvi = NVSIZE - 1;
+#endif
+#ifdef NV_LITTLE_ENDIAN
+    nvi = 0;
+#endif
+
+    if (byten > MAX_NV_BYTES) {
+        byten = MAX_NV_BYTES;
+        error = TRUE;
+    }
+    for (i = 0; bits > 0; i++) {
+        U8 b = i < byten ? ((U8*) bytes)[i] : 0;
+        if (bits > 0 && bits < 8) {
+            U8 m = (1 << bits) - 1;
+            ((U8*)nvp)[nvi] &= ~m;
+            ((U8*)nvp)[nvi] |= b & m;
+            bits = 0;
+        } else {
+            ((U8*)nvp)[nvi] = b;
+            bits -= 8;
+        }
+#ifdef NV_BIG_ENDIAN
+        nvi--;
+#endif
+#ifdef NV_LITTLE_ENDIAN
+        nvi++;
+#endif
+    }
+    if (error) {
+        Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                         nan_payload_error);
+    }
+    nan_signaling_set(nvp, signaling);
+}
+
 /*
 =for apidoc grok_infnan
 

diff --git a/proto.h b/proto.h
index 2ea10d8..b7b0887 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2845,6 +2845,12 @@ PERL_CALLCONV U8*        Perl_nan_hibyte(pTHX_ NV *nvp, U8* mask)
        assert(nvp); assert(mask)
 
 PERL_CALLCONV int      Perl_nan_is_signaling(pTHX_ NV nv);
+PERL_CALLCONV void     Perl_nan_payload_set(NV *nvp, const void *bytes, STRLEN byten, bool signaling)
+                       __attribute__nonnull__(1)
+                       __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_NAN_PAYLOAD_SET       \
+       assert(nvp); assert(bytes)
+
 PERL_CALLCONV void     Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_NAN_SIGNALING_SET     \