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 (Perl_isinfnan(SvNVX(sv)))
+ if (UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return FALSE;
if (SvTYPE(sv) == SVt_NV)
} 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) && Perl_isinfnan(SvNVX(sv)))
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return 0; /* So wrong but what can we do. */
if (SvROK(sv)) {
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && Perl_isinfnan(SvNVX(sv)))
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return 0; /* So wrong but what can we do. */
if (SvROK(sv)) {
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
} else {
- if ((numtype & IS_NUMBER_INFINITY))
- SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
- else if ((numtype & IS_NUMBER_NAN))
- SvNV_set(sv, NV_NAN);
- else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ S_sv_setnv(aTHX_ sv, numtype);
}
if (numtype)
SvNOK_on(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) {
- /* XXX this should be an assert */
+ assert(maxlen >= 4);
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
else {
*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
SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
SvPOK_on(sv);
#else
{
+ bool local_radix;
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+
+ 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();
}
}
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
- if (!Perl_isinfnan(was) &&
+ if (LIKELY(!Perl_isinfnan(was)) &&
NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
oops_its_num:
{
const NV was = SvNVX(sv);
- if (!Perl_isinfnan(was) &&
+ 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_ARGS_ASSERT_F0CONVERT;
- if (Perl_isinfnan(nv)) {
+ if (UNLIKELY(Perl_isinfnan(nv))) {
STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
*len = n;
return endbuf - n;
# 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(nvsv) (Perl_isnan(SvNV(nvsv)) ? LDBL_SNAN : SvNV(nvsv));
+# 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 SvNV
+# define NV_TO_FV(nv,fv) (fv)=(nv)
# endif
#else
NV fv;
# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
# define FV_GF NVgf
-# define NV_TO_FV SvNV
+# 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 (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;
fv = intsize == 'q' ?
va_arg(*args, NV) : va_arg(*args, double);
#elif LONG_DOUBLESIZE > DOUBLESIZE
- fv = intsize == 'q' ?
- va_arg(*args, long double) : va_arg(*args, double);
+ if (intsize == 'q')
+ fv = va_arg(*args, long double);
+ else
+ NV_TO_FV(va_arg(*args, double), fv);
#else
fv = va_arg(*args, double);
#endif
}
else
- fv = NV_TO_FV(argsv);
+ {
+ if (!infnan) SvGETMAGIC(argsv);
+ NV_TO_FV(SvNV_nomg(argsv), fv);
+ }
need = 0;
/* frexp() (or frexpl) has some unspecified behaviour for
}
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:
https://perl5.git.perl.org / perl5.git / blobdiff