GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
)
-/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
- * has a mandatory return value, even though that value is just the same
- * as the buf arg */
#ifdef PERL_UTF8_CACHE_ASSERT
/* if adding more checks watch out for the following tests:
#ifdef PERL_NEW_COPY_ON_WRITE
/* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
- * to store the COW count. So in general, allocate one more byte than
+ * to store the CowREFCNT. So in general, allocate one more byte than
* asked for, to make it likely this byte is always spare: and thus
* make more strings COW-able.
* If the new size is a big power of two, don't bother: we assume the
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
- minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
+ minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 2;
if (newlen < minlen)
newlen = minlen;
#ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv)));
-#endif
#ifdef NV_PRESERVES_UV
(void)SvIOKp_on(sv);
if (SvTYPE(sv) < SVt_NV) {
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
sv_upgrade(sv, SVt_NV);
-#ifdef USE_LONG_DOUBLE
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#else
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
+ "0x%"UVxf" num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#endif
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
and ideally should be fixed. */
return 0.0;
}
-#if defined(USE_LONG_DOUBLE)
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#else
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#endif
return SvNVX(sv);
}
return ptr;
}
+/* 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 returns zero. */
+STATIC size_t
+S_infnan_copy(NV nv, char* buffer, size_t maxlen) {
+ if (maxlen < 4)
+ return 0;
+ else {
+ char* s = buffer;
+ if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5)
+ return 0;
+ *s++ = '-';
+ }
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+ else if (Perl_isnan(nv)) {
+ *s++ = 'N';
+ *s++ = 'a';
+ *s++ = 'N';
+ /* XXX output the payload mantissa bits as "(hhh...)" */
+ }
+ else
+ return 0;
+ *s++ = 0;
+ return s - buffer - 1;
+ }
+}
+
/*
=for apidoc sv_2pv_flags
*s++ = '0';
*s = '\0';
} else {
- dSAVE_ERRNO;
+ STRLEN len;
/* The +20 is pure guesswork. Configure test needed. --jhi */
s = SvGROW_mutable(sv, NV_DIG + 20);
- /* some Xenix systems wipe out errno here */
+
+ len = S_infnan_copy(SvNVX(sv), s, SvLEN(sv));
+ if (len > 0)
+ s += len;
+ else {
+ dSAVE_ERRNO;
+ /* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
- SvPOK_on(sv);
-#else
- {
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
-
- /* If the radix character is UTF-8, and actually is in the
- * output, turn on the UTF-8 flag for the scalar */
- if (PL_numeric_local
- && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
- && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ SvPOK_on(sv);
+#else
{
- SvUTF8_on(sv);
+ DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+
+ /* If the radix character is UTF-8, and actually is in the
+ * output, turn on the UTF-8 flag for the scalar */
+ if (PL_numeric_local
+ && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+ && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ RESTORE_LC_NUMERIC();
}
- RESTORE_LC_NUMERIC();
- }
- /* We don't call SvPOK_on(), because it may come to pass that the
- * locale changes so that the stringification we just did is no
- * longer correct. We will have to re-stringify every time it is
- * needed */
+ /* We don't call SvPOK_on(), because it may come to
+ * pass that the locale changes so that the
+ * stringification we just did is no longer correct. We
+ * will have to re-stringify every time it is needed */
#endif
- RESTORE_ERRNO;
- while (*s) s++;
+ RESTORE_ERRNO;
+ }
+ while (*s) s++;
}
}
else if (isGV_with_GP(sv)) {
* set so starts from there. Otherwise, can use memory copy to
* get up to where we are now, and then start from here */
- if (invariant_head <= 0) {
+ if (invariant_head == 0) {
d = dst;
} else {
Copy(s, dst, invariant_head, char);
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
#endif /* PERL_PRESERVE_IVUV */
if (!numtype && ckWARN(WARN_NUMERIC))
* arranged in order (although not consecutively) and that only
* [A-Za-z] are accepted by isALPHA in the C locale.
*/
- if (*d != 'z' && *d != 'Z') {
+ if (isALPHA_FOLD_NE(*d, 'z')) {
do { ++*d; } while (!isALPHA(*d));
return;
}
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
}
#endif /* PERL_PRESERVE_IVUV */
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatibility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ : (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
+/* vhex will contain the values (0..15) of the hex digits ("nybbles"
+ * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa,
+ * four bits per xdigit. */
+#define VHEX_SIZE (1+128/4)
+
+/* 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 having 64-bit
+ * UV. */
+#if defined(HAS_QUAD) && defined(Uquad_t)
+# define MANTISSATYPE Uquad_t
+# define MANTISSASIZE 8
+#else
+# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */
+# define MANTISSASIZE UVSIZE
+#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_IMPLICIT_BIT() \
+ if (exponent) { \
+ if (vend) \
+ *v++ = 1; \
+ else \
+ v++; \
+ }
+
+ /* First see if we are using long doubles. */
+#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
+ const U8* nvp = (const U8*)(&nv);
+# define HEXTRACTSIZE NVSIZE
+ (void)Perl_frexp(PERL_ABS(nv), exponent);
+# 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. */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 13; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# 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. */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 2; ix <= 15; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# 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 */
+ /* There explicitly is *no* implicit bit in this case. */
+ for (ix = 7; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ /* (does this format ever happen?) */
+ /* There explicitly is *no* implicit bit in this case. */
+ for (ix = 0; ix < 8; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+ /* Where is this used?
+ * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f */
+ HEXTRACT_IMPLICIT_BIT();
+ if (vend)
+ HEXTRACT_OUTPUT_LO(14);
+ else
+ HEXTRACT_COUNT(14, 1);
+ for (ix = 13; ix >= 8; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+ /* XXX not extracting from the second double -- see the discussion
+ * below for the big endian double double. */
+# if 0
+ if (vend)
+ HEXTRACT_OUTPUT_LO(6);
+ else
+ HEXTRACT_COUNT(6, 1);
+ for (ix = 5; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# endif
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+ /* Used in e.g. PPC/Power (AIX) and MIPS.
+ *
+ * The mantissa bits are in two separate stretches, e.g. for -0.1L:
+ * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a
+ */
+ HEXTRACT_IMPLICIT_BIT();
+ if (vend)
+ HEXTRACT_OUTPUT_LO(1);
+ else
+ HEXTRACT_COUNT(1, 1);
+ for (ix = 2; ix < 8; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+ /* XXX not extracting the second double mantissa bits- this is not
+ * right nor ideal (we effectively reduce the output format to
+ * that of a "single double", only 53 bits), but we do not know
+ * exactly how to do the extraction correctly so that it matches
+ * the semantics of, say, the IEEE quadruple float. */
+# if 0
+ if (vend)
+ HEXTRACT_OUTPUT_LO(9);
+ else
+ HEXTRACT_COUNT(9, 1);
+ for (ix = 10; ix < 16; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# endif
+# else
+ Perl_croak(aTHX_
+ "Hexadecimal float: unsupported long double format");
+# endif
+#else
+ /* If not using long doubles (or if the long double format is
+ * known but not yet supported), try to retrieve the mantissa bits
+ * via frexp+ldexp. */
+
+ NV norm = Perl_frexp(PERL_ABS(nv), exponent);
+ /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to
+ * inspect; but in practice we don't want the leading nybbles that
+ * are zero. With the common IEEE 754 value for NV_MANT_DIG being
+ * 53, we want the limit byte to be (int)((53-1)/8) == 6.
+ *
+ * Note that this is _not_ inspecting the in-memory format of the
+ * nv (as opposed to the long double method), but instead the UV
+ * retrieved with the frexp+ldexp invocation. */
+# if MANTISSASIZE * 8 > NV_MANT_DIG
+ MANTISSATYPE mantissa = (MANTISSATYPE)Perl_ldexp(norm, NV_MANT_DIG);
+ int limit_byte = (NV_MANT_DIG - 1) / 8;
+# else
+ /* There will be low-order precision loss. Try to salvage as many
+ * bits as possible. Will truncate, not round. */
+ MANTISSATYPE mantissa =
+ Perl_ldexp(norm,
+ /* The highest possible shift by two that fits in the
+ * mantissa and is aligned (by four) the same was as
+ * NV_MANT_DIG. */
+ MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4));
+ int limit_byte = MANTISSASIZE - 1;
+# endif
+ const U8* nvp = (const U8*)(&mantissa);
+# define HEXTRACTSIZE MANTISSASIZE
+ /* We make here the wild assumption that the endianness of doubles
+ * is similar to the endianness of integers, and that there is no
+ * middle-endianness. This may come back to haunt us (the rumor
+ * has it that ARM can be quite haunted).
+ *
+ * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
+ * bytes, since we might need to handle printf precision, and also
+ * insert the radix.
+ */
+# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+ /* Little endian. */
+ for (ix = limit_byte; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# else
+ /* Big endian. */
+ for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT(ix);
+ else
+ HEXTRACT_COUNT(ix, 2);
+ }
+# endif
+ /* If there are not enough bits in MANTISSATYPE, we couldn't get
+ * all of them, issue a warning.
+ *
+ * Note that NV_PRESERVES_UV_BITS would not help here, it is the
+ * wrong way around. */
+# if NV_MANT_DIG > MANTISSASIZE * 8
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: precision loss");
+# endif
+#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 ||
+ ixmin < 0 || ixmax >= HEXTRACTSIZE ||
+ (vend && v != vend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ return v;
+}
+
void
Perl_sv_vcatpvfn_flags(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,
I32 epix = 0; /* explicit precision index */
I32 evix = 0; /* explicit vector index */
bool asterisk = FALSE;
+ bool infnan = FALSE;
/* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
}
}
+ if (argsv && SvNOK(argsv)) {
+ /* XXX va_arg(*args) case? */
+ infnan = Perl_isinfnan(SvNV(argsv));
+ }
+
switch (c = *q++) {
/* STRINGS */
case 'c':
if (vectorize)
goto unknown;
- uv = (args) ? va_arg(*args, int) : SvIV(argsv);
+ uv = (args) ? va_arg(*args, int) :
+ infnan ? UNICODE_REPLACEMENT : SvIV(argsv);
if ((uv > 255 ||
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
/* INTEGERS */
case 'p':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
/* FALLTHROUGH */
case 'd':
case 'i':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
if (!veclen)
base = 16;
uns_integer:
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
vector:
/* FLOATING POINT */
+ floating_point:
+
case 'F':
c = 'f'; /* maybe %F isn't supported here */
/* FALLTHROUGH */
: SvNV(argsv);
need = 0;
- /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
- else. frexp() has some unspecified behaviour for those three */
- if (c != 'e' && c != 'E' && (nv * 0) == 0) {
+ /* frexp() (or frexpl) has some unspecified behaviour for
+ * nan/inf/-inf, so let's avoid calling that on those
+ * three values. nv * 0 will be NaN for NaN, +Inf and -Inf,
+ * and 0 for anything else. */
+ if (isALPHA_FOLD_NE(c, 'e') && (nv * 0) == 0) {
i = PERL_INT_MIN;
- /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
- will cast our (long double) to (double) */
(void)Perl_frexp(nv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp");
- hexfp = (c == 'a' || c == 'A');
+ /* Do not set hexfp earlier since we want to printf
+ * Inf/NaN for Inf/NAN, not their hexfp. */
+ hexfp = isALPHA_FOLD_EQ(c, 'a');
if (UNLIKELY(hexfp)) {
- /* Hexadecimal floating point: this size
- * computation probably overshoots, but that is
- * better than undershooting. */
+ /* This seriously overshoots in most cases, but
+ * better the undershooting. Firstly, all bytes
+ * of the NV are not mantissa, some of them are
+ * exponent. Secondly, for the reasonably common
+ * long doubles case, the "80-bit extended", two
+ * or six bytes of the NV are unused. */
need +=
- (nv < 0) + /* possible unary minus */
+ (nv < 0) ? 1 : 0 + /* possible unary minus */
2 + /* "0x" */
1 + /* the very unlikely carry */
1 + /* "1" */
1 + /* "." */
- /* We want one byte per each 4 bits in the
- * mantissa. This works out to about 0.83
- * bytes per NV decimal digit (of 4 bits):
- * (NV_DIG * log(10)/log(2)) / 4,
- * we overestimate by using 5/6 (0.8333...) */
- ((NV_DIG * 5) / 6 + 1) +
+ 2 * NVSIZE + /* 2 hexdigits for each byte */
2 + /* "p+" */
- (i >= 0 ? BIT_DIGITS(i) : 1 + BIT_DIGITS(-i)) +
+ BIT_DIGITS(NV_MAX_EXP) + /* exponent */
1; /* \0 */
+#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+ /* However, for the "double double", we need more.
+ * Since each double has their own exponent, the
+ * doubles may float (haha) rather far from each
+ * other, and the number of required bits is much
+ * larger, up to total of 1028 bits. (NOTE: this
+ * is not actually implemented properly yet,
+ * we are using just the first double, see
+ * S_hextract() for details. But let's prepare
+ * for the future.) */
+
+ /* 2 hexdigits for each byte. */
+ need += (1028/8 - DOUBLESIZE + 1) * 2;
+#endif
#ifdef USE_LOCALE_NUMERIC
STORE_LC_NUMERIC_SET_TO_NEEDED();
if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))
if (UNLIKELY(hexfp)) {
/* Hexadecimal floating point. */
char* p = PL_efloatbuf;
- /* vdig will contain the values (0..15) of the hex
- * digits ("nybbles" of 4 bits); at most 128 bits
- * mantissa, 4 bits per xdigit. */
- U8 vdig[128 / 4];
- U8* v = vdig; /* working pointer to vdig */
- U8* vend; /* pointer to one beyond last of vdig */
+ U8 vhex[VHEX_SIZE];
+ U8* v = vhex; /* working pointer to vhex */
+ U8* vend; /* pointer to one beyond last digit of vhex */
U8* vfnz = NULL; /* first non-zero */
const bool lower = (c == 'a');
- /* At output the values of vdig (up to vend) will
+ /* At output the values of vhex (up to vend) will
* be mapped through the xdig to get the actual
* human-readable xdigits. */
const char* xdig = PL_hexdigit;
int zerotail = 0; /* how many extra zeros to append */
- int exponent; /* exponent of the floating point input */
- int ix; /* working horse index */
-
- /* 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 having 64-bit UV. */
-#if UVSIZE == 8
-# define MANTISSATYPE UV
-# define MANTISSASIZE UVSIZE
-#elif defined(HAS_QUAD) && defined(Uquad_t)
-# define MANTISSATYPE Uquad_t
-# define MANTISSASIZE 8
-#else
-# define MANTISSATYPE UV /* Will likely lose precision. */
-# define MANTISSASIZE UVSIZE
-#endif
-
- /* First we see if we are using long doubles. */
-
-#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
- {
- const U8* nvp = (const U8*)(&nv);
- (void)Perl_frexp(PERL_ABS(nv), &exponent);
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
- /* The bytes 15..0 are the mantissa/fraction */
- for (ix = 15; ix >= 0; ix--) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
- /* Used in e.g. Solaris Sparc and HP-PA HP-UX, e.g.
- * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
- /* The bytes 0..15 are the mantissa/fraction */
- for (ix = 0; ix <= 15; ix++) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
-# 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 4 or 6 bytes are empty padding. */
- /* The bytes 7..0 are the mantissa/fraction */
- for (ix = 7; ix >= 0; ix--) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
- /* The last 10 bytes are the mantissa/fraction.
- * (does this format ever happen?) */
- for (ix = LONGDBLSIZE - 10; ix < LONGDBLSIZE; ix++) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
- /* XXX: implement, the mantissa/fraction bits are in
- * two separate stretches. */
-# define LONGDOUBLE_FALLBACK
- goto frexp_ldexp_fallback;
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
- /* XXX: implement, the mantissa/fraction bits are in
- * two separate stretches. */
- /* Used in e.g. PPC/Power and MIPS. */
- /* -0.1L:
- * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a
- * as seen in PowerPC AIX, as opposed to "true" 128-bit
- * IEEE 754:
- * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a
- * as seen in HP-PA HP-UX. */
-# define LONGDOUBLE_FALLBACK
- goto frexp_ldexp_fallback;
-# else
- Perl_croak(aTHX_
- "Hexadecimal float: unsupported long double format");
-# endif
- }
-
-# ifdef LONGDOUBLE_FALLBACK
- frexp_ldexp_fallback:
-# endif
-#else
- {
- /* If not using long doubles (or if the long double
- * format is known but not yet supported), try to
- * retrieve the mantissa bits via frexp+ldexp. */
-
- MANTISSATYPE mantissa =
- Perl_ldexp(Perl_frexp(PERL_ABS(nv), &exponent),
- NV_MANT_DIG);
- const U8* nvp = (const U8*)(&mantissa);
- /* Theoretically we have all the bytes [0, UVSIZE - 1]
- * to inspect; but in practice we don't want the
- * leading nybbles that are zero. With the common
- * IEEE 754 value for NV_MANT_DIG being 53, we want
- * the limit byte to be (int)((52-1)/8) == 6.
- *
- * Note that this is _not_ inspecting the in-memory
- * format of the nv (as opposed to the long double
- * method), but instead the UV retrieved with the
- * frexp+ldexp invocation. */
- int limit_byte = (NV_MANT_DIG - 1) / 8;
- /* We make here the wild assumption that
- * the endianness of doubles is similar to
- * the endianness of integers, and that
- * there is no middle-endianness. This may
- * come back to haunt us (the rumor has it
- * that ARM can be quite haunted).
- *
- * We generate 4-bit xdigits (nybble/nibble)
- * instead of 8-bit bytes, since we might need
- * to handle printf precision, and also insert
- * the decimal point.
- */
-# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
- /* Little endian. */
- for (ix = limit_byte; ix >= 0; ix--) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
+ int exponent = 0; /* exponent of the floating point input */
+
+ /* XXX: denormals, NaN, Inf.
+ *
+ * For example with denormals, (assuming the vanilla
+ * 64-bit double): the exponent is zero. 1xp-1074 is
+ * the smallest denormal and the smallest double, it
+ * should be output as 0x0.0000000000001p-1022 to
+ * match its internal structure. */
+
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
+
+#if NVSIZE > DOUBLESIZE && defined(LONG_DOUBLEKIND)
+# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ exponent -= 4;
# else
- /* Big endian. */
- for (ix = 0; ix <= limit_byte; ix++) {
- *v++ = nvp[ix] >> 4;
- *v++ = nvp[ix] & 0xF;
- }
-# endif
- /* If there are not enough bits in MANTISSATYPE,
- * we couldn't get all of them.
- *
- * Note that NV_PRESERVES_UV_BITS would not help
- * here, it is the wrong way around. */
-# if NV_MANT_DIG > MANTISSASIZE * 8
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Hexadecimal float: precision loss");
+ exponent--;
# endif
- }
#endif
- vend = v;
- assert(vend > vdig);
- assert(vend < vdig + sizeof(vdig));
if (nv < 0)
*p++ = '-';
}
/* Find the first non-zero xdigit. */
- for (v = vdig; v < vend; v++) {
+ for (v = vhex; v < vend; v++) {
if (*v) {
vfnz = v;
break;
U8* vlnz = NULL; /* The last non-zero. */
/* Find the last non-zero xdigit. */
- for (v = vend - 1; v >= vdig; v--) {
+ for (v = vend - 1; v >= vhex; v--) {
if (*v) {
vlnz = v;
break;
}
}
- /* Adjust the exponent so that the first output
- * xdigit aligns with the 4-bit nybbles. */
- exponent -= NV_MANT_DIG % 4 ? NV_MANT_DIG % 4 : 4;
+#if NVSIZE == DOUBLESIZE
+ exponent--;
+#endif
if (precis > 0) {
- v = vdig + precis + 1;
+ v = vhex + precis + 1;
if (v < vend) {
/* Round away from zero: if the tail
* beyond the precis xdigits is equal to
}
}
if (round) {
- for (v = vdig + precis; v >= vdig; v--) {
+ for (v = vhex + precis; v >= vhex; v--) {
if (*v < 0xF) {
(*v)++;
break;
}
*v = 0;
- if (v == vdig) {
+ if (v == vhex) {
/* If the carry goes all the way to
* the front, we need to output
* a single '1'. This goes against
- * the "xdigit and then decimal point"
+ * the "xdigit and then radix"
* but since this is "cannot happen"
* category, that is probably good. */
*p++ = xdig[1];
}
}
/* The new effective "last non zero". */
- vlnz = vdig + precis;
+ vlnz = vhex + precis;
}
else {
- zerotail = precis - (vlnz - vdig);
+ zerotail = precis - (vlnz - vhex);
}
}
- v = vdig;
+ v = vhex;
*p++ = xdig[*v++];
- /* The decimal point is always output after
- * the first non-zero xdigit, or if alt. */
- /* XXX if PL_numeric_radix_sv && IN_LC(LC_NUMERIC) */
+ /* The radix is always output after the first
+ * non-zero xdigit, or if alt. */
if (vfnz < vlnz || alt) {
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
elen = width;
}
}
- else {
- char *ptr = ebuf + sizeof ebuf;
- *--ptr = '\0';
- *--ptr = c;
- /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+ else
+ elen = S_infnan_copy(nv, PL_efloatbuf, PL_efloatsize);
+ if (elen == 0) {
+ char *ptr = ebuf + sizeof ebuf;
+ *--ptr = '\0';
+ *--ptr = c;
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl,
+ * not USE_LONG_DOUBLE and NVff. In other words,
+ * this needs to work without USE_LONG_DOUBLE. */
if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
- static char const prifldbl[] = PERL_PRIfldbl;
- char const *p = prifldbl + sizeof(prifldbl) - 3;
- while (p >= prifldbl) { *--ptr = *p--; }
+ static char const ldblf[] = PERL_PRIfldbl;
+ char const *p = ldblf + sizeof(ldblf) - 3;
+ while (p >= ldblf) { *--ptr = *p--; }
}
#endif
if (has_precis) {
(proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
parser->lex_defer = proto->lex_defer;
parser->lex_dojoin = proto->lex_dojoin;
- parser->lex_expect = proto->lex_expect;
parser->lex_formbrack = proto->lex_formbrack;
parser->lex_inpat = proto->lex_inpat;
parser->lex_inwhat = proto->lex_inwhat;
https://perl5.git.perl.org / perl5.git / blobdiff