X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/47d3b731f074752fe0862ffdf333cfd3935f793a..ec610f8a9f2738d8a59ee84a3ec7ed858addea85:/sv.c diff --git a/sv.c b/sv.c index cd77099..f2f86d0 100644 --- a/sv.c +++ b/sv.c @@ -48,25 +48,23 @@ 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. */ @@ -261,14 +259,14 @@ Public API: # 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. @@ -284,7 +282,7 @@ Public API: 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); \ @@ -410,6 +408,34 @@ S_del_sv(pTHX_ SV *p) #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 @@ -1292,8 +1318,8 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) 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; @@ -1304,10 +1330,6 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) 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)) @@ -1330,13 +1352,13 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) 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 - SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv)); + SET_SVANY_FOR_BODYLESS_NV(sv); #else SvANY(sv) = new_XNV(); #endif @@ -1403,6 +1425,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) no route from NV to PVIV, NOK can never be true */ assert(!SvNOKp(sv)); assert(!SvNOK(sv)); + /* FALLTHROUGH */ case SVt_PVIO: case SVt_PVFM: case SVt_PVGV: @@ -1572,8 +1595,11 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) * 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 @@ -1591,7 +1617,9 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) /* Don't round up on the first allocation, as odds are pretty good that * the initial request is accurate as to what is really needed */ if (SvLEN(sv)) { - newlen = PERL_STRLEN_ROUNDUP(newlen); + STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen); + if (rounded > newlen) + newlen = rounded; } #endif if (SvLEN(sv) && s) { @@ -1911,6 +1939,7 @@ Perl_looks_like_number(pTHX_ SV *const sv) { const char *sbegin; STRLEN len; + int numtype; PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; @@ -1919,7 +1948,8 @@ Perl_looks_like_number(pTHX_ SV *const sv) } 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 @@ -2080,6 +2110,10 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv /* 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) { @@ -2104,6 +2138,9 @@ S_sv_setnv(pTHX_ SV* sv, int numtype) SvPOK_on(sv); /* PV is okay, though. */ } } +#ifdef USING_MSVC6 +# pragma warning(pop) +#endif STATIC bool S_sv_2iuv_common(pTHX_ SV *const sv) @@ -2117,9 +2154,6 @@ 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); @@ -2128,10 +2162,18 @@ S_sv_2iuv_common(pTHX_ SV *const sv) 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 @@ -2219,6 +2261,8 @@ S_sv_2iuv_common(pTHX_ SV *const sv) 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; } @@ -2247,7 +2291,8 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } 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. */ @@ -2279,6 +2324,13 @@ S_sv_2iuv_common(pTHX_ SV *const sv) #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)) { @@ -2388,9 +2440,6 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) 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; @@ -2418,9 +2467,8 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) 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) { @@ -2434,6 +2482,13 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) } } + /* 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); @@ -2483,9 +2538,6 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) 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; @@ -2508,9 +2560,8 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) 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) { @@ -2519,6 +2570,13 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) 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); @@ -2677,107 +2735,104 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) 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 */ + const UV nv_as_uv = U_V(nv); - 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); + 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); } @@ -2785,8 +2840,8 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) =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 macro to -access this function. +reference or overload conversion. The caller is expected to have handled +get-magic already. =cut */ @@ -2829,7 +2884,7 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe uv = iv; sign = 0; } else { - uv = -iv; + uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv); sign = 1; } do { @@ -2851,7 +2906,7 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe * 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; @@ -2862,6 +2917,8 @@ S_infnan_2pv(NV nv, char* buffer, size_t maxlen) { if (maxlen < 5) /* "-Inf\0" */ return 0; *s++ = '-'; + } else if (plus) { + *s++ = '+'; } *s++ = 'I'; *s++ = 'n'; @@ -3065,7 +3122,6 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) 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 ) { @@ -3077,7 +3133,7 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) 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); @@ -3104,7 +3160,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) #else { bool local_radix; - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_TO_NEEDED(); local_radix = PL_numeric_local && @@ -3206,14 +3263,6 @@ include SV_GMAGIC. */ 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; @@ -3444,8 +3493,8 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr 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); } @@ -3484,7 +3533,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr 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 @@ -4239,7 +4288,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) PERL_ARGS_ASSERT_SV_SETSV_FLAGS; - if (sstr == dstr) + if (UNLIKELY( sstr == dstr )) return; if (SvIS_FREED(dstr)) { @@ -4247,7 +4296,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) " 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", @@ -4261,7 +4310,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 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; } @@ -4270,7 +4319,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 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: @@ -4298,7 +4353,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) break; case SVt_NV: - if (SvNOK(sstr)) { + if (LIKELY( SvNOK(sstr) )) { switch (dtype) { case SVt_NULL: case SVt_IV: @@ -4387,7 +4442,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 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; @@ -4403,7 +4458,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 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 */ @@ -5149,22 +5206,27 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) } 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); @@ -5387,8 +5449,14 @@ Handles 'get' magic, but not 'set' magic. See C. =for apidoc sv_catpvn_flags Concatenates the string onto the end of the string which is in the SV. The -C 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 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 +flag, and as bytes by supplying the C flag; the SV or the +string appended will be upgraded to UTF-8 if necessary. + If C has the C bit set, will C on C afterwards if appropriate. C and C are implemented @@ -5602,8 +5670,6 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 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); @@ -5881,6 +5947,45 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) return sv; } +/* +=for apidoc sv_get_backrefs + +If the sv is the target of a weak reference then it returns the back +references 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 elements of the AV are the weak reference RVs which +point at this item. If it is any other type then the item itself is the +weak reference. + +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. * @@ -6201,8 +6306,6 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l PERL_ARGS_ASSERT_SV_INSERT_FLAGS; - if (!bigstr) - Perl_croak(aTHX_ "Can't modify nonexistent substring"); SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { @@ -6320,8 +6423,7 @@ Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) 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); } @@ -6417,7 +6519,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) SV* iter_sv = NULL; SV* next_sv = NULL; SV *sv = orig_sv; - STRLEN hash_index; + STRLEN hash_index = 0; /* initialise to make Coverity et al happy. + Not strictly necessary */ PERL_ARGS_ASSERT_SV_CLEAR; @@ -6443,7 +6546,9 @@ Perl_sv_clear(pTHX_ SV *const orig_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)) { @@ -6457,19 +6562,12 @@ Perl_sv_clear(pTHX_ SV *const orig_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: */ @@ -6480,7 +6578,10 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) 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)); @@ -6510,17 +6611,19 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_last_swash_hv = NULL; } if (HvTOTALKEYS((HV*)sv) > 0) { - const char *name; + const HEK *hek; /* this statement should match the one at the beginning of * hv_undef_flags() */ if ( PL_phase != PERL_PHASE_DESTRUCT - && (name = HvNAME((HV*)sv))) + && (hek = HvNAME_HEK((HV*)sv))) { if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", - SVfARG(sv))); + DEBUG_o(Perl_deb(aTHX_ + "sv_clear clearing PL_stashcache for '%"HEKf + "'\n", + HEKfARG(hek))); (void)hv_deletehek(PL_stashcache, - HvNAME_HEK((HV*)sv), G_DISCARD); + hek, G_DISCARD); } hv_name_set((HV*)sv, NULL, 0, 0); } @@ -6571,6 +6674,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); if (isREGEXP(sv)) goto freeregexp; + /* FALLTHROUGH */ case SVt_PVGV: if (isGV_with_GP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) @@ -6595,6 +6699,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_statgv = NULL; else if ((const GV *)sv == PL_stderrgv) PL_stderrgv = NULL; + /* FALLTHROUGH */ case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -7724,15 +7829,15 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) 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. */ @@ -7815,9 +7920,9 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, /* 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 { @@ -7827,9 +7932,9 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, } } 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 { @@ -8489,13 +8594,13 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) 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, @@ -8523,7 +8628,7 @@ thats_really_all_folks: STDCHAR buf[8192]; #endif -screamer2: + screamer2: if (rslen) { const STDCHAR * const bpe = buf + sizeof(buf); bp = buf; @@ -9306,7 +9411,22 @@ Perl_newSViv(pTHX_ const IV i) 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; } @@ -9324,8 +9444,29 @@ Perl_newSVuv(pTHX_ const UV u) { 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; } @@ -9362,13 +9503,25 @@ SV is B incremented. 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; } @@ -9951,7 +10104,7 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) 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); @@ -10636,7 +10789,7 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) PERL_ARGS_ASSERT_F0CONVERT; if (UNLIKELY(Perl_isinfnan(nv))) { - STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len); + STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0); *len = n; return endbuf - n; } @@ -10694,40 +10847,28 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 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 +#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. */ + * after the first 1023 zero bits. + * + * XXX The 2098 is quite large (262.25 bytes) and therefore some sort + * of dynamically growing buffer might be better, start at just 16 bytes + * (for example) and grow only when necessary. Or maybe just by looking + * at the exponents of the two doubles? */ # define DOUBLEDOUBLE_MAXBITS 2098 #endif /* vhex will contain the values (0..15) of the hex digits ("nybbles" * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits - * per xdigit. For the double-double case, this can be rather many. */ + * 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 @@ -10747,15 +10888,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, # 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 @@ -10798,17 +10936,31 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend) } 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 +/* 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) @@ -10816,176 +10968,207 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend) # define HEXTRACTSIZE 2 * NVSIZE #endif - const U8* nvp = (const U8*)(&nv); 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 < NVSIZE; 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 @@ -11022,7 +11205,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ bool hexfp = FALSE; /* hexadecimal floating point? */ - DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -11068,7 +11251,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p return; } -#ifndef USE_LONG_DOUBLE +#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH) /* special-case "%.[gf]" */ if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { @@ -11160,7 +11343,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #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 */ @@ -11173,10 +11358,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p # endif #else NV fv; -# define FV_ISFINITE(x) Perl_isfinite((NV)(x)) # define FV_GF NVgf # 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; @@ -11476,23 +11664,25 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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; @@ -11545,6 +11735,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (argsv && strchr("BbcDdiOopuUXx",*q)) { /* XXX va_arg(*args) case? need peek, use va_copy? */ SvGETMAGIC(argsv); + if (UNLIKELY(SvAMAGIC(argsv))) + argsv = sv_2num(argsv); infnan = UNLIKELY(isinfnansv(argsv)); } @@ -11698,7 +11890,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p esignbuf[esignlen++] = plus; } else { - uv = -iv; + uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv); esignbuf[esignlen++] = '-'; } } @@ -11876,7 +12068,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p */ switch (intsize) { case 'V': -#if defined(USE_LONG_DOUBLE) +#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) intsize = 'q'; #endif break; @@ -11884,7 +12076,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'l': /* FALLTHROUGH */ default: -#if defined(USE_LONG_DOUBLE) +#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) intsize = args ? 0 : 'q'; #endif break; @@ -11916,19 +12108,25 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef USE_QUADMATH fv = intsize == 'q' ? va_arg(*args, NV) : va_arg(*args, double); + nv = fv; #elif LONG_DOUBLESIZE > DOUBLESIZE - if (intsize == 'q') + if (intsize == 'q') { fv = va_arg(*args, long double); - else - NV_TO_FV(va_arg(*args, double), fv); + 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 { if (!infnan) SvGETMAGIC(argsv); - NV_TO_FV(SvNV_nomg(argsv), fv); + nv = SvNV_nomg(argsv); + NV_TO_FV(nv, fv); } need = 0; @@ -12075,7 +12273,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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; } } @@ -12103,16 +12301,18 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * 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 @@ -12154,12 +12354,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #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) { @@ -12257,15 +12459,37 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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. */ @@ -12273,13 +12497,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* 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) { @@ -12316,7 +12536,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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) @@ -13234,7 +13454,9 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) #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; } @@ -13244,7 +13466,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 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 { @@ -13253,7 +13475,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) break; case SVt_NV: #if NVSIZE <= IVSIZE - SvANY(dstr) = (XPVNV*)((char*)&(dstr->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv)); + SET_SVANY_FOR_BODYLESS_NV(dstr); #else SvANY(dstr) = new_XNV(); #endif @@ -13319,11 +13541,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 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)); @@ -13422,7 +13640,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) } items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { - *dst_ary++ = &PL_sv_undef; + *dst_ary++ = NULL; } } else { @@ -13554,7 +13772,15 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const 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) @@ -13655,17 +13881,22 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_LOOP_LAZYSV: ncx->blk_loop.state_u.lazysv.end = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); - /* We are taking advantage of av_dup_inc and sv_dup_inc - actually being the same function, and order equivalence of - the two unions. + /* Fallthrough: duplicate lazysv.cur by using the ary.ary + duplication code instead. + We are taking advantage of (1) av_dup_inc and sv_dup_inc + actually being the same function, and (2) order + equivalence of the two unions. We can assert the later [but only at run time :-(] */ assert ((void *) &ncx->blk_loop.state_u.ary.ary == (void *) &ncx->blk_loop.state_u.lazysv.cur); + /* FALLTHROUGH */ case CXt_LOOP_FOR: ncx->blk_loop.state_u.ary.ary = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); + /* FALLTHROUGH */ case CXt_LOOP_LAZYIV: case CXt_LOOP_PLAIN: + /* code common to all CXt_LOOP_* types */ if (CxPADLOOP(ncx)) { ncx->blk_loop.itervar_u.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, @@ -13816,14 +14047,16 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* 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: @@ -13831,6 +14064,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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); @@ -13841,6 +14079,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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; @@ -13993,7 +14233,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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); @@ -14038,11 +14278,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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); @@ -14200,9 +14442,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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 +# ifdef PERL_TRACE_OPS + Zero(PL_op_exec_cnt, OP_max+2, UV); +# endif #else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); #endif /* DEBUGGING */ @@ -14342,6 +14589,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_subline = proto_perl->Isubline; + PL_cv_has_eval = proto_perl->Icv_has_eval; + #ifdef FCRYPT PL_cryptseen = proto_perl->Icryptseen; #endif @@ -14480,6 +14729,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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(); @@ -14520,18 +14771,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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 */ @@ -14594,6 +14846,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); @@ -14673,6 +14926,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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 */ @@ -14698,9 +14956,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, for (i = 0; i < POSIX_CC_COUNT; i++) { PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); } + PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param); + PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param); + PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param); PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); - PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); - PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); @@ -14989,6 +15248,8 @@ Perl_init_constants(pTHX) 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; } /* @@ -15027,6 +15288,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) nsv = sv_newmortal(); SvSetSV_nosteal(nsv, sv); } + save_re_context(); PUSHMARK(sp); EXTEND(SP, 3); PUSHs(encoding); @@ -15092,11 +15354,12 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, PERL_ARGS_ASSERT_SV_CAT_DECODE; - if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { + if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) { SV *offsv; dSP; ENTER; SAVETMPS; + save_re_context(); PUSHMARK(sp); EXTEND(SP, 6); PUSHs(encoding); @@ -15226,16 +15489,15 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, } 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) { @@ -15270,6 +15532,8 @@ warning, then following the direct child of the op may yield an 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. @@ -15281,13 +15545,15 @@ PL_comppad/PL_curpad points to the currently executing pad. 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; @@ -15327,7 +15593,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, } 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; } @@ -15362,7 +15628,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 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) @@ -15412,7 +15678,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const 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: @@ -15421,7 +15687,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 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; @@ -15453,7 +15720,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, /* index is constant */ SV* kidsv; if (negate) { - kidsv = sv_2mortal(newSVpvs("-")); + kidsv = newSVpvs_flags("-", SVs_TEMP); sv_catsv(kidsv, cSVOPx_sv(kid)); } else @@ -15510,18 +15777,214 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 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; */ @@ -15545,14 +16008,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 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; @@ -15566,7 +16027,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, && ( 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; @@ -15697,7 +16158,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, * 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)) @@ -15713,14 +16174,14 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 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; } @@ -15742,14 +16203,15 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) 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); } - desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded - ? "join or string" - : OP_DESC(PL_op); /* PL_warn_uninit_sv is constant */ GCC_DIAG_IGNORE(-Wformat-nonliteral); /* diag_listed_as: Use of uninitialized value%s */ @@ -15768,11 +16230,5 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */