X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=7fa9c06933a7c8d9de35e6d30a017628e00a479f;hb=389edf32390606e5c67e324a614e68d6ca3c6f81;hp=ead07f0db91f0ef61786667d4f57deba9eecb412;hpb=9014280dc8264580f076d4325a59f22a11592058;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index ead07f0..7fa9c06 100644 --- a/pp.c +++ b/pp.c @@ -17,6 +17,8 @@ #include "perl.h" #include "keywords.h" +#include "reentr.h" + /* variations on pp_null */ /* XXX I can't imagine anyone who doesn't have this actually _needs_ @@ -62,7 +64,7 @@ PP(pp_padav) EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { U32 i; - for (i=0; i < maxarg; i++) { + for (i=0; i < (U32)maxarg; i++) { SV **svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } @@ -877,10 +879,100 @@ PP(pp_postdec) PP(pp_pow) { dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + /* ** is implemented with pow. pow is floating point. Perl programmers + write 2 ** 31 and expect it to be 2147483648 + pow never made any guarantee to deliver a result to 53 (or whatever) + bits of accuracy. Which is unfortunate, as perl programmers expect it + to, and on some platforms (eg Irix with long doubles) it doesn't in + a very visible case. (2 ** 31, which a regression test uses) + So we'll implement power-of-2 ** +ve integer with multiplies, to avoid + these problems. */ { - dPOPTOPnnrl; - SETn( Perl_pow( left, right) ); - RETURN; + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool baseuok = SvUOK(TOPm1s); + UV baseuv; + + if (baseuok) { + baseuv = SvUVX(TOPm1s); + } else { + IV iv = SvIVX(TOPm1s); + if (iv >= 0) { + baseuv = iv; + baseuok = TRUE; /* effectively it's a UV now */ + } else { + baseuv = -iv; /* abs, baseuok == false records sign */ + } + } + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + UV power; + + if (SvUOK(TOPs)) { + power = SvUVX(TOPs); + } else { + IV iv = SvIVX(TOPs); + if (iv >= 0) { + power = iv; + } else { + goto float_it; /* Can't do negative powers this way. */ + } + } + /* now we have integer ** positive integer. + foo & (foo - 1) is zero only for a power of 2. */ + if (!(baseuv & (baseuv - 1))) { + /* We are raising power-of-2 to postive integer. + The logic here will work for any base (even non-integer + bases) but it can be less accurate than + pow (base,power) or exp (power * log (base)) when the + intermediate values start to spill out of the mantissa. + With powers of 2 we know this can't happen. + And powers of 2 are the favourite thing for perl + programmers to notice ** not doing what they mean. */ + NV result = 1.0; + NV base = baseuok ? baseuv : -(NV)baseuv; + int n = 0; + + /* The logic is this. + x ** n === x ** m1 * x ** m2 where n = m1 + m2 + so as 42 is 32 + 8 + 2 + x ** 42 can be written as + x ** 32 * x ** 8 * x ** 2 + I can calculate x ** 2, x ** 4, x ** 8 etc trivially: + x ** 2n is x ** n * x ** n + So I loop round, squaring x each time + (x, x ** 2, x ** 4, x ** 8) and multiply the result + by the x-value whenever that bit is set in the power. + To finish as soon as possible I zero bits in the power + when I've done them, so that power becomes zero when + I clear the last bit (no more to do), and the loop + terminates. */ + for (; power; base *= base, n++) { + /* Do I look like I trust gcc with long longs here? + Do I hell. */ + UV bit = (UV)1 << (UV)n; + if (power & bit) { + result *= base; + /* Only bother to clear the bit if it is set. */ + power &= ~bit; + /* Avoid squaring base again if we're done. */ + if (power == 0) break; + } + } + SP--; + SETn( result ); + RETURN; + } + } + } + } + float_it: +#endif + { + dPOPTOPnnrl; + SETn( Perl_pow( left, right) ); + RETURN; } } @@ -1097,7 +1189,7 @@ PP(pp_divide) } /* 2s complement assumption */ if (result <= (UV)IV_MIN) - SETi( -result ); + SETi( -(IV)result ); else { /* It's exact but too negative for IV. */ SETn( -(NV)result ); @@ -2592,7 +2684,7 @@ S_seed(pTHX) u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY - gettimeofday(&when,(struct timezone *) 0); + PerlProc_gettimeofday(&when,NULL); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else (void)time(&when); @@ -3073,7 +3165,7 @@ PP(pp_index) sv_pos_u2b(big, &offset, 0); if (offset < 0) offset = 0; - else if (offset > biglen) + else if (offset > (I32)biglen) offset = biglen; if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, (unsigned char*)tmps + biglen, little, 0))) @@ -3114,7 +3206,7 @@ PP(pp_rindex) } if (offset < 0) offset = 0; - else if (offset > blen) + else if (offset > (I32)blen) offset = blen; if (!(tmps2 = rninstr(tmps, tmps + offset, tmps2, tmps2 + llen))) @@ -3153,7 +3245,9 @@ PP(pp_ord) argsv = tmpsv; } - XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff)); + XPUSHu(DO_UTF8(argsv) ? + utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) : + (*s & 0xff)); RETURN; } @@ -3167,7 +3261,7 @@ PP(pp_chr) (void)SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { - SvGROW(TARG, UNISKIP(value)+1); + SvGROW(TARG, (STRLEN)UNISKIP(value)+1); tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; @@ -3180,7 +3274,7 @@ PP(pp_chr) SvGROW(TARG,2); SvCUR_set(TARG, 1); tmps = SvPVX(TARG); - *tmps++ = value; + *tmps++ = (char)value; *tmps = '\0'; (void)SvPOK_only(TARG); if (PL_encoding) @@ -3213,12 +3307,12 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); # endif + SETs(TARG); + RETURN; #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif - SETs(TARG); - RETURN; } PP(pp_ucfirst) @@ -3293,7 +3387,7 @@ PP(pp_lcfirst) tend = uvchr_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { + if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -3598,7 +3692,8 @@ PP(pp_each) EXTEND(SP, 2); if (entry) { - PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ + SV* sv = hv_iterkeysv(entry); + PUSHs(sv); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { SV *val; PUTBACK; @@ -3732,17 +3827,38 @@ PP(pp_hslice) register HV *hv = (HV*)POPs; register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 realhv = (SvTYPE(hv) == SVt_PVHV); + bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE; + bool other_magic = FALSE; + + if (localizing) { + MAGIC *mg; + HV *stash; + + other_magic = mg_find((SV*)hv, PERL_MAGIC_env) || + ((mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE)); + } - if (!realhv && PL_op->op_private & OPpLVAL_INTRO) + if (!realhv && localizing) DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; - I32 preeminent = SvRMAGICAL(hv) ? 1 : - realhv ? hv_exists_ent(hv, keysv, 0) - : avhv_exists_ent((AV*)hv, keysv, 0); + bool preeminent = FALSE; + + if (localizing) { + preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : + realhv ? hv_exists_ent(hv, keysv, 0) + : avhv_exists_ent((AV*)hv, keysv, 0); + } + if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; @@ -3755,7 +3871,7 @@ PP(pp_hslice) STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } - if (PL_op->op_private & OPpLVAL_INTRO) { + if (localizing) { if (preeminent) save_helem(hv, keysv, svp); else { @@ -4213,7 +4329,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } } } @@ -4223,7 +4339,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } (void)SvPOK_only_UTF8(TARG); } @@ -4453,7 +4569,7 @@ PP(pp_split) (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { - for (i = 1; i <= rx->nparens; i++) { + for (i = 1; i <= (I32)rx->nparens; i++) { s = rx->startp[i] + orig; m = rx->endp[i] + orig;