X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=f4dc624fceadf3f75f6ad064975d2038ddc0e677;hb=33f01dd10fdacfa5ccb83c4f933cacb0f65b707e;hp=509715665d302526f495df8704b0c03708fb2f3c;hpb=cea2e8a9dd23747fd2b66edc86c58c64e9970321;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 5097156..f4dc624 100644 --- a/op.c +++ b/op.c @@ -142,7 +142,7 @@ Perl_pad_allocmy(pTHX_ char *name) (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isPRINT(name[1])) { + if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ char *p; p = strchr(name, '\0'); @@ -192,7 +192,7 @@ Perl_pad_allocmy(pTHX_ char *name) PL_sv_objcount++; } av_store(PL_comppad_name, off, sv); - SvNVX(sv) = (double)PAD_MAX; + SvNVX(sv) = (NV)PAD_MAX; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ if (!PL_min_intro_pending) PL_min_intro_pending = off; @@ -255,7 +255,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, sv_upgrade(namesv, SVt_PVNV); sv_setpv(namesv, name); av_store(PL_comppad_name, newoff, namesv); - SvNVX(namesv) = (double)PL_curcop->cop_seq; + SvNVX(namesv) = (NV)PL_curcop->cop_seq; SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ SvFAKE_on(namesv); /* A ref, not a real var */ if (SvOBJECT(sv)) { /* A typed var */ @@ -414,13 +414,14 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { + dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; if (PL_min_intro_pending && fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef) - Perl_warn(aTHX_ "%s never introduced", SvPVX(sv)); + if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ @@ -686,10 +687,7 @@ Perl_op_free(pTHX_ OP *o) break; case OP_NEXTSTATE: case OP_DBSTATE: - Safefree(cCOPo->cop_label); - SvREFCNT_dec(cCOPo->cop_filegv); - if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL) - SvREFCNT_dec(cCOPo->cop_warnings); + cop_free((COP*)o); break; case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); @@ -730,6 +728,15 @@ Perl_op_free(pTHX_ OP *o) } STATIC void +S_cop_free(pTHX_ COP* cop) +{ + Safefree(cop->cop_label); + SvREFCNT_dec(cop->cop_filegv); + if (! specialWARN(cop->cop_warnings)) + SvREFCNT_dec(cop->cop_warnings); +} + +STATIC void S_null(pTHX_ OP *o) { if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0) @@ -805,6 +812,10 @@ Perl_scalar(pTHX_ OP *o) || o->op_type == OP_RETURN) return o; + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + return scalar(o); /* As if inside SASSIGN */ + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (o->op_type) { @@ -884,6 +895,10 @@ Perl_scalarvoid(pTHX_ OP *o) || o->op_type == OP_RETURN) return o; + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + return scalar(o); /* As if inside SASSIGN */ + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { @@ -1083,6 +1098,10 @@ Perl_list(pTHX_ OP *o) || o->op_type == OP_RETURN) return o; + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + return o; /* As if inside SASSIGN */ + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { @@ -1190,6 +1209,10 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!o || PL_error_count) return o; + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + return o; + switch (o->op_type) { case OP_UNDEF: PL_modcount++; @@ -1662,7 +1685,7 @@ Perl_scope(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){ - SvREFCNT_dec(((COP*)kid)->cop_filegv); + cop_free((COP*)kid); null(kid); } } @@ -1705,8 +1728,7 @@ Perl_block_start(pTHX_ int full) SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVEPPTR(PL_compiling.cop_warnings); - if (PL_compiling.cop_warnings != WARN_ALL && - PL_compiling.cop_warnings != WARN_NONE) { + if (! specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } @@ -1830,11 +1852,17 @@ Perl_fold_constants(pTHX_ register OP *o) if (PL_opargs[type] & OA_RETSCALAR) scalar(o); - if (PL_opargs[type] & OA_TARGET) + if (PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); - if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) + /* integerize op, unless it happens to be C<-foo>. + * XXX should pp_i_negate() do magic string negation instead? */ + if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) + && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST + && (cUNOPo->op_first->op_private & OPpCONST_BARE))) + { o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; + } if (!(PL_opargs[type] & OA_FOLDCONST)) goto nope; @@ -1893,7 +1921,7 @@ Perl_fold_constants(pTHX_ register OP *o) type != OP_NEGATE) { IV iv = SvIV(sv); - if ((double)iv == SvNV(sv)) { + if ((NV)iv == SvNV(sv)) { SvREFCNT_dec(sv); sv = newSViv(iv); } @@ -2185,7 +2213,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } binop = (BINOP*)CHECKOP(type, binop); - if (binop->op_next) + if (binop->op_next || binop->op_type != type) return (OP*)binop; binop->op_last = binop->op_first->op_sibling; @@ -2843,8 +2871,8 @@ S_list_assignment(pTHX_ register OP *o) o = cUNOPo->op_first; if (o->op_type == OP_COND_EXPR) { - I32 t = list_assignment(cCONDOPo->op_first->op_sibling); - I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling); + I32 t = list_assignment(cLOGOPo->op_first->op_sibling); + I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -3034,8 +3062,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) } cop->cop_seq = seq; cop->cop_arybase = PL_curcop->cop_arybase; - if (PL_curcop->cop_warnings == WARN_NONE - || PL_curcop->cop_warnings == WARN_ALL) + if (specialWARN(PL_curcop->cop_warnings)) cop->cop_warnings = PL_curcop->cop_warnings ; else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; @@ -3077,7 +3104,7 @@ Perl_intro_my(pTHX) for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) { SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */ - SvNVX(sv) = (double)PL_cop_seqmax; + SvNVX(sv) = (NV)PL_cop_seqmax; } } PL_min_intro_pending = 0; @@ -3202,7 +3229,8 @@ OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { dTHR; - CONDOP *condop; + LOGOP *logop; + OP *start; OP *o; if (!falseop) @@ -3227,27 +3255,27 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) list(trueop); scalar(falseop); } - NewOp(1101, condop, 1, CONDOP); + NewOp(1101, logop, 1, LOGOP); + logop->op_type = OP_COND_EXPR; + logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; + logop->op_first = first; + logop->op_flags = flags | OPf_KIDS; + logop->op_private = 1 | (flags >> 8); + logop->op_other = LINKLIST(trueop); + logop->op_next = LINKLIST(falseop); - condop->op_type = OP_COND_EXPR; - condop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; - condop->op_first = first; - condop->op_flags = flags | OPf_KIDS; - condop->op_true = LINKLIST(trueop); - condop->op_false = LINKLIST(falseop); - condop->op_private = 1 | (flags >> 8); /* establish postfix order */ - condop->op_next = LINKLIST(first); - first->op_next = (OP*)condop; + start = LINKLIST(first); + first->op_next = (OP*)logop; first->op_sibling = trueop; trueop->op_sibling = falseop; - o = newUNOP(OP_NULL, 0, (OP*)condop); + o = newUNOP(OP_NULL, 0, (OP*)logop); - trueop->op_next = o; - falseop->op_next = o; + trueop->op_next = falseop->op_next = o; + o->op_next = start; return o; } @@ -3255,34 +3283,36 @@ OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { dTHR; - CONDOP *condop; + LOGOP *range; OP *flip; OP *flop; + OP *leftstart; OP *o; - NewOp(1101, condop, 1, CONDOP); + NewOp(1101, range, 1, LOGOP); - condop->op_type = OP_RANGE; - condop->op_ppaddr = PL_ppaddr[OP_RANGE]; - condop->op_first = left; - condop->op_flags = OPf_KIDS; - condop->op_true = LINKLIST(left); - condop->op_false = LINKLIST(right); - condop->op_private = 1 | (flags >> 8); + range->op_type = OP_RANGE; + range->op_ppaddr = PL_ppaddr[OP_RANGE]; + range->op_first = left; + range->op_flags = OPf_KIDS; + leftstart = LINKLIST(left); + range->op_other = LINKLIST(right); + range->op_private = 1 | (flags >> 8); left->op_sibling = right; - condop->op_next = (OP*)condop; - flip = newUNOP(OP_FLIP, flags, (OP*)condop); + range->op_next = (OP*)range; + flip = newUNOP(OP_FLIP, flags, (OP*)range); flop = newUNOP(OP_FLOP, 0, flip); o = newUNOP(OP_NULL, 0, flop); linklist(flop); + range->op_next = leftstart; left->op_next = flip; right->op_next = flop; - condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); - sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV); + range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); @@ -3492,7 +3522,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo * treated as min/max values by 'pp_iterinit'. */ UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; - CONDOP* range = (CONDOP*) flip->op_first; + LOGOP* range = (LOGOP*) flip->op_first; OP* left = range->op_first; OP* right = left->op_sibling; LISTOP* listop; @@ -3501,8 +3531,8 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo range->op_first = Nullop; listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); - listop->op_first->op_next = range->op_true; - left->op_next = range->op_false; + listop->op_first->op_next = range->op_next; + left->op_next = range->op_other; right->op_next = (OP*)listop; listop->op_next = listop->op_first; @@ -3808,7 +3838,10 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) { + dTHR; + + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && + ckWARN_d(WARN_UNSAFE) ) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -3824,7 +3857,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warn(aTHX_ "%_", msg); + Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg); } } @@ -3894,8 +3927,9 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { - if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)) - Perl_warn(aTHX_ "Runaway prototype"); + if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) + && ckWARN_d(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype"); cv_ckproto((CV*)gv, NULL, ps); } if (ps) @@ -4306,7 +4340,8 @@ Perl_oopsAV(pTHX_ OP *o) break; default: - Perl_warn(aTHX_ "oops: oopsAV"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV"); break; } return o; @@ -4315,6 +4350,10 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { + dTHR; + + dTHR; + switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4330,7 +4369,8 @@ Perl_oopsHV(pTHX_ OP *o) break; default: - Perl_warn(aTHX_ "oops: oopsHV"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV"); break; } return o; @@ -4993,23 +5033,27 @@ OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { dTHR; - if (ckWARN(WARN_DEPRECATED)) { - switch (cUNOPo->op_first->op_type) { - case OP_RV2AV: - case OP_PADAV: - case OP_AASSIGN: /* Is this a good idea? */ - Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated (and not really meaningful)"); - Perl_warner(aTHX_ WARN_DEPRECATED, "(Maybe you should just omit the defined()?)\n"); - break; - case OP_RV2HV: - case OP_PADHV: - Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%hash) is deprecated (and not really meaningful)"); - Perl_warner(aTHX_ WARN_DEPRECATED, "(Maybe you should just omit the defined()?)\n"); + if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { + switch (cUNOPo->op_first->op_type) { + case OP_RV2AV: + case OP_PADAV: + case OP_AASSIGN: /* Is this a good idea? */ + Perl_warner(aTHX_ WARN_DEPRECATED, + "defined(@array) is deprecated"); + Perl_warner(aTHX_ WARN_DEPRECATED, + "(Maybe you should just omit the defined()?)\n"); break; - default: - /* no warning */ - break; - } + case OP_RV2HV: + case OP_PADHV: + Perl_warner(aTHX_ WARN_DEPRECATED, + "defined(%hash) is deprecated"); + Perl_warner(aTHX_ WARN_DEPRECATED, + "(Maybe you should just omit the defined()?)\n"); + break; + default: + /* no warning */ + break; + } } return ck_rfun(o); } @@ -5074,6 +5118,38 @@ Perl_ck_fun_locale(pTHX_ OP *o) } OP * +Perl_ck_sassign(pTHX_ OP *o) +{ + OP *kid = cLISTOPo->op_first; + /* has a disposable target? */ + if ((PL_opargs[kid->op_type] & OA_TARGLEX) + && !(kid->op_flags & OPf_STACKED)) + { + OP *kkid = kid->op_sibling; + + /* Can just relocate the target. */ + if (kkid && kkid->op_type == OP_PADSV) { + /* Concat has problems if target is equal to right arg. */ + if (kid->op_type == OP_CONCAT + && kLISTOP->op_first->op_sibling->op_type == OP_PADSV + && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ) + { + return o; + } + kid->op_targ = kkid->op_targ; + /* Now we do not need PADSV and SASSIGN. */ + kid->op_sibling = o->op_sibling; /* NULL */ + cLISTOPo->op_first = NULL; + op_free(o); + op_free(kkid); + kid->op_private |= OPpTARGET_MY; /* Used for context settings */ + return kid; + } + } + return o; +} + +OP * Perl_ck_scmp(pTHX_ OP *o) { o->op_private = 0; @@ -5534,9 +5610,12 @@ Perl_ck_trunc(pTHX_ OP *o) if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; - if (kid && - kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; + } } return ck_fun(o); } @@ -5579,8 +5658,24 @@ Perl_peep(pTHX_ register OP *o) case OP_LC: case OP_LCFIRST: case OP_QUOTEMETA: - if (o->op_next && o->op_next->op_type == OP_STRINGIFY) + if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { + if (o->op_next->op_private & OPpTARGET_MY) { + if ((o->op_type == OP_CONST) /* no target */ + || (o->op_flags & OPf_STACKED) /* chained concats */ + || (o->op_type == OP_CONCAT + /* Concat has problems if target is equal to right arg. */ + && (((LISTOP*)o)->op_first->op_sibling->op_type + == OP_PADSV) + && (((LISTOP*)o)->op_first->op_sibling->op_targ + == o->op_next->op_targ))) { + goto ignore_optimization; + } else { + o->op_targ = o->op_next->op_targ; + } + } null(o->op_next); + } + ignore_optimization: o->op_seq = PL_op_seqmax++; break; case OP_STUB: @@ -5645,18 +5740,14 @@ Perl_peep(pTHX_ register OP *o) case OP_GREPWHILE: case OP_AND: case OP_OR: + case OP_COND_EXPR: + case OP_RANGE: o->op_seq = PL_op_seqmax++; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); break; - case OP_COND_EXPR: - o->op_seq = PL_op_seqmax++; - peep(cCONDOP->op_true); - peep(cCONDOP->op_false); - break; - case OP_ENTERLOOP: o->op_seq = PL_op_seqmax++; peep(cLOOP->op_redoop);