X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=1855b2d941807867bc3f1143238b802660e31210;hb=89d60977162f464114a3f311f9059bb0c281bdbd;hp=51e10def8940b7299d0ec9ee617a82eb7dcfd70a;hpb=afd1eb533c8ea286efcac6fd054ae7cebaf0dfe3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 51e10de..1855b2d 100644 --- a/pp.c +++ b/pp.c @@ -467,8 +467,8 @@ S_refto(pTHX_ SV *sv) SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } - else if (SvPADTMP(sv)) - sv = newSVsv(sv); + else if (SvPADTMP(sv) && !IS_PADGV(sv)) + sv = newSVsv(sv); else { SvTEMP_off(sv); (void)SvREFCNT_inc(sv); @@ -999,29 +999,111 @@ PP(pp_multiply) PP(pp_divide) { dSP; dATARGET; tryAMAGICbin(div,opASSIGN); - { - dPOPPOPnnrl; - NV value; - if (right == 0.0) - DIE(aTHX_ "Illegal division by zero"); + /* Only try to do UV divide first + if ((SLOPPYDIVIDE is true) or + (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large + to preserve)) + The assumption is that it is better to use floating point divide + whenever possible, only doing integer divide first if we can't be sure. + If NV_PRESERVES_UV is true then we know at compile time that no UV + can be too large to preserve, so don't need to compile the code to + test the size of UVs. */ + #ifdef SLOPPYDIVIDE - /* insure that 20./5. == 4. */ - { - IV k; - if ((NV)I_V(left) == left && - (NV)I_V(right) == right && - (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { - value = k; - } - else { - value = left / right; - } - } +# define PERL_TRY_UV_DIVIDE + /* ensure that 20./5. == 4. */ #else - value = left / right; +# ifdef PERL_PRESERVE_IVUV +# ifndef NV_PRESERVES_UV +# define PERL_TRY_UV_DIVIDE +# endif +# endif #endif - PUSHn( value ); - RETURN; + +#ifdef PERL_TRY_UV_DIVIDE + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool left_non_neg = SvUOK(TOPm1s); + bool right_non_neg = SvUOK(TOPs); + UV left; + UV right; + + if (right_non_neg) { + right = SvUVX(TOPs); + } + else { + IV biv = SvIVX(TOPs); + if (biv >= 0) { + right = biv; + right_non_neg = TRUE; /* effectively it's a UV now */ + } + else { + right = -biv; + } + } + /* historically undef()/0 gives a "Use of uninitialized value" + warning before dieing, hence this test goes here. + If it were immediately before the second SvIV_please, then + DIE() would be invoked before left was even inspected, so + no inpsection would give no warning. */ + if (right == 0) + DIE(aTHX_ "Illegal division by zero"); + + if (left_non_neg) { + left = SvUVX(TOPm1s); + } + else { + IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + left = aiv; + left_non_neg = TRUE; /* effectively it's a UV now */ + } + else { + left = -aiv; + } + } + + if (left >= right +#ifdef SLOPPYDIVIDE + /* For sloppy divide we always attempt integer division. */ +#else + /* Otherwise we only attempt it if either or both operands + would not be preserved by an NV. If both fit in NVs + we fall through to the NV divide code below. */ + && ((left > ((UV)1 << NV_PRESERVES_UV_BITS)) + || (right > ((UV)1 << NV_PRESERVES_UV_BITS))) +#endif + ) { + /* Integer division can't overflow, but it can be imprecise. */ + UV result = left / right; + if (result * right == left) { + SP--; /* result is valid */ + if (left_non_neg == right_non_neg) { + /* signs identical, result is positive. */ + SETu( result ); + RETURN; + } + /* 2s complement assumption */ + if (result <= (UV)IV_MIN) + SETi( -result ); + else { + /* It's exact but too negative for IV. */ + SETn( -(NV)result ); + } + RETURN; + } /* tried integer divide but it was not an integer result */ + } /* else (abs(result) < 1.0) or (both UVs in range for NV) */ + } /* left wasn't SvIOK */ + } /* right wasn't SvIOK */ +#endif /* PERL_TRY_UV_DIVIDE */ + { + dPOPPOPnnrl; + if (right == 0.0) + DIE(aTHX_ "Illegal division by zero"); + PUSHn( left / right ); + RETURN; } } @@ -1139,8 +1221,10 @@ PP(pp_repeat) MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { - if (*SP) - SvTEMP_off((*SP)); + if (*SP) { + *SP = sv_2mortal(newSVsv(*SP)); + SvREADONLY_on(*SP); + } SP--; } MARK++; @@ -2931,6 +3015,8 @@ PP(pp_sprintf) dSP; dMARK; dORIGMARK; dTARGET; do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); + if (DO_UTF8(*(MARK+1))) + SvUTF8_on(TARG); SP = ORIGMARK; PUSHTARG; RETURN; @@ -3013,8 +3099,10 @@ PP(pp_ucfirst) SvTAINTED_on(sv); uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0)); } - else - uv = toTITLE_utf8(s); + else { + uv = toTITLE_utf8(s); + ulen = UNISKIP(uv); + } tend = uvchr_to_utf8(tmpbuf, uv); @@ -3072,8 +3160,10 @@ PP(pp_lcfirst) SvTAINTED_on(sv); uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0)); } - else - uv = toLOWER_utf8(s); + else { + uv = toLOWER_utf8(s); + ulen = UNISKIP(uv); + } tend = uvchr_to_utf8(tmpbuf, uv); @@ -4047,6 +4137,8 @@ PP(pp_split) TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); + PL_reg_sv_utf8 = do_utf8; + if (pm->op_pmreplroot) { #ifdef USE_ITHREADS ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); @@ -4228,12 +4320,16 @@ PP(pp_split) for (i = 1; i <= rx->nparens; i++) { s = rx->startp[i] + orig; m = rx->endp[i] + orig; - if (m && s) { + + /* japhy (07/27/01) -- the (m && s) test doesn't catch + parens that didn't match -- they should be set to + undef, not the empty string */ + if (m >= orig && s >= orig) { dstr = NEWSV(33, m-s); sv_setpvn(dstr, s, m-s); } else - dstr = NEWSV(33, 0); + dstr = &PL_sv_undef; /* undef, not "" */ if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4338,6 +4434,11 @@ PP(pp_lock) #ifdef USE_THREADS sv_lock(sv); #endif /* USE_THREADS */ +#ifdef USE_ITHREADS + shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv); + if(ssv) + Perl_sharedsv_lock(aTHX_ ssv); +#endif /* USE_ITHREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { retsv = refto(retsv);