X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f853a304aafc5955d2a11f2fe43a434e225de741..a282984d19c73aae6ef9231e723101b3c3b5d2d0:/op.c diff --git a/op.c b/op.c index 3f94c03..9918a1e 100644 --- a/op.c +++ b/op.c @@ -541,22 +541,24 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) } STATIC void -S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) +S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) { PERL_ARGS_ASSERT_BAD_TYPE_PV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, OP_DESC(kid)), flags); + (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); } +/* remove flags var, its unused in all callers, move to to right end since gv + and kid are always the same */ STATIC void -S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) +S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) { SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", - (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } STATIC void @@ -592,6 +594,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) (name[1] == '_' && (*name == '$' || len > 2)))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && isASCII(name[1]) && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", name[0], toCTRL(name[1]), (int)(len - 2), name + 2, @@ -752,7 +755,7 @@ Perl_op_free(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { - nextkid = OP_SIBLING(kid); /* Get before next freeing kid */ + nextkid = OpSIBLING(kid); /* Get before next freeing kid */ if (!kid || kid->op_type == OP_FREED) /* During the forced freeing of ops after compilation failure, kidops may be freed before @@ -950,7 +953,7 @@ Perl_op_clear(pTHX_ OP *o) /* FALLTHROUGH */ case OP_MATCH: case OP_QR: -clear_pmop: + clear_pmop: if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) op_free(cPMOPo->op_code_list); cPMOPo->op_code_list = NULL; @@ -1152,7 +1155,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) forget_pmop((PMOP*)kid); } find_and_forget_pmops(kid); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); } } } @@ -1260,7 +1263,7 @@ For example: OP * Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) { - OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first; + OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first; OP *rest; OP *last_del = NULL; OP *last_ins = NULL; @@ -1271,10 +1274,10 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) if (del_count && first) { last_del = first; - while (--del_count && OP_HAS_SIBLING(last_del)) - last_del = OP_SIBLING(last_del); - rest = OP_SIBLING(last_del); - OP_SIBLING_set(last_del, NULL); + while (--del_count && OpHAS_SIBLING(last_del)) + last_del = OpSIBLING(last_del); + rest = OpSIBLING(last_del); + OpSIBLING_set(last_del, NULL); last_del->op_lastsib = 1; } else @@ -1282,16 +1285,16 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) if (insert) { last_ins = insert; - while (OP_HAS_SIBLING(last_ins)) - last_ins = OP_SIBLING(last_ins); - OP_SIBLING_set(last_ins, rest); + while (OpHAS_SIBLING(last_ins)) + last_ins = OpSIBLING(last_ins); + OpSIBLING_set(last_ins, rest); last_ins->op_lastsib = rest ? 0 : 1; } else insert = rest; if (start) { - OP_SIBLING_set(start, insert); + OpSIBLING_set(start, insert); start->op_lastsib = insert ? 0 : 1; } else { @@ -1344,8 +1347,8 @@ Perl_op_parent(OP *o) { PERL_ARGS_ASSERT_OP_PARENT; #ifdef PERL_OP_PARENT - while (OP_HAS_SIBLING(o)) - o = OP_SIBLING(o); + while (OpHAS_SIBLING(o)) + o = OpSIBLING(o); return o->op_sibling; #else PERL_UNUSED_ARG(o); @@ -1402,8 +1405,8 @@ S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) logop->op_first = first; logop->op_other = other; logop->op_flags = OPf_KIDS; - while (kid && OP_HAS_SIBLING(kid)) - kid = OP_SIBLING(kid); + while (kid && OpHAS_SIBLING(kid)) + kid = OpSIBLING(kid); if (kid) { kid->op_lastsib = 1; #ifdef PERL_OP_PARENT @@ -1467,7 +1470,7 @@ Perl_op_linklist(pTHX_ OP *o) o->op_next = LINKLIST(first); kid = first; for (;;) { - OP *sibl = OP_SIBLING(kid); + OP *sibl = OpSIBLING(kid); if (sibl) { kid->op_next = LINKLIST(sibl); kid = sibl; @@ -1488,7 +1491,7 @@ S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) scalar(kid); } return o; @@ -1573,7 +1576,7 @@ S_scalar_slice_warning(pTHX_ const OP *o) return; kid = cLISTOPo->op_first; - kid = OP_SIBLING(kid); /* get past pushmark */ + kid = OpSIBLING(kid); /* get past pushmark */ /* weed out false positives: any ops that can return lists */ switch (kid->op_type) { case OP_BACKTICK: @@ -1608,8 +1611,8 @@ S_scalar_slice_warning(pTHX_ const OP *o) if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) return; - assert(OP_SIBLING(kid)); - name = S_op_varname(aTHX_ OP_SIBLING(kid)); + assert(OpSIBLING(kid)); + name = S_op_varname(aTHX_ OpSIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ return; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1652,7 +1655,7 @@ Perl_scalar(pTHX_ OP *o) if (o->op_private & OPpREPEAT_DOLIST) { kid = cLISTOPx(cUNOPo->op_first)->op_first; assert(kid->op_type == OP_PUSHMARK); - if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) { + if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) { op_null(cLISTOPx(cUNOPo->op_first)->op_first); o->op_private &=~ OPpREPEAT_DOLIST; } @@ -1661,7 +1664,7 @@ Perl_scalar(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) scalar(kid); break; /* FALLTHROUGH */ @@ -1672,7 +1675,7 @@ Perl_scalar(pTHX_ OP *o) case OP_NULL: default: if (o->op_flags & OPf_KIDS) { - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) scalar(kid); } break; @@ -1680,12 +1683,12 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); do_kids: while (kid) { - OP *sib = OP_SIBLING(kid); + OP *sib = OpSIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN - && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL + && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL || ( sib->op_targ != OP_NEXTSTATE && sib->op_targ != OP_DBSTATE ))) scalarvoid(kid); @@ -1720,9 +1723,9 @@ Perl_scalar(pTHX_ OP *o) if (!ckWARN(WARN_SYNTAX)) break; kid = cLISTOPo->op_first; - kid = OP_SIBLING(kid); /* get past pushmark */ - assert(OP_SIBLING(kid)); - name = S_op_varname(aTHX_ OP_SIBLING(kid)); + kid = OpSIBLING(kid); /* get past pushmark */ + assert(OpSIBLING(kid)); + name = S_op_varname(aTHX_ OpSIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ break; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1798,6 +1801,8 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_REPEAT: if (o->op_flags & OPf_STACKED) break; + if (o->op_type == OP_REPEAT) + scalar(cBINOPo->op_first); goto func_ops; case OP_SUBSTR: if (o->op_private == 4) @@ -1922,7 +1927,7 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_RV2AV: case OP_RV2HV: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && - (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE)) + (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE)) useless = "a variable"; break; @@ -2046,7 +2051,7 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_COND_EXPR: case OP_ENTERGIVEN: case OP_ENTERWHEN: - for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) if (!(kid->op_flags & OPf_KIDS)) scalarvoid(kid); else @@ -2072,7 +2077,7 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_LEAVEGIVEN: case OP_LEAVEWHEN: kids: - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) if (!(kid->op_flags & OPf_KIDS)) scalarvoid(kid); else @@ -2083,12 +2088,12 @@ Perl_scalarvoid(pTHX_ OP *arg) optimisation would reject, then null the list and the pushmark. */ if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK - && ( !(kid = OP_SIBLING(kid)) + && ( !(kid = OpSIBLING(kid)) || ( kid->op_type != OP_PADSV && kid->op_type != OP_PADAV && kid->op_type != OP_PADHV) || kid->op_private & ~OPpLVAL_INTRO - || !(kid = OP_SIBLING(kid)) + || !(kid = OpSIBLING(kid)) || ( kid->op_type != OP_PADSV && kid->op_type != OP_PADAV && kid->op_type != OP_PADHV) @@ -2129,7 +2134,7 @@ S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) list(kid); } return o; @@ -2179,7 +2184,7 @@ Perl_list(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) list(kid); break; default: @@ -2206,10 +2211,10 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); do_kids: while (kid) { - OP *sib = OP_SIBLING(kid); + OP *sib = OpSIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -2237,8 +2242,8 @@ S_scalarseq(pTHX_ OP *o) { OP *kid, *sib; for (kid = cLISTOPo->op_first; kid; kid = sib) { - if ((sib = OP_SIBLING(kid)) - && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL + if ((sib = OpSIBLING(kid)) + && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL || ( sib->op_targ != OP_NEXTSTATE && sib->op_targ != OP_DBSTATE ))) { @@ -2261,7 +2266,7 @@ S_modkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) op_lvalue(kid, type); } return o; @@ -2308,7 +2313,7 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE)) && isGV(*fields) && GvHV(*fields); - for (; key_op; key_op = (SVOP*)OP_SIBLING(key_op)) { + for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) { SV **svp, *sv; if (key_op->op_type != OP_CONST) continue; @@ -2395,13 +2400,13 @@ S_finalize_op(pTHX_ OP* o) PL_curcop = ((COP*)o); /* for warnings */ break; case OP_EXEC: - if (OP_HAS_SIBLING(o)) { - OP *sib = OP_SIBLING(o); + if (OpHAS_SIBLING(o)) { + OP *sib = OpSIBLING(o); if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) && ckWARN(WARN_EXEC) - && OP_HAS_SIBLING(sib)) + && OpHAS_SIBLING(sib)) { - const OPCODE type = OP_SIBLING(sib)->op_type; + const OPCODE type = OpSIBLING(sib)->op_type; if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { const line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, CopLINE((COP*)sib)); @@ -2466,7 +2471,7 @@ S_finalize_op(pTHX_ OP* o) /* FALLTHROUGH */ case OP_KVHSLICE: - kid = OP_SIBLING(cLISTOPo->op_first); + kid = OpSIBLING(cLISTOPo->op_first); if (/* I bet there's always a pushmark... */ OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) && OP_TYPE_ISNT_NN(kid, OP_CONST)) @@ -2476,7 +2481,7 @@ S_finalize_op(pTHX_ OP* o) key_op = (SVOP*)(kid->op_type == OP_CONST ? kid - : OP_SIBLING(kLISTOP->op_first)); + : OpSIBLING(kLISTOP->op_first)); rop = (UNOP*)((LISTOP*)o)->op_last; @@ -2539,23 +2544,16 @@ S_finalize_op(pTHX_ OP* o) || type == OP_CUSTOM || type == OP_NULL /* new_logop does this */ ); - /* XXX list form of 'x' is has a null op_last. This is wrong, - * but requires too much hacking (e.g. in Deparse) to fix for - * now */ - if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) { - assert(has_last); - has_last = 0; - } - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { # ifdef PERL_OP_PARENT - if (!OP_HAS_SIBLING(kid)) { + if (!OpHAS_SIBLING(kid)) { if (has_last) assert(kid == cLISTOPo->op_last); assert(kid->op_sibling == o); } # else - if (OP_HAS_SIBLING(kid)) { + if (OpHAS_SIBLING(kid)) { assert(!kid->op_lastsib); } else { @@ -2567,7 +2565,7 @@ S_finalize_op(pTHX_ OP* o) } #endif - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) finalize_op(kid); } } @@ -2629,8 +2627,8 @@ S_lvref(pTHX_ OP *o, I32 type) OP *kid; switch (o->op_type) { case OP_COND_EXPR: - for (kid = OP_SIBLING(cUNOPo->op_first); kid; - kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; + kid = OpSIBLING(kid)) S_lvref(aTHX_ kid, type); /* FALLTHROUGH */ case OP_PUSHMARK: @@ -2716,7 +2714,7 @@ S_lvref(pTHX_ OP *o, I32 type) } /* FALLTHROUGH */ case OP_LIST: - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) { + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) { assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID); S_lvref(aTHX_ kid, type); } @@ -2801,8 +2799,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } - while (OP_HAS_SIBLING(kid)) - kid = OP_SIBLING(kid); + while (OpHAS_SIBLING(kid)) + kid = OpSIBLING(kid); if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { break; /* Postpone until runtime */ } @@ -2898,7 +2896,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COND_EXPR: localize = 1; - for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) op_lvalue(kid, type); break; @@ -3002,7 +3000,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; if (o->op_flags & OPf_KIDS) - op_lvalue(OP_SIBLING(cBINOPo->op_first), type); + op_lvalue(OpSIBLING(cBINOPo->op_first), type); break; case OP_AELEM: @@ -3042,7 +3040,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) /* FALLTHROUGH */ case OP_LIST: localize = 0; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) /* elements might be in void context because the list is in scalar context or because they are attribute sub calls */ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID ) @@ -3058,8 +3056,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) || !S_vivifies(cLOGOPo->op_first->op_type)) op_lvalue(cLOGOPo->op_first, type); if (type == OP_LEAVESUBLV - || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type)) - op_lvalue(OP_SIBLING(cLOGOPo->op_first), type); + || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) + op_lvalue(OpSIBLING(cLOGOPo->op_first), type); goto nomod; case OP_SREFGEN: @@ -3068,7 +3066,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; /* Don’t bother applying lvalue context to the ex-list. */ kid = cUNOPx(cUNOPo->op_first)->op_first; - assert (!OP_HAS_SIBLING(kid)); + assert (!OpHAS_SIBLING(kid)); goto kid_2lvref; case OP_REFGEN: if (type != OP_AASSIGN) goto nomod; @@ -3225,7 +3223,7 @@ S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) ref(kid, type); } return o; @@ -3261,7 +3259,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) break; case OP_COND_EXPR: - for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) doref(kid, type, set_op_ref); break; case OP_RV2SV: @@ -3345,7 +3343,7 @@ S_dup_attrlist(pTHX_ OP *o) else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); rop = NULL; - for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) { + for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) { if (o->op_type == OP_CONST) rop = op_append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, @@ -3414,7 +3412,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) newSVOP(OP_CONST, 0, stashsv), op_prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, - op_lvalue(arg, OP_REFGEN)), + arg), dup_attrlist(attrs))); /* Fake up a method call to import */ @@ -3507,7 +3505,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) assert(o->op_flags & OPf_KIDS); lasto = cLISTOPo->op_first; assert(lasto->op_type == OP_PUSHMARK); - for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) { + for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) { if (o->op_type == OP_CONST) { pv = SvPV(cSVOPo_sv, pvlen); if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { @@ -3536,7 +3534,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) } /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs would get pulled in with no real need */ - if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) { + if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) { op_free(*attrs); *attrs = NULL; } @@ -3603,7 +3601,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) if (type == OP_LIST) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) my_kid(kid, attrs, imopsp); return o; } else if (type == OP_UNDEF || type == OP_STUB) { @@ -3797,7 +3795,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) } else return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0)); + pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0)); } OP * @@ -3839,7 +3837,7 @@ Perl_op_scope(pTHX_ OP *o) op_null(kid); /* The following deals with things like 'do {1 for 1}' */ - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); if (kid && (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) op_null(kid); @@ -3856,7 +3854,7 @@ Perl_op_unscope(pTHX_ OP *o) { if (o && o->op_type == OP_LINESEQ) { OP *kid = cLISTOPo->op_first; - for(; kid; kid = OP_SIBLING(kid)) + for(; kid; kid = OpSIBLING(kid)) if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) op_null(kid); } @@ -3977,7 +3975,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) */ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; - for (;; kid = OP_SIBLING(kid)) { + for (;; kid = OpSIBLING(kid)) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); @@ -4267,11 +4265,11 @@ S_fold_constants(pTHX_ OP *o) #endif break; case OP_PACK: - if (!OP_HAS_SIBLING(cLISTOPo->op_first) - || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST) + if (!OpHAS_SIBLING(cLISTOPo->op_first) + || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST) goto nope; { - SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first)); + SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first)); if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; { const char *s = SvPVX_const(sv); @@ -4505,7 +4503,7 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) return op_append_elem(type, first, last); ((LISTOP*)first)->op_last->op_lastsib = 0; - OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); + OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; ((LISTOP*)first)->op_last->op_lastsib = 1; #ifdef PERL_OP_PARENT @@ -4584,7 +4582,7 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); else { - OP * const kid2 = OP_SIBLING(cLISTOPo->op_first); + OP * const kid2 = OpSIBLING(cLISTOPo->op_first); if (kid2 && kid2->op_type == OP_COREARGS) { op_null(cLISTOPo->op_first); kid2->op_private |= OPpCOREARGS_PUSHMARK; @@ -4643,8 +4641,8 @@ S_force_list(pTHX_ OP *o, bool nullit) OP *rest = NULL; if (o) { /* manually detach any siblings then add them back later */ - rest = OP_SIBLING(o); - OP_SIBLING_set(o, NULL); + rest = OpSIBLING(o); + OpSIBLING_set(o, NULL); o->op_lastsib = 1; } o = newLISTOP(OP_LIST, 0, o, NULL); @@ -4681,7 +4679,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; LISTOP *listop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP + || type == OP_CUSTOM); NewOp(1101, listop, 1, LISTOP); @@ -4695,13 +4694,13 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - OP_SIBLING_set(first, last); + OpSIBLING_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); pushop->op_lastsib = 0; - OP_SIBLING_set(pushop, first); + OpSIBLING_set(pushop, first); listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) @@ -4790,6 +4789,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP || type == OP_SASSIGN || type == OP_ENTERTRY + || type == OP_CUSTOM || type == OP_NULL ); if (!first) @@ -4804,7 +4804,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_private = (U8)(1 | (flags >> 8)); #ifdef PERL_OP_PARENT - if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */ + if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */ first->op_sibling = (OP*)unop; #endif @@ -4830,7 +4830,8 @@ Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) dVAR; UNOP_AUX *unop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX + || type == OP_CUSTOM); NewOp(1101, unop, 1, UNOP_AUX); unop->op_type = (OPCODE)type; @@ -4841,7 +4842,7 @@ Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) unop->op_aux = aux; #ifdef PERL_OP_PARENT - if (first && !OP_HAS_SIBLING(first)) /* true unless weird syntax error */ + if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */ first->op_sibling = (OP*)unop; #endif @@ -4870,7 +4871,8 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth dVAR; METHOP *methop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP + || type == OP_CUSTOM); NewOp(1101, methop, 1, METHOP); if (dynamic_meth) { @@ -4880,7 +4882,7 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth methop->op_private = (U8)(1 | (flags >> 8)); #ifdef PERL_OP_PARENT - if (!OP_HAS_SIBLING(dynamic_meth)) + if (!OpHAS_SIBLING(dynamic_meth)) dynamic_meth->op_sibling = (OP*)methop; #endif } @@ -4948,7 +4950,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) BINOP *binop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP - || type == OP_SASSIGN || type == OP_NULL ); + || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); @@ -4964,16 +4966,16 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - OP_SIBLING_set(first, last); + OpSIBLING_set(first, last); first->op_lastsib = 0; } #ifdef PERL_OP_PARENT - if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */ + if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */ last->op_sibling = (OP*)binop; #endif - binop->op_last = OP_SIBLING(binop->op_first); + binop->op_last = OpSIBLING(binop->op_first); #ifdef PERL_OP_PARENT if (binop->op_last) binop->op_last->op_sibling = (OP*)binop; @@ -5353,7 +5355,8 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) dVAR; PMOP *pmop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP + || type == OP_CUSTOM); NewOp(1101, pmop, 1, PMOP); CHANGE_TYPE(pmop, type); @@ -5436,8 +5439,7 @@ S_set_haseval(pTHX) * isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list - * if the pattern contains more than one term (eg /a$b/) or if it contains - * a replacement, ie s/// or tr///. + * if the pattern contains more than one term (eg /a$b/). * * When the pattern has been compiled within a new anon CV (for * qr/(?{...})/ ), then floor indicates the savestack level just before @@ -5445,46 +5447,19 @@ S_set_haseval(pTHX) */ OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) +Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) { - dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; - OP* repl = NULL; bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); bool is_compiletime; bool has_code; PERL_ARGS_ASSERT_PMRUNTIME; - /* for s/// and tr///, last element in list is the replacement; pop it */ - - if (is_trans || o->op_type == OP_SUBST) { - OP* kid; - repl = cLISTOPx(expr)->op_last; - kid = cLISTOPx(expr)->op_first; - while (OP_SIBLING(kid) != repl) - kid = OP_SIBLING(kid); - op_sibling_splice(expr, kid, 1, NULL); - } - - /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ - if (is_trans) { - OP *first, *last; - - assert(expr->op_type == OP_LIST); - first = cLISTOPx(expr)->op_first; - last = cLISTOPx(expr)->op_last; - assert(first->op_type == OP_PUSHMARK); - assert(OP_SIBLING(first) == last); - - /* cut 'last' from sibling chain, then free everything else */ - op_sibling_splice(expr, first, 1, NULL); - op_free(expr); - - return pmtrans(o, last, repl); + return pmtrans(o, expr, repl); } /* find whether we have any runtime or code elements; @@ -5497,11 +5472,11 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) has_code = 0; if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) { if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { has_code = 1; assert(!o->op_next); - if (UNLIKELY(!OP_HAS_SIBLING(o))) { + if (UNLIKELY(!OpHAS_SIBLING(o))) { assert(PL_parser && PL_parser->error_count); /* This can happen with qr/ (?{(^{})/. Just fake up the op we were expecting to see, to avoid crashing @@ -5509,7 +5484,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) op_sibling_splice(expr, o, 0, newSVOP(OP_CONST, 0, &PL_sv_no)); } - o->op_next = OP_SIBLING(o); + o->op_next = OpSIBLING(o); } else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) is_compiletime = 0; @@ -5525,7 +5500,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) { if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { assert( !(o->op_flags & OPf_WANT)); @@ -5544,8 +5519,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first); /* skip ENTER */ assert(leaveop->op_first->op_type == OP_ENTER); - assert(OP_HAS_SIBLING(leaveop->op_first)); - o->op_next = OP_SIBLING(leaveop->op_first); + assert(OpHAS_SIBLING(leaveop->op_first)); + o->op_next = OpSIBLING(leaveop->op_first); /* skip leave */ assert(leaveop->op_flags & OPf_KIDS); assert(leaveop->op_last->op_next == (OP*)leaveop); @@ -5758,8 +5733,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) { OP *sib; OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; - if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid)) - && !OP_HAS_SIBLING(sib)) + if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid)) + && !OpHAS_SIBLING(sib)) curop = sib; } if (curop->op_type == OP_CONST) @@ -5826,7 +5801,8 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); NewOp(1101, svop, 1, SVOP); CHANGE_TYPE(svop, type); @@ -5891,7 +5867,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); NewOp(1101, padop, 1, PADOP); CHANGE_TYPE(padop, type); @@ -5957,7 +5934,7 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) flags &= ~SVf_UTF8; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || type == OP_RUNCV + || type == OP_RUNCV || type == OP_CUSTOM || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); @@ -6293,9 +6270,9 @@ S_assignment_type(pTHX_ const OP *o) flags = o->op_flags; type = o->op_type; if (type == OP_COND_EXPR) { - OP * const sib = OP_SIBLING(cLOGOPo->op_first); + OP * const sib = OpSIBLING(cLOGOPo->op_first); const I32 t = assignment_type(sib); - const I32 f = assignment_type(OP_SIBLING(sib)); + const I32 f = assignment_type(OpSIBLING(sib)); if (t == ASSIGN_LIST && f == ASSIGN_LIST) return ASSIGN_LIST; @@ -6365,7 +6342,7 @@ PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o) { OP *curop; - for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { + for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV || curop->op_type == OP_GVSV || curop->op_type == OP_AELEMFAST) { @@ -6441,7 +6418,7 @@ PERL_STATIC_INLINE bool S_aassign_common_vars_aliases_only(pTHX_ OP *o) { OP *curop; - for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { + for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { if ((curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || @@ -6553,7 +6530,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) /* Other ops in the list. */ maybe_common_vars = TRUE; } - lop = OP_SIBLING(lop); + lop = OpSIBLING(lop); } } else if ((left->op_private & OPpLVAL_INTRO) @@ -6826,7 +6803,7 @@ S_search_const(pTHX_ OP *o) case OP_ENTER: case OP_NULL: case OP_NEXTSTATE: - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); break; default: if (kid != cLISTOPo->op_last) @@ -6836,7 +6813,7 @@ S_search_const(pTHX_ OP *o) } while (kid); if (!kid) kid = cLISTOPo->op_last; -last: + last: return search_const(kid); } } @@ -6901,7 +6878,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP + || type == OP_CUSTOM); scalarboolean(first); /* optimize AND and OR ops that have NOTs as children */ @@ -6953,7 +6931,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK - && (( o2 = OP_SIBLING(o2))) ) + && (( o2 = OpSIBLING(o2))) ) ) o2 = other; if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV @@ -6976,7 +6954,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { const OP * const k1 = ((UNOP*)first)->op_first; - const OP * const k2 = OP_SIBLING(k1); + const OP * const k2 = OpSIBLING(k1); OPCODE warnop = 0; switch (first->op_type) { @@ -7028,7 +7006,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) /* establish postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP*)logop; - assert(!OP_HAS_SIBLING(first)); + assert(!OpHAS_SIBLING(first)); op_sibling_splice((OP*)logop, first, 0, other); CHECKOP(type,logop); @@ -7133,7 +7111,6 @@ and become part of the constructed op tree. OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { - dVAR; LOGOP *range; OP *flip; OP *flop; @@ -7230,7 +7207,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL; + const OP * const k2 = k1 ? OpSIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -7328,7 +7305,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL; + const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -7503,7 +7480,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; OP* const left = range->op_first; - OP* const right = OP_SIBLING(left); + OP* const right = OpSIBLING(left); LISTOP* listop; range->op_flags &= ~OPf_KIDS; @@ -7575,7 +7552,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_CUSTOM); if (type != OP_GOTO) { /* "last()" means "last" */ @@ -7719,7 +7697,7 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_AND: { - OP* sibl = OP_SIBLING(cLOGOPo->op_first); + OP* sibl = OpSIBLING(cLOGOPo->op_first); ASSUME(sibl); return ( looks_like_bool(cLOGOPo->op_first) @@ -8080,7 +8058,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV *clonee = NULL; HEK *hek = NULL; bool reusable = FALSE; - OP *start; + OP *start = NULL; #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; #endif @@ -8440,10 +8418,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); - OP *start; + bool evanescent = FALSE; + OP *start = NULL; #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; - bool special = FALSE; #endif if (o_is_gv) { @@ -8585,7 +8563,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv = NULL; else const_sv = - S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv)); + S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv))); if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { assert (block); @@ -8847,9 +8825,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else -#ifdef PERL_DEBUG_READONLY_OPS - special = -#endif + evanescent = process_special_blocks(floor, name, gv, cv); } } @@ -8858,11 +8834,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); + if (!evanescent) { #ifdef PERL_DEBUG_READONLY_OPS - /* Watch out for BEGIN blocks */ - if (!special && slab) + if (slab) Slab_to_ro(slab); #endif + if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv))) + pad_add_weakref(cv); + } return cv; } @@ -8891,6 +8870,7 @@ S_clear_special_blocks(pTHX_ const char *const fullname, } } +/* Returns true if the sub has been freed. */ STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, @@ -8920,7 +8900,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, POPSTACK; LEAVE; - return TRUE; + return !PL_savebegin; } else return FALSE; @@ -8963,7 +8943,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, DEBUG_x( dump_sub(gv) ); (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ - return TRUE; + return FALSE; } } @@ -9281,9 +9261,16 @@ Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) OP * Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { - return newUNOP(OP_REFGEN, 0, + SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); + OP * anoncode = newSVOP(OP_ANONCODE, 0, - MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); + cv); + if (CvANONCONST(cv)) + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); + return newUNOP(OP_REFGEN, 0, anoncode); } OP * @@ -9471,7 +9458,7 @@ Perl_ck_backtick(pTHX_ OP *o) OP *sibl; PERL_ARGS_ASSERT_CK_BACKTICK; /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ - if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first)) + if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first)) && (gv = gv_override("readpipe",8))) { /* detach rest of siblings from o and its first child */ @@ -9494,21 +9481,32 @@ Perl_ck_bitop(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_BITOP; o->op_private = (U8)(PL_hints & HINT_INTEGER); + + if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR + || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR + || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND + || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT) + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE), + "The bitwise feature is experimental"); if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ - && (o->op_type == OP_BIT_OR - || o->op_type == OP_BIT_AND - || o->op_type == OP_BIT_XOR)) + && OP_IS_INFIX_BIT(o->op_type)) { const OP * const left = cBINOPo->op_first; - const OP * const right = OP_SIBLING(left); + const OP * const right = OpSIBLING(left); if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && (right->op_flags & OPf_PARENS) == 0)) Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), - "Possible precedence problem on bitwise %c operator", - o->op_type == OP_BIT_OR ? '|' - : o->op_type == OP_BIT_AND ? '&' : '^' + "Possible precedence problem on bitwise %s operator", + o->op_type == OP_BIT_OR + ||o->op_type == OP_NBIT_OR ? "|" + : o->op_type == OP_BIT_AND + ||o->op_type == OP_NBIT_AND ? "&" + : o->op_type == OP_BIT_XOR + ||o->op_type == OP_NBIT_XOR ? "^" + : o->op_type == OP_SBIT_OR ? "|." + : o->op_type == OP_SBIT_AND ? "&." : "^." ); } return o; @@ -9534,10 +9532,10 @@ Perl_ck_cmp(pTHX_ OP *o) if (kid && ( ( is_dollar_bracket(aTHX_ kid) - && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST + && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST ) || ( kid->op_type == OP_CONST - && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) ) ) ) @@ -9576,10 +9574,10 @@ Perl_ck_spair(pTHX_ OP *o) o = modkids(ck_fun(o), type); kid = cUNOPo->op_first; kidkid = kUNOP->op_first; - newop = OP_SIBLING(kidkid); + newop = OpSIBLING(kidkid); if (newop) { const OPCODE type = newop->op_type; - if (OP_HAS_SIBLING(newop)) + if (OpHAS_SIBLING(newop)) return o; if (o->op_type == OP_REFGEN && ( type == OP_RV2CV @@ -9671,7 +9669,7 @@ Perl_ck_eval(pTHX_ OP *o) SVOP * const kid = (SVOP*)cUNOPo->op_first; assert(kid); - if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { + if (o->op_type == OP_ENTERTRY) { LOGOP *enter; /* cut whole sibling chain free from o */ @@ -9728,7 +9726,7 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; o = ck_fun(o); - kid = OP_SIBLING(cUNOPo->op_first); + kid = OpSIBLING(cUNOPo->op_first); if (kid->op_type == OP_RV2GV) op_null(kid); } @@ -9878,8 +9876,10 @@ Perl_ck_ftst(pTHX_ OP *o) } if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; - if (PL_check[kidtype] == Perl_ck_ftst - && kidtype != OP_STAT && kidtype != OP_LSTAT) { + if (type != OP_STAT && type != OP_LSTAT + && PL_check[kidtype] == Perl_ck_ftst + && kidtype != OP_STAT && kidtype != OP_LSTAT + ) { o->op_private |= OPpFT_STACKED; kid->op_private |= OPpFT_STACKING; if (kidtype == OP_FTTTY && ( @@ -9924,7 +9924,7 @@ Perl_ck_fun(pTHX_ OP *o) (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { prev_kid = kid; - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); } if (kid && kid->op_type == OP_COREARGS) { bool optional = FALSE; @@ -9969,7 +9969,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !OP_HAS_SIBLING(kid)) + && !OpHAS_SIBLING(kid)) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); @@ -9978,7 +9978,7 @@ Perl_ck_fun(pTHX_ OP *o) && ( !SvROK(cSVOPx_sv(kid)) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) - bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid); + bad_type_pv(numargs, "array", o, kid); /* Defer checks to run-time if we have a scalar arg */ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) op_lvalue(kid, type); @@ -9993,7 +9993,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_HVREF: if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); + bad_type_pv(numargs, "hash", o, kid); op_lvalue(kid, type); break; case OA_CVREF: @@ -10019,7 +10019,7 @@ Perl_ck_fun(pTHX_ OP *o) } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ - bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid); + bad_type_pv(numargs, "HANDLE", o, kid); } else { I32 flags = OPf_SPECIAL; @@ -10134,7 +10134,7 @@ Perl_ck_fun(pTHX_ OP *o) } oa >>= 4; prev_kid = kid; - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); } /* FIXME - should the numargs or-ing move after the too many * arguments check? */ @@ -10166,7 +10166,7 @@ Perl_ck_glob(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_GLOB; o = ck_fun(o); - if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first)) + if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first)) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) @@ -10211,7 +10211,6 @@ Perl_ck_glob(pTHX_ OP *o) OP * Perl_ck_grep(pTHX_ OP *o) { - dVAR; LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; @@ -10222,12 +10221,12 @@ Perl_ck_grep(pTHX_ OP *o) /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { - kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first; + kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) return no_fh_allowed(o); o->op_flags &= ~OPf_STACKED; } - kid = OP_SIBLING(cLISTOPo->op_first); + kid = OpSIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) list(kid); else @@ -10235,7 +10234,7 @@ Perl_ck_grep(pTHX_ OP *o) o = ck_fun(o); if (PL_parser && PL_parser->error_count) return o; - kid = OP_SIBLING(cLISTOPo->op_first); + kid = OpSIBLING(cLISTOPo->op_first); if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; @@ -10252,8 +10251,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_targ = o->op_targ = offset; } - kid = OP_SIBLING(cLISTOPo->op_first); - for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid)) + kid = OpSIBLING(cLISTOPo->op_first); + for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; @@ -10265,9 +10264,9 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid) - kid = OP_SIBLING(kid); /* get past "big" */ + kid = OpSIBLING(kid); /* get past "big" */ if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; SV *sv = kSVOP->op_sv; @@ -10363,10 +10362,10 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = OP_SIBLING(kid); - else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */ + kid = OpSIBLING(kid); + else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE && !kid->op_folded) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ @@ -10374,7 +10373,7 @@ Perl_ck_listiob(pTHX_ OP *o) /* replace old const op with new OP_RV2GV parent */ kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, OP_RV2GV, OPf_REF); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); } } @@ -10392,7 +10391,7 @@ Perl_ck_smartmatch(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SMARTMATCH; if (0 == (o->op_flags & OPf_SPECIAL)) { OP *first = cBINOPo->op_first; - OP *second = OP_SIBLING(first); + OP *second = OpSIBLING(first); /* Implicitly take a reference to an array or hash */ @@ -10422,7 +10421,6 @@ Perl_ck_smartmatch(pTHX_ OP *o) static OP * S_maybe_targlex(pTHX_ OP *o) { - dVAR; OP * const kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) @@ -10431,7 +10429,7 @@ S_maybe_targlex(pTHX_ OP *o) && !(kid->op_private & OPpTARGET_MY) ) { - OP * const kkid = OP_SIBLING(kid); + OP * const kkid = OpSIBLING(kid); /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV @@ -10459,8 +10457,8 @@ Perl_ck_sassign(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SASSIGN; - if (OP_HAS_SIBLING(kid)) { - OP *kkid = OP_SIBLING(kid); + if (OpHAS_SIBLING(kid)) { + OP *kkid = OpSIBLING(kid); /* For state variable assignment with attributes, kkid is a list op whose op_last is a padsv. */ if ((kkid->op_type == OP_PADSV || @@ -10598,23 +10596,34 @@ Perl_ck_open(pTHX_ OP *o) if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && - (oa = OP_SIBLING(first)) && /* The fh. */ - (oa = OP_SIBLING(oa)) && /* The mode. */ + (oa = OpSIBLING(first)) && /* The fh. */ + (oa = OpSIBLING(oa)) && /* The mode. */ (oa->op_type == OP_CONST) && SvPOK(((SVOP*)oa)->op_sv) && (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ - (last == OP_SIBLING(oa))) /* The bareword. */ + (last == OpSIBLING(oa))) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); } OP * +Perl_ck_prototype(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_PROTOTYPE; + if (!(o->op_flags & OPf_KIDS)) { + op_free(o); + return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); + } + return o; +} + +OP * Perl_ck_refassign(pTHX_ OP *o) { OP * const right = cLISTOPo->op_first; - OP * const left = OP_SIBLING(right); + OP * const left = OpSIBLING(right); OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first; bool stacked = 0; @@ -10807,9 +10816,9 @@ Perl_ck_return(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RETURN; - kid = OP_SIBLING(cLISTOPo->op_first); + kid = OpSIBLING(cLISTOPo->op_first); if (CvLVALUE(PL_compcv)) { - for (; kid; kid = OP_SIBLING(kid)) + for (; kid; kid = OpSIBLING(kid)) op_lvalue(kid, OP_LEAVESUBLV); } @@ -10825,15 +10834,15 @@ Perl_ck_select(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SELECT; if (o->op_flags & OPf_KIDS) { - kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ - if (kid && OP_HAS_SIBLING(kid)) { + kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && OpHAS_SIBLING(kid)) { CHANGE_TYPE(o, OP_SSELECT); o = ck_fun(o); return fold_constants(op_integerize(op_std_init(o))); } } o = ck_fun(o); - kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; return o; @@ -10885,7 +10894,7 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); - firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ @@ -10935,10 +10944,10 @@ Perl_ck_sort(pTHX_ OP *o) } } - firstkid = OP_SIBLING(firstkid); + firstkid = OpSIBLING(firstkid); } - for (kid = firstkid; kid; kid = OP_SIBLING(kid)) { + for (kid = firstkid; kid; kid = OpSIBLING(kid)) { /* provide list context for arguments */ list(kid); if (stacked) @@ -10961,7 +10970,7 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { - OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ OP *k; int descending; GV *gv; @@ -11015,7 +11024,7 @@ S_simplify_sort(pTHX_ OP *o) : "my", PadnamePV(name)); } - } while ((kid = OP_SIBLING(kid))); + } while ((kid = OpSIBLING(kid))); return; } kid = kBINOP->op_first; /* get past cmp */ @@ -11054,7 +11063,7 @@ S_simplify_sort(pTHX_ OP *o) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; - kid = OP_SIBLING(cLISTOPo->op_first); + kid = OpSIBLING(cLISTOPo->op_first); /* cut out and delete old block (second sibling) */ op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); op_free(kid); @@ -11076,7 +11085,7 @@ Perl_ck_split(pTHX_ OP *o) Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); /* delete leading NULL node, then add a CONST if no other nodes */ op_sibling_splice(o, NULL, 1, - OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); + OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); op_free(kid); kid = cLISTOPo->op_first; @@ -11084,34 +11093,36 @@ Perl_ck_split(pTHX_ OP *o) /* remove kid, and replace with new optree */ op_sibling_splice(o, NULL, 1, NULL); /* OPf_SPECIAL is used to trigger split " " behavior */ - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0); op_sibling_splice(o, NULL, 0, kid); } CHANGE_TYPE(kid, OP_PUSHRE); + /* target implies @ary=..., so wipe it */ + kid->op_targ = 0; scalar(kid); if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } - if (!OP_HAS_SIBLING(kid)) + if (!OpHAS_SIBLING(kid)) op_append_elem(OP_SPLIT, o, newDEFSVOP()); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); assert(kid); scalar(kid); - if (!OP_HAS_SIBLING(kid)) + if (!OpHAS_SIBLING(kid)) { op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); o->op_private |= OPpSPLIT_IMPLIM; } - assert(OP_HAS_SIBLING(kid)); + assert(OpHAS_SIBLING(kid)); - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); scalar(kid); - if (OP_HAS_SIBLING(kid)) + if (OpHAS_SIBLING(kid)) return too_many_arguments_pv(o,OP_DESC(o), 0); return o; @@ -11120,13 +11131,13 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_stringify(pTHX_ OP *o) { - OP * const kid = OP_SIBLING(cUNOPo->op_first); + OP * const kid = OpSIBLING(cUNOPo->op_first); PERL_ARGS_ASSERT_CK_STRINGIFY; if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) { - assert(!OP_HAS_SIBLING(kid)); + assert(!OpHAS_SIBLING(kid)); op_sibling_splice(o, cUNOPo->op_first, -1, NULL); op_free(o); return kid; @@ -11137,7 +11148,7 @@ Perl_ck_stringify(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - OP * const kid = OP_SIBLING(cLISTOPo->op_first); + OP * const kid = OpSIBLING(cLISTOPo->op_first); PERL_ARGS_ASSERT_CK_JOIN; @@ -11159,8 +11170,8 @@ Perl_ck_join(pTHX_ OP *o) || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) { - const OP * const bairn = OP_SIBLING(kid); /* the list */ - if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */ + const OP * const bairn = OpSIBLING(kid); /* the list */ + if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ && OP_GIMME(bairn,0) == G_SCALAR) { OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, @@ -11313,9 +11324,9 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) OP *aop; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; aop = cUNOPx(entersubop)->op_first; - if (!OP_HAS_SIBLING(aop)) + if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) { + for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -11371,13 +11382,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) proto_end = proto + proto_len; parent = entersubop; aop = cUNOPx(entersubop)->op_first; - if (!OP_HAS_SIBLING(aop)) { + if (!OpHAS_SIBLING(aop)) { parent = aop; aop = cUNOPx(aop)->op_first; } prev = aop; - aop = OP_SIBLING(aop); - for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; + aop = OpSIBLING(aop); + for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; while (aop != cvop) { OP* o3 = aop; @@ -11417,9 +11428,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) != OP_ANONCODE && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_RV2CV)) - bad_type_gv(arg, - arg == 1 ? "block or sub {}" : "sub {}", - namegv, 0, o3); + bad_type_gv(arg, namegv, o3, + arg == 1 ? "block or sub {}" : "sub {}"); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -11474,9 +11484,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s", - (int)(end - p), p), - namegv, 0, o3); + bad_type_gv(arg, namegv, o3, + Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); } else goto oops; break; @@ -11484,15 +11493,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type_gv(arg, "symbol", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "symbol"); break; case '&': if (o3->op_type == OP_ENTERSUB && !(o3->op_flags & OPf_STACKED)) goto wrapref; if (!contextclass) - bad_type_gv(arg, "subroutine", namegv, 0, - o3); + bad_type_gv(arg, namegv, o3, "subroutine"); break; case '$': if (o3->op_type == OP_RV2SV || @@ -11507,7 +11515,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_gv(arg, "scalar", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "scalar"); } break; case '@': @@ -11518,7 +11526,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; } if (!contextclass) - bad_type_gv(arg, "array", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "array"); break; case '%': if (o3->op_type == OP_RV2HV || @@ -11528,7 +11536,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; } if (!contextclass) - bad_type_gv(arg, "hash", namegv, 0, o3); + bad_type_gv(arg, namegv, o3, "hash"); break; wrapref: aop = S_op_sibling_newUNOP(aTHX_ parent, prev, @@ -11556,7 +11564,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) op_lvalue(aop, OP_ENTERSUB); prev = aop; - aop = OP_SIBLING(aop); + aop = OpSIBLING(aop); } if (aop == cvop && *proto == '_') { /* generate an access to $_ */ @@ -11620,10 +11628,10 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!opnum) { OP *cvop; - if (!OP_HAS_SIBLING(aop)) + if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = OP_SIBLING(aop); - for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; + aop = OpSIBLING(aop); + for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; if (aop != cvop) (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); @@ -11651,20 +11659,20 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) U32 flags = 0; parent = entersubop; - if (!OP_HAS_SIBLING(aop)) { + if (!OpHAS_SIBLING(aop)) { parent = aop; aop = cUNOPx(aop)->op_first; } first = prev = aop; - aop = OP_SIBLING(aop); + aop = OpSIBLING(aop); /* find last sibling */ for (cvop = aop; - OP_HAS_SIBLING(cvop); - prev = cvop, cvop = OP_SIBLING(cvop)) + OpHAS_SIBLING(cvop); + prev = cvop, cvop = OpSIBLING(cvop)) ; if (!(cvop->op_private & OPpENTERSUB_NOPAREN) - /* Usually, OPf_SPECIAL on a UNOP means that its arg had no + /* Usually, OPf_SPECIAL on an op with no args means that it had * parens, but these have their own meaning for that flag: */ && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH && opnum != OP_DELETE && opnum != OP_EXISTS) @@ -11836,6 +11844,13 @@ Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, } } +static void +S_entersub_alloc_targ(pTHX_ OP * const o) +{ + o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP); + o->op_private |= OPpENTERSUB_HASTARG; +} + OP * Perl_ck_subr(pTHX_ OP *o) { @@ -11847,15 +11862,14 @@ Perl_ck_subr(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SUBR; aop = cUNOPx(o)->op_first; - if (!OP_HAS_SIBLING(aop)) + if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = OP_SIBLING(aop); - for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; + aop = OpSIBLING(aop); + for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; - o->op_private |= OPpENTERSUB_HASTARG; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; @@ -11874,7 +11888,7 @@ Perl_ck_subr(pTHX_ OP *o) const_class = &cSVOPx(aop)->op_sv; } else if (aop->op_type == OP_LIST) { - OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); + OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); if (sib && sib->op_type == OP_CONST) { sib->op_private &= ~OPpCONST_STRICT; const_class = &cSVOPx(sib)->op_sv; @@ -11882,12 +11896,14 @@ Perl_ck_subr(pTHX_ OP *o) } /* make class name a shared cow string to speedup method calls */ /* constant string might be replaced with object, f.e. bigint */ - if (const_class && !SvROK(*const_class)) { + if (const_class && SvPOK(*const_class)) { STRLEN len; const char* str = SvPV(*const_class, len); if (len) { SV* const shared = newSVpvn_share( - str, SvUTF8(*const_class) ? -len : len, 0 + str, SvUTF8(*const_class) + ? -(SSize_t)len : (SSize_t)len, + 0 ); SvREFCNT_dec(*const_class); *const_class = shared; @@ -11897,12 +11913,15 @@ Perl_ck_subr(pTHX_ OP *o) } if (!cv) { + S_entersub_alloc_targ(aTHX_ o); return ck_entersub_args_list(o); } else { Perl_call_checker ckfun; SV *ckobj; U8 flags; S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (CvISXSUB(cv) || !CvROOT(cv)) + S_entersub_alloc_targ(aTHX_ o); if (!namegv) { /* The original call checker API guarantees that a GV will be be provided with the right name. So, if the old API was @@ -11959,7 +11978,7 @@ Perl_ck_trunc(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) - kid = (SVOP*)OP_SIBLING(kid); + kid = (SVOP*)OpSIBLING(kid); if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE) && !kid->op_folded) @@ -11981,7 +12000,7 @@ Perl_ck_substr(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) - kid = OP_SIBLING(kid); + kid = OpSIBLING(kid); if (kid) kid->op_flags |= OPf_MOD; @@ -11996,7 +12015,7 @@ Perl_ck_tell(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid); + if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; } return o; @@ -12108,39 +12127,39 @@ S_inplace_aassign(pTHX_ OP *o) { assert(cUNOPo->op_first->op_type == OP_NULL); modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; assert(modop_pushmark->op_type == OP_PUSHMARK); - modop = OP_SIBLING(modop_pushmark); + modop = OpSIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) return; /* no other operation except sort/reverse */ - if (OP_HAS_SIBLING(modop)) + if (OpHAS_SIBLING(modop)) return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return; + if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ assert(oright->op_type == OP_NULL); - oright = OP_SIBLING(oright); + oright = OpSIBLING(oright); } - assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL); - oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first; + assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL); + oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first; assert(oleft_pushmark->op_type == OP_PUSHMARK); - oleft = OP_SIBLING(oleft_pushmark); + oleft = OpSIBLING(oleft_pushmark); /* Check the lhs is an array */ if (!oleft || (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || OP_HAS_SIBLING(oleft) + || OpHAS_SIBLING(oleft) || (oleft->op_private & OPpLVAL_INTRO) ) return; /* Only one thing on the rhs */ - if (OP_HAS_SIBLING(oright)) + if (OpHAS_SIBLING(oright)) return; /* check the array is the same on both sides */ @@ -12267,7 +12286,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) break; default: - assert(0); + NOT_REACHED; return; } @@ -12275,7 +12294,6 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* look for another (rv2av/hv; get index; * aelem/helem/exists/delele) sequence */ - IV iv; OP *kid; bool is_deref; bool ok; @@ -12296,7 +12314,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* rv2av or rv2hv sKR/1 */ - assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS |OPf_REF|OPf_MOD|OPf_SPECIAL))); if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) return; @@ -12306,14 +12324,14 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only) */ - assert(!(o->op_private & + ASSUME(!(o->op_private & ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING))); hints = (o->op_private & OPpHINT_STRICT_REFS); /* make sure the type of the previous /DEREF matches the * type of the next lookup */ - assert(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV)); + ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV)); top_op = o; action = next_is_hash @@ -12333,12 +12351,13 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) switch (o->op_type) { case OP_PADSV: /* it may be a lexical var index */ - assert(!(o->op_flags & ~(OPf_WANT|OPf_PARENS + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS |OPf_REF|OPf_MOD|OPf_SPECIAL))); - assert(!(o->op_private & + ASSUME(!(o->op_private & ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); - if ( o->op_flags == OPf_WANT_SCALAR + if ( OP_GIMME(o,0) == G_SCALAR + && !(o->op_flags & (OPf_REF|OPf_MOD)) && o->op_private == 0) { if (pass) @@ -12363,7 +12382,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) UNOP *rop = NULL; OP * helem_op = o->op_next; - assert( helem_op->op_type == OP_HELEM + ASSUME( helem_op->op_type == OP_HELEM || helem_op->op_type == OP_NULL); if (helem_op->op_type == OP_HELEM) { rop = (UNOP*)(((BINOP*)helem_op)->op_first); @@ -12386,12 +12405,10 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) } else { /* it's a constant array index */ + IV iv; SV *ix_sv = cSVOPo->op_sv; - if (UNLIKELY(SvROK(ix_sv) && !SvGAMAGIC(ix_sv) - && ckWARN(WARN_MISC))) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Use of reference \"%"SVf"\" as array index", - SVfARG(ix_sv)); + if (!SvIOK(ix_sv)) + break; iv = SvIV(ix_sv); if ( action_count == 0 @@ -12418,9 +12435,9 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) case OP_GV: /* it may be a package var index */ - assert(!(o->op_flags & ~(OPf_WANT))); - assert(!(o->op_private & ~(OPpEARLY_CV))); - if ( o->op_flags != OPf_WANT_SCALAR + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL))); + ASSUME(!(o->op_private & ~(OPpEARLY_CV))); + if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR || o->op_private != 0 ) break; @@ -12429,13 +12446,15 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) if (kid->op_type != OP_RV2SV) break; - assert(!(kid->op_flags & - ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF|OPf_SPECIAL))); - assert(!(kid->op_private & + ASSUME(!(kid->op_flags & + ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF + |OPf_SPECIAL|OPf_PARENS))); + ASSUME(!(kid->op_private & ~(OPpARG1_MASK |OPpHINT_STRICT_REFS|OPpOUR_INTRO |OPpDEREF|OPpLVAL_INTRO))); - if( kid->op_flags != (OPf_WANT_SCALAR|OPf_KIDS) + if( (kid->op_flags &~ OPf_PARENS) + != (OPf_WANT_SCALAR|OPf_KIDS) || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS)) ) break; @@ -12479,7 +12498,8 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* if something like arybase (a.k.a $[ ) is in scope, * abandon optimisation attempt */ - if (o->op_type == OP_AELEM && PL_check[OP_AELEM] != Perl_ck_null) + if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM) + && PL_check[o->op_type] != Perl_ck_null) return; if ( o->op_type != OP_AELEM @@ -12508,22 +12528,24 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) || (o->op_private & OPpDEREF) == OPpDEREF_HV); if (is_deref) { - assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD))); - assert(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF))); + ASSUME(!(o->op_flags & + ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS))); + ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF))); - ok = o->op_flags == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD) + ok = (o->op_flags &~ OPf_PARENS) + == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD) && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK)); } else if (o->op_type == OP_EXISTS) { - assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS |OPf_REF|OPf_MOD|OPf_SPECIAL))); - assert(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB))); + ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB))); ok = !(o->op_private & ~OPpARG1_MASK); } else if (o->op_type == OP_DELETE) { - assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS |OPf_REF|OPf_MOD|OPf_SPECIAL))); - assert(!(o->op_private & + ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO))); /* don't handle slices or 'local delete'; the latter * is fairly rare, and has a complex runtime */ @@ -12533,10 +12555,10 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL)); } else { - assert(o->op_type == OP_AELEM || o->op_type == OP_HELEM); - assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD + ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM); + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD |OPf_PARENS|OPf_REF|OPf_SPECIAL))); - assert(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB + ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO))); ok = (o->op_private & OPpDEREF) != OPpDEREF_SV; } @@ -12593,7 +12615,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) if (pass) { OP *mderef; - OP *p; + OP *p, *q; mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf); if (index_skip == -1) { @@ -12733,7 +12755,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) * expr->[..]? so we need to save the 'expr' subtree */ if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE) p = cUNOPx(p)->op_first; - assert( start->op_type == OP_RV2AV + ASSUME( start->op_type == OP_RV2AV || start->op_type == OP_RV2HV); } else { @@ -12744,7 +12766,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) ) p = cUNOPx(p)->op_first; } - assert(cUNOPx(p)->op_first == start); + ASSUME(cUNOPx(p)->op_first == start); /* detach from main tree, and re-attach under the multideref */ op_sibling_splice(mderef, NULL, 0, @@ -12757,7 +12779,12 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* excise and free the original tree, and replace with * the multideref op */ - op_free(op_sibling_splice(top_op, NULL, -1, mderef)); + p = op_sibling_splice(top_op, NULL, -1, mderef); + while (p) { + q = OpSIBLING(p); + op_free(p); + p = q; + } op_null(top_op); } else { @@ -12867,14 +12894,15 @@ Perl_rpeep(pTHX_ OP *o) * not aware of, rather than: * * silently failing to optimise, or * * silently optimising the flag away. - * If this assert starts failing, examine what new flag + * If this ASSUME starts failing, examine what new flag * has been added to the op, and decide whether the * optimisation should still occur with that flag, then * update the code accordingly. This applies to all the - * other asserts in the block of code too. + * other ASSUMEs in the block of code too. */ - assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD))); - assert(!(o2->op_private & ~OPpEARLY_CV)); + ASSUME(!(o2->op_flags & + ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL))); + ASSUME(!(o2->op_private & ~OPpEARLY_CV)); o2 = o2->op_next; @@ -12894,12 +12922,12 @@ Perl_rpeep(pTHX_ OP *o) /* at this point we've seen gv,rv2sv, so the only valid * construct left is $pkg->[] or $pkg->{} */ - assert(!(o2->op_flags & OPf_STACKED)); + ASSUME(!(o2->op_flags & OPf_STACKED)); if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) != (OPf_WANT_SCALAR|OPf_MOD)) break; - assert(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS + ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO))); if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO)) break; @@ -12921,14 +12949,14 @@ Perl_rpeep(pTHX_ OP *o) case OP_PADSV: /* $lex->[...]: padsv[$lex] sM/DREFAV */ - assert(!(o2->op_flags & + ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL))); if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) != (OPf_WANT_SCALAR|OPf_MOD)) break; - assert(!(o2->op_private & + ASSUME(!(o2->op_private & ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); /* skip if state or intro, or not a deref */ if ( o2->op_private != OPpDEREF_AV @@ -12950,7 +12978,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_PADHV: /* $lex[..]: padav[@lex:1,2] sR * * or $lex{..}: padhv[%lex:1,2] sR */ - assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS| + ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS| OPf_REF|OPf_SPECIAL))); if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) @@ -12960,7 +12988,7 @@ Perl_rpeep(pTHX_ OP *o) break; /* OPf_PARENS isn't currently used in this case; * if that changes, let us know! */ - assert(!(o2->op_flags & OPf_PARENS)); + ASSUME(!(o2->op_flags & OPf_PARENS)); /* at this point, we wouldn't expect any of the remaining * possible private flags: @@ -12969,7 +12997,7 @@ Perl_rpeep(pTHX_ OP *o) * * OPpSLICEWARNING shouldn't affect runtime */ - assert(!(o2->op_private & ~(OPpSLICEWARNING))); + ASSUME(!(o2->op_private & ~(OPpSLICEWARNING))); action = o2->op_type == OP_PADAV ? MDEREF_AV_padav_aelem @@ -12989,20 +13017,21 @@ Perl_rpeep(pTHX_ OP *o) /* (expr)->[...]: rv2av sKR/1; * (expr)->{...}: rv2hv sKR/1; */ - assert(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV); + ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV); - assert(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL))); if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) break; /* at this point, we wouldn't expect any of these * possible private flags: - * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO + * OPpMAYBE_LVSUB, OPpLVAL_INTRO * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only) */ - assert(!(o2->op_private & - ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING))); + ASSUME(!(o2->op_private & + ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING + |OPpOUR_INTRO))); hints |= (o2->op_private & OPpHINT_STRICT_REFS); o2 = o2->op_next; @@ -13039,7 +13068,7 @@ Perl_rpeep(pTHX_ OP *o) */ { OP *next = o->op_next; - OP *sibling = OP_SIBLING(o); + OP *sibling = OpSIBLING(o); if ( OP_TYPE_IS(next, OP_PUSHMARK) && OP_TYPE_IS(sibling, OP_RETURN) && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) @@ -13047,19 +13076,19 @@ Perl_rpeep(pTHX_ OP *o) ||OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUBLV)) && cUNOPx(sibling)->op_first == next - && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next + && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next && next->op_next ) { /* Look through the PUSHMARK's siblings for one that * points to the RETURN */ - OP *top = OP_SIBLING(next); + OP *top = OpSIBLING(next); while (top && top->op_next) { if (top->op_next == sibling) { top->op_next = sibling->op_next; o->op_next = next->op_next; break; } - top = OP_SIBLING(top); + top = OpSIBLING(top); } } } @@ -13103,14 +13132,14 @@ Perl_rpeep(pTHX_ OP *o) /* we assume here that the op_next chain is the same as * the op_sibling chain */ - assert(OP_SIBLING(o) == pad1); - assert(OP_SIBLING(pad1) == ns2); - assert(OP_SIBLING(ns2) == pad2); - assert(OP_SIBLING(pad2) == ns3); + assert(OpSIBLING(o) == pad1); + assert(OpSIBLING(pad1) == ns2); + assert(OpSIBLING(ns2) == pad2); + assert(OpSIBLING(pad2) == ns3); /* create new listop, with children consisting of: * a new pushmark, pad1, pad2. */ - OP_SIBLING_set(pad2, NULL); + OpSIBLING_set(pad2, NULL); newop = newLISTOP(OP_LIST, 0, pad1, pad2); newop->op_flags |= OPf_PARENS; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; @@ -13125,8 +13154,8 @@ Perl_rpeep(pTHX_ OP *o) pad2 ->op_next = newop; /* listop */ newop->op_next = ns3; - OP_SIBLING_set(o, newop); - OP_SIBLING_set(newop, ns3); + OpSIBLING_set(o, newop); + OpSIBLING_set(newop, ns3); newop->op_lastsib = 0; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; @@ -13239,7 +13268,7 @@ Perl_rpeep(pTHX_ OP *o) op_free(cBINOPo->op_last ); o->op_flags &=~ OPf_KIDS; /* stub is a baseop; repeat is a binop */ - assert(sizeof(OP) <= sizeof(BINOP)); + STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP)); CHANGE_TYPE(o, OP_STUB); o->op_private = 0; break; @@ -13272,7 +13301,7 @@ Perl_rpeep(pTHX_ OP *o) U8 count = 0; U8 intro = 0; PADOFFSET base = 0; /* init only to stop compiler whining */ - U8 gimme = 0; /* init only to stop compiler whining */ + bool gvoid = 0; /* init only to stop compiler whining */ bool defav = 0; /* seen (...) = @_ */ bool reuse = 0; /* reuse an existing padrange op */ @@ -13333,7 +13362,7 @@ Perl_rpeep(pTHX_ OP *o) if (count == 0) { intro = (p->op_private & OPpLVAL_INTRO); base = p->op_targ; - gimme = (p->op_flags & OPf_WANT); + gvoid = OP_GIMME(p,0) == G_VOID; } else { if ((p->op_private & OPpLVAL_INTRO) != intro) @@ -13345,14 +13374,18 @@ Perl_rpeep(pTHX_ OP *o) if (p->op_targ != base + count) break; assert(p->op_targ == base + count); - /* all the padops should be in the same context */ - if (gimme != (p->op_flags & OPf_WANT)) + /* Either all the padops or none of the padops should + be in void context. Since we only do the optimisa- + tion for av/hv when the aggregate itself is pushed + on to the stack (one item), there is no need to dis- + tinguish list from scalar context. */ + if (gvoid != (OP_GIMME(p,0) == G_VOID)) break; } /* for AV, HV, only when we're not flattening */ if ( p->op_type != OP_PADSV - && gimme != OPf_WANT_VOID + && !gvoid && !(p->op_flags & OPf_REF) ) break; @@ -13388,9 +13421,9 @@ Perl_rpeep(pTHX_ OP *o) * the stack) makes no difference in void context. */ assert(followop); - if (gimme == OPf_WANT_VOID) { + if (gvoid) { if (followop->op_type == OP_LIST - && gimme == (followop->op_flags & OPf_WANT) + && OP_GIMME(followop,0) == G_VOID ) { followop = followop->op_next; /* skip OP_LIST */ @@ -13473,7 +13506,8 @@ Perl_rpeep(pTHX_ OP *o) /* bit 7: INTRO; bit 6..0: count */ o->op_private = (intro | count); o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL)) - | gimme | (defav ? OPf_SPECIAL : 0)); + | gvoid * OPf_WANT_VOID + | (defav ? OPf_SPECIAL : 0)); } break; } @@ -13587,7 +13621,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_OR: case OP_DOR: fop = cLOGOP->op_first; - sop = OP_SIBLING(fop); + sop = OpSIBLING(fop); while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; while (o->op_next && ( o->op_type == o->op_next->op_type @@ -13701,7 +13735,7 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_flags & OPf_SPECIAL) { /* first arg is a code block */ - OP * const nullop = OP_SIBLING(cLISTOP->op_first); + OP * const nullop = OpSIBLING(cLISTOP->op_first); OP * kid = cUNOPx(nullop)->op_first; assert(nullop->op_type == OP_NULL); @@ -13734,7 +13768,7 @@ Perl_rpeep(pTHX_ OP *o) break; /* reverse sort ... can be optimised. */ - if (!OP_HAS_SIBLING(cUNOPo)) { + if (!OpHAS_SIBLING(cUNOPo)) { /* Nothing follows us on the list. */ OP * const reverse = o->op_next; @@ -13742,7 +13776,7 @@ Perl_rpeep(pTHX_ OP *o) (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { OP * const pushmark = cUNOPx(reverse)->op_first; if (pushmark && (pushmark->op_type == OP_PUSHMARK) - && (OP_SIBLING(cUNOPx(pushmark)) == o)) { + && (OpSIBLING(cUNOPx(pushmark)) == o)) { /* reverse -> pushmark -> sort */ o->op_private |= OPpSORT_REVERSE; op_null(reverse); @@ -13797,7 +13831,7 @@ Perl_rpeep(pTHX_ OP *o) || expushmark->op_targ != OP_PUSHMARK) break; - exlist = (LISTOP *) OP_SIBLING(expushmark); + exlist = (LISTOP *) OpSIBLING(expushmark); if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; @@ -13810,7 +13844,7 @@ Perl_rpeep(pTHX_ OP *o) if (!theirmark || theirmark->op_type != OP_PUSHMARK) break; - if (OP_SIBLING(theirmark) != o) { + if (OpSIBLING(theirmark) != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ @@ -13825,8 +13859,8 @@ Perl_rpeep(pTHX_ OP *o) if (!ourlast || ourlast->op_next != o) break; - rv2av = OP_SIBLING(ourmark); - if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av) + rv2av = OpSIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { /* We're just reversing a single array. */ @@ -13897,7 +13931,7 @@ Perl_rpeep(pTHX_ OP *o) * arg2 * ... */ - OP *left = OP_SIBLING(right); + OP *left = OpSIBLING(right); if (left->op_type == OP_SUBSTR && (left->op_private & 7) < 4) { op_null(o); @@ -13919,7 +13953,7 @@ Perl_rpeep(pTHX_ OP *o) (as formerly), so that all lexical vars that get aliased are marked as such before we do the check. */ /* There can’t be common vars if the lhs is a stub. */ - if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first) + if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first) == cLISTOPx(cBINOPo->op_last)->op_last && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB) {