char *gconvert(double, int, int, char *);
#endif
+#ifdef USE_QUADMATH
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
+#else
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
+#endif
+
#ifdef PERL_NEW_COPY_ON_WRITE
# ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
This is the same trick as was used for NV and IV bodies. Ironically it
doesn't need to be used for NV bodies any more, because NV is now at
-the start of the structure. IV bodies don't need it either, because
-they are no longer allocated.
+the start of the structure. IV bodies, and also in some builds NV bodies,
+don't need it either, because they are no longer allocated.
In turn, the new_body_* allocators call S_new_body(), which invokes
new_body_inline macro, which takes a lock, and takes a body off the
struct body_details {
U8 body_size; /* Size to allocate */
U8 copy; /* Size of structure to copy (may be shorter) */
- U8 offset;
- unsigned int type : 4; /* We have space for a sanity check. */
- unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
- unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
- unsigned int arena : 1; /* Allocated from an arena */
- size_t arena_size; /* Size of arena to allocate */
+ U8 offset; /* Size of unalloced ghost fields to first alloced field*/
+ PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */
+ PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
+ PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
+ PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
+ U32 arena_size; /* Size of arena to allocate */
};
#define HADNV FALSE
NOARENA /* IVS don't need an arena */, 0
},
+#if NVSIZE <= IVSIZE
+ { 0, sizeof(NV),
+ STRUCT_OFFSET(XPVNV, xnv_u),
+ SVt_NV, FALSE, HADNV, NOARENA, 0 },
+#else
{ sizeof(NV), sizeof(NV),
STRUCT_OFFSET(XPVNV, xnv_u),
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
+#endif
{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
} STMT_END
#ifdef PURIFY
-
-#define new_XNV() safemalloc(sizeof(XPVNV))
+#if !(NVSIZE <= IVSIZE)
+# define new_XNV() safemalloc(sizeof(XPVNV))
+#endif
#define new_XPVNV() safemalloc(sizeof(XPVNV))
#define new_XPVMG() safemalloc(sizeof(XPVMG))
#else /* !PURIFY */
-#define new_XNV() new_body_allocated(SVt_NV)
+#if !(NVSIZE <= IVSIZE)
+# define new_XNV() new_body_allocated(SVt_NV)
+#endif
#define new_XPVNV() new_body_allocated(SVt_PVNV)
#define new_XPVMG() new_body_allocated(SVt_PVMG)
return;
case SVt_NV:
assert(old_type == SVt_NULL);
+#if NVSIZE <= IVSIZE
+ SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv));
+#else
SvANY(sv) = new_XNV();
+#endif
SvNV_set(sv, 0);
return;
case SVt_PVHV:
(unsigned long)new_type);
}
- if (old_type > SVt_IV) {
+ /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
+ and sometimes SVt_NV */
+ if (old_type_details->body_size) {
#ifdef PURIFY
safefree(old_body);
#else
}
#endif /* !NV_PRESERVES_UV*/
+/* If numtype is infnan, set the NV of the sv accordingly.
+ * If numtype is anything else, try setting the NV using Atof(PV). */
+static void
+S_sv_setnv(pTHX_ SV* sv, int numtype)
+{
+ bool pok = cBOOL(SvPOK(sv));
+ bool nok = FALSE;
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+ nok = TRUE;
+ }
+ else if ((numtype & IS_NUMBER_NAN)) {
+ SvNV_set(sv, NV_NAN);
+ nok = TRUE;
+ }
+ else if (pok) {
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ /* Purposefully no true nok here, since we don't want to blow
+ * away the possible IOK/UV of an existing sv. */
+ }
+ if (nok) {
+ SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
+ if (pok)
+ SvPOK_on(sv); /* PV is okay, though. */
+ }
+}
+
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
{
* IV or UV at same time to avoid this. */
/* IV-over-UV optimisation - choose to cache IV if possible */
+ if (UNLIKELY(Perl_isinfnan(SvNVX(sv))))
+ return FALSE;
+
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
certainly cast into the IV range at IV_MAX, whereas the correct
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- if (Perl_isnan(SvNVX(sv))) {
- SvUV_set(sv, 0);
- SvIsUV_on(sv);
- return FALSE;
- }
-#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
} else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
+ if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
+ S_sv_setnv(aTHX_ sv, numtype);
+ return FALSE;
+ }
+
/* If NVs preserve UVs then we only use the UV value if we know that
we aren't going to call atof() below. If NVs don't preserve UVs
then the value returned may have more precision than atof() will
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). */
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ S_sv_setnv(aTHX_ sv, numtype);
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
+ return 0; /* So wrong but what can we do. */
+
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV * tmpstr;
UV value;
const char * const ptr =
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
- const int numtype
- = grok_number(ptr, SvCUR(sv), &value);
+ const int numtype = grok_number(ptr, SvCUR(sv), &value);
+
+ assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
return (IV)value;
}
}
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
+ return 0; /* So wrong but what can we do. */
+
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV *tmpstr;
UV value;
const char * const ptr =
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
- const int numtype
- = grok_number(ptr, SvCUR(sv), &value);
+ const int numtype = grok_number(ptr, SvCUR(sv), &value);
+
+ assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (!(numtype & IS_NUMBER_NEG))
return value;
}
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
- } else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ } else {
+ S_sv_setnv(aTHX_ sv, numtype);
+ }
if (numtype)
SvNOK_on(sv);
else
SvNOKp_on(sv);
#else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
- /* Only set the public NV OK flag if this NV preserves the value in
- the PV at least as well as an IV/UV would.
- Not sure how to do this 100% reliably. */
- /* if that shift count is out of range then Configure's test is
- wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
- UV_BITS */
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
- SvNOK_on(sv); /* Definitely small enough to preserve all bits */
- } else if (!(numtype & IS_NUMBER_IN_UV)) {
- /* Can't use strtol etc to convert this string, so don't try.
- sv_2iv and sv_2uv will use the NV to convert, not the PV. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+ SvNOK_on(sv);
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ SvNV_set(sv, NV_NAN);
SvNOK_on(sv);
} else {
- /* value has been set. It may not be precise. */
- if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
- /* 2s complement assumption for (UV)IV_MIN */
- SvNOK_on(sv); /* Integer is too negative. */
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ /* Only set the public NV OK flag if this NV preserves the value in
+ the PV at least as well as an IV/UV would.
+ Not sure how to do this 100% reliably. */
+ /* if that shift count is out of range then Configure's test is
+ wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+ UV_BITS */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+ } else if (!(numtype & IS_NUMBER_IN_UV)) {
+ /* Can't use strtol etc to convert this string, so don't try.
+ sv_2iv and sv_2uv will use the NV to convert, not the PV. */
+ SvNOK_on(sv);
} else {
- SvNOKp_on(sv);
- SvIOKp_on(sv);
-
- if (numtype & IS_NUMBER_NEG) {
- SvIV_set(sv, -(IV)value);
- } else if (value <= (UV)IV_MAX) {
- SvIV_set(sv, (IV)value);
- } else {
- SvUV_set(sv, value);
- SvIsUV_on(sv);
- }
-
- if (numtype & IS_NUMBER_NOT_INT) {
- /* I believe that even if the original PV had decimals,
- they are lost beyond the limit of the FP precision.
- However, neither is canonical, so both only get p
- flags. NWC, 2000/11/25 */
- /* Both already have p flags, so do nothing */
+ /* value has been set. It may not be precise. */
+ if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
+ /* 2s complement assumption for (UV)IV_MIN */
+ SvNOK_on(sv); /* Integer is too negative. */
} else {
- const NV nv = SvNVX(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- if (SvIVX(sv) == I_V(nv)) {
- SvNOK_on(sv);
- } else {
- /* It had no "." so it must be integer. */
- }
- SvIOK_on(sv);
+ SvNOKp_on(sv);
+ SvIOKp_on(sv);
+
+ if (numtype & IS_NUMBER_NEG) {
+ SvIV_set(sv, -(IV)value);
+ } else if (value <= (UV)IV_MAX) {
+ SvIV_set(sv, (IV)value);
} else {
- /* between IV_MAX and NV(UV_MAX).
- Could be slightly > UV_MAX */
+ SvUV_set(sv, value);
+ SvIsUV_on(sv);
+ }
- if (numtype & IS_NUMBER_NOT_INT) {
- /* UV and NV both imprecise. */
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* I believe that even if the original PV had decimals,
+ they are lost beyond the limit of the FP precision.
+ However, neither is canonical, so both only get p
+ flags. NWC, 2000/11/25 */
+ /* Both already have p flags, so do nothing */
+ } else {
+ const NV nv = SvNVX(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ if (SvIVX(sv) == I_V(nv)) {
+ SvNOK_on(sv);
+ } else {
+ /* It had no "." so it must be integer. */
+ }
+ SvIOK_on(sv);
} else {
- const UV nv_as_uv = U_V(nv);
+ /* between IV_MAX and NV(UV_MAX).
+ Could be slightly > UV_MAX */
- if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
- SvNOK_on(sv);
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* UV and NV both imprecise. */
+ } else {
+ const UV nv_as_uv = U_V(nv);
+
+ if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ SvNOK_on(sv);
+ }
+ SvIOK_on(sv);
}
- SvIOK_on(sv);
}
}
}
}
- }
- /* It might be more code efficient to go through the entire logic above
- and conditionally set with SvNOKp_on() rather than SvNOK(), but it
- gets complex and potentially buggy, so more programmer efficient
+ /* It might be more code efficient to go through the entire logic above
+ and conditionally set with SvNOKp_on() rather than SvNOK(), but it
+ gets complex and potentially buggy, so more programmer efficient
to do it this way, by turning off the public flags: */
- if (!numtype)
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+ if (!numtype)
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+ }
#endif /* NV_PRESERVES_UV */
}
else {
- if (isGV_with_GP(sv)) {
- glob_2number(MUTABLE_GV(sv));
- return 0.0;
- }
+ if (isGV_with_GP(sv)) {
+ glob_2number(MUTABLE_GV(sv));
+ return 0.0;
+ }
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- assert (SvTYPE(sv) >= SVt_NV);
- /* Typically the caller expects that sv_any is not NULL now. */
- /* XXX Ilya implies that this is a bug in callers that assume this
- and ideally should be fixed. */
- return 0.0;
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ assert (SvTYPE(sv) >= SVt_NV);
+ /* Typically the caller expects that sv_any is not NULL now. */
+ /* XXX Ilya implies that this is a bug in callers that assume this
+ and ideally should be fixed. */
+ return 0.0;
}
DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
+ PTR2UV(sv), SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
return SvNVX(sv);
}
* 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) {
+ assert(maxlen >= 4);
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
else {
*s++ = 'I';
*s++ = 'n';
*s++ = 'f';
- }
- else if (Perl_isnan(nv)) {
+ } else if (Perl_isnan(nv)) {
*s++ = 'N';
*s++ = 'a';
*s++ = 'N';
* 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));
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvNVX(sv) == 0.0) {
+ if (SvNVX(sv) == 0.0
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ /* XXX Create SvNVXeq(sv, x)? Or just SvNVXzero(sv)? */
+ && !Perl_isnan(SvNVX(sv))
+#endif
+ ) {
s = SvGROW_mutable(sv, 2);
*s++ = '0';
*s = '\0';
} else {
- /* The +20 is pure guesswork. Configure test needed. --jhi */
- STRLEN size = NV_DIG + 20;
STRLEN len;
- s = SvGROW_mutable(sv, size);
+ STRLEN size = 5; /* "-Inf\0" */
+ s = SvGROW_mutable(sv, size);
len = S_infnan_2pv(SvNVX(sv), s, size);
- if (len > 0)
+ if (len > 0) {
s += len;
+ SvPOK_on(sv);
+ }
else {
- dSAVE_ERRNO;
/* some Xenix systems wipe out errno here */
+ dSAVE_ERRNO;
+ size =
+ 1 + /* sign */
+ 1 + /* "." */
+ NV_DIG +
+ 1 + /* "e" */
+ 1 + /* sign */
+ 5 + /* exponent digits */
+ 1 + /* \0 */
+ 2; /* paranoia */
+
+ s = SvGROW_mutable(sv, size);
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+
SvPOK_on(sv);
#else
{
+ bool local_radix;
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+
+ local_radix =
+ PL_numeric_local &&
+ PL_numeric_radix_sv &&
+ SvUTF8(PL_numeric_radix_sv);
+ if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
+ size += SvLEN(PL_numeric_radix_sv) - 1;
+ s = SvGROW_mutable(sv, size);
+ }
+
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
/* 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);
- }
+ if (local_radix &&
+ instr(s, SvPVX_const(PL_numeric_radix_sv))) {
+ SvUTF8_on(sv);
+ }
+
RESTORE_LC_NUMERIC();
}
PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
- if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
- mg_get(ssv);
- s = SvPV_nomg_const(ssv,len);
+ s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (import_flag == GVf_IMPORTED_SV) {
+ if (intro) {
+ dSS_ADD;
+ SS_ADD_PTR(gp_ref(GvGP(dstr)));
+ SS_ADD_UV(SAVEt_GP_ALIASED_SV
+ | cBOOL(GvALIASED_SV(dstr)) << 8);
+ SS_ADD_END(2);
+ }
+ /* Turn off the flag if sref is not referenced elsewhere,
+ even by weak refs. (SvRMAGICAL is a pessimistic check for
+ back refs.) */
+ if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+ GvALIASED_SV_off(dstr);
+ else
+ GvALIASED_SV_on(dstr);
+ }
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
/* slated for free anyway (and not COW)? */
(sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
/* or a swipable TARG */
- || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
+ || ((sflags &
+ (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
== SVs_PADTMP
/* whose buffer is worth stealing */
&& CHECK_COWBUF_THRESHOLD(cur,len)
Tells an SV to use C<ptr> to find its string value. Normally the
string is stored inside the SV, but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by L<Newx|perlclib/Memory Management and String Handling>. It must be
+by L<Newx|perlclib/Memory Management and String Handling>. It must be
the start of a Newx-ed block of memory, and not a pointer to the
middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
-and not be from a non-Newx memory allocator like C<malloc>. The
+and not be from a non-Newx memory allocator like C<malloc>. The
string length, C<len>, must be supplied. By default this function
will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
if (SvREADONLY(sv))
Perl_croak_no_modify();
- else if (SvIsCOW(sv))
+ else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
S_sv_uncow(aTHX_ sv, flags);
if (SvROK(sv))
sv_unref_flags(sv, flags);
assert(cache);
if (PL_utf8cache < 0 && SvPOKp(sv)) {
- /* SvPOKp() because it's possible that sv has string overloading, and
- therefore is a reference, hence SvPVX() is actually a pointer.
- This cures the (very real) symptoms of RT 69422, but I'm not actually
- sure whether we should even be caching the results of UTF-8
- operations on overloading, given that nothing stops overloading
- returning a different value every time it's called. */
+ /* SvPOKp() because, if sv is a reference, then SvPVX() is actually
+ a pointer. Note that we no longer cache utf8 offsets on refer-
+ ences, but this check is still a good idea, for robustness. */
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
cache[3] = byte;
}
} else {
+/* float casts necessary? XXX */
#define THREEWAY_SQUARE(a,b,c,d) \
((float)((d) - (c))) * ((float)((d) - (c))) \
+ ((float)((c) - (b))) * ((float)((c) - (b))) \
if (keep_later < keep_earlier) {
cache[2] = cache[0];
cache[3] = cache[1];
- cache[0] = utf8;
- cache[1] = byte;
- }
- else {
- cache[0] = utf8;
- cache[1] = byte;
- }
- }
- else if (byte > cache[3]) {
- /* New position is between the existing pair of pairs. */
- const float keep_earlier
- = THREEWAY_SQUARE(0, cache[3], byte, blen);
- const float keep_later
- = THREEWAY_SQUARE(0, byte, cache[1], blen);
-
- if (keep_later < keep_earlier) {
- cache[2] = utf8;
- cache[3] = byte;
- }
- else {
- cache[0] = utf8;
- cache[1] = byte;
}
+ cache[0] = utf8;
+ cache[1] = byte;
}
else {
- /* New position is before the existing pair of pairs. */
- const float keep_earlier
- = THREEWAY_SQUARE(0, byte, cache[3], blen);
- const float keep_later
- = THREEWAY_SQUARE(0, byte, cache[1], blen);
-
- if (keep_later < keep_earlier) {
- cache[2] = utf8;
- cache[3] = byte;
+ const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen);
+ float b, c, keep_earlier;
+ if (byte > cache[3]) {
+ /* New position is between the existing pair of pairs. */
+ b = cache[3];
+ c = byte;
+ } else {
+ /* New position is before the existing pair of pairs. */
+ b = byte;
+ c = cache[3];
+ }
+ keep_earlier = THREEWAY_SQUARE(0, b, c, blen);
+ if (byte > cache[3]) {
+ if (keep_later < keep_earlier) {
+ cache[2] = utf8;
+ cache[3] = byte;
+ }
+ else {
+ cache[0] = utf8;
+ cache[1] = byte;
+ }
}
else {
- cache[0] = cache[2];
- cache[1] = cache[3];
- cache[2] = utf8;
- cache[3] = byte;
+ if (! (keep_later < keep_earlier)) {
+ cache[0] = cache[2];
+ cache[1] = cache[3];
+ }
+ cache[2] = utf8;
+ cache[3] = byte;
}
}
}
}
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
- if (NV_OVERFLOWS_INTEGERS_AT &&
+ if (LIKELY(!Perl_isinfnan(was)) &&
+ NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
oops_its_num:
{
const NV was = SvNVX(sv);
- if (NV_OVERFLOWS_INTEGERS_AT &&
+ if (LIKELY(!Perl_isinfnan(was)) &&
+ NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
- if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+ if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) {
if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
PERL_ARGS_ASSERT_F0CONVERT;
+ if (UNLIKELY(Perl_isinfnan(nv))) {
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
+ *len = n;
+ return endbuf - n;
+ }
if (neg)
nv = -nv;
if (nv < UV_MAX) {
# define DOUBLEDOUBLE_MAXBITS 1028
#endif
-#ifdef LONGDOUBLE_X86_80_BIT
-# undef LONGDOUBLE_HAS_IMPLICIT_BIT
-#else
-# define LONGDOUBLE_HAS_IMPLICIT_BIT
-#endif
-
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
- * of 4 bits); 1 for the implicit 1, and at most 1028 bits of mantissa,
- * four bits per xdigit. */
+ * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
+ * per xdigit. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
#else
-/* 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)
#endif
* 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. */
+ * 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 /* May lose precision if UVSIZE is not 8. */
+# define MANTISSATYPE UV
# define MANTISSASIZE UVSIZE
#endif
+/* 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). */
+#if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ defined(DOUBLEKIND_LITTLE_ENDIAN)
+# define HEXTRACT_LITTLE_ENDIAN
+#else
+# define HEXTRACT_BIG_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
#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
+ 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
-#ifdef LONGDOUBLE_HAS_IMPLICIT_BIT
+ 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
# define HEXTRACT_IMPLICIT_BIT(nv) \
- if (nv != 0.0 && vend) \
- *v++ = 1; \
- else \
- v++;
+ STMT_START { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } STMT_END
+
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
#else
-# undef HEXTRACT_IMPLICIT_BIT
+# define HEXTRACTSIZE NVSIZE
#endif
- /* First see if we are using long doubles. */
-#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
const U8* nvp = (const U8*)(&nv);
-# ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
-# else
-# define HEXTRACTSIZE NVSIZE
-# endif
const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
(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 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 15,14 are the sign+exponent. */
HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 13; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# 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:
* the 0,1 are the sign+exponent. */
HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 2; ix <= 15; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
* 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. */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
for (ix = 7; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# 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.) */
- /* There explicitly is *no* implicit bit in this case. */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
for (ix = 0; ix < 8; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif defined(LONGDOUBLE_DOUBLEDOUBLE)
- /* The little-endian double-double is used .. somewhere?
+ /* 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)
- *
- * With the double-double format the bytewise extraction we use
- * for the other long double formats doesn't work, we must extract
- * the values bit by bit. */
+ */
if (nv == (NV)0.0) {
if (vend)
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) {
"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).
+ /* 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
- * insert the radix.
- */
-# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
- defined(LONGDOUBLEKIND_LITTLE_ENDIAN)
- /* Little endian. */
- for (ix = limit_byte; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ * bytes, since we might need to handle printf precision, and
+ * also need to insert the radix. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ HEXTRACT_LO_NYBBLE(6);
+ for (ix = 5; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
}
# else
- /* Big endian. */
- for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_LO_NYBBLE(1);
+ for (ix = 2; ix < HEXTRACTSIZE; ix++) {
+ HEXTRACT_BYTE(ix);
}
# 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
Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
if (pp - pat == (int)patlen - 1 && svix < svmax) {
const NV nv = SvNV(*svargs);
- if (*pp == 'g') {
- /* Add check for digits != 0 because it seems that some
- gconverts are buggy in this case, and we don't yet have
- a Configure test for this. */
- if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
- /* 0, point, slack */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
- sv_catpv_nomg(sv, ebuf);
- if (*ebuf) /* May return an empty string for digits==0 */
- return;
- }
- } else if (!digits) {
- STRLEN l;
+ if (LIKELY(!Perl_isinfnan(nv))) {
+ if (*pp == 'g') {
+ /* Add check for digits != 0 because it seems that some
+ gconverts are buggy in this case, and we don't yet have
+ a Configure test for this. */
+ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+ /* 0, point, slack */
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ SNPRINTF_G(nv, ebuf, size, digits);
+ sv_catpv_nomg(sv, ebuf);
+ if (*ebuf) /* May return an empty string for digits==0 */
+ return;
+ }
+ } else if (!digits) {
+ STRLEN l;
- if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn_nomg(sv, p, l);
- return;
- }
- }
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn_nomg(sv, p, l);
+ return;
+ }
+ }
+ }
}
}
#endif /* !USE_LONG_DOUBLE */
* the time it is not (most compilers these days recognize
* "long double", even if only as a synonym for "double").
*/
-#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
+ defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
long double fv;
-# define FV_ISFINITE Perl_isfinitel
-# define FV_FREXP frexpl
+# define FV_ISFINITE(x) Perl_isfinitel(x)
# define FV_GF PERL_PRIgldbl
+# if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT)
+ /* Work around breakage in OTS$CVT_FLOAT_T_X */
+# define NV_TO_FV(nv,fv) STMT_START { \
+ double _dv = nv; \
+ fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \
+ } STMT_END
+# else
+# define NV_TO_FV(nv,fv) (fv)=(nv)
+# endif
#else
NV fv;
-# define FV_ISFINITE Perl_isfinite
-# define FV_FREXP Perl_frexp
+# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
# define FV_GF NVgf
+# define NV_TO_FV(nv,fv) (fv)=(nv)
#endif
STRLEN have;
STRLEN need;
is safe. */
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
+ if ((IV)elen < 0) {
+ /* check if utf8 length is larger than 0 when cast to IV */
+ assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+ elen= 0; /* otherwise we want to treat this as an empty string */
+ }
eptr = va_arg(*args, char *);
q += sizeof(UTF8f)-1;
goto string;
#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALLTHROUGH */
+#ifdef USE_QUADMATH
+ case 'Q':
+ /* FALLTHROUGH */
+#endif
#if IVSIZE >= 8
case 'q': /* qd */
#endif
}
}
- if (argsv && SvNOK(argsv)) {
- /* XXX va_arg(*args) case? */
- infnan = Perl_isinfnan(SvNV(argsv));
+ if (argsv && strchr("BbcDdiOopuUXx",*q)) {
+ /* XXX va_arg(*args) case? need peek, use va_copy? */
+ SvGETMAGIC(argsv);
+ infnan = UNLIKELY(isinfnansv(argsv));
}
switch (c = *q++) {
case 'c':
if (vectorize)
goto unknown;
- uv = (args) ? va_arg(*args, int) :
- infnan ? UNICODE_REPLACEMENT : SvIV(argsv);
+ if (infnan)
+ Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'",
+ /* no va_arg() case */
+ SvNV_nomg(argsv), (int)c);
+ uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv);
if ((uv > 255 ||
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
case 'p':
if (infnan) {
- c = 'g';
goto floating_point;
}
if (alt || vectorize)
case 'd':
case 'i':
if (infnan) {
- c = 'g';
goto floating_point;
}
if (vectorize) {
}
}
else {
- IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
+ IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'c': iv = (char)tiv; break;
case 'h': iv = (short)tiv; break;
uns_integer:
if (infnan) {
- c = 'g';
goto floating_point;
}
if (vectorize) {
}
}
else {
- UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
+ UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'c': uv = (unsigned char)tuv; break;
case 'h': uv = (unsigned short)tuv; break;
goto unknown;
}
- /* now we need (long double) if intsize == 'q', else (double) */
- fv = (args) ?
-#if LONG_DOUBLESIZE > DOUBLESIZE
- intsize == 'q' ?
- va_arg(*args, long double) :
- va_arg(*args, double)
+ /* Now we need (long double) if intsize == 'q', else (double). */
+ if (args) {
+ /* Note: do not pull NVs off the va_list with va_arg()
+ * (pull doubles instead) because if you have a build
+ * with long doubles, you would always be pulling long
+ * doubles, which would badly break anyone using only
+ * doubles (i.e. the majority of builds). In other
+ * words, you cannot mix doubles and long doubles.
+ * The only case where you can pull off long doubles
+ * is when the format specifier explicitly asks so with
+ * e.g. "%Lg". */
+#ifdef USE_QUADMATH
+ fv = intsize == 'q' ?
+ va_arg(*args, NV) : va_arg(*args, double);
+#elif LONG_DOUBLESIZE > DOUBLESIZE
+ if (intsize == 'q')
+ fv = va_arg(*args, long double);
+ else
+ NV_TO_FV(va_arg(*args, double), fv);
#else
- va_arg(*args, double)
+ fv = va_arg(*args, double);
#endif
- : SvNV(argsv);
+ }
+ else
+ {
+ if (!infnan) SvGETMAGIC(argsv);
+ NV_TO_FV(SvNV_nomg(argsv), fv);
+ }
need = 0;
/* frexp() (or frexpl) has some unspecified behaviour for
* nan/inf/-inf, so let's avoid calling that on non-finites. */
if (isALPHA_FOLD_NE(c, 'e') && FV_ISFINITE(fv)) {
i = PERL_INT_MIN;
- (void)FV_FREXP(fv, &i);
+ (void)Perl_frexp((NV)fv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv);
/* Do not set hexfp earlier since we want to printf
1 + /* "." */
2 * NVSIZE + /* 2 hexdigits for each byte */
2 + /* "p+" */
- BIT_DIGITS(NV_MAX_EXP) + /* exponent */
+ 6 + /* exponent: sign, plus up to 16383 (quad fp) */
1; /* \0 */
#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* However, for the "double double", we need more.
* for the future.) */
/* 2 hexdigits for each byte. */
- need += (DOUBLEDOUBLE_MAXBITS/8 - DOUBLESIZE + 1) * 2;
+ need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
+ /* the size for the exponent already added */
#endif
#ifdef USE_LOCALE_NUMERIC
STORE_LC_NUMERIC_SET_TO_NEEDED();
}
if ( !(width || left || plus || alt) && fill != '0'
- && has_precis && intsize != 'q' ) { /* Shortcuts */
+ && has_precis && intsize != 'q' /* Shortcuts */
+ && LIKELY(!Perl_isinfnan((NV)fv)) ) {
/* See earlier comment about buggy Gconvert when digits,
aka precis is 0 */
if ( c == 'g' && precis ) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert((NV)fv, (int)precis, 0, PL_efloatbuf));
+ SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis);
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
* match its internal structure. */
/* Note: fv can be (and often is) long double.
- * Here it is implicitly cast to NV. */
- vend = S_hextract(aTHX_ fv, &exponent, vhex, NULL);
- S_hextract(aTHX_ fv, &exponent, vhex, vend);
+ * Here it is explicitly cast to NV. */
+ vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
-# ifdef LONGDOUBLE_HAS_IMPLICIT_BIT
- exponent--;
-# else
+# ifdef LONGDOUBLE_X86_80_BIT
exponent -= 4;
+# else
+ exponent--;
# endif
#endif
}
#if NVSIZE == DOUBLESIZE
- exponent--;
+ if (fv != 0.0)
+ exponent--;
#endif
if (precis > 0) {
}
else
elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+
if (elen == 0) {
char *ptr = ebuf + sizeof ebuf;
*--ptr = '\0';
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
+#ifdef USE_QUADMATH
+ *--ptr = 'Q';
+#else
static char const ldblf[] = PERL_PRIfldbl;
char const *p = ldblf + sizeof(ldblf) - 3;
while (p >= ldblf) { *--ptr = *p--; }
+#endif
}
#endif
if (has_precis) {
/* hopefully the above makes ptr a very constrained format
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
-#if defined(HAS_LONG_DOUBLE)
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(ptr);
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
+ elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
+ qfmt, fv);
+ if ((IV)elen == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+ if (qfmt != ptr)
+ Safefree(qfmt);
+ }
+#elif defined(HAS_LONG_DOUBLE)
elen = ((intsize == 'q')
? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
: my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
}
break;
case SVt_NV:
+#if NVSIZE <= IVSIZE
+ SvANY(dstr) = (XPVNV*)((char*)&(dstr->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv));
+#else
SvANY(dstr) = new_XNV();
+#endif
SvNV_set(dstr, SvNVX(sstr));
break;
default:
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
if (CvNAMED(dstr))
SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
- share_hek_hek(CvNAME_HEK((CV *)sstr));
+ hek_dup(CvNAME_HEK((CV *)sstr), param);
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
else
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
+ case SAVEt_GP_ALIASED_SV:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gp_dup((GP *)ptr, param);
+ ((GP *)ptr)->gp_refcnt++;
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
+ PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif
Perl_init_constants(pTHX)
{
SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
- SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
+ SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL;
SvANY(&PL_sv_undef) = NULL;
SvANY(&PL_sv_no) = new_XPVNV();
SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
- SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
+ SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY|SVf_PROTECT
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK;
SvANY(&PL_sv_yes) = new_XPVNV();
SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
- SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
+ SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY|SVf_PROTECT
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK;
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
dSP;
ENTER;
SAVETMPS;
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
https://perl5.git.perl.org / perl5.git / blobdiff