In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4258cf903c752ec19a3aeee9b93020533d923e1a?hp=1d5f8e8e6ae4cf57194522cabded39fe7371c9da>
- Log ----------------------------------------------------------------- commit 4258cf903c752ec19a3aeee9b93020533d923e1a Author: Jarkko Hietaniemi <[email protected]> Date: Wed Feb 11 08:24:55 2015 -0500 infnan: store the nan payload error in an optional SV M embed.fnc M embed.h M numeric.c M proto.h commit 91e945c051cfcdf499d5b43aa5ac0a5681cdd595 Author: Jarkko Hietaniemi <[email protected]> Date: Wed Feb 11 07:55:55 2015 -0500 infnan: perldata tweaks M pod/perldata.pod ----------------------------------------------------------------------- Summary of changes: embed.fnc | 6 +++--- embed.h | 6 +++--- numeric.c | 38 ++++++++++++++++++-------------------- pod/perldata.pod | 12 ++++++++---- proto.h | 8 ++++---- 5 files changed, 36 insertions(+), 34 deletions(-) diff --git a/embed.fnc b/embed.fnc index fb2c1ac..7ae61a7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -814,8 +814,8 @@ EMsPR |char*|form_short_octal_warning|NN const char * const s \ #endif Apd |UV |grok_hex |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result Apd |int |grok_infnan |NN const char** sp|NN const char *send|NULLOK NV *nvp -Apd |const char *|grok_nan |NN const char* s|NN const char *send|NN int *flags|NULLOK NV *nvp -Apd |const char *|grok_nan_payload|NN const char* s|NN const char *send|bool signaling|NN int *flags|NULLOK NV *nvp +Apd |const char *|grok_nan |NN const char* s|NN const char *send|NN int *flags|NULLOK NV *nvp|NULLOK SV* svp +Apd |const char *|grok_nan_payload|NN const char* s|NN const char *send|bool signaling|NN int *flags|NULLOK NV *nvp|NULLOK SV *svp Apd |int |grok_number |NN const char *pv|STRLEN len|NULLOK UV *valuep Apd |int |grok_number_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|U32 flags Apd |int |grok_number2_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|NULLOK NV* nvp|U32 flags @@ -825,7 +825,7 @@ Apdn |UV |grok_atou |NN const char* pv|NULLOK const char** endptr Apdn |U8* |nan_hibyte|NN NV *nvp|NN U8* mask Apd |void |nan_signaling_set|NN NV *nvp|bool signaling Apdn |int |nan_is_signaling|NV nv -Apd |void |nan_payload_set|NN NV *nvp|NN const void *bytes|STRLEN byten|bool signaling +Apd |void |nan_payload_set|NN NV *nvp|NULLOK SV *svp|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 0c43ce7..fd22891 100644 --- a/embed.h +++ b/embed.h @@ -183,8 +183,8 @@ #define grok_bin(a,b,c,d) Perl_grok_bin(aTHX_ a,b,c,d) #define grok_hex(a,b,c,d) Perl_grok_hex(aTHX_ a,b,c,d) #define grok_infnan(a,b,c) Perl_grok_infnan(aTHX_ a,b,c) -#define grok_nan(a,b,c,d) Perl_grok_nan(aTHX_ a,b,c,d) -#define grok_nan_payload(a,b,c,d,e) Perl_grok_nan_payload(aTHX_ a,b,c,d,e) +#define grok_nan(a,b,c,d,e) Perl_grok_nan(aTHX_ a,b,c,d,e) +#define grok_nan_payload(a,b,c,d,e,f) Perl_grok_nan_payload(aTHX_ a,b,c,d,e,f) #define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c) #define grok_number2_flags(a,b,c,d,e) Perl_grok_number2_flags(aTHX_ a,b,c,d,e) #define grok_number_flags(a,b,c,d) Perl_grok_number_flags(aTHX_ a,b,c,d) @@ -361,7 +361,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 Perl_nan_hibyte #define nan_is_signaling Perl_nan_is_signaling -#define nan_payload_set(a,b,c,d) Perl_nan_payload_set(aTHX_ a,b,c,d) +#define nan_payload_set(a,b,c,d,e) Perl_nan_payload_set(aTHX_ a,b,c,d,e) #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 a1e8aea..6a578e1 100644 --- a/numeric.c +++ b/numeric.c @@ -708,7 +708,7 @@ Do not assume any portability of the NaN semantics. =cut */ void -Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signaling) +Perl_nan_payload_set(pTHX_ NV *nvp, SV* svp, const void *bytes, STRLEN byten, bool signaling) { /* How many bits we can set in the payload. * @@ -773,8 +773,9 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal *hibyte &= ~mask; } if (overflow) { - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "NaN payload overflowed %d bits", NV_NAN_BITS); + if (svp) { + sv_setpvf(svp, "NaN payload overflowed %d bits", NV_NAN_BITS); + } } nan_signaling_set(nvp, signaling); } @@ -791,7 +792,7 @@ If you want the parse the "nan" part you need to use grok_nan(). =cut */ const char * -Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int *flags, NV* nvp) +Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int *flags, NV* nvp, SV* svp) { U8 bytes[MAX_NV_BYTES]; STRLEN byten = 0; @@ -809,9 +810,7 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int if (*t != ')') { U8 bytes[1] = { 0 }; - nan_payload_set(nvp, bytes, 1, signaling); - Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), - "NaN payload \"%s\" invalid", orig); + nan_payload_set(nvp, svp, bytes, 1, signaling); return t; } @@ -930,14 +929,13 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int bytes[byten++] = 0; } - if (overflow) { - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "NaN payload \"%s\" overflowed %d bits", - orig, NV_NAN_BITS); - } - if (bogus) { - Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), - "NaN payload \"%s\" invalid", orig); + if (svp) { + if (bogus) { + sv_setpvf(svp, "NaN payload \"%s\" invalid",orig); + } else if (overflow) { + sv_setpvf(svp, "NaN payload \"%s\" overflowed %d bits", + orig, NV_NAN_BITS); + } } if (s == send) { @@ -946,7 +944,7 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int } if (nvp) { - nan_payload_set(nvp, bytes, byten, signaling); + nan_payload_set(nvp, svp, bytes, byten, signaling); } return s; @@ -967,7 +965,7 @@ The "..." is parsed with grok_nan_payload(). =cut */ const char * -Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp) +Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp, SV* svp) { bool signaling = FALSE; @@ -998,7 +996,7 @@ Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp) } if (*s == '(') { - const char *n = grok_nan_payload(s, send, signaling, flags, nvp); + const char *n = grok_nan_payload(s, send, signaling, flags, nvp, svp); if (n == send) return NULL; s = n; if (*s != ')') { @@ -1008,7 +1006,7 @@ Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp) } else { if (nvp) { U8 bytes[1] = { 0 }; - nan_payload_set(nvp, bytes, 1, signaling); + nan_payload_set(nvp, svp, bytes, 1, signaling); } while (s < send && isSPACE(*s)) s++; @@ -1139,7 +1137,7 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp) } else { /* Maybe NAN of some sort */ - const char *n = grok_nan(s, send, &flags, nvp); + const char *n = grok_nan(s, send, &flags, nvp, NULL); if (n == NULL) return 0; s = n; } diff --git a/pod/perldata.pod b/pod/perldata.pod index 9b3f63a..b456a81 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -567,10 +567,14 @@ number of bits available again depends on the platform. (Though for the most common floating point format, 64-bit IEEE 754, there is room for 51 bits.) -The payload is propagated on straight copies, but on operations -(like addition) the result (which payload bits end up where) again -depends on the platform. You can generate a NaN with payload by -e.g. "nan(0x123)". +You can generate a NaN with payload with e.g. "nan(0x123)" or "nans(456)". +Note that you have to be aware of the binary representation of the payload: +because of how negative numbers are stored, they often cannot be used as +the payload. + +The payload (and quiet/signaling flag) is propagated on straight +copies, but on operations (like addition) the result (which payload +bits end up where) again depends on the platform. The default stringification of not-a-numbers will just show the C<NaN> but you can use C<printf %#g> to see the payload: the C<#> is the key. diff --git a/proto.h b/proto.h index 765c85d..bb09d84 100644 --- a/proto.h +++ b/proto.h @@ -1365,14 +1365,14 @@ PERL_CALLCONV int Perl_grok_infnan(pTHX_ const char** sp, const char *send, NV * #define PERL_ARGS_ASSERT_GROK_INFNAN \ assert(sp); assert(send) -PERL_CALLCONV const char * Perl_grok_nan(pTHX_ const char* s, const char *send, int *flags, NV *nvp) +PERL_CALLCONV const char * Perl_grok_nan(pTHX_ const char* s, const char *send, int *flags, NV *nvp, SV* svp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_GROK_NAN \ assert(s); assert(send); assert(flags) -PERL_CALLCONV const char * Perl_grok_nan_payload(pTHX_ const char* s, const char *send, bool signaling, int *flags, NV *nvp) +PERL_CALLCONV const char * Perl_grok_nan_payload(pTHX_ const char* s, const char *send, bool signaling, int *flags, NV *nvp, SV *svp) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_4); @@ -2864,9 +2864,9 @@ PERL_CALLCONV U8* Perl_nan_hibyte(NV *nvp, U8* mask) assert(nvp); assert(mask) PERL_CALLCONV int Perl_nan_is_signaling(NV nv); -PERL_CALLCONV void Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signaling) +PERL_CALLCONV void Perl_nan_payload_set(pTHX_ NV *nvp, SV *svp, const void *bytes, STRLEN byten, bool signaling) __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); + __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_NAN_PAYLOAD_SET \ assert(nvp); assert(bytes) -- Perl5 Master Repository
