X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/057ba76ababce335660483d8ac1f9a460182c91c..d3f5b0a08053f885ee584142cbe1f9a31cffd409:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 37b73f5..2df5df8 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -361,8 +361,8 @@ In addition: sprintf "...%s...". Don't call '.' overloading: only use '""' overloading. - OPpMULTICONCAT_STRINGIFY: (for Deparse's benefit) the RHS was of the - form "...$a...$b..." rather than + OPpMULTICONCAT_STRINGIFY: the RHS was of the form + "...$a...$b..." rather than "..." . $a . "..." . $b . "..." An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are @@ -948,7 +948,7 @@ PP(pp_multiconcat) SV **svp; const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; - bool first = TRUE; /* first call to S_do_concat */ + Size_t arg_count = 0; /* how many args have been processed */ if (!cpv) { cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; @@ -964,9 +964,44 @@ PP(pp_multiconcat) */ n = nargs *2 + 1; - for (i = 0; i < n + is_append; i++) { + for (i = 0; i <= n; i++) { + SSize_t len; + + /* if necessary, stringify the final RHS result in + * something like $targ .= "$a$b$c" - simulating + * pp_stringify + */ + if ( i == n + && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY) + && !(SvPOK(left)) + /* extra conditions for backwards compatibility: + * probably incorrect, but keep the existing behaviour + * for now. The rules are: + * $x = "$ov" single arg: stringify; + * $x = "$ov$y" multiple args: don't stringify, + * $lex = "$ov$y$z" except TARGMY with at least 2 concats + */ + && ( arg_count == 1 + || ( arg_count >= 3 + && !is_append + && (PL_op->op_private & OPpTARGET_MY) + && !(PL_op->op_private & OPpLVAL_INTRO) + ) + ) + ) + { + SV *tmp = sv_newmortal(); + sv_copypv(tmp, left); + SvSETMAGIC(tmp); + left = tmp; + } + + /* do one extra iteration to handle $targ in $targ .= ... */ + if (i == n && !is_append) + break; + /* get the next arg SV or regen the next const SV */ - SSize_t len = lens[i >> 1].ssize; + len = lens[i >> 1].ssize; if (i == n) { /* handle the final targ .= (....) */ right = left; @@ -981,18 +1016,19 @@ PP(pp_multiconcat) cpv += len; } - if (!left) { + arg_count++; + + if (arg_count <= 1) { left = right; continue; /* need at least two SVs to concat together */ } - if (first && i < n) { + if (arg_count == 2 && i < n) { /* for the first concat, create a mortal acting like the * padtmp from OP_CONST. In later iterations this will * be appended to */ nexttarg = sv_newmortal(); nextappend = FALSE; - first = FALSE; } else { nexttarg = left; @@ -1024,9 +1060,9 @@ PP(pp_multiconcat) SV * const tmpsv = amagic_call(left, right, concat_amg, (nextappend ? AMGf_assign: 0)); if (tmpsv) { - /* NB: tryAMAGICbin_MG() includes an SvPADMY test - * here, which isn;t needed as any implicit - * assign does under OPpTARGET_MY is done after + /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test + * here, which isn't needed as any implicit + * assign done under OPpTARGET_MY is done after * this loop */ if (nextappend) { sv_setsv(left, tmpsv); @@ -1061,15 +1097,20 @@ PP(pp_multiconcat) SP = toparg - stack_adj + 1; - /* Assign result of all RHS concats (left) to LHS (targ). + /* Return the result of all RHS concats, unless this op includes + * an assign ($lex = x.y.z or expr = x.y.z), in which case copy + * to target (which will be $lex or expr). * If we are appending, targ will already have been appended to in * the loop */ - if (is_append) - SvTAINT(targ); - else { + if ( !is_append + && ( (PL_op->op_flags & OPf_STACKED) + || (PL_op->op_private & OPpTARGET_MY)) + ) { sv_setsv(targ, left); SvSETMAGIC(targ); } + else + targ = left; SETs(targ); RETURN; } @@ -1221,7 +1262,7 @@ PP(pp_eq) dSP; SV *left, *right; - tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); + tryAMAGICbin_MG(eq_amg, AMGf_numeric); right = POPs; left = TOPs; SETs(boolSV( @@ -1394,16 +1435,10 @@ PP(pp_add) NV nl = SvNVX(svl); NV nr = SvNVX(svr); - if ( -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) - && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) -#else - nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) -#endif - ) + if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) { /* nothing was lost by converting to IVs */ goto do_iv; + } SP--; TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */ SETs(TARG); @@ -1485,7 +1520,9 @@ PP(pp_add) auv = aiv; auvok = 1; /* Now acting as a sign flag. */ } else { - auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); + /* Using 0- here and later to silence bogus warning + * from MS VC */ + auv = (UV) (0 - (UV) aiv); } } a_valid = 1; @@ -1505,7 +1542,7 @@ PP(pp_add) buv = biv; buvok = 1; } else - buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); + buv = (UV) (0 - (UV) biv); } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. @@ -1786,7 +1823,6 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) PUSHi(i); } else -#ifdef PERL_OP_PARENT if (is_keys) { /* parent op should be an unused OP_KEYS whose targ we can * use */ @@ -1800,7 +1836,6 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) PUSHi(i); } else -#endif mPUSHi(i); } } @@ -3896,7 +3931,7 @@ PP(pp_iter) case CXt_LOOP_LIST: /* for (1,2,3) */ assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */ - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.stack.ix += inc); if (UNLIKELY(inc > 0 ? ix > cx->blk_oldsp @@ -3911,7 +3946,7 @@ PP(pp_iter) case CXt_LOOP_ARY: /* for (@ary) */ av = cx->blk_loop.state_u.ary.ary; - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.ary.ix += inc); if (UNLIKELY(inc > 0 ? ix > AvFILL(av) @@ -3962,25 +3997,41 @@ PP(pp_iter) DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); } - /* Bypass pushing &PL_sv_yes and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead * jump straight to the AND op's op_other */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); - return cLOGOPx(PL_op->op_next)->op_other; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return cLOGOPx(PL_op->op_next)->op_other; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + /* pp_enteriter should have pre-extended the stack */ + EXTEND_SKIP(PL_stack_sp, 1); + *++PL_stack_sp = &PL_sv_yes; + return PL_op->op_next; + } retno: - /* Bypass pushing &PL_sv_no and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead * jump straight to the AND op's op_next */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); /* pp_enteriter should have pre-extended the stack */ EXTEND_SKIP(PL_stack_sp, 1); /* we only need this for the rare case where the OP_AND isn't * in void context, e.g. $x = do { for (..) {...} }; - * but its cheaper to just push it rather than testing first + * (or for when an XS module has replaced the op_ppaddr) + * but it's cheaper to just push it rather than testing first */ *++PL_stack_sp = &PL_sv_no; - return PL_op->op_next->op_next; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return PL_op->op_next->op_next; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + return PL_op->op_next; + } } @@ -5284,9 +5335,7 @@ PP(pp_aelem) else if (SvNOK(elemsv)) elem = (IV)SvNV(elemsv); if (elem > 0) { - static const char oom_array_extend[] = - "Out of memory during array extend"; /* Duplicated in av.c */ - MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); + MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); } #endif if (!svp || !*svp) {