PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
#endif
-#ifdef PERL_NEW_COPY_ON_WRITE
-# ifndef SV_COW_THRESHOLD
+#ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
-# endif
-# ifndef SV_COWBUF_THRESHOLD
+#endif
+#ifndef SV_COWBUF_THRESHOLD
# define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
-# endif
-# ifndef SV_COW_MAX_WASTE_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_THRESHOLD
# define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COWBUF_WASTE_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_THRESHOLD
# define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
# define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
-# ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
# define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
#endif
/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
hold is 0. */
# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
/* Whilst I'd love to do this, it seems that things like to check on
unreferenced scalars
-# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
+# define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
*/
-# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
+# define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
PoisonNew(&SvREFCNT(sv), 1, U32)
#else
# define SvARENA_CHAIN(sv) SvANY(sv)
# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
-# define POSION_SV_HEAD(sv)
+# define POISON_SV_HEAD(sv)
#endif
/* Mark an SV head as unused, and add to free list.
MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
DEBUG_SV_SERIAL(p); \
FREE_SV_DEBUG_FILE(p); \
- POSION_SV_HEAD(p); \
+ POISON_SV_HEAD(p); \
SvFLAGS(p) = SVTYPEMASK; \
if (!(old_flags & SVf_BREAK)) { \
SvARENA_CHAIN_SET(p, PL_sv_root); \
#endif /* DEBUGGING */
+/*
+ * Bodyless IVs and NVs!
+ *
+ * Since 5.9.2, we can avoid allocating a body for SVt_IV-type SVs.
+ * Since the larger IV-holding variants of SVs store their integer
+ * values in their respective bodies, the family of SvIV() accessor
+ * macros would naively have to branch on the SV type to find the
+ * integer value either in the HEAD or BODY. In order to avoid this
+ * expensive branch, a clever soul has deployed a great hack:
+ * We set up the SvANY pointer such that instead of pointing to a
+ * real body, it points into the memory before the location of the
+ * head. We compute this pointer such that the location of
+ * the integer member of the hypothetical body struct happens to
+ * be the same as the location of the integer member of the bodyless
+ * SV head. This now means that the SvIV() family of accessors can
+ * always read from the (hypothetical or real) body via SvANY.
+ *
+ * Since the 5.21 dev series, we employ the same trick for NVs
+ * if the architecture can support it (NVSIZE <= IVSIZE).
+ */
+
+/* The following two macros compute the necessary offsets for the above
+ * trick and store them in SvANY for SvIV() (and friends) to use. */
+#define SET_SVANY_FOR_BODYLESS_IV(sv) \
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv))
+
+#define SET_SVANY_FOR_BODYLESS_NV(sv) \
+ SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv))
/*
=head1 SV Manipulation Functions
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
? count * body_size \
: FIT_ARENA0 (body_size)
#define FIT_ARENA(count,body_size) \
- count \
+ (U32)(count \
? FIT_ARENAn (count, body_size) \
- : FIT_ARENA0 (body_size)
+ : FIT_ARENA0 (body_size))
/* Calculate the length to copy. Specifically work out the length less any
final padding the compiler needed to add. See the comment in sv_upgrade
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)
break;
case SVt_PV:
assert(new_type > SVt_PV);
- assert(SVt_IV < SVt_PV);
- assert(SVt_NV < SVt_PV);
+ STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
+ STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
break;
case SVt_PVIV:
break;
there's no way that it can be safely upgraded, because perl.c
expects to Safefree(SvANY(PL_mess_sv)) */
assert(sv != PL_mess_sv);
- /* This flag bit is used to mean other things in other scalar types.
- Given that it only has meaning inside the pad, it shouldn't be set
- on anything that can get upgraded. */
- assert(!SvPAD_TYPED(sv));
break;
default:
if (UNLIKELY(old_type_details->cant_upgrade))
switch (new_type) {
case SVt_IV:
assert(old_type == SVt_NULL);
- SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SET_SVANY_FOR_BODYLESS_IV(sv);
SvIV_set(sv, 0);
return;
case SVt_NV:
assert(old_type == SVt_NULL);
+#if NVSIZE <= IVSIZE
+ SET_SVANY_FOR_BODYLESS_NV(sv);
+#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
* make more strings COW-able.
* If the new size is a big power of two, don't bother: we assume the
* caller wanted a nice 2^N sized block and will be annoyed at getting
- * 2^N+1 */
- if (newlen & 0xff)
+ * 2^N+1.
+ * Only increment if the allocation isn't MEM_SIZE_MAX,
+ * otherwise it will wrap to 0.
+ */
+ if (newlen & 0xff && newlen != MEM_SIZE_MAX)
newlen++;
#endif
{
const char *sbegin;
STRLEN len;
+ int numtype;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
}
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
- return grok_number(sbegin, len, NULL);
+ numtype = grok_number(sbegin, len, NULL);
+ return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
}
STATIC bool
/* If numtype is infnan, set the NV of the sv accordingly.
* If numtype is anything else, try setting the NV using Atof(PV). */
+#ifdef USING_MSVC6
+# pragma warning(push)
+# pragma warning(disable:4756;disable:4056)
+#endif
static void
S_sv_setnv(pTHX_ SV* sv, int numtype)
{
- bool pok = SvPOK(sv);
+ 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)) {
- nok = TRUE;
SvNV_set(sv, NV_NAN);
+ nok = TRUE;
}
- else if (pok)
+ 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. */
+ SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
if (pok)
SvPOK_on(sv); /* PV is okay, though. */
}
}
+#ifdef USING_MSVC6
+# pragma warning(pop)
+#endif
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)))
- 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)
#ifndef NV_PRESERVES_UV
+ && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
(UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
/* Don't flag it as "accurately an integer" if the number
sv_upgrade(sv, SVt_PVNV);
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);
return FALSE;
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIV_set(sv, -(IV)value);
+ SvIV_set(sv, value == (UV)IV_MIN
+ ? IV_MIN : -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
#ifdef NV_PRESERVES_UV
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
+#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 ((NV)(SvIVX(sv)) == SvNVX(sv)) {
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && 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);
-
- assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
+ const int numtype
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
}
}
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && 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);
-
- assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
+ const int numtype
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
return value;
}
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return UV_MAX; /* So wrong. */
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
else
SvNOKp_on(sv);
#else
- 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);
+ 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 {
- 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);
+ /* 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 {
- /* 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 {
- SvNOKp_on(sv);
- SvIOKp_on(sv);
+ SvNOKp_on(sv);
+ SvIOKp_on(sv);
+
+ if (numtype & IS_NUMBER_NEG) {
+ /* -IV_MIN is undefined, but we should never reach
+ * this point with both IS_NUMBER_NEG and value ==
+ * (UV)IV_MIN */
+ assert(value != (UV)IV_MIN);
+ 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_NEG) {
- SvIV_set(sv, -(IV)value);
- } else if (value <= (UV)IV_MAX) {
- SvIV_set(sv, (IV)value);
+ 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);
+ /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
+ 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 {
- SvUV_set(sv, value);
- SvIsUV_on(sv);
- }
+ /* between IV_MAX and NV(UV_MAX).
+ Could be slightly > UV_MAX */
- 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);
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* UV and NV both imprecise. */
} else {
- /* between IV_MAX and NV(UV_MAX).
- Could be slightly > UV_MAX */
-
- if (numtype & IS_NUMBER_NOT_INT) {
- /* UV and NV both imprecise. */
- } else {
- const UV nv_as_uv = U_V(nv);
+ const UV nv_as_uv = U_V(nv);
- if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
- SvNOK_on(sv);
- }
- SvIOK_on(sv);
+ if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ SvNOK_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
- to do it this way, by turning off the public flags: */
- if (!numtype)
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
}
+ /* 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);
#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);
}
=for apidoc sv_2num
Return an SV with the numeric value of the source SV, doing any necessary
-reference or overload conversion. You must use the C<SvNUM(sv)> macro to
-access this function.
+reference or overload conversion. The caller is expected to have handled
+get-magic already.
=cut
*/
uv = iv;
sign = 0;
} else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
sign = 1;
}
do {
* 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) {
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
assert(maxlen >= 4);
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
if (maxlen < 5) /* "-Inf\0" */
return 0;
*s++ = '-';
+ } else if (plus) {
+ *s++ = '+';
}
*s++ = 'I';
*s++ = 'n';
sv_upgrade(sv, SVt_PVNV);
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
) {
STRLEN size = 5; /* "-Inf\0" */
s = SvGROW_mutable(sv, size);
- len = S_infnan_2pv(SvNVX(sv), s, size);
+ len = S_infnan_2pv(SvNVX(sv), s, size, 0);
if (len > 0) {
s += len;
SvPOK_on(sv);
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
-{
- PERL_ARGS_ASSERT_SV_COPYPV;
-
- sv_copypv_flags(dsv, ssv, 0);
-}
-
-void
Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
STRLEN len;
S_sv_uncow(aTHX_ sv, 0);
}
- if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
- sv_recode_to_utf8(sv, PL_encoding);
+ if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
+ sv_recode_to_utf8(sv, _get_encoding());
if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
}
if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
-must_be_utf8:
+ must_be_utf8:
/* Here, the string should be converted to utf8, either because of an
* input flag (two_byte_count = 0), or because a character that
return;
}
-static void
-S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
+void
+Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
{
SV * const sref = SvRV(sstr);
SV *dref;
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
- PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
+ PERL_ARGS_ASSERT_GV_SETREF;
if (intro) {
GvINTRO_off(dstr); /* one-shot 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);
+ save_aliased_sv((GV *)dstr);
}
/* Turn off the flag if sref is not referenced elsewhere,
even by weak refs. (SvRMAGICAL is a pessimistic check for
Perl_magic_clearisa(aTHX_ NULL, mg);
}
else if (stype == SVt_PVIO) {
- DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+ DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
/* It's a cache. It will rebuild itself quite happily.
It's a lot of effort to work out exactly which key (or keys)
might be invalidated by the creation of the this file handle.
PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
- if (sstr == dstr)
+ if (UNLIKELY( sstr == dstr ))
return;
if (SvIS_FREED(dstr)) {
" to a freed scalar %p", SVfARG(sstr), (void *)dstr);
}
SV_CHECK_THINKFIRST_COW_DROP(dstr);
- if (!sstr)
+ if (UNLIKELY( !sstr ))
sstr = &PL_sv_undef;
if (SvIS_FREED(sstr)) {
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
switch (stype) {
case SVt_NULL:
undef_sstr:
- if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
+ if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
(void)SvOK_off(dstr);
return;
}
if (SvIOK(sstr)) {
switch (dtype) {
case SVt_NULL:
- sv_upgrade(dstr, SVt_IV);
+ /* For performance, we inline promoting to type SVt_IV. */
+ /* We're starting from SVt_NULL, so provided that define is
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_NULL == 0);
+ SET_SVANY_FOR_BODYLESS_IV(dstr);
+ SvFLAGS(dstr) |= SVt_IV;
break;
case SVt_NV:
case SVt_PV:
break;
case SVt_NV:
- if (SvNOK(sstr)) {
+ if (LIKELY( SvNOK(sstr) )) {
switch (dtype) {
case SVt_NULL:
case SVt_IV:
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV) {
+ if (UNLIKELY( dtype == SVt_PVCV )) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
SvOK_off(dstr);
}
}
- else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
+ else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
+ || dtype == SVt_PVFM))
+ {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
/* diag_listed_as: Cannot copy to %s */
if (dtype >= SVt_PV) {
if (isGV_with_GP(dstr)) {
- glob_assign_ref(dstr, sstr);
+ gv_setref(dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
* be allocated it is still not worth swiping PADTMPs for short
* strings, as the savings here are small.
*
- * If the rhs is already flagged as a copy-on-write string and COW
- * is possible here, we use copy-on-write and make both SVs share
- * the string buffer.
- *
- * If the rhs is not flagged as copy-on-write, then we see whether
- * it is worth upgrading it to such. If the lhs already has a buf-
+ * If swiping is not an option, then we see whether it is
+ * worth using copy-on-write. If the lhs already has a buf-
* fer big enough and the string is short, we skip it and fall back
* to method 3, since memcpy is faster for short strings than the
* later bookkeeping overhead that copy-on-write entails.
+
+ * If the rhs is not a copy-on-write string yet, then we also
+ * consider whether the buffer is too large relative to the string
+ * it holds. Some operations such as readline allocate a large
+ * buffer in the expectation of reusing it. But turning such into
+ * a COW buffer is counter-productive because it increases memory
+ * usage by making readline allocate a new large buffer the sec-
+ * ond time round. So, if the buffer is too large, again, we use
+ * method 3 (copy).
*
- * If there is no buffer on the left, or the buffer is too small,
- * then we use copy-on-write.
+ * Finally, if there is no buffer on the left, or the buffer is too
+ * small, then we use copy-on-write and make both SVs share the
+ * string buffer.
+ *
*/
/* Whichever path we take through the next code, we want this true,
}
SvIsCOW_off(sv);
# ifdef PERL_NEW_COPY_ON_WRITE
- if (len && CowREFCNT(sv) == 0)
- /* We own the buffer ourselves. */
- sv_buf_to_rw(sv);
+ if (len) {
+ /* Must do this first, since the CowREFCNT uses SvPVX and
+ we need to write to CowREFCNT, or de-RO the whole buffer if we are
+ the only owner left of the buffer. */
+ sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
+ {
+ U8 cowrefcnt = CowREFCNT(sv);
+ if(cowrefcnt != 0) {
+ cowrefcnt--;
+ CowREFCNT(sv) = cowrefcnt;
+ sv_buf_to_ro(sv);
+ goto copy_over;
+ }
+ }
+ /* Else we are the only owner of the buffer. */
+ }
else
# endif
{
-
/* This SV doesn't own the buffer, so need to Newx() a new one: */
-# ifdef PERL_NEW_COPY_ON_WRITE
- /* Must do this first, since the macro uses SvPVX. */
- if (len) {
- sv_buf_to_rw(sv);
- CowREFCNT(sv)--;
- sv_buf_to_ro(sv);
- }
-# endif
+ copy_over:
SvPV_set(sv, NULL);
SvCUR_set(sv, 0);
SvLEN_set(sv, 0);
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF-8
-status set, then the bytes appended should be valid UTF-8.
+C<len> indicates number of bytes to copy.
+
+By default, the string appended is assumed to be valid UTF-8 if the SV has
+the UTF-8 status set, and a string of bytes otherwise. One can force the
+appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
+flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
+string appended will be upgraded to UTF-8 if necessary.
+
If C<flags> has the C<SV_SMAGIC> bit set, will
C<mg_set> on C<dsv> afterwards if appropriate.
C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
if (ssv) {
STRLEN slen;
const char *spv = SvPV_flags_const(ssv, slen, flags);
- if (spv) {
- if (flags & SV_GMAGIC)
+ if (flags & SV_GMAGIC)
SvGETMAGIC(dsv);
- sv_catpvn_flags(dsv, spv, slen,
+ sv_catpvn_flags(dsv, spv, slen,
DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
- if (flags & SV_SMAGIC)
+ if (flags & SV_SMAGIC)
SvSETMAGIC(dsv);
- }
}
}
new_SV(sv);
if (len) {
- sv_upgrade(sv, SVt_PV);
- SvGROW(sv, len + 1);
+ sv_grow(sv, len + 1);
}
return sv;
}
PERL_ARGS_ASSERT_SV_MAGICEXT;
- if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
-
SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
return sv;
}
+/*
+=for apidoc sv_get_backrefs
+
+If the sv is the target of a weakrefence then return
+the backrefs structure associated with the sv, otherwise
+return NULL.
+
+When returning a non-null result the type of the return
+is relevant. If it is an AV then the contents of the AV
+are the weakrefs which point at this item. If it is any
+other type then the item itself is the weakref.
+
+See also Perl_sv_add_backref(), Perl_sv_del_backref(),
+Perl_sv_kill_backrefs()
+
+=cut
+*/
+
+SV *
+Perl_sv_get_backrefs(SV *const sv)
+{
+ SV *backrefs= NULL;
+
+ PERL_ARGS_ASSERT_SV_GET_BACKREFS;
+
+ /* find slot to store array or singleton backref */
+
+ if (SvTYPE(sv) == SVt_PVHV) {
+ if (SvOOK(sv)) {
+ struct xpvhv_aux * const iter = HvAUX((HV *)sv);
+ backrefs = (SV *)iter->xhv_backreferences;
+ }
+ } else if (SvMAGICAL(sv)) {
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
+ if (mg)
+ backrefs = mg->mg_obj;
+ }
+ return backrefs;
+}
+
/* Give tsv backref magic if it hasn't already got it, then push a
* back-reference to sv onto the array associated with the backref magic.
*
StructCopy(nsv,sv,SV);
#endif
if(SvTYPE(sv) == SVt_IV) {
- SvANY(sv)
- = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SET_SVANY_FOR_BODYLESS_IV(sv);
}
goto free_head;
}
- assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+ /* objs are always >= MG, but pad names use the SVs_OBJECT flag
+ for another purpose */
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG);
if (type >= SVt_PVMG) {
if (SvOBJECT(sv)) {
if (SvMAGIC(sv))
mg_free(sv);
}
- else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
- SvREFCNT_dec(SvOURSTASH(sv));
- }
- else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
- assert(!SvMAGICAL(sv));
- } else if (SvMAGIC(sv)) {
+ else if (SvMAGIC(sv)) {
/* Free back-references before other types of magic. */
sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
}
SvMAGICAL_off(sv);
- if (type == SVt_PVMG && SvPAD_TYPED(sv))
- SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
/* case SVt_INVLIST: */
IoIFP(sv) != PerlIO_stderr() &&
!(IoFLAGS(sv) & IOf_FAKE_DIRP))
{
- io_close(MUTABLE_IO(sv), FALSE);
+ io_close(MUTABLE_IO(sv), NULL, FALSE,
+ (IoTYPE(sv) == IoTYPE_WRONLY ||
+ IoTYPE(sv) == IoTYPE_RDWR ||
+ IoTYPE(sv) == IoTYPE_APPEND));
}
if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
PerlDir_close(IoDIRP(sv));
float b, c, keep_earlier;
if (byte > cache[3]) {
/* New position is between the existing pair of pairs. */
- b = cache[3];
- c = byte;
+ b = (float)cache[3];
+ c = (float)byte;
} else {
/* New position is before the existing pair of pairs. */
- b = byte;
- c = cache[3];
+ b = (float)byte;
+ c = (float)cache[3];
}
keep_earlier = THREEWAY_SQUARE(0, b, c, blen);
if (byte > cache[3]) {
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
/* Differing utf8ness.
* Do not UTF8size the comparands as a side-effect. */
- if (PL_encoding) {
+ if (IN_ENCODING) {
if (SvUTF8(sv1)) {
svrecode = newSVpvn(pv2, cur2);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv2 = SvPV_const(svrecode, cur2);
}
else {
svrecode = newSVpvn(pv1, cur1);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv1 = SvPV_const(svrecode, cur1);
}
/* Now both are in UTF-8. */
/* Differing utf8ness.
* Do not UTF8size the comparands as a side-effect. */
if (SvUTF8(sv1)) {
- if (PL_encoding) {
+ if (IN_ENCODING) {
svrecode = newSVpvn(pv2, cur2);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv2 = SvPV_const(svrecode, cur2);
}
else {
}
}
else {
- if (PL_encoding) {
+ if (IN_ENCODING) {
svrecode = newSVpvn(pv1, cur1);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv1 = SvPV_const(svrecode, cur1);
}
else {
goto thats_all_folks;
}
-thats_all_folks:
+ thats_all_folks:
/* check if we have actually found the separator - only really applies
* when rslen > 1 */
if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
-thats_really_all_folks:
+ thats_really_all_folks:
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
STDCHAR buf[8192];
#endif
-screamer2:
+ screamer2:
if (rslen) {
const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
}
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 */
*/
#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
STMT_START { \
- EXTEND_MORTAL(1); \
- PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
+ SSize_t ix = ++PL_tmps_ix; \
+ if (UNLIKELY(ix >= PL_tmps_max)) \
+ ix = tmps_grow_p(ix); \
+ PL_tmps_stack[ix] = (AnSv); \
} STMT_END
/*
{
dVAR;
if (!sv)
- return NULL;
+ return sv;
if (SvIMMORTAL(sv))
return sv;
PUSH_EXTEND_MORTAL__SV_C(sv);
SV *sv;
new_SV(sv);
- sv_setiv(sv,i);
+
+ /* Inlining ONLY the small relevant subset of sv_setiv here
+ * for performance. Makes a significant difference. */
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ (void)SvIOK_on(sv);
+
+ SvIV_set(sv, i);
+ SvTAINT(sv);
+
return sv;
}
{
SV *sv;
+ /* Inlining ONLY the small relevant subset of sv_setuv here
+ * for performance. Makes a significant difference. */
+
+ /* Using ivs is more efficient than using uvs - see sv_setuv */
+ if (u <= (UV)IV_MAX) {
+ return newSViv((IV)u);
+ }
+
new_SV(sv);
- sv_setuv(sv,u);
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+
+ SvUV_set(sv, u);
+ SvTAINT(sv);
+
return sv;
}
SV *sv;
new_SV(sv);
- sv_upgrade(sv, type);
+ ASSUME(SvTYPE(sv) == SVt_FIRST);
+ if(type != SVt_FIRST)
+ sv_upgrade(sv, type);
return sv;
}
SV *
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
- SV *sv = newSV_type(SVt_IV);
+ SV *sv;
PERL_ARGS_ASSERT_NEWRV_NOINC;
+ new_SV(sv);
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ SvROK_on(sv);
+ SvIV_set(sv, 0);
+
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
- SvROK_on(sv);
+
return sv;
}
SV_CHECK_THINKFIRST_COW_DROP(rv);
- if (SvTYPE(rv) >= SVt_PVMG) {
+ if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) {
const U32 refcnt = SvREFCNT(rv);
SvREFCNT(rv) = 0;
sv_clear(rv);
PERL_ARGS_ASSERT_F0CONVERT;
- if (Perl_isinfnan(nv)) {
- STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
+ if (UNLIKELY(Perl_isinfnan(nv))) {
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0);
*len = n;
return endbuf - n;
}
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
-#if 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
-# define LONGDOUBLE_LITTLE_ENDIAN
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_BIG_ENDIAN
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
-# define LONGDOUBLE_X86_80_BIT
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_DOUBLEDOUBLE
-# define DOUBLEDOUBLE_MAXBITS 1028
+#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. */
+ * 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+128/4)
+# define VHEX_SIZE (1+(NVSIZE * 8)/4)
#endif
/* If we do not have a known long double format, (including not using
# 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)
+#if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
# define HEXTRACT_LITTLE_ENDIAN
-#else
+#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
} STMT_END
#define HEXTRACT_BYTE(ix) \
STMT_START { \
- if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ 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) \
+ /* 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
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
+/* 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 NVSIZE
+# define HEXTRACTSIZE 2 * NVSIZE
#endif
- const U8* nvp = (const U8*)(&nv);
- const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
+ 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 NVSIZE > DOUBLESIZE
+ {
+ /* 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. */
- HEXTRACT_IMPLICIT_BIT(nv);
- for (ix = 13; ix >= 0; ix--) {
- HEXTRACT_BYTE(ix);
- }
+ /* 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. */
- HEXTRACT_IMPLICIT_BIT(nv);
- for (ix = 2; ix <= 15; ix++) {
- HEXTRACT_BYTE(ix);
- }
+ /* 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 */
-
- /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
- for (ix = 7; ix >= 0; ix--) {
- HEXTRACT_BYTE(ix);
- }
+ /* 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.) */
-
- /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
- for (ix = 0; ix < 8; ix++) {
- HEXTRACT_BYTE(ix);
- }
-# elif defined(LONGDOUBLE_DOUBLEDOUBLE)
- /* 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)
- */
-
- 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 {
+ /* 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;
}
- e *= (NV)0.5;
+ 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 */
- /* Then extract the remaining hexdigits. */
- while (d > (NV)0.0) {
+ /* First extract the leading hexdigit (the implicit bit). */
if (d >= e) {
- ha |= hd;
d -= e;
+ if (vend)
+ *v++ = 1;
+ else
+ v++;
}
- if (hd == 1) {
- /* Output or count in groups of four bits,
- * that is, when the hexdigit is down to one. */
+ else {
if (vend)
- *v++ = ha;
+ *v++ = 0;
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++;
+ /* 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++;
+ }
}
- }
-# else
- Perl_croak(aTHX_
- "Hexadecimal float: unsupported long double format");
# endif
-#else
- /* 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. */
- HEXTRACT_IMPLICIT_BIT(nv);
-# ifdef HEXTRACT_LITTLE_ENDIAN
- HEXTRACT_LO_NYBBLE(6);
- for (ix = 5; ix >= 0; ix--) {
- HEXTRACT_BYTE(ix);
}
-# else
- HEXTRACT_LO_NYBBLE(1);
- for (ix = 2; ix < HEXTRACTSIZE; ix++) {
- HEXTRACT_BYTE(ix);
- }
-# 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
/* For double-double the ixmin and ixmax stay at zero,
* which is convenient since the HEXTRACTSIZE is tricky
* for double-double. */
- ixmin < 0 || ixmax >= HEXTRACTSIZE ||
+ ixmin < 0 || ixmax >= NVSIZE ||
(vend && v != vend))
Perl_croak(aTHX_ "Hexadecimal float: internal error");
return v;
return;
}
-#ifndef USE_LONG_DOUBLE
+#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH)
/* special-case "%.<number>[gf]" */
if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
&& (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
long double fv;
-# define FV_ISFINITE(x) Perl_isfinitel(x)
+# ifdef Perl_isfinitel
+# define FV_ISFINITE(x) Perl_isfinitel(x)
+# endif
# 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
+#ifndef FV_ISFINITE
+# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
+#endif
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
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;
q++;
break;
#endif
-#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
case 'L': /* Ld */
/* FALLTHROUGH */
-#ifdef USE_QUADMATH
+# ifdef USE_QUADMATH
case 'Q':
/* FALLTHROUGH */
-#endif
-#if IVSIZE >= 8
+# endif
+# if IVSIZE >= 8
case 'q': /* qd */
-#endif
+# endif
intsize = 'q';
q++;
break;
#endif
case 'l':
++q;
-#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
if (*q == 'l') { /* lld, llf */
intsize = 'q';
++q;
}
}
- if (argsv && SvNOK(argsv)) {
+ if (argsv && strchr("BbcDdiOopuUXx",*q)) {
/* XXX va_arg(*args) case? need peek, use va_copy? */
- infnan = Perl_isinfnan(SvNV(argsv));
+ SvGETMAGIC(argsv);
+ if (UNLIKELY(SvAMAGIC(argsv)))
+ argsv = sv_2num(argsv);
+ infnan = UNLIKELY(isinfnansv(argsv));
}
switch (c = *q++) {
if (infnan)
Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'",
/* no va_arg() case */
- SvNV(argsv), (int)c);
- uv = (args) ? va_arg(*args, int) : SvIV(argsv);
+ 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;
esignbuf[esignlen++] = plus;
}
else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
esignbuf[esignlen++] = '-';
}
}
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;
*/
switch (intsize) {
case 'V':
-#if defined(USE_LONG_DOUBLE)
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
intsize = 'q';
#endif
break;
case 'l':
/* FALLTHROUGH */
default:
-#if defined(USE_LONG_DOUBLE)
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
intsize = args ? 0 : 'q';
#endif
break;
#ifdef USE_QUADMATH
fv = intsize == 'q' ?
va_arg(*args, NV) : va_arg(*args, double);
+ nv = fv;
#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);
+ nv = fv;
+ } else {
+ nv = va_arg(*args, double);
+ NV_TO_FV(nv, fv);
+ }
#else
- fv = va_arg(*args, double);
+ nv = va_arg(*args, double);
+ fv = nv;
#endif
}
else
- fv = NV_TO_FV(argsv);
+ {
+ if (!infnan) SvGETMAGIC(argsv);
+ nv = SvNV_nomg(argsv);
+ NV_TO_FV(nv, fv);
+ }
need = 0;
/* frexp() (or frexpl) has some unspecified behaviour for
* 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. */
+ * larger, up to total of DOUBLEDOUBLE_MAXBITS bits.
+ * See the definition of DOUBLEDOUBLE_MAXBITS.
+ *
+ * Need 2 hexdigits for each byte. */
need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
/* the size for the exponent already added */
#endif
goto float_converted;
}
} else if ( c == 'f' && !precis ) {
- if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen)))
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
break;
}
}
* should be output as 0x0.0000000000001p-1022 to
* match its internal structure. */
- /* Note: fv can be (and often is) long double.
- * Here it is explicitly cast to NV. */
- vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
- S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
-# ifdef LONGDOUBLE_X86_80_BIT
- exponent -= 4;
-# else
+# ifdef HEXTRACT_HAS_IMPLICIT_BIT
+ /* In this case there is an implicit bit,
+ * and therefore the exponent is shifted shift by one. */
exponent--;
+# else
+ /* In this case there is no implicit bit,
+ * and the exponent is shifted by the first xdigit. */
+ exponent -= 4;
# endif
#endif
#endif
if (precis > 0) {
- v = vhex + precis + 1;
- if (v < vend) {
+ if ((SSize_t)(precis + 1) < vend - vhex) {
+ bool round;
+
+ v = vhex + precis + 1;
/* Round away from zero: if the tail
* beyond the precis xdigits is equal to
* or greater than 0x8000... */
- bool round = *v > 0x8;
+ round = *v > 0x8;
if (!round && *v == 0x8) {
for (v++; v < vend; v++) {
if (*v) {
elen = width;
}
}
- else
- elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+ else {
+ elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
+ if (elen) {
+ /* Not affecting infnan output: precision, alt, fill. */
+ if (elen < width) {
+ if (left) {
+ /* Pack the back with spaces. */
+ memset(PL_efloatbuf + elen, ' ', width - elen);
+ } else {
+ /* Move it to the right. */
+ Move(PL_efloatbuf, PL_efloatbuf + width - elen,
+ elen, char);
+ /* Pad the front with spaces. */
+ memset(PL_efloatbuf, ' ', width - elen);
+ }
+ elen = width;
+ }
+ }
+ }
if (elen == 0) {
char *ptr = ebuf + sizeof ebuf;
*--ptr = '\0';
*--ptr = c;
+#if defined(USE_QUADMATH)
+ if (intsize == 'q') {
+ /* "g" -> "Qg" */
+ *--ptr = 'Q';
+ }
/* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
-#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+#elif 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. */
/* 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) {
if (!qfmt)
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
- qfmt, fv);
+ qfmt, nv);
if ((IV)elen == -1)
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
if (qfmt != ptr)
#endif
/* don't clone objects whose class has asked us not to */
- if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ if (SvOBJECT(sstr)
+ && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE))
+ {
SvFLAGS(dstr) = 0;
return dstr;
}
SvANY(dstr) = NULL;
break;
case SVt_IV:
- SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SET_SVANY_FOR_BODYLESS_IV(dstr);
if(SvROK(sstr)) {
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
} else {
}
break;
case SVt_NV:
+#if NVSIZE <= IVSIZE
+ SET_SVANY_FOR_BODYLESS_NV(dstr);
+#else
SvANY(dstr) = new_XNV();
+#endif
SvNV_set(dstr, SvNVX(sstr));
break;
default:
missing by always going for the destination.
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
- if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
- SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
- } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
- NOOP;
- } else if (SvMAGIC(dstr))
+ if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvOBJECT(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
? NULL
: gv_dup(CvGV(sstr), param);
- CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
+ if (!CvISXSUB(sstr)) {
+ PADLIST * padlist = CvPADLIST(sstr);
+ if(padlist)
+ padlist = padlist_dup(padlist, param);
+ CvPADLIST_set(dstr, padlist);
+ } else
+/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */
+ PoisonPADLIST(dstr);
+
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
+ case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
/* FALLTHROUGH */
case SAVEt_ITEM: /* normal string */
case SAVEt_GVSV: /* scalar slot in GV */
- case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ if (type == SAVEt_SV)
+ break;
/* FALLTHROUGH */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
+ case SAVEt_FREEPADNAME:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param);
+ PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++;
+ break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = savesharedpv(c);
case SAVEt_SVREF: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ if (type == SAVEt_SVREF)
+ SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
break;
case SAVEt_AELEM: /* array element */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (const AV *)POPPTR(ss,ix);
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++;
+ case SAVEt_GP_ALIASED_SV: {
+ GP * gp_ptr = (GP *)POPPTR(ss,ix);
+ GP * new_gp_ptr = gp_dup(gp_ptr, param);
+ TOPPTR(nss,ix) = new_gp_ptr;
+ new_gp_ptr->gp_refcnt++;
break;
+ }
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_sig_pending = 0;
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+ Zero(&PL_padname_undef, 1, PADNAME);
+ Zero(&PL_padname_const, 1, PADNAME);
# ifdef DEBUG_LEAKING_SCALARS
PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
PL_subline = proto_perl->Isubline;
+ PL_cv_has_eval = proto_perl->Icv_has_eval;
+
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+ ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const,
+ &PL_padname_const);
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
+ PL_xsubfilename = proto_perl->Ixsubfilename;
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
- PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
PL_inplace = SAVEPV(proto_perl->Iinplace);
PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
/* magical thingies */
PL_encoding = sv_dup(proto_perl->Iencoding, param);
+ PL_lex_encoding = sv_dup(proto_perl->Ilex_encoding, param);
sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, IV);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
+ PL_savebegin = proto_perl->Isavebegin;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+#ifdef USE_LOCALE_CTYPE
+ /* Should we warn if uses locale? */
+ PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+#endif
+
#ifdef USE_LOCALE_COLLATE
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
#endif /* USE_LOCALE_COLLATE */
SvLEN_set(&PL_sv_yes, 0);
SvIV_set(&PL_sv_yes, 1);
SvNV_set(&PL_sv_yes, 1);
+
+ PadnamePV(&PL_padname_const) = (char *)PL_No;
}
/*
}
else {
CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
- SV *sv;
- AV *av;
+ PADNAME *sv;
assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
if (!cv || !CvPADLIST(cv))
return NULL;
- av = *PadlistARRAY(CvPADLIST(cv));
- sv = *av_fetch(av, targ, FALSE);
- sv_setsv_flags(name, sv, 0);
+ sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ);
+ sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv));
+ SvUTF8_on(name);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
OP_PADSV or OP_GV that gives the name of the undefined variable. On the
other hand, with OP_ADD there are two branches to follow, so we only print
the variable name if we get an exact match.
+desc_p points to a string pointer holding the description of the op.
+This may be updated if needed.
The name is returned as a mortal SV.
STATIC SV *
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
- bool match)
+ bool match, const char **desc_p)
{
dVAR;
SV *sv;
const GV *gv;
const OP *o, *o2, *kid;
+ PERL_ARGS_ASSERT_FIND_UNINIT_VAR;
+
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
return NULL;
}
else if (obase == PL_op) /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
- uninit_sv, match);
+ uninit_sv, match, desc_p);
else /* @{expr}, %{expr} as a sub-expression */
return NULL;
}
if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
break;
- return varname(gv, hash ? '%' : '@', obase->op_targ,
+ return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ,
keysv, index, subscript_type);
}
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
}
/* ${expr} */
- return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
+ return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p);
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
if (!o || o->op_type != OP_NULL ||
! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
break;
- return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p);
case OP_AELEM:
case OP_HELEM:
if (PL_op == obase)
/* $a[uninit_expr] or $h{uninit_expr} */
- return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_last,
+ uninit_sv, match, desc_p);
gv = NULL;
o = cBINOPx(obase)->op_first;
/* index is constant */
SV* kidsv;
if (negate) {
- kidsv = sv_2mortal(newSVpvs("-"));
+ kidsv = newSVpvs_flags("-", SVs_TEMP);
sv_catsv(kidsv, cSVOPx_sv(kid));
}
else
if (match)
break;
return varname(gv,
- (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
- ? '@' : '%',
+ (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+ ? '@' : '%'),
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
NOT_REACHED; /* NOTREACHED */
}
+ case OP_MULTIDEREF: {
+ /* If we were executing OP_MULTIDEREF when the undef warning
+ * triggered, then it must be one of the index values within
+ * that triggered it. If not, then the only possibility is that
+ * the value retrieved by the last aggregate lookup might be the
+ * culprit. For the former, we set PL_multideref_pc each time before
+ * using an index, so work though the item list until we reach
+ * that point. For the latter, just work through the entire item
+ * list; the last aggregate retrieved will be the candidate.
+ */
+
+ /* the named aggregate, if any */
+ PADOFFSET agg_targ = 0;
+ GV *agg_gv = NULL;
+ /* the last-seen index */
+ UV index_type;
+ PADOFFSET index_targ;
+ GV *index_gv;
+ IV index_const_iv = 0; /* init for spurious compiler warn */
+ SV *index_const_sv;
+ int depth = 0; /* how many array/hash lookups we've done */
+
+ UNOP_AUX_item *items = cUNOP_AUXx(obase)->op_aux;
+ UNOP_AUX_item *last = NULL;
+ UV actions = items->uv;
+ bool is_hv;
+
+ if (PL_op == obase) {
+ last = PL_multideref_pc;
+ assert(last >= items && last <= items + items[-1].uv);
+ }
+
+ assert(actions);
+
+ while (1) {
+ is_hv = FALSE;
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem: /* $lex{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem: /* $lex[...] */
+ agg_targ = (++items)->pad_offset;
+ agg_gv = NULL;
+ break;
+
+ case MDEREF_HV_gvhv_helem: /* $pkg{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvav_aelem: /* $pkg[...] */
+ agg_targ = 0;
+ agg_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(agg_gv));
+ break;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
+ case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
+ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
+ agg_targ = 0;
+ agg_gv = NULL;
+ is_hv = TRUE;
+ break;
+
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
+ case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
+ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
+ agg_targ = 0;
+ agg_gv = NULL;
+ } /* switch */
+
+ index_targ = 0;
+ index_gv = NULL;
+ index_const_sv = NULL;
+
+ index_type = (actions & MDEREF_INDEX_MASK);
+ switch (index_type) {
+ case MDEREF_INDEX_none:
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hv)
+ index_const_sv = UNOP_AUX_item_sv(++items)
+ else
+ index_const_iv = (++items)->iv;
+ break;
+ case MDEREF_INDEX_padsv:
+ index_targ = (++items)->pad_offset;
+ break;
+ case MDEREF_INDEX_gvsv:
+ index_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(index_gv));
+ break;
+ }
+
+ if (index_type != MDEREF_INDEX_none)
+ depth++;
+
+ if ( index_type == MDEREF_INDEX_none
+ || (actions & MDEREF_FLAG_last)
+ || (last && items == last)
+ )
+ break;
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+
+ if (PL_op == obase) {
+ /* index was undef */
+
+ *desc_p = ( (actions & MDEREF_FLAG_last)
+ && (obase->op_private
+ & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)))
+ ?
+ (obase->op_private & OPpMULTIDEREF_EXISTS)
+ ? "exists"
+ : "delete"
+ : is_hv ? "hash element" : "array element";
+ assert(index_type != MDEREF_INDEX_none);
+ if (index_gv)
+ return varname(index_gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ if (index_targ)
+ return varname(NULL, '$', index_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+ assert(is_hv); /* AV index is an IV and can't be undef */
+ /* can a const HV index ever be undef? */
+ return NULL;
+ }
+
+ /* the SV returned by pp_multideref() was undef, if anything was */
+
+ if (depth != 1)
+ break;
+
+ if (agg_targ)
+ sv = PAD_SV(agg_targ);
+ else if (agg_gv)
+ sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
+ else
+ break;
+
+ if (index_type == MDEREF_INDEX_const) {
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (is_hv) {
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ SV * const * const svp =
+ av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ return is_hv
+ ? varname(agg_gv, '%', agg_targ,
+ index_const_sv, 0, FUV_SUBSCRIPT_HASH)
+ : varname(agg_gv, '@', agg_targ,
+ NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
+ }
+ else {
+ /* index is an var */
+ if (is_hv) {
+ SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+ if (keysv)
+ return varname(agg_gv, '%', agg_targ,
+ keysv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ else {
+ const I32 index
+ = find_array_subscript((const AV *)sv, uninit_sv);
+ if (index >= 0)
+ return varname(agg_gv, '@', agg_targ,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return varname(agg_gv,
+ is_hv ? '%' : '@',
+ agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+ }
+ NOT_REACHED; /* NOTREACHED */
+ }
+
case OP_AASSIGN:
/* only examine RHS */
- return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv,
+ match, desc_p);
case OP_OPEN:
o = cUNOPx(obase)->op_first;
if ( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
)
- o = OP_SIBLING(o);
+ o = OpSIBLING(o);
- if (!OP_HAS_SIBLING(o)) {
+ if (!OpHAS_SIBLING(o)) {
/* one-arg version of open is highly magical */
if (o->op_type == OP_GV) { /* open FOO; */
case OP_SUBST:
case OP_MATCH:
if ( !(obase->op_flags & OPf_STACKED)) {
- if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
- ? PAD_SVl(obase->op_targ)
- : DEFSV))
- {
- sv = sv_newmortal();
- sv_setpvs(sv, "$_");
- return sv;
- }
+ if (uninit_sv == DEFSV)
+ return newSVpvs_flags("$_", SVs_TEMP);
+ else if (obase->op_targ
+ && uninit_sv == PAD_SVl(obase->op_targ))
+ return varname(NULL, '$', obase->op_targ, NULL, 0,
+ FUV_SUBSCRIPT_NONE);
}
goto do_op;
&&
( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
- o = OP_SIBLING(OP_SIBLING(o));
+ o = OpSIBLING(OpSIBLING(o));
goto do_op2;
* it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
- for (kid=o; kid; kid = OP_SIBLING(kid)) {
+ for (kid=o; kid; kid = OpSIBLING(kid)) {
const OPCODE type = kid->op_type;
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
o2 = kid;
}
if (o2)
- return find_uninit_var(o2, uninit_sv, match);
+ return find_uninit_var(o2, uninit_sv, match, desc_p);
/* scan all args */
while (o) {
- sv = find_uninit_var(o, uninit_sv, 1);
+ sv = find_uninit_var(o, uninit_sv, 1, desc_p);
if (sv)
return sv;
- o = OP_SIBLING(o);
+ o = OpSIBLING(o);
}
break;
}
{
if (PL_op) {
SV* varname = NULL;
+ const char *desc;
+
+ desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+ ? "join or string"
+ : OP_DESC(PL_op);
if (uninit_sv && PL_curpad) {
- varname = find_uninit_var(PL_op, uninit_sv,0);
+ varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
/* diag_listed_as: Use of uninitialized value%s */
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
SVfARG(varname ? varname : &PL_sv_no),
- " in ", OP_DESC(PL_op));
+ " in ", desc);
GCC_DIAG_RESTORE;
}
else {
https://perl5.git.perl.org / perl5.git / blobdiff