|const STRLEN len
#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|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_infnan |NN const char** sp|NN const char *send
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
ApdR |bool |grok_numeric_radix|NN const char **sp|NN const char *send
Apd |UV |grok_oct |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
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|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
#define grok_atou Perl_grok_atou
#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,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_infnan(a,b) Perl_grok_infnan(aTHX_ a,b)
#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)
#define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b)
#define grok_oct(a,b,c,d) Perl_grok_oct(aTHX_ a,b,c,d)
#define my_socketpair Perl_my_socketpair
#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 Perl_nan_hibyte
-#define nan_is_signaling Perl_nan_is_signaling
-#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)
#define newANONLIST(a) Perl_newANONLIST(aTHX_ a)
j0 j1 jn y0 y1 yn
- * other extensions:
-
- issignaling (http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1664.pdf)
-
* Configure already (5.21.5) scans for:
copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l*
isinf = 3
isnan = 4
isnormal = 5
- issignaling = 6
- lrint = 7
- lround = 8
- signbit = 9
+ lrint = 6
+ lround = 7
+ signbit = 8
CODE:
PERL_UNUSED_VAR(x);
RETVAL = -1;
#endif
break;
case 6:
- RETVAL = nan_is_signaling(x);
- break;
- case 7:
#ifdef c99_lrint
RETVAL = c99_lrint(x);
#else
not_here("lrint");
#endif
break;
- case 8:
+ case 7:
#ifdef c99_lround
RETVAL = c99_lround(x);
#else
not_here("lround");
#endif
break;
- case 9:
+ case 8:
default:
#ifdef Perl_signbit
RETVAL = Perl_signbit(x);
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.52';
+our $VERSION = '1.51';
require XSLoader;
erfc exp2 expm1 fabs fdim floor fma fmax fmin fmod
fpclassify frexp hypot ilogb isfinite isgreater
isgreaterequal isinf isless islessequal
- islessgreater isnan isnormal issignaling isunordered j0 j1 jn
+ islessgreater isnan isnormal isunordered j0 j1 jn
ldexp lgamma log10 log1p log2 logb lrint modf nan
nearbyint nextafter nexttoward pow remainder remquo
rint round scalbn signbit sinh tan tanh tgamma trunc
Returns true if the argument is a finite number (that is, not an
infinity, or the not-a-number) [C99].
-See also L</nan>, L</isinf>, L</issignaling>, and L</fpclassify>.
+See also L</isinf>, L</isnan>, and L</fpclassify>.
=item C<isgraph>
The function returns C<TRUE> if the input string is empty, or if the
corresponding C function returns C<TRUE> for every byte in the string.
-=item C<issignaling>
-
-Returns true if the argument is a signaling C<NaN> (not-a-number)
-
-See also L</isnan> and L</fpclassify>. (There is no "isquiet".)
-
=item C<isspace>
Deprecated function whose use raises a warning, and which is slated to
isatty iscntrl isdigit isfinite isgraph isgreater
isgreaterequal isinf isless islessequal
islessgreater islower isnan isnormal isprint ispunct
- issignaling isspace isunordered isupper isxdigit j0 j1 jn labs
+ isspace isunordered isupper isxdigit j0 j1 jn labs
ldexp ldiv lgamma localeconv log10 log1p log2 logb
longjmp lrint lseek malloc mblen mbstowcs mbtowc
memchr memcmp memcpy memmove memset mkfifo mktime
return FALSE;
}
-#if 0
-/* For debugging. */
-static void
-S_hexdump_nv(NV nv)
-{
- int i;
- /* Remember that NVSIZE may include garbage bytes, the most
- * notable case being the x86 80-bit extended precision long doubles,
- * which have 6 or 2 unused bytes (NVSIZE = 16 or NVSIZE = 12). */
- for (i = 0; i < NVSIZE; i++) {
- PerlIO_printf(Perl_debug_log, "%02x ", ((U8*)&nv)[i]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
-}
-#endif
-
-/*
-=for apidoc nan_hibyte
-
-Given an NV, returns pointer to the byte containing the most
-significant bit of the NaN, this bit is most commonly the
-quiet/signaling bit of the NaN. The mask will contain a mask
-appropriate for manipulating the most significant bit.
-Note that this bit may not be the highest bit of the byte.
-
-If the NV is not a NaN, returns NULL.
-
-Most platforms have "high bit is one" -> quiet nan.
-The known opposite exceptions are older MIPS and HPPA platforms.
-
-Some platforms do not differentiate between quiet and signaling NaNs.
-
-=cut
-*/
-U8*
-Perl_nan_hibyte(NV *nvp, U8* mask)
-{
- STRLEN i = (NV_MANT_REAL_DIG - 1) / 8;
-
- PERL_ARGS_ASSERT_NAN_HIBYTE;
-
-#if defined(USE_LONG_DOUBLE) && (LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN)
- /* See the definition of NV_NAN_BITS. */
- *mask = 1 << 6;
-#else
- {
- STRLEN j = (NV_MANT_REAL_DIG - 1) % 8;
- *mask = 1 << j;
- }
-#endif
-#ifdef NV_BIG_ENDIAN
- return (U8*) nvp + NVSIZE - 1 - i;
-#endif
-#ifdef NV_LITTLE_ENDIAN
- return (U8*) nvp + i;
-#endif
-}
-
-/*
-=for apidoc nan_signaling_set
-
-Set or unset the NaN signaling-ness.
-
-Of those platforms that differentiate between quiet and signaling
-platforms the majority has the semantics of the most significant bit
-being on meaning quiet NaN, so for signaling we need to clear the bit.
-
-Some platforms (older MIPS, and HPPA) have the opposite
-semantics, and we set the bit for a signaling NaN.
-
-=cut
-*/
-void
-Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
-{
- U8 mask;
- U8* hibyte;
-
- PERL_ARGS_ASSERT_NAN_SIGNALING_SET;
-
- hibyte = nan_hibyte(nvp, &mask);
- if (hibyte) {
- const NV nan = NV_NAN;
- /* Decent optimizers should make the irrelevant branch to disappear.
- * XXX Configure scan */
- if ((((U8*)&nan)[hibyte - (U8*)nvp] & mask)) {
- /* x86 style: the most significant bit of the NaN is off
- * for a signaling NaN, and on for a quiet NaN. */
- if (signaling) {
- *hibyte &= ~mask;
- } else {
- *hibyte |= mask;
- }
- } else {
- /* MIPS/HPPA style: the most significant bit of the NaN is on
- * for a signaling NaN, and off for a quiet NaN. */
- if (signaling) {
- *hibyte |= mask;
- } else {
- *hibyte &= ~mask;
- }
- }
- }
-}
-
-/*
-=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/hppa 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 = nan_hibyte(&nv, &mask);
- if (hibyte) {
- /* 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);
- }
- }
- return 0;
-#endif
-}
-
-/* The largest known floating point numbers are the IEEE quadruple
- * precision of 128 bits. */
-#define MAX_NV_BYTES (128/8)
-
-/*
-
-=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(pTHX_ NV *nvp, SV* svp, 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_NAN_BITS;
- U8 mask;
- U8* hibyte;
- U8 hibit;
-
- STRLEN i, nvi;
- bool overflow = FALSE;
-
- /* XXX None of this works for doubledouble platforms, or for mixendians. */
-
- PERL_ARGS_ASSERT_NAN_PAYLOAD_SET;
-
- *nvp = NV_NAN;
- hibyte = nan_hibyte(nvp, &mask);
- hibit = *hibyte & mask;
-
-#ifdef NV_BIG_ENDIAN
- nvi = NVSIZE - 1;
-#endif
-#ifdef NV_LITTLE_ENDIAN
- nvi = 0;
-#endif
-
- if (byten > MAX_NV_BYTES) {
- byten = MAX_NV_BYTES;
- overflow = 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 (hibit) {
- *hibyte |= mask;
- } else {
- *hibyte &= ~mask;
- }
- if (overflow) {
- if (svp) {
- sv_setpvf(svp, "NaN payload overflowed %d bits", NV_NAN_BITS);
- }
- }
- nan_signaling_set(nvp, signaling);
-}
-
-/*
-=for apidoc grok_nan_payload
-
-Helper for grok_nan().
-
-Parses the "..." in C99-style "nan(...)" strings, and sets the nvp accordingly.
-
-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, SV* svp)
-{
- U8 bytes[MAX_NV_BYTES];
- STRLEN byten = 0;
- const char *t = send - 1; /* minus one for ')' */
- bool overflow = FALSE;
- bool bogus = FALSE;
- const char *orig = s;
-
- PERL_ARGS_ASSERT_GROK_NAN_PAYLOAD;
-
- /* XXX: legacy nan payload formats like "nan123",
- * "nan0xabc", or "nan(s123)" ("s" for signaling). */
-
- while (t > s && isSPACE(*t)) t--;
-
- if (*t != ')') {
- U8 bytes[1] = { 0 };
- nan_payload_set(nvp, svp, bytes, 1, signaling);
- return t;
- }
-
- if (++s == send) {
- *flags |= IS_NUMBER_TRAILING;
- return s;
- }
-
- while (s < t && byten < MAX_NV_BYTES) {
- UV uv;
- int nantype = 0;
-
- if (s[0] == '0' && s + 2 < t &&
- isALPHA_FOLD_EQ(s[1], 'x') &&
- isXDIGIT(s[2])) {
- const char *u = s + 3;
- STRLEN len;
- I32 uvflags;
-
- while (isXDIGIT(*u)) u++;
- len = u - s;
- uvflags = PERL_SCAN_ALLOW_UNDERSCORES;
- uv = grok_hex(s, &len, &uvflags, NULL);
- if ((uvflags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
- nantype = 0;
- } else {
- nantype = IS_NUMBER_IN_UV;
- }
- s += len;
- } else if (s[0] == '0' && s + 2 < t &&
- isALPHA_FOLD_EQ(s[1], 'b') &&
- (s[2] == '0' || s[2] == '1')) {
- const char *u = s + 3;
- STRLEN len;
- I32 uvflags;
-
- while (*u == '0' || *u == '1') u++;
- len = u - s;
- uvflags = PERL_SCAN_ALLOW_UNDERSCORES;
- uv = grok_bin(s, &len, &uvflags, NULL);
- if ((uvflags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
- nantype = 0;
- } else {
- nantype = IS_NUMBER_IN_UV;
- }
- s += len;
- } else if ((s[0] == '\'' || s[0] == '"') &&
- s + 2 < t && t[-1] == s[0]) {
- /* Perl extension: if the input looks like a string
- * constant ('' or ""), read its bytes as-they-come. */
- STRLEN n = t - s - 2;
- STRLEN i;
- if ((n > MAX_NV_BYTES - byten) ||
- (n * 8 > NV_MANT_REAL_DIG)) {
- overflow = TRUE;
- break;
- }
- /* Copy the bytes in reverse so that \x41\x42 ('AB')
- * is equivalent to 0x4142. In other words, the bytes
- * are in big-endian order. */
- for (i = 0; i < n; i++) {
- bytes[n - i - 1] = s[i + 1];
- }
- byten += n;
- break;
- } else if (s < t && (isDIGIT(*s) || *s == '-' || *s == '+')) {
- const char *u;
- nantype =
- grok_number_flags(s, (STRLEN)(t - s), &uv,
- PERL_SCAN_TRAILING |
- PERL_SCAN_ALLOW_UNDERSCORES);
- /* Unfortunately grok_number_flags() doesn't
- * tell how far we got and the ')' will always
- * be "trailing", so we need to double-check
- * whether we had something dubious. */
- u = s;
- if ((*u == '-' || *u == '+')) {
- u++;
- }
- for (; u < t; u++) {
- if (!isDIGIT(*u)) {
- *flags |= IS_NUMBER_TRAILING;
- break;
- }
- }
- if ((nantype & IS_NUMBER_NEG)) {
- uv = (UV) (-uv);
- }
- s = u;
- } else {
- bogus = TRUE;
- break;
- }
- /* XXX Doesn't do octal: nan("0123").
- * Probably not a big loss. */
-
- if (!(nantype & IS_NUMBER_IN_UV)) {
- overflow = TRUE;
- break;
- }
-
- if (uv) {
- int bits = NV_NAN_BITS;
- while (uv && byten < MAX_NV_BYTES && bits > 0) {
- bytes[byten++] = (U8) (uv & 0xFF);
- uv >>= 8;
- bits -= 8;
- }
- }
- if (uv) {
- overflow = TRUE;
- }
- }
-
- if (byten == 0) {
- bytes[byten++] = 0;
- }
-
- 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) {
- *flags |= IS_NUMBER_TRAILING;
- return s;
- }
-
- if (nvp) {
- nan_payload_set(nvp, svp, bytes, byten, signaling);
- }
-
- return s;
-}
-
-/*
-=for apidoc grok_nan
-
-Helper for grok_infnan().
-
-Parses the C99-style "nan(...)" strings, and sets the nvp accordingly.
-
-*sp points to the beginning of "nan", which can be also "qnan", "nanq",
-or "snan", "nans", and case is ignored.
-
-The "..." is parsed with grok_nan_payload().
-
-=cut
-*/
-const char *
-Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp, SV* svp)
-{
- bool signaling = FALSE;
-
- PERL_ARGS_ASSERT_GROK_NAN;
-
- if (isALPHA_FOLD_EQ(*s, 'S')) {
- signaling = TRUE;
- s++; if (s == send) return s;
- } else if (isALPHA_FOLD_EQ(*s, 'Q')) {
- s++; if (s == send) return s;
- }
-
- if (isALPHA_FOLD_EQ(*s, 'N')) {
- s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return s;
- s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return s;
- s++;
-
- *flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
-
- /* NaN can be followed by various stuff (NaNQ, NaNS), while
- * some legacy implementations have weird stuff like "NaN%"
- * (no idea what that means). */
- if (isALPHA_FOLD_EQ(*s, 's')) {
- signaling = TRUE;
- s++;
- } else if (isALPHA_FOLD_EQ(*s, 'q')) {
- s++;
- }
-
- if (*s == '(') {
- const char *n = grok_nan_payload(s, send, signaling, flags, nvp, svp);
- if (n == send) return NULL;
- s = n;
- if (*s != ')') {
- *flags |= IS_NUMBER_TRAILING;
- return s;
- }
- } else {
- if (nvp) {
- U8 bytes[1] = { 0 };
- nan_payload_set(nvp, svp, bytes, 1, signaling);
- }
-
- while (s < send && isSPACE(*s)) s++;
-
- if (s < send && *s) {
- /* Note that we here implicitly accept (parse as
- * "nan", but with warnings) also any other weird
- * trailing stuff for "nan". In the above we just
- * check that if we got the C99-style "nan(...)",
- * the "..." looks sane. If in future we accept
- * more ways of specifying the nan payload (like
- * "nan123" or "nan0xabc"), the accepting would
- * happen around here. */
- *flags |= IS_NUMBER_TRAILING;
- }
- }
-
- s = send;
- }
- else
- return NULL;
-
- return s;
-}
-
/*
=for apidoc grok_infnan
*/
int
-Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp)
+Perl_grok_infnan(pTHX_ const char** sp, const char* send)
{
const char* s = *sp;
int flags = 0;
PERL_ARGS_ASSERT_GROK_INFNAN;
- /* XXX there are further legacy formats like HP-UX "++" for Inf
- * and "--" for -Inf. While we might be able to grok those in
- * string numification, having those in source code might open
- * up too much golfing: ++++;
- */
-
if (*s == '+') {
s++; if (s == send) return 0;
}
flags |= IS_NUMBER_TRAILING;
}
flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
- if (nvp) {
- *nvp = (flags & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
- }
}
else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
s++;
flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
- if (nvp) {
- *nvp = NV_NAN;
- }
while (*s == '0') { /* 1.#IND00 */
s++;
}
}
else {
/* Maybe NAN of some sort */
- const char *n = grok_nan(s, send, &flags, nvp, NULL);
- if (n == NULL) return 0;
- s = n;
+
+ if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
+ /* snan, qNaN */
+ /* XXX do something with the snan/qnan difference */
+ s++; if (s == send) return 0;
+ }
+
+ if (isALPHA_FOLD_EQ(*s, 'N')) {
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
+ s++;
+
+ flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+
+ /* NaN can be followed by various stuff (NaNQ, NaNS), but
+ * there are also multiple different NaN values, and some
+ * implementations output the "payload" values,
+ * e.g. NaN123, NAN(abc), while some legacy implementations
+ * have weird stuff like NaN%. */
+ if (isALPHA_FOLD_EQ(*s, 'q') ||
+ isALPHA_FOLD_EQ(*s, 's')) {
+ /* "nanq" or "nans" are ok, though generating
+ * these portably is tricky. */
+ s++;
+ }
+ if (*s == '(') {
+ /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
+ const char *t;
+ s++;
+ if (s == send) {
+ return flags | IS_NUMBER_TRAILING;
+ }
+ t = s + 1;
+ while (t < send && *t && *t != ')') {
+ t++;
+ }
+ if (t == send) {
+ return flags | IS_NUMBER_TRAILING;
+ }
+ if (*t == ')') {
+ int nantype;
+ UV nanval;
+ if (s[0] == '0' && s + 2 < t &&
+ isALPHA_FOLD_EQ(s[1], 'x') &&
+ isXDIGIT(s[2])) {
+ STRLEN len = t - s;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ nanval = grok_hex(s, &len, &flags, NULL);
+ if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
+ nantype = 0;
+ } else {
+ nantype = IS_NUMBER_IN_UV;
+ }
+ s += len;
+ } else if (s[0] == '0' && s + 2 < t &&
+ isALPHA_FOLD_EQ(s[1], 'b') &&
+ (s[2] == '0' || s[2] == '1')) {
+ STRLEN len = t - s;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ nanval = grok_bin(s, &len, &flags, NULL);
+ if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
+ nantype = 0;
+ } else {
+ nantype = IS_NUMBER_IN_UV;
+ }
+ s += len;
+ } else {
+ const char *u;
+ nantype =
+ grok_number_flags(s, t - s, &nanval,
+ PERL_SCAN_TRAILING |
+ PERL_SCAN_ALLOW_UNDERSCORES);
+ /* Unfortunately grok_number_flags() doesn't
+ * tell how far we got and the ')' will always
+ * be "trailing", so we need to double-check
+ * whether we had something dubious. */
+ for (u = s; u < t; u++) {
+ if (!isDIGIT(*u)) {
+ flags |= IS_NUMBER_TRAILING;
+ break;
+ }
+ }
+ s = u;
+ }
+
+ /* XXX Doesn't do octal: nan("0123").
+ * Probably not a big loss. */
+
+ if ((nantype & IS_NUMBER_NOT_INT) ||
+ !(nantype && IS_NUMBER_IN_UV)) {
+ /* XXX the nanval is currently unused, that is,
+ * not inserted as the NaN payload of the NV.
+ * But the above code already parses the C99
+ * nan(...) format. See below, and see also
+ * the nan() in POSIX.xs.
+ *
+ * Certain configuration combinations where
+ * NVSIZE is greater than UVSIZE mean that
+ * a single UV cannot contain all the possible
+ * NaN payload bits. There would need to be
+ * some more generic syntax than "nan($uv)".
+ *
+ * Issues to keep in mind:
+ *
+ * (1) In most common cases there would
+ * not be an integral number of bytes that
+ * could be set, only a certain number of bits.
+ * For example for the common case of
+ * NVSIZE == UVSIZE == 8 there is room for 52
+ * bits in the payload, but the most significant
+ * bit is commonly reserved for the
+ * signaling/quiet bit, leaving 51 bits.
+ * Furthermore, the C99 nan() is supposed
+ * to generate quiet NaNs, so it is doubtful
+ * whether it should be able to generate
+ * signaling NaNs. For the x86 80-bit doubles
+ * (if building a long double Perl) there would
+ * be 62 bits (s/q bit being the 63rd).
+ *
+ * (2) Endianness of the payload bits. If the
+ * payload is specified as an UV, the low-order
+ * bits of the UV are naturally little-endianed
+ * (rightmost) bits of the payload. The endianness
+ * of UVs and NVs can be different. */
+ return 0;
+ }
+ if (s < t) {
+ flags |= IS_NUMBER_TRAILING;
+ }
+ } else {
+ /* Looked like nan(...), but no close paren. */
+ flags |= IS_NUMBER_TRAILING;
+ }
+ } else {
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s < send && *s) {
+ /* Note that we here implicitly accept (parse as
+ * "nan", but with warnings) also any other weird
+ * trailing stuff for "nan". In the above we just
+ * check that if we got the C99-style "nan(...)",
+ * the "..." looks sane.
+ * If in future we accept more ways of specifying
+ * the nan payload, the accepting would happen around
+ * here. */
+ flags |= IS_NUMBER_TRAILING;
+ }
+ }
+ s = send;
+ }
+ else
+ return 0;
}
while (s < send && isSPACE(*s))
}
/*
-=for apidoc grok_number2_flags
+=for apidoc grok_number_flags
Recognise (or not) a number. The type of the number is returned
(0 if unrecognised), otherwise it is a bit-ORed combination of
If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
valuep is non-NULL, but no actual assignment (or SEGV) will occur.
-The nvp is used to directly set the value for infinities (Inf) and
-not-a-numbers (NaN).
-
IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
seen (in which case *valuep gives the true value truncated to an integer), and
IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
non-numeric text on an otherwise successful I<grok>, setting
C<IS_NUMBER_TRAILING> on the result.
-=for apidoc grok_number_flags
-
-Identical to grok_number2_flags() with nvp and flags set to zero.
-
=for apidoc grok_number
Identical to grok_number_flags() with flags set to zero.
return grok_number_flags(pv, len, valuep, 0);
}
-int
-Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
-{
- PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
-
- return grok_number2_flags(pv, len, valuep, NULL, flags);
-}
-
static const UV uv_max_div_10 = UV_MAX / 10;
static const U8 uv_max_mod_10 = UV_MAX % 10;
int
-Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U32 flags)
+Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
{
const char *s = pv;
const char * const send = pv + len;
const char *d;
int numtype = 0;
- PERL_ARGS_ASSERT_GROK_NUMBER2_FLAGS;
+ PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
while (s < send && isSPACE(*s))
s++;
if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
/* Really detect inf/nan. Start at d, not s, since the above
* code might have already consumed the "1." or "1". */
- NV nanv;
- int infnan = Perl_grok_infnan(aTHX_ &d, send, &nanv);
+ int infnan = Perl_grok_infnan(aTHX_ &d, send);
if ((infnan & IS_NUMBER_INFINITY)) {
- if (nvp) {
- *nvp = (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF;
- }
return (numtype | infnan); /* Keep sign for infinity. */
}
else if ((infnan & IS_NUMBER_NAN)) {
- if (nvp) {
- *nvp = nanv;
- }
return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
}
}
{
const char *p0 = negative ? s - 1 : s;
const char *p = p0;
- int infnan = grok_infnan(&p, send, value);
+ int infnan = grok_infnan(&p, send);
if (infnan && p != p0) {
/* If we can generate inf/nan directly, let's do so. */
#ifdef NV_INF
if ((infnan & IS_NUMBER_INFINITY)) {
- /* grok_infnan() already set the value. */
+ *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
return (char*)p;
}
#endif
#ifdef NV_NAN
if ((infnan & IS_NUMBER_NAN)) {
- /* grok_infnan() already set the value. */
+ *value = NV_NAN;
return (char*)p;
}
#endif
{
STRLEN len;
const char *s = SvPV_nomg_const(sv, len);
- return cBOOL(grok_infnan(&s, s+len, NULL));
+ return cBOOL(grok_infnan(&s, s+len));
}
}
# define NV_QNAN LDBL_QNAN
# endif
# if !defined(NV_NAN) && defined(LDBL_SNAN)
+# define NV_NAN LDBL_SNAN
# define NV_SNAN LDBL_SNAN
# endif
#endif
# define NV_QNAN DBL_QNAN
#endif
#if !defined(NV_NAN) && defined(DBL_SNAN)
+# define NV_NAN (NV)DBL_SNAN
# define NV_SNAN DBL_SNAN
#endif
#if !defined(NV_NAN) && defined(NAN)
# define NV_QNAN QNAN
#endif
#if !defined(NV_NAN) && defined(SNAN)
+# define NV_NAN (NV)SNAN
# define NV_SNAN SNAN
#endif
#if !defined(NV_NAN) && defined(I_SUNMATH)
* Though IEEE-754-logically correct, some compilers (like Visual C 2003)
* falsely misoptimize that to zero (x-x is zero, right?) */
-/* x86 80-bit extended precision mantissa bits:
- *
- * 63 62 61 30387+ pre-387
- * -------- ---- --------
- * 0 0 0 invalid infinity
- * 0 0 n invalid snan
- * 0 1 * invalid snan
- * 1 0 0 infinity snan
- * 1 0 n snan
- * 1 1 0 qnan (1.#IND)
- * 1 1 n qnan
- *
- * This means that there are 61 bits for nan payload.
- */
-#if defined(USE_LONG_DOUBLE) && (LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN)
-# define NV_NAN_BITS 61
-#elif defined(__hppa) /* XXX Configure scan */
-# define NV_NAN_BITS 50 /* qnan: 7f f4 00 00 00 00 00 00 */
-#elif defined(__mips) && UVSIZE == 4 /* IRIX64/MIPS cc -32 */
-# define NV_NAN_BITS 35 /* qnan: 7f ff 2f 30 00 00 00 00
- * +inf: 7f ff 2f 20 00 00 00 00
- * -inf: 7f ff 2f 28 00 00 00 00 */
-#else
-# define NV_NAN_BITS (NV_MANT_REAL_DIG - 1)
-#endif
-/* IRIX64/MIPS cc -64 is something bizarre:
- * qnan 00 00 0f ff ff ff ae 90
- * +inf 00 00 0f ff ff ff ae 80
- * -inf 00 00 0f ff ff ff ae 88
- * In other words, it doesn't seem to follow any IEEE pattern for infnan,
- * and even seems more little-endian than big-endian. */
-
#ifndef __cplusplus
# if !defined(WIN32) && !defined(VMS)
#ifndef crypt
Multi-number v-strings like C<v65.66> and C<65.66.67> continue to
be v-strings always.
-=head3 Special floating point
-
-Floating point values include the special values C<Inf> and C<NaN>,
-for infinity and not-a-number. The infinity can be also negative.
-
-The infinity is the result of certain math operations that overflow
-the floating point range, like 9**9**9. The not-a-number is the
-result when the result is undefined or unrepresentable. Though note
-that you cannot get C<NaN> from some common "undefined" or
-"out-of-range" operations like dividing by zero, or square root of
-a negative number, since Perl generates fatal errors for those.
-
-The infinity and not-a-number have their own special arithmetic rules.
-The general rule is that they are "contagious": C<Inf> plus one is
-C<Inf>, and C<NaN> plus one is C<NaN>. Where things get interesting
-is when you combine infinities and not-a-numbers: C<Inf> minus C<Inf>
-and C<Inf> divided by C<INf> are C<NaN> (while C<Inf> plus C<Inf> is
-C<Inf> and C<Inf> times C<Inf> is C<Inf>).
-
-Perl doesn't understand C<Inf> and C<NaN> as numeric literals, but you
-can have them as strings, and Perl will convert them as needed: "Inf" + 1.
-(If you want to have them as kind of literals, you can import them from
-the POSIX extension.)
-
-Note that on input (string to number) Perl accepts C<Inf> and C<NaN>
-in many forms. Case is ignored, and the Win32-specific forms like
-C<1.#INF> are understood, but on output the values are normalized to
-C<Inf> and C<NaN>.
-
-The C<NaN> has two special features of its own. Firstly, it comes in
-two flavors, quiet and signaling. What this means is depends on the
-platform. Secondly, it may have "payload" of a number of bits. The
-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.)
-
-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.
-The payload will be shown as hexadecimal integer if possible on
-the platform (floating point values may have more bits than integers),
-if not, as a string of hexadecimal bytes.
-
=head3 Special Literals
X<special literal> X<__END__> X<__DATA__> X<END> X<DATA>
X<end> X<data> X<^D> X<^Z>
Symbols beginning with an underscore and symbols using special
identifiers (q.v. L<perldata>) are exempt from this warning.
-=item NaN payload overflowed %d bits
-
-(W overflow) C<Nan> (not-a-number) floating point values can carry
-payload information in addition to just being NaN. The amount of
-information is limited, and dependent on the platform.
-See L<perldata/Special floating point>.
-
-=item NaN payload "%s" overflowed %d bits
-
-(W overflow) C<Nan> (not-a-number) floating point values can carry
-payload information in addition to just being NaN. The amount of
-information is limited, and dependent on the platform.
-See L<perldata/Special floating point>.
-
-=item NaN payload "%s" invalid
-
-(W digit) C<Nan> (not-a-number) floating point values can carry
-payload information in addition to just being NaN. The payload
-could not be parsed. See L<perldata/Special floating point>.
-
=item Need exactly 3 octal digits in regex; marked by S<<-- HERE> in m/%s/
(F) Within S<C<(?[ ])>>, all constants interpreted as octal need to be
#define PERL_ARGS_ASSERT_GROK_HEX \
assert(start); assert(len_p); assert(flags)
-PERL_CALLCONV int Perl_grok_infnan(pTHX_ const char** sp, const char *send, NV *nvp)
+PERL_CALLCONV int Perl_grok_infnan(pTHX_ const char** sp, const char *send)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#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, 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, SV *svp)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_GROK_NAN_PAYLOAD \
- assert(s); assert(send); assert(flags)
-
PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GROK_NUMBER \
assert(pv)
-PERL_CALLCONV int Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV* nvp, U32 flags)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GROK_NUMBER2_FLAGS \
- assert(pv)
-
PERL_CALLCONV int Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS \
#define PERL_ARGS_ASSERT_MY_VSNPRINTF \
assert(buffer); assert(format)
-PERL_CALLCONV U8* Perl_nan_hibyte(NV *nvp, U8* mask)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-#define PERL_ARGS_ASSERT_NAN_HIBYTE \
- assert(nvp); assert(mask)
-
-PERL_CALLCONV int Perl_nan_is_signaling(NV nv);
-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_3);
-#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 \
- assert(nvp)
-
PERL_CALLCONV OP* Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block);
PERL_CALLCONV OP* Perl_newANONHASH(pTHX_ OP* o)
__attribute__malloc__
# pragma warning(disable:4756;disable:4056)
#endif
static void
-S_sv_setnv(pTHX_ SV* sv, int numtype, NV nanv)
+S_sv_setnv(pTHX_ SV* sv, int numtype)
{
bool pok = cBOOL(SvPOK(sv));
bool nok = FALSE;
nok = TRUE;
}
else if ((numtype & IS_NUMBER_NAN)) {
- SvNV_set(sv, nanv);
+ SvNV_set(sv, NV_NAN);
nok = TRUE;
}
else if (pok) {
}
else if (SvPOKp(sv)) {
UV value;
- NV nanv;
- const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
not_a_number(sv);
- S_sv_setnv(aTHX_ sv, numtype, nanv);
+ S_sv_setnv(aTHX_ sv, numtype);
return FALSE;
}
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
/* It wasn't an (integer that doesn't overflow the UV). */
- S_sv_setnv(aTHX_ sv, numtype, nanv);
+ S_sv_setnv(aTHX_ sv, numtype);
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
else if (SvPOKp(sv)) {
UV value;
- NV nanv;
- const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
#ifdef NV_PRESERVES_UV
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
} else {
- S_sv_setnv(aTHX_ sv, numtype, nanv);
+ S_sv_setnv(aTHX_ sv, numtype);
}
if (numtype)
SvNOK_on(sv);
return ptr;
}
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
-/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
- * The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
- * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
- * after the first 1023 zero bits.
- *
- * XXX The 2098 is quite large (262.25 bytes) and therefore some sort
- * of dynamically growing buffer might be better, start at just 16 bytes
- * (for example) and grow only when necessary. Or maybe just by looking
- * at the exponents of the two doubles? */
-# define DOUBLEDOUBLE_MAXBITS 2098
-#endif
-
-/* vhex will contain the values (0..15) of the hex digits ("nybbles"
- * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
- * per xdigit. For the double-double case, this can be rather many.
- * The non-double-double-long-double overshoots since all bits of NV
- * are not mantissa bits, there are also exponent bits. */
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
-#else
-# define VHEX_SIZE (1+(NVSIZE * 8)/4)
-#endif
-
-/* If we do not have a known long double format, (including not using
- * long doubles, or long doubles being equal to doubles) then we will
- * fall back to the ldexp/frexp route, with which we can retrieve at
- * most as many bits as our widest unsigned integer type is. We try
- * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
- *
- * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
- * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
- */
-#if defined(HAS_QUAD) && defined(Uquad_t)
-# define MANTISSATYPE Uquad_t
-# define MANTISSASIZE 8
-#else
-# define MANTISSATYPE UV
-# define MANTISSASIZE UVSIZE
-#endif
-
-#if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
-# define HEXTRACT_LITTLE_ENDIAN
-#elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
-# define HEXTRACT_BIG_ENDIAN
-#else
-# define HEXTRACT_MIX_ENDIAN
-#endif
-
-/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
- * the hexadecimal values (for %a/%A). The nv is the NV where the value
- * are being extracted from (either directly from the long double in-memory
- * presentation, or from the uquad computed via frexp+ldexp). frexp also
- * is used to update the exponent. vhex is the pointer to the beginning
- * of the output buffer (of VHEX_SIZE).
- *
- * The tricky part is that S_hextract() needs to be called twice:
- * the first time with vend as NULL, and the second time with vend as
- * the pointer returned by the first call. What happens is that on
- * the first round the output size is computed, and the intended
- * extraction sanity checked. On the second round the actual output
- * (the extraction of the hexadecimal values) takes place.
- * Sanity failures cause fatal failures during both rounds. */
-STATIC U8*
-S_hextract(const NV nv, int* exponent, U8* vhex, U8* vend)
-{
- U8* v = vhex;
- int ix;
- int ixmin = 0, ixmax = 0;
-
- /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
- * and elsewhere. */
-
- /* These macros are just to reduce typos, they have multiple
- * repetitions below, but usually only one (or sometimes two)
- * of them is really being used. */
- /* HEXTRACT_OUTPUT() extracts the high nybble first. */
-#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
-#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
-#define HEXTRACT_OUTPUT(ix) \
- STMT_START { \
- HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
- } STMT_END
-#define HEXTRACT_COUNT(ix, c) \
- STMT_START { \
- v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
- } STMT_END
-#define HEXTRACT_BYTE(ix) \
- STMT_START { \
- if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
- } STMT_END
-#define HEXTRACT_LO_NYBBLE(ix) \
- STMT_START { \
- if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
- } STMT_END
- /* HEXTRACT_TOP_NYBBLE is just convenience disguise,
- * to make it look less odd when the top bits of a NV
- * are extracted using HEXTRACT_LO_NYBBLE: the highest
- * order bits can be in the "low nybble" of a byte. */
-#define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
-#define HEXTRACT_BYTES_LE(a, b) \
- for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
-#define HEXTRACT_BYTES_BE(a, b) \
- for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
-#define HEXTRACT_IMPLICIT_BIT(nv) \
- STMT_START { \
- if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
- } STMT_END
-
-/* Most formats do. Those which don't should undef this. */
-#define HEXTRACT_HAS_IMPLICIT_BIT
-/* Many formats do. Those which don't should undef this. */
-#define HEXTRACT_HAS_TOP_NYBBLE
-
- /* HEXTRACTSIZE is the maximum number of xdigits. */
-#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
-#else
-# define HEXTRACTSIZE 2 * NVSIZE
-#endif
-
- const U8* vmaxend = vhex + HEXTRACTSIZE;
- PERL_UNUSED_VAR(ix); /* might happen */
- if (!Perl_isinfnan(nv)) {
- (void)Perl_frexp(PERL_ABS(nv), exponent);
- if (vend && (vend <= vhex || vend > vmaxend))
- Perl_croak_nocontext("Hexadecimal float: internal error");
- }
- {
- /* First check if using long doubles. */
-#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
- /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
- * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
- /* The bytes 13..0 are the mantissa/fraction,
- * the 15,14 are the sign+exponent. */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
-# undef HEXTRACT_HAS_TOP_NYBBLE
- HEXTRACT_BYTES_LE(13, 0);
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
- /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
- * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
- /* The bytes 2..15 are the mantissa/fraction,
- * the 0,1 are the sign+exponent. */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
-# undef HEXTRACT_HAS_TOP_NYBBLE
- HEXTRACT_BYTES_BE(2, 15);
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
- /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
- * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
- * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
- * meaning that 2 or 6 bytes are empty padding. */
- /* The bytes 7..0 are the mantissa/fraction */
- const U8* nvp = (const U8*)(&nv);
-# undef HEXTRACT_HAS_IMPLICIT_BIT
-# undef HEXTRACT_HAS_TOP_NYBBLE
- HEXTRACT_BYTES_LE(7, 0);
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
- /* Does this format ever happen? (Wikipedia says the Motorola
- * 6888x math coprocessors used format _like_ this but padded
- * to 96 bits with 16 unused bits between the exponent and the
- * mantissa.) */
- const U8* nvp = (const U8*)(&nv);
-# undef HEXTRACT_HAS_IMPLICIT_BIT
-# undef HEXTRACT_HAS_TOP_NYBBLE
- HEXTRACT_BYTES_BE(0, 7);
-# else
-# define HEXTRACT_FALLBACK
- /* Double-double format: two doubles next to each other.
- * The first double is the high-order one, exactly like
- * it would be for a "lone" double. The second double
- * is shifted down using the exponent so that that there
- * are no common bits. The tricky part is that the value
- * of the double-double is the SUM of the two doubles and
- * the second one can be also NEGATIVE.
- *
- * Because of this tricky construction the bytewise extraction we
- * use for the other long double formats doesn't work, we must
- * extract the values bit by bit.
- *
- * The little-endian double-double is used .. somewhere?
- *
- * The big endian double-double is used in e.g. PPC/Power (AIX)
- * and MIPS (SGI).
- *
- * The mantissa bits are in two separate stretches, e.g. for -0.1L:
- * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
- * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
- */
-# endif
-#else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
- /* Using normal doubles, not long doubles.
- *
- * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
- * bytes, since we might need to handle printf precision, and
- * also need to insert the radix. */
-# if NVSIZE == 8
-# ifdef HEXTRACT_LITTLE_ENDIAN
- /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
- HEXTRACT_TOP_NYBBLE(6);
- HEXTRACT_BYTES_LE(5, 0);
-# elif defined(HEXTRACT_BIG_ENDIAN)
- /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
- HEXTRACT_TOP_NYBBLE(1);
- HEXTRACT_BYTES_BE(2, 7);
-# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
- /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
- HEXTRACT_TOP_NYBBLE(2); /* 6 */
- HEXTRACT_BYTE(1); /* 5 */
- HEXTRACT_BYTE(0); /* 4 */
- HEXTRACT_BYTE(7); /* 3 */
- HEXTRACT_BYTE(6); /* 2 */
- HEXTRACT_BYTE(5); /* 1 */
- HEXTRACT_BYTE(4); /* 0 */
-# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
- /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
- const U8* nvp = (const U8*)(&nv);
- HEXTRACT_IMPLICIT_BIT(nv);
- HEXTRACT_TOP_NYBBLE(5); /* 6 */
- HEXTRACT_BYTE(6); /* 5 */
- HEXTRACT_BYTE(7); /* 4 */
- HEXTRACT_BYTE(0); /* 3 */
- HEXTRACT_BYTE(1); /* 2 */
- HEXTRACT_BYTE(2); /* 1 */
- HEXTRACT_BYTE(3); /* 0 */
-# else
-# define HEXTRACT_FALLBACK
-# endif
-# else
-# define HEXTRACT_FALLBACK
-# endif
-#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
-# ifdef HEXTRACT_FALLBACK
-# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
- /* The fallback is used for the double-double format, and
- * for unknown long double formats, and for unknown double
- * formats, or in general unknown NV formats. */
- if (nv == (NV)0.0) {
- if (vend)
- *v++ = 0;
- else
- v++;
- *exponent = 0;
- }
- else {
- NV d = nv < 0 ? -nv : nv;
- NV e = (NV)1.0;
- U8 ha = 0x0; /* hexvalue accumulator */
- U8 hd = 0x8; /* hexvalue digit */
-
- /* Shift d and e (and update exponent) so that e <= d < 2*e,
- * this is essentially manual frexp(). Multiplying by 0.5 and
- * doubling should be lossless in binary floating point. */
-
- *exponent = 1;
-
- while (e > d) {
- e *= (NV)0.5;
- (*exponent)--;
- }
- /* Now d >= e */
-
- while (d >= e + e) {
- e += e;
- (*exponent)++;
- }
- /* Now e <= d < 2*e */
-
- /* First extract the leading hexdigit (the implicit bit). */
- if (d >= e) {
- d -= e;
- if (vend)
- *v++ = 1;
- else
- v++;
- }
- else {
- if (vend)
- *v++ = 0;
- else
- v++;
- }
- e *= (NV)0.5;
-
- /* Then extract the remaining hexdigits. */
- while (d > (NV)0.0) {
- if (d >= e) {
- ha |= hd;
- d -= e;
- }
- if (hd == 1) {
- /* Output or count in groups of four bits,
- * that is, when the hexdigit is down to one. */
- if (vend)
- *v++ = ha;
- else
- v++;
- /* Reset the hexvalue. */
- ha = 0x0;
- hd = 0x8;
- }
- else
- hd >>= 1;
- e *= (NV)0.5;
- }
-
- /* Flush possible pending hexvalue. */
- if (ha) {
- if (vend)
- *v++ = ha;
- else
- v++;
- }
- }
-# endif
- }
- /* Croak for various reasons: if the output pointer escaped the
- * output buffer, if the extraction index escaped the extraction
- * buffer, or if the ending output pointer didn't match the
- * previously computed value. */
- if (v <= vhex || v - vhex >= VHEX_SIZE ||
- /* For double-double the ixmin and ixmax stay at zero,
- * which is convenient since the HEXTRACTSIZE is tricky
- * for double-double. */
- ixmin < 0 || ixmax >= NVSIZE ||
- (vend && v != vend))
- Perl_croak_nocontext("Hexadecimal float: internal error");
- return v;
-}
-
/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
* infinity or a not-a-number, writes the appropriate strings to the
* buffer, including a zero byte. On success returns the written length,
* excluding the zero byte, on failure (not an infinity, not a nan, or the
- * maxlen too small) returns zero. */
+ * maxlen too small) returns zero.
+ *
+ * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
+ * shared string constants we point to, instead of generating a new
+ * string for each instance. */
STATIC size_t
-S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char format, char plus, char alt) {
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
assert(maxlen >= 4);
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
*s++ = 'N';
*s++ = 'a';
*s++ = 'N';
- if (nan_is_signaling(nv)) {
- *s++ = 's';
- }
- if (alt) {
- U8 vhex[VHEX_SIZE];
- U8* vend;
- U8* v;
- int exponent = 0;
- char* start;
- bool upper = isUPPER(format);
- const char* xdig = PL_hexdigit + (upper ? 16 : 0);
- char xhex = upper ? 'X' : 'x';
- U8 mask;
- NV payload = nv;
- U8* hibyte = nan_hibyte(&payload, &mask);
-
- /* Clear the bits that are not part of the payload. */
- *hibyte &= ~mask;
- *hibyte &= ((1 << (NV_NAN_BITS % 8)) - 1);
-
- vend = S_hextract(payload, &exponent, vhex, NULL);
- S_hextract(payload, &exponent, vhex, vend);
-
- v = vhex;
-
-#ifdef NV_IMPLICIT_BIT
- /* S_hextract thinks it needs to extract the implicit bit,
- * which is bogus with NaN. */
- v++;
-#endif
- while (v < vend && *v == 0) v++;
-
- *s++ = '(';
-
- start = s;
- if (vend - v <= 2 * UVSIZE) {
- *s++ = '0';
- *s++ = xhex;
- start = s;
- while (v < vend) {
- *s++ = xdig[*v++];
- }
- if (s == start) {
- *s++ = '0';
- }
- } else {
- /* If not displayable as an UV, display as hex
- * bytes, then. This happens with e.g. 32-bit
- * (UVSIZE=4) platforms. The format is "\xHH..."
- *
- * Similar formats are accepted on numification.
- *
- * The choice of quoting in the result is not
- * customizable currently. Maybe something could
- * be rigged to follow the '%#'. */
- *s++ = '"';
-
- if ((vend - vhex) % 2) {
- *s++ = '\\';
- *s++ = xhex;
- *s++ = '0';
- *s++ = xdig[*v++];
- }
- while (v < vend) {
- *s++ = '\\';
- *s++ = 'x';
- *s++ = xdig[*v++];
- *s++ = xdig[*v++];
- }
-
- *s++ = '"';
- }
-
- *s++ = ')';
- }
+ /* XXX optionally output the payload mantissa bits as
+ * "(unsigned)" (to match the nan("...") C99 function,
+ * or maybe as "(0xhhh...)" would make more sense...
+ * provide a format string so that the user can decide?
+ * NOTE: would affect the maxlen and assert() logic.*/
}
+
else
return 0;
+ assert((s == buffer + 3) || (s == buffer + 4));
*s++ = 0;
return s - buffer - 1; /* -1: excluding the zero byte */
}
STRLEN size = 5; /* "-Inf\0" */
s = SvGROW_mutable(sv, size);
- len = S_infnan_2pv(SvNVX(sv), s, size, 'g', 0, 0);
+ len = S_infnan_2pv(SvNVX(sv), s, size, 0);
if (len > 0) {
s += len;
SvPOK_on(sv);
PERL_ARGS_ASSERT_F0CONVERT;
if (UNLIKELY(Perl_isinfnan(nv))) {
- STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 'g', 0, 0);
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0);
*len = n;
return endbuf - n;
}
}
-/*
-=for apidoc sv_vcatpvfn
+/*
+=for apidoc sv_vcatpvfn
+
+=for apidoc sv_vcatpvfn_flags
+
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV. Uses an array of SVs if the C style variable argument list is
+missing (NULL). When running with taint checks enabled, indicates via
+C<maybe_tainted> if results are untrustworthy (often due to the use of
+locales).
+
+If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+
+Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
+
+=cut
+*/
+
+#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
+ vecstr = (U8*)SvPV_const(vecsv,veclen);\
+ vec_utf8 = DO_UTF8(vecsv);
+
+/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+
+void
+Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
+{
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
+
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+}
+
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
+ * The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
+ * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
+ * after the first 1023 zero bits.
+ *
+ * XXX The 2098 is quite large (262.25 bytes) and therefore some sort
+ * of dynamically growing buffer might be better, start at just 16 bytes
+ * (for example) and grow only when necessary. Or maybe just by looking
+ * at the exponents of the two doubles? */
+# define DOUBLEDOUBLE_MAXBITS 2098
+#endif
+
+/* vhex will contain the values (0..15) of the hex digits ("nybbles"
+ * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
+ * per xdigit. For the double-double case, this can be rather many.
+ * The non-double-double-long-double overshoots since all bits of NV
+ * are not mantissa bits, there are also exponent bits. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
+#else
+# define VHEX_SIZE (1+(NVSIZE * 8)/4)
+#endif
+
+/* If we do not have a known long double format, (including not using
+ * long doubles, or long doubles being equal to doubles) then we will
+ * fall back to the ldexp/frexp route, with which we can retrieve at
+ * most as many bits as our widest unsigned integer type is. We try
+ * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
+ *
+ * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
+ * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
+ */
+#if defined(HAS_QUAD) && defined(Uquad_t)
+# define MANTISSATYPE Uquad_t
+# define MANTISSASIZE 8
+#else
+# define MANTISSATYPE UV
+# define MANTISSASIZE UVSIZE
+#endif
+
+#if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
+# define HEXTRACT_LITTLE_ENDIAN
+#elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
+# define HEXTRACT_BIG_ENDIAN
+#else
+# define HEXTRACT_MIX_ENDIAN
+#endif
+
+/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
+ * the hexadecimal values (for %a/%A). The nv is the NV where the value
+ * are being extracted from (either directly from the long double in-memory
+ * presentation, or from the uquad computed via frexp+ldexp). frexp also
+ * is used to update the exponent. vhex is the pointer to the beginning
+ * of the output buffer (of VHEX_SIZE).
+ *
+ * The tricky part is that S_hextract() needs to be called twice:
+ * the first time with vend as NULL, and the second time with vend as
+ * the pointer returned by the first call. What happens is that on
+ * the first round the output size is computed, and the intended
+ * extraction sanity checked. On the second round the actual output
+ * (the extraction of the hexadecimal values) takes place.
+ * Sanity failures cause fatal failures during both rounds. */
+STATIC U8*
+S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+{
+ U8* v = vhex;
+ int ix;
+ int ixmin = 0, ixmax = 0;
+
+ /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
+ * and elsewhere. */
+
+ /* These macros are just to reduce typos, they have multiple
+ * repetitions below, but usually only one (or sometimes two)
+ * of them is really being used. */
+ /* HEXTRACT_OUTPUT() extracts the high nybble first. */
+#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
+#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
+#define HEXTRACT_OUTPUT(ix) \
+ STMT_START { \
+ HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
+ } STMT_END
+#define HEXTRACT_COUNT(ix, c) \
+ STMT_START { \
+ v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
+ } STMT_END
+#define HEXTRACT_BYTE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ } STMT_END
+#define HEXTRACT_LO_NYBBLE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
+ } STMT_END
+ /* HEXTRACT_TOP_NYBBLE is just convenience disguise,
+ * to make it look less odd when the top bits of a NV
+ * are extracted using HEXTRACT_LO_NYBBLE: the highest
+ * order bits can be in the "low nybble" of a byte. */
+#define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
+#define HEXTRACT_BYTES_LE(a, b) \
+ for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_BYTES_BE(a, b) \
+ for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_IMPLICIT_BIT(nv) \
+ STMT_START { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } STMT_END
+
+/* Most formats do. Those which don't should undef this. */
+#define HEXTRACT_HAS_IMPLICIT_BIT
+/* Many formats do. Those which don't should undef this. */
+#define HEXTRACT_HAS_TOP_NYBBLE
-=for apidoc sv_vcatpvfn_flags
+ /* HEXTRACTSIZE is the maximum number of xdigits. */
+#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
+#else
+# define HEXTRACTSIZE 2 * NVSIZE
+#endif
-Processes its arguments like C<vsprintf> and appends the formatted output
-to an SV. Uses an array of SVs if the C style variable argument list is
-missing (NULL). When running with taint checks enabled, indicates via
-C<maybe_tainted> if results are untrustworthy (often due to the use of
-locales).
+ const U8* vmaxend = vhex + HEXTRACTSIZE;
+ PERL_UNUSED_VAR(ix); /* might happen */
+ (void)Perl_frexp(PERL_ABS(nv), exponent);
+ if (vend && (vend <= vhex || vend > vmaxend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ {
+ /* First check if using long doubles. */
+#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
+# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
+ * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+ /* The bytes 13..0 are the mantissa/fraction,
+ * the 15,14 are the sign+exponent. */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_LE(13, 0);
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
+ * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
+ /* The bytes 2..15 are the mantissa/fraction,
+ * the 0,1 are the sign+exponent. */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_BE(2, 15);
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+ /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
+ * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
+ * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
+ * meaning that 2 or 6 bytes are empty padding. */
+ /* The bytes 7..0 are the mantissa/fraction */
+ const U8* nvp = (const U8*)(&nv);
+# undef HEXTRACT_HAS_IMPLICIT_BIT
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_LE(7, 0);
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ /* Does this format ever happen? (Wikipedia says the Motorola
+ * 6888x math coprocessors used format _like_ this but padded
+ * to 96 bits with 16 unused bits between the exponent and the
+ * mantissa.) */
+ const U8* nvp = (const U8*)(&nv);
+# undef HEXTRACT_HAS_IMPLICIT_BIT
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_BE(0, 7);
+# else
+# define HEXTRACT_FALLBACK
+ /* Double-double format: two doubles next to each other.
+ * The first double is the high-order one, exactly like
+ * it would be for a "lone" double. The second double
+ * is shifted down using the exponent so that that there
+ * are no common bits. The tricky part is that the value
+ * of the double-double is the SUM of the two doubles and
+ * the second one can be also NEGATIVE.
+ *
+ * Because of this tricky construction the bytewise extraction we
+ * use for the other long double formats doesn't work, we must
+ * extract the values bit by bit.
+ *
+ * The little-endian double-double is used .. somewhere?
+ *
+ * The big endian double-double is used in e.g. PPC/Power (AIX)
+ * and MIPS (SGI).
+ *
+ * The mantissa bits are in two separate stretches, e.g. for -0.1L:
+ * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
+ * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
+ */
+# endif
+#else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
+ /* Using normal doubles, not long doubles.
+ *
+ * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
+ * bytes, since we might need to handle printf precision, and
+ * also need to insert the radix. */
+# if NVSIZE == 8
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(6);
+ HEXTRACT_BYTES_LE(5, 0);
+# elif defined(HEXTRACT_BIG_ENDIAN)
+ /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(1);
+ HEXTRACT_BYTES_BE(2, 7);
+# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
+ /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(2); /* 6 */
+ HEXTRACT_BYTE(1); /* 5 */
+ HEXTRACT_BYTE(0); /* 4 */
+ HEXTRACT_BYTE(7); /* 3 */
+ HEXTRACT_BYTE(6); /* 2 */
+ HEXTRACT_BYTE(5); /* 1 */
+ HEXTRACT_BYTE(4); /* 0 */
+# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
+ /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(5); /* 6 */
+ HEXTRACT_BYTE(6); /* 5 */
+ HEXTRACT_BYTE(7); /* 4 */
+ HEXTRACT_BYTE(0); /* 3 */
+ HEXTRACT_BYTE(1); /* 2 */
+ HEXTRACT_BYTE(2); /* 1 */
+ HEXTRACT_BYTE(3); /* 0 */
+# else
+# define HEXTRACT_FALLBACK
+# endif
+# else
+# define HEXTRACT_FALLBACK
+# endif
+#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
+# ifdef HEXTRACT_FALLBACK
+# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
+ /* The fallback is used for the double-double format, and
+ * for unknown long double formats, and for unknown double
+ * formats, or in general unknown NV formats. */
+ if (nv == (NV)0.0) {
+ if (vend)
+ *v++ = 0;
+ else
+ v++;
+ *exponent = 0;
+ }
+ else {
+ NV d = nv < 0 ? -nv : nv;
+ NV e = (NV)1.0;
+ U8 ha = 0x0; /* hexvalue accumulator */
+ U8 hd = 0x8; /* hexvalue digit */
-If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+ /* Shift d and e (and update exponent) so that e <= d < 2*e,
+ * this is essentially manual frexp(). Multiplying by 0.5 and
+ * doubling should be lossless in binary floating point. */
-Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
+ *exponent = 1;
-=cut
-*/
+ while (e > d) {
+ e *= (NV)0.5;
+ (*exponent)--;
+ }
+ /* Now d >= e */
-#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
- vecstr = (U8*)SvPV_const(vecsv,veclen);\
- vec_utf8 = DO_UTF8(vecsv);
+ while (d >= e + e) {
+ e += e;
+ (*exponent)++;
+ }
+ /* Now e <= d < 2*e */
-/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+ /* First extract the leading hexdigit (the implicit bit). */
+ if (d >= e) {
+ d -= e;
+ if (vend)
+ *v++ = 1;
+ else
+ v++;
+ }
+ else {
+ if (vend)
+ *v++ = 0;
+ else
+ v++;
+ }
+ e *= (NV)0.5;
-void
-Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
- va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
-{
- PERL_ARGS_ASSERT_SV_VCATPVFN;
+ /* Then extract the remaining hexdigits. */
+ while (d > (NV)0.0) {
+ if (d >= e) {
+ ha |= hd;
+ d -= e;
+ }
+ if (hd == 1) {
+ /* Output or count in groups of four bits,
+ * that is, when the hexdigit is down to one. */
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ /* Reset the hexvalue. */
+ ha = 0x0;
+ hd = 0x8;
+ }
+ else
+ hd >>= 1;
+ e *= (NV)0.5;
+ }
- sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+ /* Flush possible pending hexvalue. */
+ if (ha) {
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ }
+ }
+# endif
+ }
+ /* Croak for various reasons: if the output pointer escaped the
+ * output buffer, if the extraction index escaped the extraction
+ * buffer, or if the ending output pointer didn't match the
+ * previously computed value. */
+ if (v <= vhex || v - vhex >= VHEX_SIZE ||
+ /* For double-double the ixmin and ixmax stay at zero,
+ * which is convenient since the HEXTRACTSIZE is tricky
+ * for double-double. */
+ ixmin < 0 || ixmax >= NVSIZE ||
+ (vend && v != vend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ return v;
}
void
2 * NVSIZE + /* 2 hexdigits for each byte */
2 + /* "p+" */
6 + /* exponent: sign, plus up to 16383 (quad fp) */
- 1; /* \0 */
+ 1; /* \0 */
#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* However, for the "double double", we need more.
* Since each double has their own exponent, the
else if (i > 0) {
need = BIT_DIGITS(i);
} /* if i < 0, the number of digits is hard to predict. */
- } else if (UNLIKELY(Perl_isnan(nv))) {
- need +=
- 3 + /* nan */
- 1 + /* 's', maybe */
- 1; /* \0 */
-
- if (alt) {
- /* NaN payload - all of it really only needed
- * if we have a full payload. */
- need +=
- 1 + /* '(' */
-#if NVSIZE == UVSIZE
- /* 0x... */
- 2 + /* "0x" */
- 2 * (NV_MANT_REAL_DIG + 7) / 8 +
-#else
- /* hexbytes \xHH */
- 2 + /* '...' */
- 4 * (NV_MANT_REAL_DIG + 7) / 8 +
-#endif
- 1; /* ')' */
- }
- }
+ }
need += has_precis ? precis : 6; /* known default */
if (need < width)
* should be output as 0x0.0000000000001p-1022 to
* match its internal structure. */
- vend = S_hextract(nv, &exponent, vhex, NULL);
- S_hextract(nv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
# ifdef HEXTRACT_HAS_IMPLICIT_BIT
}
}
else {
- elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, c, plus, alt);
+ elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
if (elen) {
- /* Not affecting infnan output: precision, fill. */
+ /* Not affecting infnan output: precision, alt, fill. */
if (elen < width) {
if (left) {
/* Pack the back with spaces. */
is eval { unpack "P3", pack 'P', $NaN }, "NaN", "pack P +NaN";
for my $i (@NaN) {
- if (($i =~ /snan/i || $i =~ /nans/i) &&
- (($i + 0) eq $PInf || ($i + 0 eq $NInf))) {
- # Crazy but apparently true: signaling nan with zero payload
- # can be Inf or -Inf on some platforms (like x86).
- } else {
- cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
- is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
- }
+ cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
+ is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
}
ok(!($NaN < 0), "NaN is not lt zero");
[ "nan", 0, $NaN ],
[ "nanxy", 1, $NaN ],
[ "nan34", 1, $NaN ],
- [ "nan0x34", 1, $NaN ],
- [ "nan 34", 1, $NaN ],
- [ "nan 0x34", 1, $NaN ],
[ "nanq", 0, $NaN ],
- # [ "nans", 0, $NaN, $PInf ], # Odd but valid.
+ [ "nans", 0, $NaN ],
[ "nanx", 1, $NaN ],
[ "nanqy", 1, $NaN ],
- [ "nanxy", 1, $NaN ],
[ "nan(123)", 0, $NaN ],
- [ "nan(123)xy", 1, $NaN ],
[ "nan(0x123)", 0, $NaN ],
[ "nan(123xy)", 1, $NaN ],
- [ "nan(123x)y", 1, $NaN ],
- [ "nan(1)(2)", 1, $NaN ],
- [ "nan(1xy2)", 1, $NaN ],
- [ "nan(1)x(2)", 1, $NaN ],
- [ "nan(1)x(2)", 1, $NaN ],
- [ "nan(1)x(2)y", 1, $NaN ],
[ "nan(0x123xy)", 1, $NaN ],
[ "nanq(123)", 0, $NaN ],
- [ "nanx(123)", 1, $NaN ],
- [ "nanx(123)y", 1, $NaN ],
- [ "nanx(123y)", 1, $NaN ],
- [ "nanx(123y)z", 1, $NaN ],
[ "nan(123", 1, $NaN ],
+ [ "nan(", 1, $NaN ],
[ "1.#NANQ", 0, $NaN ],
[ "1.#QNAN", 0, $NaN ],
[ "1.#NANQx", 1, $NaN ],
[ " nan", 0, $NaN ],
[ "nan ", 0, $NaN ],
[ " nan ", 0, $NaN ],
- [ " nan(123) ", 0, $NaN ],
];
for my $t (@$T) {
is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]");
if ($t->[1]) {
like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/,
- "'$t->[2]' numify warn");
+ "$t->[2] numify warn");
} else {
is($w, "", "no warning expected");
}
is("$b", "$t->[2]", "$n plus one is $t->[2]");
if ($t->[1]) {
like($w, qr/^Argument \Q"$n"\E isn't numeric/,
- "'$n' numify warn");
+ "$n numify warn");
} else {
is($w, "", "no warning expected");
}
}
}
-# === NaN quiet/signaling/payload ===
-
-# The '#' or 'the alt' of printf knows how to prettyprint NaN payloads.
-
-SKIP: {
- # Test only on certain known platforms since the features
- # are not that well standardized.
- unless (
- ((
- $^O eq 'linux'
- ||
- $^O eq 'darwin' # OS X
- ||
- $^O eq 'freebsd'
- )
- &&
- (
- (
- $Config{nvsize} == 8 && # double
- $Config{doublekind} == 3 # IEEE double little-endian (x86)
- )
- ||
- (
- $Config{uselongdouble} &&
- $Config{nvsize} == 16 && # long double
- $Config{longdblkind} == 3 # x86 80-bit extended precision
- )
- ))
- ||
- ($^O eq 'solaris' &&
- $Config{nvsize} == 8 && # double
- ($Config{uvsize} == 4 # 32-bit
- ||
- $Config{uvsize} == 8 # 64-bit (-Duse64bitint)
- ) &&
- $Config{doublesize} == 8 &&
- $Config{doublekind} == 4 # IEEE double big-endian (sparc)
- )
- ||
- ($^O eq 'hpux' &&
- $Config{nvsize} == 8 && # double
- $Config{uvsize} == 4 && # 32-bit
- $Config{doublesize} == 8 &&
- $Config{doublekind} == 4 # IEEE double big-endian (hppa)
- )
- ||
- ($^O eq 'dec_osf' && # Digital UNIX aka Tru64
- $Config{nvsize} == 8 && # double
- $Config{uvsize} == 8 && # 32-bit
- $Config{doublesize} == 8 &&
- $Config{doublekind} == 3 # IEEE double little-endian (alpha)
- )
- ) {
- my ($uselongdouble, $longdblsize, $longdblkind) =
- $Config{uselongdouble} ?
- ($Config{uselongdouble},
- $Config{longdblsize},
- $Config{longdblkind}) :
- ('undef', 'undef', 'undef');
- skip("skipping NaN specials testing on os=$^O, uvsize=$Config{uvsize}, nvsize=$Config{nvsize}, doublesize=$Config{doublesize}, doublekind=$Config{doublekind}, uselongdouble=$uselongdouble, longdblsize=$longdblsize, longdblkind=$longdblkind", 16);
- }
-
- is(sprintf("%#g", $NaN), "NaN(0x0)", "sprintf %#g");
- is(sprintf("%#g", "nan"), "NaN(0x0)");
- is(sprintf("%#g", "nanq"), "NaN(0x0)");
- is(sprintf("%#g", "qnan"), "NaN(0x0)");
-
- # This weirdness brought to you courtesy of asymmetry in the IEEE spec.
- # In x86 style nans, nans(0) is equal to infinity or -infinity.
- # In mips/hppa style, nans(0) is nans(0).
- like(sprintf("%#g", "nans"), qr/^(?:-?Inf|NaNs\(0x0\))$/);
- like(sprintf("%#g", "snan"), qr/^(?:-?Inf|NaNs\(0x0\))$/);
-
- is(sprintf("%#g", "nan(12345)"), "NaN(0x3039)");
- is(sprintf("%#g", "nan(0b101101)"), "NaN(0x2d)");
- is(sprintf("%#g", "nan(0x12345)"), "NaN(0x12345)");
- is(sprintf("%#g", "nanq(0x123EF)"), "NaN(0x123ef)");
- is(sprintf("%#g", "nans(0x12345)"), "NaNs(0x12345)");
- is(sprintf("%#g", "snan(0x12345)"), "NaNs(0x12345)");
-
- is(sprintf("%#G", "nanq(0x123ef)"), "NaN(0X123EF)");
-
- SKIP: {
- if (ord('A') == 65) { # ASCII
- is(sprintf("%#g", "nan('obot')"), "NaN(0x6f626f74)", "nanobot");
- } elsif (ord('A') == 193) { # EBCDIC
- is(sprintf("%#g", "nan('obot')"), "NaN(0x968296a3)", "nanobot");
- } else {
- skip "unknown encoding", 1;
- }
-}
-
-}
-
done_testing();
https://perl5.git.perl.org / perl5.git / commitdiff