X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a25b59276cf9505a41280bad7847c33234f7e7c6..07ec6dc6c1e9a3a06ac5059d954fcec1dde7945d:/sv.c diff --git a/sv.c b/sv.c index e0b08d0..5f88508 100644 --- a/sv.c +++ b/sv.c @@ -35,15 +35,6 @@ # include #endif -#ifndef HAS_C99 -# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS) -# define HAS_C99 1 -# endif -#endif -#ifdef HAS_C99 -# include -#endif - #ifdef __Lynx__ /* Missing proto on LynxOS */ char *gconvert(double, int, int, char *); @@ -112,9 +103,6 @@ GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \ GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \ ) -/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to), - * has a mandatory return value, even though that value is just the same - * as the buf arg */ #ifdef PERL_UTF8_CACHE_ASSERT /* if adding more checks watch out for the following tests: @@ -310,7 +298,6 @@ Public API: STATIC SV* S_more_sv(pTHX) { - dVAR; SV* sv; char *chunk; /* must use New here to match call to */ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ @@ -386,8 +373,6 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) STATIC void S_del_sv(pTHX_ SV *p) { - dVAR; - PERL_ARGS_ASSERT_DEL_SV; if (DEBUG_D_TEST) { @@ -432,7 +417,6 @@ and split it into a list of free SVs. static void S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) { - dVAR; SV *const sva = MUTABLE_SV(ptr); SV* sv; SV* svend; @@ -472,7 +456,6 @@ S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) STATIC I32 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) { - dVAR; SV* sva; I32 visited = 0; @@ -531,7 +514,6 @@ Perl_sv_report_used(pTHX) static void do_clean_objs(pTHX_ SV *const ref) { - dVAR; assert (SvROK(ref)); { SV * const target = SvRV(ref); @@ -557,7 +539,6 @@ do_clean_objs(pTHX_ SV *const ref) static void do_clean_named_objs(pTHX_ SV *const sv) { - dVAR; SV *obj; assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); @@ -601,7 +582,6 @@ do_clean_named_objs(pTHX_ SV *const sv) static void do_clean_named_io_objs(pTHX_ SV *const sv) { - dVAR; SV *obj; assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); @@ -638,7 +618,6 @@ Attempt to destroy all objects not yet freed. void Perl_sv_clean_objs(pTHX) { - dVAR; GV *olddef, *olderr; PL_in_clean_objs = TRUE; visit(do_clean_objs, SVf_ROK, SVf_ROK); @@ -667,7 +646,6 @@ Perl_sv_clean_objs(pTHX) static void do_clean_all(pTHX_ SV *const sv) { - dVAR; if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { /* don't clean pid table and strtab */ return; @@ -690,7 +668,6 @@ SVs which are in complex self-referential hierarchies. I32 Perl_sv_clean_all(pTHX) { - dVAR; I32 cleaned; PL_in_clean_all = TRUE; cleaned = visit(do_clean_all, 0,0); @@ -746,7 +723,6 @@ heads and bodies within the arenas must already have been freed. void Perl_sv_free_arenas(pTHX) { - dVAR; SV* sva; SV* svanext; unsigned int i; @@ -814,6 +790,8 @@ Perl_sv_free_arenas(pTHX) =head1 SV-Body Allocation +=cut + Allocation of SV-bodies is similar to SV-heads, differing as follows; the allocation mechanism is used for many body types, so is somewhat more complicated, it uses arena-sets, and has no need for still-live @@ -1074,7 +1052,6 @@ void * Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, const size_t arena_size) { - dVAR; void ** const root = &PL_body_roots[sv_type]; struct arena_desc *adesc; struct arena_set *aroot = (struct arena_set *) PL_body_arenas; @@ -1082,6 +1059,9 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, char *start; const char *end; const size_t good_arena_size = Perl_malloc_good_size(arena_size); +#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT) + dVAR; +#endif #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; @@ -1180,7 +1160,6 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, STATIC void * S_new_body(pTHX_ const svtype sv_type) { - dVAR; void *xpv; new_body_inline(xpv, sv_type); return xpv; @@ -1207,7 +1186,6 @@ C. void Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) { - dVAR; void* old_body; void* new_body; const svtype old_type = SvTYPE(sv); @@ -1507,13 +1485,12 @@ wrapper instead. */ int -Perl_sv_backoff(pTHX_ SV *const sv) +Perl_sv_backoff(SV *const sv) { STRLEN delta; const char * const s = SvPVX_const(sv); PERL_ARGS_ASSERT_SV_BACKOFF; - PERL_UNUSED_CONTEXT; assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); @@ -1567,7 +1544,7 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) #ifdef PERL_NEW_COPY_ON_WRITE /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare) - * to store the COW count. So in general, allocate one more byte than + * to store the CowREFCNT. So in general, allocate one more byte than * asked for, to make it likely this byte is always spare: and thus * make more strings COW-able. * If the new size is a big power of two, don't bother: we assume the @@ -1583,7 +1560,7 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) if (newlen > SvLEN(sv)) { /* need more room? */ STRLEN minlen = SvCUR(sv); - minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; + minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 2; if (newlen < minlen) newlen = minlen; #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC @@ -1628,8 +1605,6 @@ Does not handle 'set' magic. See also C. void Perl_sv_setiv(pTHX_ SV *const sv, const IV i) { - dVAR; - PERL_ARGS_ASSERT_SV_SETIV; SV_CHECK_THINKFIRST_COW_DROP(sv); @@ -1740,8 +1715,6 @@ Does not handle 'set' magic. See also C. void Perl_sv_setnv(pTHX_ SV *const sv, const NV num) { - dVAR; - PERL_ARGS_ASSERT_SV_SETNV; SV_CHECK_THINKFIRST_COW_DROP(sv); @@ -1790,26 +1763,24 @@ Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) SvSETMAGIC(sv); } -/* Print an "isn't numeric" warning, using a cleaned-up, - * printable version of the offending string +/* Return a cleaned-up, printable version of sv, for non-numeric, or + * not incrementable warning display. + * Originally part of S_not_a_number(). + * The return value may be != tmpbuf. */ -STATIC void -S_not_a_number(pTHX_ SV *const sv) -{ - dVAR; - SV *dsv; - char tmpbuf[64]; - const char *pv; +STATIC const char * +S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { + const char *pv; - PERL_ARGS_ASSERT_NOT_A_NUMBER; + PERL_ARGS_ASSERT_SV_DISPLAY; if (DO_UTF8(sv)) { - dsv = newSVpvs_flags("", SVs_TEMP); + SV *dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT); } else { char *d = tmpbuf; - const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; + const char * const limit = tmpbuf + tmpbuf_size - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ @@ -1860,6 +1831,23 @@ S_not_a_number(pTHX_ SV *const sv) pv = tmpbuf; } + return pv; +} + +/* Print an "isn't numeric" warning, using a cleaned-up, + * printable version of the offending string + */ + +STATIC void +S_not_a_number(pTHX_ SV *const sv) +{ + char tmpbuf[64]; + const char *pv; + + PERL_ARGS_ASSERT_NOT_A_NUMBER; + + pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); + if (PL_op) Perl_warner(aTHX_ packWARN(WARN_NUMERIC), /* diag_listed_as: Argument "%s" isn't numeric%s */ @@ -1871,6 +1859,19 @@ S_not_a_number(pTHX_ SV *const sv) "Argument \"%s\" isn't numeric", pv); } +STATIC void +S_not_incrementable(pTHX_ SV *const sv) { + char tmpbuf[64]; + const char *pv; + + PERL_ARGS_ASSERT_NOT_INCREMENTABLE; + + pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); + + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" treated as 0 in increment (++)", pv); +} + /* =for apidoc looks_like_number @@ -2007,9 +2008,8 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv # endif ) { - dVAR; - PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; + PERL_UNUSED_CONTEXT; DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { @@ -2058,8 +2058,6 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv STATIC bool S_sv_2iuv_common(pTHX_ SV *const sv) { - dVAR; - PERL_ARGS_ASSERT_SV_2IUV_COMMON; if (SvNOKp(sv)) { @@ -2224,13 +2222,8 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv))); -#endif #ifdef NV_PRESERVES_UV (void)SvIOKp_on(sv); @@ -2336,8 +2329,6 @@ Normally used via the C and C macros. IV Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2IV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV @@ -2431,8 +2422,6 @@ Normally used via the C and C macros. UV Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2UV_FLAGS; if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) @@ -2513,8 +2502,6 @@ Normally used via the C and C macros. NV Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2NV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV @@ -2580,22 +2567,13 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (SvTYPE(sv) < SVt_NV) { /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ sv_upgrade(sv, SVt_NV); -#ifdef USE_LONG_DOUBLE DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, - "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", + "0x%"UVxf" num(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); -#endif } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -2724,21 +2702,12 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) and ideally should be fixed. */ return 0.0; } -#if defined(USE_LONG_DOUBLE) DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif return SvNVX(sv); } @@ -2802,6 +2771,39 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe return ptr; } +/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an +* infinity or a not-a-number, writes the appropriate strings to the +* buffer, including a zero byte. On success returns the written length, +* excluding the zero byte, on failure returns zero. */ +STATIC size_t +S_infnan_copy(NV nv, char* buffer, size_t maxlen) { + if (maxlen < 4) + return 0; + else { + char* s = buffer; + if (Perl_isinf(nv)) { + if (nv < 0) { + if (maxlen < 5) + return 0; + *s++ = '-'; + } + *s++ = 'I'; + *s++ = 'n'; + *s++ = 'f'; + } + else if (Perl_isnan(nv)) { + *s++ = 'N'; + *s++ = 'a'; + *s++ = 'N'; + /* XXX output the payload mantissa bits as "(hhh...)" */ + } + else + return 0; + *s++ = 0; + return s - buffer - 1; + } +} + /* =for apidoc sv_2pv_flags @@ -2816,7 +2818,6 @@ C and C usually end up here too. char * Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { - dVAR; char *s; PERL_ARGS_ASSERT_SV_2PV_FLAGS; @@ -2986,37 +2987,44 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) *s++ = '0'; *s = '\0'; } else { - dSAVE_ERRNO; + STRLEN len; /* The +20 is pure guesswork. Configure test needed. --jhi */ s = SvGROW_mutable(sv, NV_DIG + 20); - /* some Xenix systems wipe out errno here */ + + len = S_infnan_copy(SvNVX(sv), s, SvLEN(sv)); + if (len > 0) + s += len; + else { + dSAVE_ERRNO; + /* some Xenix systems wipe out errno here */ #ifndef USE_LOCALE_NUMERIC - PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); - SvPOK_on(sv); -#else - { - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); - - /* If the radix character is UTF-8, and actually is in the - * output, turn on the UTF-8 flag for the scalar */ - if (PL_numeric_local - && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) - && instr(s, SvPVX_const(PL_numeric_radix_sv))) + SvPOK_on(sv); +#else { - SvUTF8_on(sv); + DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); + PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); + + /* If the radix character is UTF-8, and actually is in the + * output, turn on the UTF-8 flag for the scalar */ + if (PL_numeric_local + && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) + && instr(s, SvPVX_const(PL_numeric_radix_sv))) + { + SvUTF8_on(sv); + } + RESTORE_LC_NUMERIC(); } - RESTORE_LC_NUMERIC(); - } - /* We don't call SvPOK_on(), because it may come to pass that the - * locale changes so that the stringification we just did is no - * longer correct. We will have to re-stringify every time it is - * needed */ + /* We don't call SvPOK_on(), because it may come to + * pass that the locale changes so that the + * stringification we just did is no longer correct. We + * will have to re-stringify every time it is needed */ #endif - RESTORE_ERRNO; - while (*s) s++; + RESTORE_ERRNO; + } + while (*s) s++; } } else if (isGV_with_GP(sv)) { @@ -3187,8 +3195,6 @@ contain SV_GMAGIC, then it does an mg_get() first. bool Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; restart: @@ -3304,8 +3310,6 @@ especially if it could return the position of the first one. STRLEN Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) { - dVAR; - PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; if (sv == &PL_sv_undef) @@ -3459,7 +3463,7 @@ must_be_utf8: * set so starts from there. Otherwise, can use memory copy to * get up to where we are now, and then start from here */ - if (invariant_head <= 0) { + if (invariant_head == 0) { d = dst; } else { Copy(s, dst, invariant_head, char); @@ -3564,8 +3568,6 @@ use the Encode extension for that. bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) { - dVAR; - PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; if (SvPOKp(sv) && SvUTF8(sv)) { @@ -4103,7 +4105,6 @@ S_sv_buf_to_rw(pTHX_ SV *sv) void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) { - dVAR; U32 sflags; int dtype; svtype stype; @@ -4703,7 +4704,6 @@ undefined. Does not handle 'set' magic. See C. void Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) { - dVAR; char *dptr; PERL_ARGS_ASSERT_SV_SETPVN; @@ -4761,7 +4761,6 @@ Does not handle 'set' magic. See C. void Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) { - dVAR; STRLEN len; PERL_ARGS_ASSERT_SV_SETPV; @@ -4802,8 +4801,6 @@ Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr) void Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) { - dVAR; - PERL_ARGS_ASSERT_SV_SETHEK; if (!hek) { @@ -4873,7 +4870,6 @@ C, and already meets the requirements for storing in C). void Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) { - dVAR; STRLEN allocate; PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; @@ -4996,8 +4992,6 @@ of. Hence, it croaks on read-only values. static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags) { - dVAR; - assert(SvIsCOW(sv)); { #ifdef PERL_ANY_COW @@ -5270,7 +5264,6 @@ in terms of this function. void Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags) { - dVAR; STRLEN dlen; const char * const dstr = SvPV_force_flags(dsv, dlen, flags); @@ -5336,8 +5329,6 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_CATSV_FLAGS; if (ssv) { @@ -5367,7 +5358,6 @@ valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. void Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr) { - dVAR; STRLEN len; STRLEN tlen; char *junk; @@ -5443,7 +5433,6 @@ modules supporting older perls. SV * Perl_newSV(pTHX_ const STRLEN len) { - dVAR; SV *sv; new_SV(sv); @@ -5476,7 +5465,6 @@ MAGIC * Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, const MGVTBL *const vtable, const char *const name, const I32 namlen) { - dVAR; MAGIC* mg; PERL_ARGS_ASSERT_SV_MAGICEXT; @@ -5584,7 +5572,6 @@ void Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, const char *const name, const I32 namlen) { - dVAR; const MGVTBL *vtable; MAGIC* mg; unsigned int flags; @@ -5791,7 +5778,6 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) { - dVAR; SV **svp; AV *av = NULL; MAGIC *mg = NULL; @@ -5852,7 +5838,6 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) void Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) { - dVAR; SV **svp = NULL; PERL_ARGS_ASSERT_SV_DEL_BACKREF; @@ -6074,7 +6059,6 @@ C that applies to C. void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { - dVAR; char *big; char *mid; char *midend; @@ -6172,7 +6156,6 @@ time you'll want to use C or one of its many macro front-ends. void Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) { - dVAR; const U32 refcnt = SvREFCNT(sv); PERL_ARGS_ASSERT_SV_REPLACE; @@ -6650,8 +6633,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) static bool S_curse(pTHX_ SV * const sv, const bool check_refcnt) { - dVAR; - PERL_ARGS_ASSERT_CURSE; assert(SvOBJECT(sv)); @@ -6911,7 +6892,6 @@ Perl_sv_len_utf8(pTHX_ SV *const sv) STRLEN Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) { - dVAR; STRLEN len; const U8 *s = (U8*)SvPV_nomg_const(sv, len); @@ -7586,7 +7566,6 @@ if necessary. If the flags include SV_GMAGIC, it handles get-magic, too. I32 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { - dVAR; const char *pv1; STRLEN cur1; const char *pv2; @@ -7688,7 +7667,6 @@ I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags) { - dVAR; STRLEN cur1, cur2; const char *pv1, *pv2; I32 cmp; @@ -7784,7 +7762,6 @@ I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags) { - dVAR; #ifdef USE_LOCALE_COLLATE char *pv1, *pv2; @@ -7857,7 +7834,6 @@ settings. char * Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS; @@ -8048,7 +8024,6 @@ in the SV (typically, C is a suitable choice). char * Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) { - dVAR; const char *rsptr; STRLEN rslen; STDCHAR rslast; @@ -8518,7 +8493,6 @@ if necessary. Handles operator overloading. Skips handling 'get' magic. void Perl_sv_inc_nomg(pTHX_ SV *const sv) { - dVAR; char *d; int flags; @@ -8591,11 +8565,11 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (d < SvEND(sv)) { + const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); #ifdef PERL_PRESERVE_IVUV /* Got to punt this as an integer if needs be, but we don't issue warnings. Probably ought to make the sv_iv_please() that does the conversion if possible, and silently. */ - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); if (numtype && !(numtype & IS_NUMBER_INFINITY)) { /* Need to try really hard to see if it's an integer. 9.22337203685478e+18 is an integer. @@ -8617,15 +8591,12 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) /* I don't think we can get here. Maybe I should assert this And if we do get here I suspect that sv_setnv will croak. NWC Fall through. */ -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#endif } #endif /* PERL_PRESERVE_IVUV */ + if (!numtype && ckWARN(WARN_NUMERIC)) + not_incrementable(sv); sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); return; } @@ -8644,7 +8615,7 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) * arranged in order (although not consecutively) and that only * [A-Za-z] are accepted by isALPHA in the C locale. */ - if (*d != 'z' && *d != 'Z') { + if (isALPHA_FOLD_NE(*d, 'z')) { do { ++*d; } while (!isALPHA(*d)); return; } @@ -8680,7 +8651,6 @@ if necessary. Handles 'get' magic and operator overloading. void Perl_sv_dec(pTHX_ SV *const sv) { - dVAR; if (!sv) return; SvGETMAGIC(sv); @@ -8699,7 +8669,6 @@ if necessary. Handles operator overloading. Skips handling 'get' magic. void Perl_sv_dec_nomg(pTHX_ SV *const sv) { - dVAR; int flags; if (!sv) @@ -8794,13 +8763,8 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) /* I don't think we can get here. Maybe I should assert this And if we do get here I suspect that sv_setnv will croak. NWC Fall through. */ -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#endif } } #endif /* PERL_PRESERVE_IVUV */ @@ -8836,7 +8800,6 @@ statement boundaries. See also C and C. SV * Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) { - dVAR; SV *sv; if (flags & SV_GMAGIC) @@ -8862,7 +8825,6 @@ See also C and C. SV * Perl_sv_newmortal(pTHX) { - dVAR; SV *sv; new_SV(sv); @@ -8896,7 +8858,6 @@ C is a convenience wrapper for this function, defined as SV * Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) { - dVAR; SV *sv; /* All the flags we don't support must be zero. @@ -8964,7 +8925,6 @@ For efficiency, consider using C instead. SV * Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { - dVAR; SV *sv; new_SV(sv); @@ -8988,9 +8948,7 @@ undefined. SV * Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) { - dVAR; SV *sv; - new_SV(sv); sv_setpvn(sv,buffer,len); return sv; @@ -9009,7 +8967,6 @@ SV if the hek is NULL. SV * Perl_newSVhek(pTHX_ const HEK *const hek) { - dVAR; if (!hek) { SV *sv; @@ -9177,7 +9134,6 @@ Perl_newSVpvf(pTHX_ const char *const pat, ...) SV * Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { - dVAR; SV *sv; PERL_ARGS_ASSERT_VNEWSVPVF; @@ -9199,7 +9155,6 @@ The reference count for the SV is set to 1. SV * Perl_newSVnv(pTHX_ const NV n) { - dVAR; SV *sv; new_SV(sv); @@ -9219,7 +9174,6 @@ SV is set to 1. SV * Perl_newSViv(pTHX_ const IV i) { - dVAR; SV *sv; new_SV(sv); @@ -9239,7 +9193,6 @@ The reference count for the SV is set to 1. SV * Perl_newSVuv(pTHX_ const UV u) { - dVAR; SV *sv; new_SV(sv); @@ -9278,7 +9231,6 @@ SV is B incremented. SV * Perl_newRV_noinc(pTHX_ SV *const tmpRef) { - dVAR; SV *sv = newSV_type(SVt_IV); PERL_ARGS_ASSERT_NEWRV_NOINC; @@ -9296,8 +9248,6 @@ Perl_newRV_noinc(pTHX_ SV *const tmpRef) SV * Perl_newRV(pTHX_ SV *const sv) { - dVAR; - PERL_ARGS_ASSERT_NEWRV; return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); @@ -9315,7 +9265,6 @@ Creates a new SV which is an exact duplicate of the original SV. SV * Perl_newSVsv(pTHX_ SV *const old) { - dVAR; SV *sv; if (!old) @@ -9353,7 +9302,6 @@ Perl_sv_reset(pTHX_ const char *s, HV *const stash) void Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) { - dVAR; char todo[PERL_UCHAR_MAX+1]; const char *send; @@ -9498,7 +9446,6 @@ The flags in C are passed to gv_fetchsv. CV * Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) { - dVAR; GV *gv = NULL; CV *cv = NULL; @@ -9622,8 +9569,6 @@ C and C char * Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; if (flags & SV_GMAGIC) SvGETMAGIC(sv); @@ -9753,7 +9698,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" /* tied lvalues should appear to be * scalars for backwards compatibility */ - : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') + : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) ? "SCALAR" : "LVALUE"); case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; @@ -9867,7 +9812,6 @@ reference count is 1. The reference count 1 is owned by C. SV* Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) { - dVAR; SV *sv; PERL_ARGS_ASSERT_NEWSVRV; @@ -9935,8 +9879,6 @@ Note that C copies the string while this copies the pointer. SV* Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) { - dVAR; - PERL_ARGS_ASSERT_SV_SETREF_PV; if (!pv) { @@ -10049,7 +9991,6 @@ of the SV is unaffected. SV* Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) { - dVAR; SV *tmpRef; HV *oldstash = NULL; @@ -10087,7 +10028,6 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) PERL_STATIC_INLINE void S_sv_unglob(pTHX_ SV *const sv, U32 flags) { - dVAR; void *xpvmg; HV *stash; SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal(); @@ -10187,6 +10127,7 @@ void Perl_sv_untaint(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_UNTAINT; + PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); @@ -10207,6 +10148,7 @@ bool Perl_sv_tainted(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_TAINTED; + PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); @@ -10522,7 +10464,6 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * Warn of missing argument to sprintf, and then return a defined value * to avoid inappropriate "use of uninit" warnings [perl #71000]. */ -#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ STATIC SV* S_vcatpvfn_missing_argument(pTHX) { if (ckWARN(WARN_MISSING)) { @@ -10536,7 +10477,6 @@ S_vcatpvfn_missing_argument(pTHX) { STATIC I32 S_expect_number(pTHX_ char **const pattern) { - dVAR; I32 var = 0; PERL_ARGS_ASSERT_EXPECT_NUMBER; @@ -10618,12 +10558,278 @@ 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); } +/* vhex will contain the values (0..15) of the hex digits ("nybbles" + * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa, + * four bits per xdigit. */ +#define VHEX_SIZE (1+128/4) + +/* If we do not have a known long double format, (including not using + * long doubles, or long doubles being equal to doubles) then we will + * fall back to the ldexp/frexp route, with which we can retrieve at + * most as many bits as our widest unsigned integer type is. We try + * to get a 64-bit unsigned integer even if we are not having 64-bit + * UV. */ +#if defined(HAS_QUAD) && defined(Uquad_t) +# define MANTISSATYPE Uquad_t +# define MANTISSASIZE 8 +#else +# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */ +# define MANTISSASIZE UVSIZE +#endif + +/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting + * the hexadecimal values (for %a/%A). The nv is the NV where the value + * are being extracted from (either directly from the long double in-memory + * presentation, or from the uquad computed via frexp+ldexp). frexp also + * is used to update the exponent. vhex is the pointer to the beginning + * of the output buffer (of VHEX_SIZE). + * + * The tricky part is that S_hextract() needs to be called twice: + * the first time with vend as NULL, and the second time with vend as + * the pointer returned by the first call. What happens is that on + * the first round the output size is computed, and the intended + * extraction sanity checked. On the second round the actual output + * (the extraction of the hexadecimal values) takes place. + * Sanity failures cause fatal failures during both rounds. */ +STATIC U8* +S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend) +{ + U8* v = vhex; + int ix; + int ixmin = 0, ixmax = 0; + + /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT, + * and elsewhere. */ + + /* These macros are just to reduce typos, they have multiple + * repetitions below, but usually only one (or sometimes two) + * of them is really being used. */ + /* HEXTRACT_OUTPUT() extracts the high nybble first. */ +#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4) +#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF) +#define HEXTRACT_OUTPUT(ix) \ + STMT_START { \ + HEXTRACT_OUTPUT_HI(ix); \ + HEXTRACT_OUTPUT_LO(ix); \ + } STMT_END +#define HEXTRACT_COUNT(ix, c) \ + STMT_START { \ + v += c; \ + if (ix < ixmin) \ + ixmin = ix; \ + else if (ix > ixmax) \ + ixmax = ix; \ + } STMT_END +#define HEXTRACT_IMPLICIT_BIT() \ + if (exponent) { \ + if (vend) \ + *v++ = 1; \ + else \ + v++; \ + } + + /* First see if we are using long doubles. */ +#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE + const U8* nvp = (const U8*)(&nv); +# define HEXTRACTSIZE NVSIZE + (void)Perl_frexp(PERL_ABS(nv), exponent); +# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN + /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L: + * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */ + /* The bytes 13..0 are the mantissa/fraction, + * the 15,14 are the sign+exponent. */ + HEXTRACT_IMPLICIT_BIT(); + for (ix = 13; ix >= 0; ix--) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN + /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L: + * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */ + /* The bytes 2..15 are the mantissa/fraction, + * the 0,1 are the sign+exponent. */ + HEXTRACT_IMPLICIT_BIT(); + for (ix = 2; ix <= 15; ix++) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN + /* x86 80-bit "extended precision", 64 bits of mantissa / fraction / + * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can + * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X), + * meaning that 2 or 6 bytes are empty padding. */ + /* The bytes 7..0 are the mantissa/fraction */ + /* There explicitly is *no* implicit bit in this case. */ + for (ix = 7; ix >= 0; ix--) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN + /* (does this format ever happen?) */ + /* There explicitly is *no* implicit bit in this case. */ + for (ix = 0; ix < 8; ix++) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN + /* Where is this used? + * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f */ + HEXTRACT_IMPLICIT_BIT(); + if (vend) + HEXTRACT_OUTPUT_LO(14); + else + HEXTRACT_COUNT(14, 1); + for (ix = 13; ix >= 8; ix--) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } + /* XXX not extracting from the second double -- see the discussion + * below for the big endian double double. */ +# if 0 + if (vend) + HEXTRACT_OUTPUT_LO(6); + else + HEXTRACT_COUNT(6, 1); + for (ix = 5; ix >= 0; ix--) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# endif +# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN + /* Used in e.g. PPC/Power (AIX) and MIPS. + * + * The mantissa bits are in two separate stretches, e.g. for -0.1L: + * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a + */ + HEXTRACT_IMPLICIT_BIT(); + if (vend) + HEXTRACT_OUTPUT_LO(1); + else + HEXTRACT_COUNT(1, 1); + for (ix = 2; ix < 8; ix++) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } + /* XXX not extracting the second double mantissa bits- this is not + * right nor ideal (we effectively reduce the output format to + * that of a "single double", only 53 bits), but we do not know + * exactly how to do the extraction correctly so that it matches + * the semantics of, say, the IEEE quadruple float. */ +# if 0 + if (vend) + HEXTRACT_OUTPUT_LO(9); + else + HEXTRACT_COUNT(9, 1); + for (ix = 10; ix < 16; ix++) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# endif +# else + Perl_croak(aTHX_ + "Hexadecimal float: unsupported long double format"); +# endif +#else + /* If not using long doubles (or if the long double format is + * known but not yet supported), try to retrieve the mantissa bits + * via frexp+ldexp. */ + + NV norm = Perl_frexp(PERL_ABS(nv), exponent); + /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to + * inspect; but in practice we don't want the leading nybbles that + * are zero. With the common IEEE 754 value for NV_MANT_DIG being + * 53, we want the limit byte to be (int)((53-1)/8) == 6. + * + * Note that this is _not_ inspecting the in-memory format of the + * nv (as opposed to the long double method), but instead the UV + * retrieved with the frexp+ldexp invocation. */ +# if MANTISSASIZE * 8 > NV_MANT_DIG + MANTISSATYPE mantissa = (MANTISSATYPE)Perl_ldexp(norm, NV_MANT_DIG); + int limit_byte = (NV_MANT_DIG - 1) / 8; +# else + /* There will be low-order precision loss. Try to salvage as many + * bits as possible. Will truncate, not round. */ + MANTISSATYPE mantissa = + Perl_ldexp(norm, + /* The highest possible shift by two that fits in the + * mantissa and is aligned (by four) the same was as + * NV_MANT_DIG. */ + MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4)); + int limit_byte = MANTISSASIZE - 1; +# endif + const U8* nvp = (const U8*)(&mantissa); +# define HEXTRACTSIZE MANTISSASIZE + /* We make here the wild assumption that the endianness of doubles + * is similar to the endianness of integers, and that there is no + * middle-endianness. This may come back to haunt us (the rumor + * has it that ARM can be quite haunted). + * + * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit + * bytes, since we might need to handle printf precision, and also + * insert the radix. + */ +# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN + /* Little endian. */ + for (ix = limit_byte; ix >= 0; ix--) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# else + /* Big endian. */ + for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) { + if (vend) + HEXTRACT_OUTPUT(ix); + else + HEXTRACT_COUNT(ix, 2); + } +# endif + /* If there are not enough bits in MANTISSATYPE, we couldn't get + * all of them, issue a warning. + * + * Note that NV_PRESERVES_UV_BITS would not help here, it is the + * wrong way around. */ +# if NV_MANT_DIG > MANTISSASIZE * 8 + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Hexadecimal float: precision loss"); +# endif +#endif + /* Croak for various reasons: if the output pointer escaped the + * output buffer, if the extraction index escaped the extraction + * buffer, or if the ending output pointer didn't match the + * previously computed value. */ + if (v <= vhex || v - vhex >= VHEX_SIZE || + ixmin < 0 || ixmax >= HEXTRACTSIZE || + (vend && v != vend)) + Perl_croak(aTHX_ "Hexadecimal float: internal error"); + return v; +} + void Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, const U32 flags) { - dVAR; char *p; char *q; const char *patend; @@ -10640,6 +10846,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p char ebuf[IV_DIG * 4 + NV_DIG + 32]; /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ + bool hexfp = FALSE; DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; @@ -10653,9 +10861,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p (void)SvPV_force_nomg(sv, origlen); /* special-case "", "%s", and "%-p" (SVf - see below) */ - if (patlen == 0) + if (patlen == 0) { + if (svmax && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); return; + } if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { + if (svmax > 1 && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + if (args) { const char * const s = va_arg(*args, char*); sv_catpv_nomg(sv, s ? s : nullstr); @@ -10671,6 +10887,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { + if (svmax > 1 && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); argsv = MUTABLE_SV(va_arg(*args, void*)); sv_catsv_nomg(sv, argsv); return; @@ -10686,6 +10905,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p pp = pat + 2; while (*pp >= '0' && *pp <= '9') digits = 10 * digits + (*pp++ - '0'); + + /* XXX: Why do this `svix < svmax` test? Couldn't we just + format the first argument and WARN_REDUNDANT if svmax > 1? + Munged by Nicholas Clark in v5.13.0-209-g95ea86d */ if (pp - pat == (int)patlen - 1 && svix < svmax) { const NV nv = SvNV(*svargs); if (*pp == 'g') { @@ -10770,6 +10993,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p I32 epix = 0; /* explicit precision index */ I32 evix = 0; /* explicit vector index */ bool asterisk = FALSE; + bool infnan = FALSE; /* echo everything up to the next format specification */ for (q = p; q < patend && *q != '%'; ++q) ; @@ -10866,6 +11090,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '$') { ++q; efix = width; + if (!no_redundant_warning) + /* I've forgotten if it's a better + micro-optimization to always set this or to + only set it if it's unset */ + no_redundant_warning = TRUE; } else { goto gotwidth; } @@ -11080,7 +11309,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': case 'z': case 't': -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': #endif intsize = *q++; @@ -11110,6 +11339,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } + if (argsv && SvNOK(argsv)) { + /* XXX va_arg(*args) case? */ + infnan = Perl_isinfnan(SvNV(argsv)); + } + switch (c = *q++) { /* STRINGS */ @@ -11117,7 +11351,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'c': if (vectorize) goto unknown; - uv = (args) ? va_arg(*args, int) : SvIV(argsv); + uv = (args) ? va_arg(*args, int) : + infnan ? UNICODE_REPLACEMENT : SvIV(argsv); if ((uv > 255 || (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -11173,6 +11408,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* INTEGERS */ case 'p': + if (infnan) { + c = 'g'; + goto floating_point; + } if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -11188,6 +11427,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FALLTHROUGH */ case 'd': case 'i': + if (infnan) { + c = 'g'; + goto floating_point; + } if (vectorize) { STRLEN ulen; if (!veclen) @@ -11215,7 +11458,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 't': iv = va_arg(*args, ptrdiff_t); break; #endif default: iv = va_arg(*args, int); break; -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': iv = va_arg(*args, intmax_t); break; #endif case 'q': @@ -11289,6 +11532,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p base = 16; uns_integer: + if (infnan) { + c = 'g'; + goto floating_point; + } if (vectorize) { STRLEN ulen; vector: @@ -11314,7 +11561,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef HAS_PTRDIFF_T case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ #endif -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': uv = va_arg(*args, uintmax_t); break; #endif default: uv = va_arg(*args, unsigned); break; @@ -11405,12 +11652,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FLOATING POINT */ + floating_point: + case 'F': c = 'f'; /* maybe %F isn't supported here */ /* FALLTHROUGH */ case 'e': case 'E': case 'f': case 'g': case 'G': + case 'a': case 'A': if (vectorize) goto unknown; @@ -11460,17 +11710,60 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p : SvNV(argsv); need = 0; - /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything - else. frexp() has some unspecified behaviour for those three */ - if (c != 'e' && c != 'E' && (nv * 0) == 0) { - i = PERL_INT_MIN; - /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this - will cast our (long double) to (double) */ - (void)Perl_frexp(nv, &i); - if (i == PERL_INT_MIN) - Perl_die(aTHX_ "panic: frexp"); - if (i > 0) - need = BIT_DIGITS(i); + /* frexp() (or frexpl) has some unspecified behaviour for + * nan/inf/-inf, so let's avoid calling that on those + * three values. nv * 0 will be NaN for NaN, +Inf and -Inf, + * and 0 for anything else. */ + if (isALPHA_FOLD_NE(c, 'e') && (nv * 0) == 0) { + i = PERL_INT_MIN; + (void)Perl_frexp(nv, &i); + if (i == PERL_INT_MIN) + Perl_die(aTHX_ "panic: frexp"); + /* Do not set hexfp earlier since we want to printf + * Inf/NaN for Inf/NAN, not their hexfp. */ + hexfp = isALPHA_FOLD_EQ(c, 'a'); + if (UNLIKELY(hexfp)) { + /* This seriously overshoots in most cases, but + * better the undershooting. Firstly, all bytes + * of the NV are not mantissa, some of them are + * exponent. Secondly, for the reasonably common + * long doubles case, the "80-bit extended", two + * or six bytes of the NV are unused. */ + need += + (nv < 0) ? 1 : 0 + /* possible unary minus */ + 2 + /* "0x" */ + 1 + /* the very unlikely carry */ + 1 + /* "1" */ + 1 + /* "." */ + 2 * NVSIZE + /* 2 hexdigits for each byte */ + 2 + /* "p+" */ + BIT_DIGITS(NV_MAX_EXP) + /* exponent */ + 1; /* \0 */ +#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN + /* However, for the "double double", we need more. + * Since each double has their own exponent, the + * doubles may float (haha) rather far from each + * other, and the number of required bits is much + * larger, up to total of 1028 bits. (NOTE: this + * is not actually implemented properly yet, + * we are using just the first double, see + * S_hextract() for details. But let's prepare + * for the future.) */ + + /* 2 hexdigits for each byte. */ + need += (1028/8 - DOUBLESIZE + 1) * 2; +#endif +#ifdef USE_LOCALE_NUMERIC + STORE_LC_NUMERIC_SET_TO_NEEDED(); + if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) + need += SvLEN(PL_numeric_radix_sv); + RESTORE_LC_NUMERIC(); +#endif + } + else if (i > 0) { + need = BIT_DIGITS(i); + } /* if i < 0, the number of digits is hard to predict. */ } need += has_precis ? precis : 6; /* known default */ @@ -11568,19 +11861,200 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p break; } } - { - char *ptr = ebuf + sizeof ebuf; - *--ptr = '\0'; - *--ptr = c; - /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ + + if (UNLIKELY(hexfp)) { + /* Hexadecimal floating point. */ + char* p = PL_efloatbuf; + U8 vhex[VHEX_SIZE]; + U8* v = vhex; /* working pointer to vhex */ + U8* vend; /* pointer to one beyond last digit of vhex */ + U8* vfnz = NULL; /* first non-zero */ + const bool lower = (c == 'a'); + /* At output the values of vhex (up to vend) will + * be mapped through the xdig to get the actual + * human-readable xdigits. */ + const char* xdig = PL_hexdigit; + int zerotail = 0; /* how many extra zeros to append */ + int exponent = 0; /* exponent of the floating point input */ + + /* XXX: denormals, NaN, Inf. + * + * For example with denormals, (assuming the vanilla + * 64-bit double): the exponent is zero. 1xp-1074 is + * the smallest denormal and the smallest double, it + * should be output as 0x0.0000000000001p-1022 to + * match its internal structure. */ + + vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL); + S_hextract(aTHX_ nv, &exponent, vhex, vend); + +#if NVSIZE > DOUBLESIZE && defined(LONG_DOUBLEKIND) +# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN + exponent -= 4; +# else + exponent--; +# endif +#endif + + if (nv < 0) + *p++ = '-'; + else if (plus) + *p++ = plus; + *p++ = '0'; + if (lower) { + *p++ = 'x'; + } + else { + *p++ = 'X'; + xdig += 16; /* Use uppercase hex. */ + } + + /* Find the first non-zero xdigit. */ + for (v = vhex; v < vend; v++) { + if (*v) { + vfnz = v; + break; + } + } + + if (vfnz) { + U8* vlnz = NULL; /* The last non-zero. */ + + /* Find the last non-zero xdigit. */ + for (v = vend - 1; v >= vhex; v--) { + if (*v) { + vlnz = v; + break; + } + } + +#if NVSIZE == DOUBLESIZE + exponent--; +#endif + + if (precis > 0) { + v = vhex + precis + 1; + if (v < vend) { + /* Round away from zero: if the tail + * beyond the precis xdigits is equal to + * or greater than 0x8000... */ + bool round = *v > 0x8; + if (!round && *v == 0x8) { + for (v++; v < vend; v++) { + if (*v) { + round = TRUE; + break; + } + } + } + if (round) { + for (v = vhex + precis; v >= vhex; v--) { + if (*v < 0xF) { + (*v)++; + break; + } + *v = 0; + if (v == vhex) { + /* If the carry goes all the way to + * the front, we need to output + * a single '1'. This goes against + * the "xdigit and then radix" + * but since this is "cannot happen" + * category, that is probably good. */ + *p++ = xdig[1]; + } + } + } + /* The new effective "last non zero". */ + vlnz = vhex + precis; + } + else { + zerotail = precis - (vlnz - vhex); + } + } + + v = vhex; + *p++ = xdig[*v++]; + + /* The radix is always output after the first + * non-zero xdigit, or if alt. */ + if (vfnz < vlnz || alt) { +#ifndef USE_LOCALE_NUMERIC + *p++ = '.'; +#else + STORE_LC_NUMERIC_SET_TO_NEEDED(); + if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) { + STRLEN n; + const char* r = SvPV(PL_numeric_radix_sv, n); + Copy(r, p, n, char); + p += n; + } + else { + *p++ = '.'; + } + RESTORE_LC_NUMERIC(); +#endif + } + + while (v <= vlnz) + *p++ = xdig[*v++]; + + while (zerotail--) + *p++ = '0'; + } + else { + *p++ = '0'; + exponent = 0; + } + + elen = p - PL_efloatbuf; + elen += my_snprintf(p, PL_efloatsize - elen, + "%c%+d", lower ? 'p' : 'P', + exponent); + + if (elen < width) { + if (left) { + /* Pad the back with spaces. */ + memset(PL_efloatbuf + elen, ' ', width - elen); + } + else if (fill == '0') { + /* Insert the zeros between the "0x" and + * the digits, otherwise we end up with + * "0000xHHH..." */ + STRLEN nzero = width - elen; + char* zerox = PL_efloatbuf + 2; + Move(zerox, zerox + nzero, elen - 2, char); + memset(zerox, fill, nzero); + } + 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; + } + } + else + elen = S_infnan_copy(nv, PL_efloatbuf, PL_efloatsize); + if (elen == 0) { + char *ptr = ebuf + sizeof ebuf; + *--ptr = '\0'; + *--ptr = c; + /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) + /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, + * not USE_LONG_DOUBLE and NVff. In other words, + * this needs to work without USE_LONG_DOUBLE. */ if (intsize == 'q') { /* Copy the one or more characters in a long double * format before the 'base' ([efgEFG]) character to * the format string. */ - static char const prifldbl[] = PERL_PRIfldbl; - char const *p = prifldbl + sizeof(prifldbl) - 3; - while (p >= prifldbl) { *--ptr = *p--; } + static char const ldblf[] = PERL_PRIfldbl; + char const *p = ldblf + sizeof(ldblf) - 3; + while (p >= ldblf) { *--ptr = *p--; } } #endif if (has_precis) { @@ -11612,14 +12086,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * that is safe to use, even though it's not literal */ GCC_DIAG_IGNORE(-Wformat-nonliteral); #if defined(HAS_LONG_DOUBLE) - elen = ((intsize == 'q') - ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) - : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); + elen = ((intsize == 'q') + ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) + : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); #else - elen = my_sprintf(PL_efloatbuf, ptr, nv); + elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif GCC_DIAG_RESTORE; } + float_converted: eptr = PL_efloatbuf; @@ -11652,7 +12127,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef HAS_PTRDIFF_T case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; #endif -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': *(va_arg(*args, intmax_t*)) = i; break; #endif case 'q': @@ -11790,6 +12265,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto vector; } } + + /* Now that we've consumed all our printf format arguments (svix) + * do we have things left on the stack that we didn't use? + */ + if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) { + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + } + SvTAINT(sv); RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore @@ -11877,7 +12361,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); parser->lex_defer = proto->lex_defer; parser->lex_dojoin = proto->lex_dojoin; - parser->lex_expect = proto->lex_expect; parser->lex_formbrack = proto->lex_formbrack; parser->lex_inpat = proto->lex_inpat; parser->lex_inwhat = proto->lex_inwhat; @@ -14278,8 +14761,6 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { - dVAR; - PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { @@ -14357,7 +14838,6 @@ bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, SV *ssv, int *offset, char *tstr, int tlen) { - dVAR; bool ret = FALSE; PERL_ARGS_ASSERT_SV_CAT_DECODE; @@ -14443,8 +14923,6 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) STATIC I32 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) { - dVAR; - PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; if (!av || SvMAGICAL(av) || !AvARRAY(av) || @@ -14792,9 +15270,9 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if ( o->op_type == OP_PUSHMARK || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) ) - o = o->op_sibling; + o = OP_SIBLING(o); - if (!o->op_sibling) { + if (!OP_HAS_SIBLING(o)) { /* one-arg version of open is highly magical */ if (o->op_type == OP_GV) { /* open FOO; */ @@ -14839,7 +15317,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 = o->op_sibling->op_sibling; + o = OP_SIBLING(OP_SIBLING(o)); goto do_op2; @@ -14970,7 +15448,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 = kid->op_sibling) { + for (kid=o; kid; kid = OP_SIBLING(kid)) { const OPCODE type = kid->op_type; if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) @@ -14993,7 +15471,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, sv = find_uninit_var(o, uninit_sv, 1); if (sv) return sv; - o = o->op_sibling; + o = OP_SIBLING(o); } break; } @@ -15012,7 +15490,6 @@ Print appropriate "Use of uninitialized variable" warning. void Perl_report_uninit(pTHX_ const SV *uninit_sv) { - dVAR; if (PL_op) { SV* varname = NULL; if (uninit_sv && PL_curpad) {