X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=2948d3a89ea795b084a3ada2077be54fa9af9ab9;hb=cc50ac46d6f5968c34044ce7c501b06af15fc51a;hp=3cc975921d2ad364ae6a954c475c27ffb1977447;hpb=d28f7c377ae191ca53d9157f124642cf323614a0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 3cc9759..2948d3a 100644 --- a/pp.c +++ b/pp.c @@ -28,6 +28,37 @@ static double UV_MAX_cxux = ((double)UV_MAX); #endif /* + * Types used in bitwise operations. + * + * Normally we'd just use IV and UV. However, some hardware and + * software combinations (e.g. Alpha and current OSF/1) don't have a + * floating-point type to use for NV that has adequate bits to fully + * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).) + * + * It just so happens that "int" is the right size almost everywhere. + */ +typedef int IBW; +typedef unsigned UBW; + +/* + * Mask used after bitwise operations. + * + * There is at least one realm (Cray word machines) that doesn't + * have an integral type (except char) small enough to be represented + * in a double without loss; that is, it has no 32-bit type. + */ +#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP) +# define BW_BITS 32 +# define BW_MASK ((1 << BW_BITS) - 1) +# define BW_SIGN (1 << (BW_BITS - 1)) +# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK)) +# define BWu(u) ((u) & BW_MASK) +#else +# define BWi(i) (i) +# define BWu(u) (u) +#endif + +/* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, @@ -375,6 +406,8 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); + if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; @@ -436,7 +469,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -497,6 +530,12 @@ S_refto(pTHX_ SV *sv) else (void)SvREFCNT_inc(sv); } + else if (SvTYPE(sv) == SVt_PVAV) { + if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) + av_reify((AV*)sv); + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } else if (SvPADTMP(sv)) sv = newSVsv(sv); else { @@ -832,7 +871,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -849,7 +888,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -870,7 +909,7 @@ PP(pp_postdec) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -900,7 +939,6 @@ PP(pp_pow) PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); - tryIVIVbin(*); { dPOPTOPnnrl; SETn( left * right ); @@ -911,16 +949,6 @@ PP(pp_multiply) PP(pp_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); - if (TOPIOKbin) { - dPOPTOPiirl_ul; - if (right == 0) - DIE(aTHX_ "Illegal division by zero"); - if ((left % right) && !(PL_op->op_private & HINT_INTEGER)) - SETn( (NV)left / (NV)right ); - else - SETi( left / right ); - RETURN; - } { dPOPPOPnnrl; NV value; @@ -1100,7 +1128,6 @@ PP(pp_repeat) PP(pp_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); - tryIVIVbin(-); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -1112,14 +1139,16 @@ PP(pp_left_shift) { djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - IV shift = POPi; + IBW shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IV i = TOPi; - SETi(i << shift); + IBW i = TOPi; + i = BWi(i) << shift; + SETi(BWi(i)); } else { - UV u = TOPu; - SETu(u << shift); + UBW u = TOPu; + u <<= shift; + SETu(BWu(u)); } RETURN; } @@ -1129,14 +1158,16 @@ PP(pp_right_shift) { djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - IV shift = POPi; + IBW shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IV i = TOPi; - SETi(i >> shift); + IBW i = TOPi; + i = BWi(i) >> shift; + SETi(BWi(i)); } else { - UV u = TOPu; - SETu(u >> shift); + UBW u = TOPu; + u >>= shift; + SETu(BWu(u)); } RETURN; } @@ -1306,12 +1337,12 @@ PP(pp_bit_and) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV value = SvIV(left) & SvIV(right); - SETi(value); + IBW value = SvIV(left) & SvIV(right); + SETi(BWi(value)); } else { - UV value = SvUV(left) & SvUV(right); - SETu(value); + UBW value = SvUV(left) & SvUV(right); + SETu(BWu(value)); } } else { @@ -1329,12 +1360,12 @@ PP(pp_bit_xor) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi(value); + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi(BWi(value)); } else { - UV value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); - SETu(value); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(BWu(value)); } } else { @@ -1352,12 +1383,12 @@ PP(pp_bit_or) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi(value); + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi(BWi(value)); } else { - UV value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); - SETu(value); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(BWu(value)); } } else { @@ -1418,12 +1449,12 @@ PP(pp_complement) dTOPss; if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IV value = ~SvIV(sv); - SETi(value); + IBW value = ~SvIV(sv); + SETi(BWi(value)); } else { - UV value = ~SvUV(sv); - SETu(value); + UBW value = ~SvUV(sv); + SETu(BWu(value)); } } else { @@ -1753,9 +1784,9 @@ S_seed(pTHX) # endif #endif u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ - u += SEED_C5 * (U32)(UV)&when; + u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } @@ -2029,74 +2060,24 @@ PP(pp_vec) register I32 offset = POPi; register SV *src = POPs; I32 lvalue = PL_op->op_flags & OPf_MOD; - STRLEN srclen; - unsigned char *s = (unsigned char*)SvPV(src, srclen); - unsigned long retnum; - I32 len; - SvTAINTED_off(TARG); /* decontaminate */ - offset *= size; /* turn into bit offset */ - len = (offset + size + 7) / 8; - if (offset < 0 || size < 1) - retnum = 0; - else { - if (lvalue) { /* it's an lvalue! */ - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, 'v', Nullch, 0); - } - - LvTYPE(TARG) = 'v'; - if (LvTARG(TARG) != src) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(src); - } - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; - } - if (len > srclen) { - if (size <= 8) - retnum = 0; - else { - offset >>= 3; - if (size == 16) { - if (offset >= srclen) - retnum = 0; - else - retnum = (unsigned long) s[offset] << 8; - } - else if (size == 32) { - if (offset >= srclen) - retnum = 0; - else if (offset + 1 >= srclen) - retnum = (unsigned long) s[offset] << 24; - else if (offset + 2 >= srclen) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16); - else - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8); - } - } + SvTAINTED_off(TARG); /* decontaminate */ + if (lvalue) { /* it's an lvalue! */ + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, 'v', Nullch, 0); } - else if (size < 8) - retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); - else { - offset >>= 3; - if (size == 8) - retnum = s[offset]; - else if (size == 16) - retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; - else if (size == 32) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8) + s[offset+3]; + LvTYPE(TARG) = 'v'; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); } + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; } - sv_setuv(TARG, (UV)retnum); + sv_setuv(TARG, do_vecget(src, offset, size)); PUSHs(TARG); RETURN; } @@ -3307,6 +3288,11 @@ PP(pp_unpack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -3317,7 +3303,7 @@ PP(pp_unpack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (pat >= patend) len = 1; @@ -3330,17 +3316,18 @@ PP(pp_unpack) while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) - Perl_croak(aTHX_ "Repeat count in unpack overflows"); + DIE(aTHX_ "Repeat count in unpack overflows"); } } else len = (datumtype != '@'); switch(datumtype) { default: - Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3366,16 +3353,16 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; - case '#': + case '/': if (oldsp >= SP) - DIE(aTHX_ "# must follow a numeric type"); + DIE(aTHX_ "/ must follow a numeric type"); if (*pat != 'a' && *pat != 'A' && *pat != 'Z') - DIE(aTHX_ "# must be followed by a, A or Z"); + DIE(aTHX_ "/ must be followed by a, A or Z"); datumtype = *pat++; if (*pat == '*') pat++; /* ignore '*' for compatibility with pack */ if (isDIGIT(*pat)) - DIE(aTHX_ "# cannot take a count" ); + DIE(aTHX_ "/ cannot take a count" ); len = POPi; /* drop through */ case 'A': @@ -4006,7 +3993,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4364,6 +4351,11 @@ PP(pp_pack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -4374,7 +4366,7 @@ PP(pp_pack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4385,21 +4377,21 @@ PP(pp_pack) while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) - Perl_croak(aTHX_ "Repeat count in pack overflows"); + DIE(aTHX_ "Repeat count in pack overflows"); } } else len = 1; - if (*pat == '#') { + if (*pat == '/') { ++pat; if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*') - DIE(aTHX_ "# must be followed by a*, A* or Z*"); + DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 ? *MARK : &PL_sv_no))); } switch(datumtype) { default: - Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) Perl_warner(aTHX_ WARN_UNSAFE, @@ -4688,7 +4680,7 @@ PP(pp_pack) adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - Perl_croak(aTHX_ "Cannot compress negative numbers"); + DIE(aTHX_ "Cannot compress negative numbers"); if ( #ifdef BW_BITS @@ -4722,7 +4714,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4742,14 +4734,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - Perl_croak(aTHX_ "Cannot compress integer"); + DIE(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else - Perl_croak(aTHX_ "Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -4954,6 +4946,7 @@ PP(pp_split) else { if (!AvREAL(ary)) { AvREAL_on(ary); + AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } @@ -5004,14 +4997,7 @@ PP(pp_split) ++s; } } - else if (rx->prelen == 1 && *rx->precomp == '^') { - if (!(pm->op_pmflags & PMf_MULTILINE) - && !(pm->op_pmregexp->reganch & ROPT_WARNED)) { - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, - "split /^/ better written as split /^/m"); - pm->op_pmregexp->reganch |= ROPT_WARNED; - } + else if (strEQ("^", rx->precomp)) { while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != '\n'; m++) ;