X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/148f39b7de6eae9ddd59e0b0aff691d6abea7aca..a63813b376f25b984970473e47c98e473b1f70eb:/op.c diff --git a/op.c b/op.c index 791a97f..08e6028 100644 --- a/op.c +++ b/op.c @@ -180,7 +180,6 @@ S_new_slab(pTHX_ size_t sz) void * Perl_Slab_Alloc(pTHX_ size_t sz) { - dVAR; OPSLAB *slab; OPSLAB *slab2; OPSLOT *slot; @@ -195,7 +194,10 @@ Perl_Slab_Alloc(pTHX_ size_t sz) don't use a slab, but allocate the OP directly from the heap. */ if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) - return PerlMemShared_calloc(1, sz); + { + o = (OP*)PerlMemShared_calloc(1, sz); + goto gotit; + } /* While the subroutine is under construction, the slabs are accessed via CvSTART(), to avoid needing to expand PVCV by one pointer for something @@ -230,7 +232,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) *too = o->op_next; Zero(o, opsz, I32 *); o->op_slabbed = 1; - return (void *)o; + goto gotit; } } @@ -276,6 +278,12 @@ Perl_Slab_Alloc(pTHX_ size_t sz) slot = &slab2->opslab_slots; INIT_OPSLOT; DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); + + gotit: + /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */ + o->op_lastsib = 1; + assert(!o->op_sibling); + return (void *)o; } @@ -333,7 +341,6 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) void Perl_Slab_Free(pTHX_ void *op) { - dVAR; OP * const o = (OP *)op; OPSLAB *slab; @@ -358,7 +365,6 @@ Perl_Slab_Free(pTHX_ void *op) void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) { - dVAR; const bool havepad = !!PL_comppad; PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { @@ -372,9 +378,9 @@ Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) void Perl_opslab_free(pTHX_ OPSLAB *slab) { - dVAR; OPSLAB *slab2; PERL_ARGS_ASSERT_OPSLAB_FREE; + PERL_UNUSED_CONTEXT; DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); assert(slab->opslab_refcnt == 1); for (; slab; slab = slab2) { @@ -490,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -512,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -537,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -559,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + 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)", @@ -582,7 +558,6 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { - dVAR; PADOFFSET off; const bool is_our = (PL_parser->in_my == KEY_our); @@ -706,7 +681,9 @@ optree. void Perl_op_free(pTHX_ OP *o) { +#ifdef USE_ITHREADS dVAR; +#endif OPCODE type; /* Though ops may be freed twice, freeing the op after its slab is a @@ -718,6 +695,11 @@ Perl_op_free(pTHX_ OP *o) return; type = o->op_type; + + /* an op should only ever acquire op_private flags that we know about. + * If this fails, you may need to fix something in regen/op_private */ + assert(!(o->op_private & ~PL_op_private_valid[type])); + if (o->op_private & OPpREFCOUNTED) { switch (type) { case OP_LEAVESUB: @@ -752,7 +734,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 = kid->op_sibling; /* Get before next freeing kid */ + nextkid = OP_SIBLING(kid); /* Get before next freeing kid */ op_free(kid); } } @@ -825,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - /* No GvIN_PAD_off(cGVOPo_gv) here, because other references - * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } @@ -893,8 +873,6 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - /* No GvIN_PAD_off here, because other references may still - * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else @@ -1002,7 +980,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) forget_pmop((PMOP*)kid); } find_and_forget_pmops(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); } } } @@ -1034,7 +1012,9 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } @@ -1042,11 +1022,221 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } + +/* +=for apidoc op_sibling_splice + +A general function for editing the structure of an existing chain of +op_sibling nodes. By analogy with the perl-level splice() function, allows +you to delete zero or more sequential nodes, replacing them with zero or +more different nodes. Performs the necessary op_first/op_last +housekeeping on the parent node and op_sibling manipulation on the +children. The last deleted node will be marked as as the last node by +updating the op_sibling or op_lastsib field as appropriate. + +Note that op_next is not manipulated, and nodes are not freed; that is the +responsibility of the caller. It also won't create a new list op for an +empty list etc; use higher-level functions like op_append_elem() for that. + +parent is the parent node of the sibling chain. + +start is the node preceding the first node to be spliced. Node(s) +following it will be deleted, and ops will be inserted after it. If it is +NULL, the first node onwards is deleted, and nodes are inserted at the +beginning. + +del_count is the number of nodes to delete. If zero, no nodes are deleted. +If -1 or greater than or equal to the number of remaining kids, all +remaining kids are deleted. + +insert is the first of a chain of nodes to be inserted in place of the nodes. +If NULL, no nodes are inserted. + +The head of the chain of deleted ops is returned, or NULL if no ops were +deleted. + +For example: + + action before after returns + ------ ----- ----- ------- + + P P + splice(P, A, 2, X-Y-Z) | | B-C + A-B-C-D A-X-Y-Z-D + + P P + splice(P, NULL, 1, X-Y) | | A + A-B-C-D X-Y-B-C-D + + P P + splice(P, NULL, 3, NULL) | | A-B-C + A-B-C-D D + + P P + splice(P, B, 0, X-Y) | | NULL + A-B-C-D A-B-X-Y-C-D + +=cut +*/ + +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 *rest; + OP *last_del = NULL; + OP *last_ins = NULL; + + PERL_ARGS_ASSERT_OP_SIBLING_SPLICE; + + assert(del_count >= -1); + + 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); + last_del->op_lastsib = 1; + } + else + rest = first; + + if (insert) { + last_ins = insert; + while (OP_HAS_SIBLING(last_ins)) + last_ins = OP_SIBLING(last_ins); + OP_SIBLING_set(last_ins, rest); + last_ins->op_lastsib = rest ? 0 : 1; + } + else + insert = rest; + + if (start) { + OP_SIBLING_set(start, insert); + start->op_lastsib = insert ? 0 : 1; + } + else + cLISTOPx(parent)->op_first = insert; + + if (!rest) { + /* update op_last etc */ + U32 type = parent->op_type; + OP *lastop; + + if (type == OP_NULL) + type = parent->op_targ; + type = PL_opargs[type] & OA_CLASS_MASK; + + lastop = last_ins ? last_ins : start ? start : NULL; + if ( type == OA_BINOP + || type == OA_LISTOP + || type == OA_PMOP + || type == OA_LOOP + ) + cLISTOPx(parent)->op_last = lastop; + + if (lastop) { + lastop->op_lastsib = 1; +#ifdef PERL_OP_PARENT + lastop->op_sibling = parent; +#endif + } + } + return last_del ? first : NULL; +} + +/* +=for apidoc op_parent + +returns the parent OP of o, if it has a parent. Returns NULL otherwise. +(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to +work. + +=cut +*/ + +OP * +Perl_op_parent(OP *o) +{ + PERL_ARGS_ASSERT_OP_PARENT; +#ifdef PERL_OP_PARENT + while (OP_HAS_SIBLING(o)) + o = OP_SIBLING(o); + return o->op_sibling; +#else + PERL_UNUSED_ARG(o); + return NULL; +#endif +} + + +/* replace the sibling following start with a new UNOP, which becomes + * the parent of the original sibling; e.g. + * + * op_sibling_newUNOP(P, A, unop-args...) + * + * P P + * | becomes | + * A-B-C A-U-C + * | + * B + * + * where U is the new UNOP. + * + * parent and start args are the same as for op_sibling_splice(); + * type and flags args are as newUNOP(). + * + * Returns the new UNOP. + */ + +OP * +S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) +{ + OP *kid, *newop; + + kid = op_sibling_splice(parent, start, 1, NULL); + newop = newUNOP(type, flags, kid); + op_sibling_splice(parent, start, 0, newop); + return newop; +} + + +/* lowest-level newLOGOP-style function - just allocates and populates + * the struct. Higher-level stuff should be done by S_new_logop() / + * newLOGOP(). This function exists mainly to avoid op_first assignment + * being spread throughout this file. + */ + +LOGOP * +S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) +{ + LOGOP *logop; + OP *kid = first; + NewOp(1101, logop, 1, LOGOP); + logop->op_type = (OPCODE)type; + logop->op_first = first; + logop->op_other = other; + logop->op_flags = OPf_KIDS; + while (kid && OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); + if (kid) { + kid->op_lastsib = 1; +#ifdef PERL_OP_PARENT + kid->op_sibling = (OP*)logop; +#endif + } + return logop; +} + + /* Contextualizers */ /* @@ -1100,9 +1290,10 @@ Perl_op_linklist(pTHX_ OP *o) o->op_next = LINKLIST(first); kid = first; for (;;) { - if (kid->op_sibling) { - kid->op_next = LINKLIST(kid->op_sibling); - kid = kid->op_sibling; + OP *sibl = OP_SIBLING(kid); + if (sibl) { + kid->op_next = LINKLIST(sibl); + kid = sibl; } else { kid->op_next = o; break; @@ -1120,7 +1311,7 @@ S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } return o; @@ -1129,8 +1320,6 @@ S_scalarkids(pTHX_ OP *o) STATIC OP * S_scalarboolean(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_SCALARBOOLEAN; if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST @@ -1207,7 +1396,7 @@ S_scalar_slice_warning(pTHX_ const OP *o) return; kid = cLISTOPo->op_first; - kid = kid->op_sibling; /* get past pushmark */ + kid = OP_SIBLING(kid); /* get past pushmark */ /* weed out false positives: any ops that can return lists */ switch (kid->op_type) { case OP_BACKTICK: @@ -1242,8 +1431,8 @@ S_scalar_slice_warning(pTHX_ const OP *o) if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) return; - assert(kid->op_sibling); - name = S_op_varname(aTHX_ kid->op_sibling); + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ return; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1268,7 +1457,6 @@ S_scalar_slice_warning(pTHX_ const OP *o) OP * Perl_scalar(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1288,7 +1476,7 @@ Perl_scalar(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalar(kid); break; /* FALLTHROUGH */ @@ -1299,7 +1487,7 @@ Perl_scalar(pTHX_ OP *o) case OP_NULL: default: if (o->op_flags & OPf_KIDS) { - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } break; @@ -1307,10 +1495,10 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1344,9 +1532,9 @@ Perl_scalar(pTHX_ OP *o) if (!ckWARN(WARN_SYNTAX)) break; kid = cLISTOPo->op_first; - kid = kid->op_sibling; /* get past pushmark */ - assert(kid->op_sibling); - name = S_op_varname(aTHX_ kid->op_sibling); + kid = OP_SIBLING(kid); /* get past pushmark */ + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ break; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1532,7 +1720,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_RV2AV: case OP_RV2HV: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && - (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) + (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE)) useless = "a variable"; break; @@ -1542,6 +1730,7 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { + NV nv; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1549,7 +1738,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ - else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) + else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0)) useless = NULL; else if (SvPOK(sv)) { SV * const dsv = newSVpvs(""); @@ -1659,7 +1848,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_COND_EXPR: case OP_ENTERGIVEN: case OP_ENTERWHEN: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; @@ -1682,7 +1871,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_LIST: case OP_LEAVEGIVEN: case OP_LEAVEWHEN: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; case OP_ENTEREVAL: @@ -1711,7 +1900,7 @@ S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) list(kid); } return o; @@ -1720,7 +1909,6 @@ S_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1747,7 +1935,7 @@ Perl_list(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) list(kid); break; default: @@ -1768,10 +1956,10 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1791,7 +1979,6 @@ Perl_list(pTHX_ OP *o) static OP * S_scalarseq(pTHX_ OP *o) { - dVAR; if (o) { const OPCODE type = o->op_type; @@ -1799,8 +1986,8 @@ S_scalarseq(pTHX_ OP *o) type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) { + if (OP_HAS_SIBLING(kid)) { scalarvoid(kid); } } @@ -1820,7 +2007,7 @@ S_modkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); } return o; @@ -1861,23 +2048,24 @@ S_finalize_op(pTHX_ OP* o) PL_curcop = ((COP*)o); /* for warnings */ break; case OP_EXEC: - if ( o->op_sibling - && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE) - && ckWARN(WARN_EXEC)) - { - if (o->op_sibling->op_sibling) { - const OPCODE type = o->op_sibling->op_sibling->op_type; + if (OP_HAS_SIBLING(o)) { + OP *sib = OP_SIBLING(o); + if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) + && ckWARN(WARN_EXEC) + && OP_HAS_SIBLING(sib)) + { + const OPCODE type = OP_SIBLING(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*)o->op_sibling)); + CopLINE_set(PL_curcop, CopLINE((COP*)sib)); Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } - } } + } break; case OP_GV: @@ -1936,7 +2124,7 @@ S_finalize_op(pTHX_ OP* o) /* FALLTHROUGH */ case OP_KVHSLICE: - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(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)) @@ -1946,7 +2134,7 @@ S_finalize_op(pTHX_ OP* o) key_op = (SVOP*)(kid->op_type == OP_CONST ? kid - : kLISTOP->op_first->op_sibling); + : OP_SIBLING(kLISTOP->op_first)); rop = (UNOP*)((LISTOP*)o)->op_last; @@ -1977,7 +2165,7 @@ S_finalize_op(pTHX_ OP* o) && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE)) && isGV(*fields) && GvHV(*fields); for (; key_op; - key_op = (SVOP*)key_op->op_sibling) { + key_op = (SVOP*)OP_SIBLING(key_op)) { SV **svp, *sv; if (key_op->op_type != OP_CONST) continue; @@ -2019,7 +2207,71 @@ S_finalize_op(pTHX_ OP* o) if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + +#ifdef DEBUGGING + /* check that op_last points to the last sibling, and that + * the last op_sibling field points back to the parent, and + * that the only ops with KIDS are those which are entitled to + * them */ + U32 type = o->op_type; + U32 family; + bool has_last; + + if (type == OP_NULL) { + type = o->op_targ; + /* ck_glob creates a null UNOP with ex-type GLOB + * (which is a list op. So pretend it wasn't a listop */ + if (type == OP_GLOB) + type = OP_NULL; + } + family = PL_opargs[type] & OA_CLASS_MASK; + + has_last = ( family == OA_BINOP + || family == OA_LISTOP + || family == OA_PMOP + || family == OA_LOOP + ); + assert( has_last /* has op_first and op_last, or ... + ... has (or may have) op_first: */ + || family == OA_UNOP + || family == OA_LOGOP + || family == OA_BASEOP_OR_UNOP + || family == OA_FILESTATOP + || family == OA_LOOPEXOP + /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ + || type == OP_SASSIGN + || 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)) { +# ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(kid)) { + if (has_last) + assert(kid == cLISTOPo->op_last); + assert(kid->op_sibling == o); + } +# else + if (OP_HAS_SIBLING(kid)) { + assert(!kid->op_lastsib); + } + else { + assert(kid->op_lastsib); + if (has_last) + assert(kid == cLISTOPo->op_last); + } +# endif + } +#endif + + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) finalize_op(kid); } } @@ -2091,9 +2343,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ - /* Both ENTERSUB and RV2CV use this bit, but for different pur- - poses, so we need it clear. */ - o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ @@ -2111,6 +2360,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; + GV *gv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -2120,8 +2370,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 (kid->op_sibling) - kid = kid->op_sibling; + while (OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { break; /* Postpone until runtime */ } @@ -2138,7 +2388,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } - cv = GvCV(kGVOP_gv); + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; if (!cv) break; if (CvLVALUE(cv)) @@ -2189,7 +2444,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COND_EXPR: localize = 1; - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); break; @@ -2289,7 +2544,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(cBINOPo->op_first->op_sibling, type); + op_lvalue(OP_SIBLING(cBINOPo->op_first), type); break; case OP_AELEM: @@ -2329,7 +2584,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 = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(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 ) @@ -2350,8 +2605,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(cLOGOPo->op_first->op_sibling->op_type)) - op_lvalue(cLOGOPo->op_first->op_sibling, type); + || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type)) + op_lvalue(OP_SIBLING(cLOGOPo->op_first), type); goto nomod; } @@ -2467,7 +2722,7 @@ S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) ref(kid, type); } return o; @@ -2493,7 +2748,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; - o->op_private &= ~1; } else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -2505,7 +2759,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) break; case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) doref(kid, type, set_op_ref); break; case OP_RV2SV: @@ -2576,7 +2830,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) STATIC OP * S_dup_attrlist(pTHX_ OP *o) { - dVAR; OP *rop; PERL_ARGS_ASSERT_DUP_ATTRLIST; @@ -2590,7 +2843,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=o->op_sibling) { + for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) rop = op_append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, @@ -2603,7 +2856,6 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - dVAR; SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; PERL_ARGS_ASSERT_APPLY_ATTRS; @@ -2627,7 +2879,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { - dVAR; OP *pack, *imop, *arg; SV *meth, *stashsv, **svp; @@ -2750,11 +3001,11 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) *attrs = NULL; } } else if (o->op_type == OP_LIST) { - OP * lasto = NULL; + OP * lasto; assert(o->op_flags & OPf_KIDS); - assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); - /* Counting on the first op to hit the lasto = o line */ - for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + lasto = cLISTOPo->op_first; + assert(lasto->op_type == OP_PUSHMARK); + for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) { pv = SvPV(cSVOPo_sv, pvlen); if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { @@ -2773,7 +3024,9 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) else if (new_proto) op_free(new_proto); new_proto = o; - lasto->op_sibling = o->op_sibling; + /* excise new_proto from the list */ + op_sibling_splice(*attrs, lasto, 1, NULL); + o = lasto; continue; } } @@ -2781,7 +3034,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 (!cLISTOPx(*attrs)->op_first->op_sibling) { + if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) { op_free(*attrs); *attrs = NULL; } @@ -2836,7 +3089,6 @@ S_cant_declare(pTHX_ OP *o) STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { - dVAR; I32 type; const bool stately = PL_parser && PL_parser->in_my == KEY_state; @@ -2849,7 +3101,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) if (type == OP_LIST) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) my_kid(kid, attrs, imopsp); return o; } else if (type == OP_UNDEF || type == OP_STUB) { @@ -2904,7 +3156,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { - dVAR; OP *rops; int maybe_scalar = 0; @@ -2937,7 +3188,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) { OP * const pushmark = lrops->op_first; - lrops->op_first = pushmark->op_sibling; + /* excise pushmark */ + op_sibling_splice(rops, NULL, 1, NULL); op_free(pushmark); } o = op_append_list(OP_LIST, o, rops); @@ -3082,7 +3334,7 @@ Perl_op_scope(pTHX_ OP *o) op_null(kid); /* The following deals with things like 'do {1 for 1}' */ - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) op_null(kid); @@ -3099,7 +3351,7 @@ Perl_op_unscope(pTHX_ OP *o) { if (o && o->op_type == OP_LINESEQ) { OP *kid = cLISTOPo->op_first; - for(; kid; kid = kid->op_sibling) + for(; kid; kid = OP_SIBLING(kid)) if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) op_null(kid); } @@ -3109,7 +3361,6 @@ Perl_op_unscope(pTHX_ OP *o) int Perl_block_start(pTHX_ int full) { - dVAR; const int retval = PL_savestack_ix; pad_block_start(full); @@ -3126,7 +3377,6 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); OP *o; @@ -3188,7 +3438,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 = kid->op_sibling) { + for (;; kid = OP_SIBLING(kid)) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); @@ -3224,7 +3474,6 @@ Perl_blockhook_register(pTHX_ BHK *hk) STATIC OP * S_newDEFSVOP(pTHX) { - dVAR; const PADOFFSET offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); @@ -3239,8 +3488,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { @@ -3337,8 +3584,6 @@ Perl_newPROG(pTHX_ OP *o) OP * Perl_localize(pTHX_ OP *o, I32 lex) { - dVAR; - PERL_ARGS_ASSERT_LOCALIZE; if (o->op_flags & OPf_PARENS) @@ -3459,6 +3704,7 @@ S_fold_constants(pTHX_ OP *o) SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; + U8 oldwarn = PL_dowarn; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -3495,16 +3741,16 @@ S_fold_constants(pTHX_ OP *o) #endif break; case OP_PACK: - if (!cLISTOPo->op_first->op_sibling - || cLISTOPo->op_first->op_sibling->op_type != OP_CONST) + if (!OP_HAS_SIBLING(cLISTOPo->op_first) + || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST) goto nope; { - SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling); + SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first)); if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; { const char *s = SvPVX_const(sv); while (s < SvEND(sv)) { - if (*s == 'p' || *s == 'P') goto nope; + if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; s++; } } @@ -3553,6 +3799,10 @@ S_fold_constants(pTHX_ OP *o) PL_diehook = NULL; JMPENV_PUSH(ret); + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + switch (ret) { case 0: CALLRUNOPS(aTHX); @@ -3582,6 +3832,7 @@ S_fold_constants(pTHX_ OP *o) Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } JMPENV_POP; + PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; PL_curcop = &PL_compiling; @@ -3643,34 +3894,41 @@ S_gen_constant_list(pTHX_ OP *o) o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in rpeep() */ - curop = ((UNOP*)o)->op_first; av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); + + /* replace subtree with an OP_CONST */ + curop = ((UNOP*)o)->op_first; + op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av)); + op_free(curop); + if (AvFILLp(av) != -1) for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) { SvPADTMP_on(*svp); SvREADONLY_on(*svp); } - op_free(curop); LINKLIST(o); return list(o); } +/* convert o (and any siblings) into a list if not already, then + * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it + */ + OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { dVAR; if (type < 0) type = -type, flags |= OPf_SPECIAL; if (!o || o->op_type != OP_LIST) - o = newLISTOP(OP_LIST, 0, o, NULL); + o = force_list(o, 0); else o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); else { - OP * const kid2 = cLISTOPo->op_first->op_sibling; + OP * const kid2 = OP_SIBLING(cLISTOPo->op_first); if (kid2 && kid2->op_type == OP_COREARGS) { op_null(cLISTOPo->op_first); kid2->op_private |= OPpCOREARGS_PUSHMARK; @@ -3722,13 +3980,8 @@ Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) return newLISTOP(type, 0, first, last); } - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; + op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); + first->op_flags |= OPf_KIDS; return first; } @@ -3760,8 +4013,13 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) if (last->op_type != (unsigned)type) return op_append_elem(type, first, last); - ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first; + ((LISTOP*)first)->op_last->op_lastsib = 0; + OP_SIBLING_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 + ((LISTOP*)first)->op_last->op_sibling = first; +#endif first->op_flags |= (last->op_flags & OPf_KIDS); @@ -3794,19 +4052,13 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (last->op_type == (unsigned)type) { if (type == OP_LIST) { /* already a PUSHMARK there */ - first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; - ((LISTOP*)last)->op_first->op_sibling = first; + /* insert 'first' after pushmark */ + op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first); if (!(first->op_flags & OPf_PARENS)) last->op_flags &= ~OPf_PARENS; } - else { - if (!(last->op_flags & OPf_KIDS)) { - ((LISTOP*)last)->op_last = first; - last->op_flags |= OPf_KIDS; - } - first->op_sibling = ((LISTOP*)last)->op_first; - ((LISTOP*)last)->op_first = first; - } + else + op_sibling_splice(last, NULL, 0, first); last->op_flags |= OPf_KIDS; return last; } @@ -3834,12 +4086,36 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } +/* promote o and any siblings to be a list if its not already; i.e. + * + * o - A - B + * + * becomes + * + * list + * | + * pushmark - o - A - B + * + * If nullit it true, the list op is nulled. + */ + static OP * -S_force_list(pTHX_ OP *o) -{ - if (!o || o->op_type != OP_LIST) +S_force_list(pTHX_ OP *o, bool nullit) +{ + if (!o || o->op_type != OP_LIST) { + OP *rest = NULL; + if (o) { + /* manually detach any siblings then add them back later */ + rest = OP_SIBLING(o); + OP_SIBLING_set(o, NULL); + o->op_lastsib = 1; + } o = newLISTOP(OP_LIST, 0, o, NULL); - op_null(o); + if (rest) + op_sibling_splice(o, cLISTOPo->op_last, 0, rest); + } + if (nullit) + op_null(o); return o; } @@ -3876,17 +4152,26 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - first->op_sibling = last; + OP_SIBLING_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); - pushop->op_sibling = first; + pushop->op_lastsib = 0; + OP_SIBLING_set(pushop, first); listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) listop->op_last = pushop; } + if (first) + first->op_lastsib = 0; + if (listop->op_last) { + listop->op_last->op_lastsib = 1; +#ifdef PERL_OP_PARENT + listop->op_last->op_sibling = (OP*)listop; +#endif + } return CHECKOP(type, listop); } @@ -3968,7 +4253,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) - first = force_list(first); + first = force_list(first, 1); NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)type; @@ -3976,6 +4261,12 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); + +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */ + first->op_sibling = (OP*)unop; +#endif + unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -4021,14 +4312,24 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - first->op_sibling = last; + OP_SIBLING_set(first, last); + first->op_lastsib = 0; } +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */ + last->op_sibling = (OP*)binop; +#endif + binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; - binop->op_last = binop->op_first->op_sibling; + binop->op_last = OP_SIBLING(binop->op_first); +#ifdef PERL_OP_PARENT + if (binop->op_last) + binop->op_last->op_sibling = (OP*)binop; +#endif return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -4053,7 +4354,6 @@ static int uvcompare(const void *a, const void *b) static OP * S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { - dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; SV * const rstr = ((SVOP*)repl)->op_sv; @@ -4489,25 +4789,27 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; - while (kid->op_sibling != repl) - kid = kid->op_sibling; - kid->op_sibling = NULL; - cLISTOPx(expr)->op_last = kid; + 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* const oe = expr; - assert(expr->op_type == OP_LIST); - assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); - assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); - expr = cLISTOPx(oe)->op_last; - cLISTOPx(oe)->op_first->op_sibling = NULL; - cLISTOPx(oe)->op_last = NULL; - op_free(oe); + 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, expr, repl); + return pmtrans(o, last, repl); } /* find whether we have any runtime or code elements; @@ -4520,11 +4822,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 = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { has_code = 1; - assert(!o->op_next && o->op_sibling); - o->op_next = o->op_sibling; + assert(!o->op_next && OP_HAS_SIBLING(o)); + o->op_next = OP_SIBLING(o); } else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) is_compiletime = 0; @@ -4540,7 +4842,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 = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { assert( !(o->op_flags & OPf_WANT)); @@ -4559,8 +4861,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(leaveop->op_first->op_sibling); - o->op_next = leaveop->op_first->op_sibling; + assert(OP_HAS_SIBLING(leaveop->op_first)); + o->op_next = OP_SIBLING(leaveop->op_first); /* skip leave */ assert(leaveop->op_flags & OPf_KIDS); assert(leaveop->op_last->op_next == (OP*)leaveop); @@ -4727,18 +5029,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) cv_targ = expr->op_targ; expr = newUNOP(OP_REFGEN, 0, expr); - expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); } - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_REGCOMP; + rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o); rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; - rcop->op_first = scalar(expr); - rcop->op_flags |= OPf_KIDS - | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) - | (reglist ? OPf_STACKED : 0); - rcop->op_private = 0; - rcop->op_other = o; + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); rcop->op_targ = cv_targ; /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ @@ -4764,12 +5061,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* If we are looking at s//.../e with a single statement, get past the implicit do{}. */ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS - && cUNOPx(curop)->op_first->op_type == OP_SCOPE - && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { + && cUNOPx(curop)->op_first->op_type == OP_SCOPE + && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) + { + OP *sib; OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; - if (kid->op_type == OP_NULL && kid->op_sibling - && !kid->op_sibling->op_sibling) - curop = kid->op_sibling; + if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid)) + && !OP_HAS_SIBLING(sib)) + curop = sib; } if (curop->op_type == OP_CONST) konst = TRUE; @@ -4797,13 +5096,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) op_prepend_elem(o->op_type, scalar(repl), o); } else { - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_SUBSTCONT; + rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o); rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; - rcop->op_first = scalar(repl); - rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); @@ -4887,7 +5182,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; - padop->op_padix = pad_alloc(type, SVs_PADTMP); + padop->op_padix = + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); @@ -4917,12 +5213,9 @@ reference to it. OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dVAR; - PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS - GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); @@ -4971,7 +5264,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dVAR; SV *const sv = cSVOPo->op_sv; PERL_ARGS_ASSERT_PACKAGE; @@ -4985,7 +5277,6 @@ Perl_package(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; op_free(o); } @@ -4993,7 +5284,6 @@ Perl_package(pTHX_ OP *o) void Perl_package_version( pTHX_ OP *v ) { - dVAR; U32 savehints = PL_hints; PERL_ARGS_ASSERT_PACKAGE_VERSION; PL_hints &= ~HINT_STRICT_VARS; @@ -5005,7 +5295,6 @@ Perl_package_version( pTHX_ OP *v ) void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { - dVAR; OP *pack; OP *imop; OP *veop; @@ -5126,7 +5415,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; @@ -5184,7 +5472,6 @@ Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { - dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); @@ -5239,7 +5526,6 @@ S_new_entersubop(pTHX_ GV *gv, OP *arg) OP * Perl_dofile(pTHX_ OP *term, I32 force_builtin) { - dVAR; OP *doop; GV *gv; @@ -5274,8 +5560,8 @@ OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, - list(force_list(subscript)), - list(force_list(listval)) ); + list(force_list(subscript, 1)), + list(force_list(listval, 1)) ); } STATIC I32 @@ -5293,8 +5579,9 @@ S_is_list_assignment(pTHX_ const OP *o) flags = o->op_flags; type = o->op_type; if (type == OP_COND_EXPR) { - const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); - const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + OP * const sib = OP_SIBLING(cLOGOPo->op_first); + const I32 t = is_list_assignment(sib); + const I32 f = is_list_assignment(OP_SIBLING(sib)); if (t && f) return TRUE; @@ -5332,7 +5619,7 @@ PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o) { OP *curop; - for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) { + for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); @@ -5415,7 +5702,6 @@ set as required. OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { - dVAR; OP *o; if (optype) { @@ -5441,8 +5727,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_modcount = 0; left = op_lvalue(left, OP_AASSIGN); - curop = list(force_list(left)); - o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); + curop = list(force_list(left, 1)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); o->op_private = (U8)(0 | (flags >> 8)); if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) @@ -5478,7 +5764,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) /* Other ops in the list. */ maybe_common_vars = TRUE; } - lop = lop->op_sibling; + lop = OP_SIBLING(lop); } } else if ((left->op_private & OPpLVAL_INTRO) @@ -5551,7 +5837,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) #endif tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - tmpop->op_sibling = NULL; /* don't free split */ + /* detach rest of siblings from o subtree, + * and free subtree */ + op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); right->op_next = tmpop->op_next; /* fix starting loc */ op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; @@ -5710,8 +5998,6 @@ consumed by this function and become part of the constructed op tree. OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { - dVAR; - PERL_ARGS_ASSERT_NEWLOGOP; return new_logop(type, flags, &first, &other); @@ -5742,7 +6028,7 @@ S_search_const(pTHX_ OP *o) case OP_ENTER: case OP_NULL: case OP_NEXTSTATE: - kid = kid->op_sibling; + kid = OP_SIBLING(kid); break; default: if (kid != cLISTOPo->op_last) @@ -5869,7 +6155,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 = o2->op_sibling)) ) + && (( o2 = OP_SIBLING(o2))) ) ) o2 = other; if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV @@ -5892,7 +6178,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 = k1->op_sibling; + const OP * const k2 = OP_SIBLING(k1); OPCODE warnop = 0; switch (first->op_type) { @@ -5937,19 +6223,16 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - NewOp(1101, logop, 1, LOGOP); - - logop->op_type = (OPCODE)type; + logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other)); logop->op_ppaddr = PL_ppaddr[type]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); - logop->op_other = LINKLIST(other); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = other; + assert(!OP_HAS_SIBLING(first)); + op_sibling_splice((OP*)logop, first, 0, other); CHECKOP(type,logop); @@ -6010,13 +6293,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) live->op_folded = 1; return live; } - NewOp(1101, logop, 1, LOGOP); - logop->op_type = OP_COND_EXPR; + logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); - logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ @@ -6026,8 +6306,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) start = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = trueop; - trueop->op_sibling = falseop; + /* make first, trueop, falseop siblings */ + op_sibling_splice((OP*)logop, first, 0, trueop); + op_sibling_splice((OP*)logop, trueop, 0, falseop); + o = newUNOP(OP_NULL, 0, (OP*)logop); trueop->op_next = falseop->op_next = o; @@ -6062,17 +6344,14 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) PERL_ARGS_ASSERT_NEWRANGE; - NewOp(1101, range, 1, LOGOP); - - range->op_type = OP_RANGE; + range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right)); 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 = (U8)(1 | (flags >> 8)); - left->op_sibling = right; + /* make left and right siblings */ + op_sibling_splice((OP*)range, left, 0, right); range->op_next = (OP*)range; flip = newUNOP(OP_FLIP, flags, (OP*)range); @@ -6084,10 +6363,11 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) left->op_next = flip; right->op_next = flop; - range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); - flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);; sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); + SvPADTMP_on(PAD_SV(flip->op_targ)); flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; @@ -6124,7 +6404,6 @@ unused and should always be 1. OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dVAR; OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && @@ -6152,7 +6431,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 ? k1->op_sibling : NULL; + const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6250,7 +6529,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) ? k1->op_sibling : NULL; + const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6409,8 +6688,9 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } iterpflags |= OPpITER_DEF; } + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { - expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); iterflags |= OPf_STACKED; } else if (expr->op_type == OP_NULL && @@ -6424,11 +6704,12 @@ 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 = left->op_sibling; + OP* const right = OP_SIBLING(left); LISTOP* listop; range->op_flags &= ~OPf_KIDS; - range->op_first = NULL; + /* detach range's children */ + op_sibling_splice((OP*)range, NULL, -1, NULL); listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); listop->op_first->op_next = range->op_next; @@ -6442,7 +6723,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) iterflags |= OPf_STACKED; } else { - expr = op_lvalue(force_list(expr), OP_GREPSTART); + expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); } loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, @@ -6458,6 +6739,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); +#ifdef PERL_OP_PARENT + assert(loop->op_last->op_sibling == (OP*)loop); + loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */ +#endif S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } @@ -6482,7 +6767,6 @@ becomes part of the constructed op tree. OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dVAR; OP *o = NULL; PERL_ARGS_ASSERT_NEWLOOPEX; @@ -6577,25 +6861,22 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, PERL_ARGS_ASSERT_NEWGIVWHENOP; - NewOp(1101, enterop, 1, LOGOP); - enterop->op_type = (Optype)enter_opcode; + enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); enterop->op_ppaddr = PL_ppaddr[enter_opcode]; - enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); if (cond) { - enterop->op_first = scalar(cond); - cond->op_sibling = block; + /* prepend cond if we have one */ + op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); o->op_next = LINKLIST(cond); cond->op_next = (OP *) enterop; } else { /* This is a default {} block */ - enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; o ->op_flags |= OPf_SPECIAL; @@ -6626,8 +6907,6 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, STATIC bool S_looks_like_bool(pTHX_ const OP *o) { - dVAR; - PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { @@ -6636,9 +6915,13 @@ S_looks_like_bool(pTHX_ const OP *o) return looks_like_bool(cLOGOPo->op_first); case OP_AND: + { + OP* sibl = OP_SIBLING(cLOGOPo->op_first); + ASSUME(sibl); return ( looks_like_bool(cLOGOPo->op_first) - && looks_like_bool(cLOGOPo->op_first->op_sibling)); + && looks_like_bool(sibl)); + } case OP_NULL: case OP_SCALAR: @@ -6708,7 +6991,6 @@ be affected. If it is 0, the global $_ will be used. OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { - dVAR; PERL_ARGS_ASSERT_NEWGIVENOP; return newGIVWHENOP( ref_array_or_hash(cond), @@ -6749,12 +7031,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* must not conflict with SVf_UTF8 */ +#define CV_CKPROTO_CURSTASH 0x1 + void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { SV *name = NULL, *msg; - const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + const char * cvp = SvROK(cv) + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; @@ -6791,6 +7080,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, gv_efullname3(name = sv_newmortal(), gv, NULL); else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); @@ -6828,10 +7127,9 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ const CV *const cv) +Perl_cv_const_sv(const CV *const cv) { SV *sv; - PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) @@ -6842,11 +7140,11 @@ Perl_cv_const_sv(pTHX_ const CV *const cv) } SV * -Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) +Perl_cv_const_sv_or_av(const CV * const cv) { - PERL_UNUSED_CONTEXT; if (!cv) return NULL; + if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } @@ -6875,14 +7173,13 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) SV * Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { - dVAR; SV *sv = NULL; if (!o) return NULL; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) - o = cLISTOPo->op_first->op_sibling; + o = OP_SIBLING(cLISTOPo->op_first); for (; o; o = o->op_next) { const OPCODE type = o->op_type; @@ -6903,6 +7200,10 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) @@ -6983,7 +7284,6 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dVAR; CV **spot; SV **svspot; const char *ps; @@ -7058,12 +7358,16 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvNAMED(*spot)) hek = CvNAME_HEK(*spot); else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); CvNAME_HEK_set(*spot, hek = share_hek( PadnamePV(name)+1, - PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0 + PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash ) ); + CvLEXICAL_on(*spot); } if (mg) { assert(mg->mg_obj); @@ -7110,7 +7414,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7190,14 +7494,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) *spot = cv; } setname: + CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - CvNAME_HEK_set(cv, - hek - ? share_hek_hek(hek) - : share_hek(PadnamePV(name)+1, + if (hek) (void)share_hek_hek(hek); + else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), - 0) - ); + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) goto clone; @@ -7298,7 +7606,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else *spot = cv_clone(clonee); SvREFCNT_dec_NN(clonee); cv = *spot; - SvPADMY_on(cv); } if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { PADOFFSET depth = CvDEPTH(outcv); @@ -7324,7 +7631,6 @@ CV * Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, bool o_is_gv) { - dVAR; GV *gv; const char *ps; STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ @@ -7335,7 +7641,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a - full GV and CV. If anything is present then it will take a full CV to + full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : @@ -7348,6 +7654,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; + bool special = FALSE; #endif if (o_is_gv) { @@ -7355,7 +7662,20 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, o = NULL; has_name = TRUE; } else if (name) { - gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : PL_curstash != CopSTASH(PL_curcop) + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7371,9 +7691,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); has_name = FALSE; } - if (!ec) - move_proto_attr(&proto, &attrs, gv); + move_proto_attr(&proto, &attrs, + isGV(gv) ? gv : (GV *)cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -7412,26 +7732,46 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, goto done; } - if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at - maximum a prototype before. */ + if (!block && SvTYPE(gv) != SVt_PVGV) { + /* If we are not defining a new sub and the existing one is not a + full GV + CV... */ + if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { + /* We are applying attributes to an existing sub, so we need it + upgraded if it is a constant. */ + if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_init_pvn(gv, PL_curstash, name, namlen, + SVf_UTF8 * name_is_utf8); + } + else { /* Maybe prototype now, and had at maximum + a prototype or const/sub ref before. */ if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8); } - if (ps) { + if (!SvROK(gv)) { + if (ps) { sv_setpvn(MUTABLE_SV(gv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); - } - else + } + else sv_setiv(MUTABLE_SV(gv), -1); + } SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; + } } - cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) @@ -7440,6 +7780,38 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else const_sv = op_const_sv(block, NULL); + if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { + assert (block); + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %"SVf" redefined", + SVfARG(cSVOPo->op_sv)); + + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } + } + if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7450,7 +7822,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ - if (exists || GvASSUMECV(gv)) { + if (exists || (isGV(gv) && GvASSUMECV(gv))) { if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { @@ -7463,7 +7835,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7474,11 +7846,22 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvISXSUB_on(cv); } else { - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); + if (isGV(gv)) { + if (name) GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } } op_free(block); SvREFCNT_dec(PL_compcv); @@ -7496,12 +7879,26 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); OP * const cvstart = CvSTART(cv); - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvPADLIST(cv) = CvPADLIST(PL_compcv); @@ -7533,16 +7930,35 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } else { cv = PL_compcv; - if (name) { + if (name && isGV(gv)) { GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ gv_method_changed(gv); } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + } } - if (!CvGV(cv)) { - CvGV_set(cv, gv); + if (!CvHASGV(cv)) { + if (isGV(gv)) CvGV_set(cv, gv); + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } @@ -7599,7 +8015,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { /* Need to do a C. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); if (!name) SvREFCNT_inc_simple_void_NN(cv); @@ -7607,7 +8025,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); + SV * const tmpstr = cv_name(cv,NULL,0); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -7615,7 +8033,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); @@ -7631,8 +8048,15 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } } - if (name && ! (PL_parser && PL_parser->error_count)) - process_special_blocks(floor, name, gv, cv); + if (name) { + if (PL_parser && PL_parser->error_count) + clear_special_blocks(name, gv, cv); + else +#ifdef PERL_DEBUG_READONLY_OPS + special = +#endif + process_special_blocks(floor, name, gv, cv); + } } done: @@ -7641,12 +8065,37 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS /* Watch out for BEGIN blocks */ - if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); + if (!special) Slab_to_ro(slab); #endif return cv; } STATIC void +S_clear_special_blocks(pTHX_ const char *const fullname, + GV *const gv, CV *const cv) { + const char *colon; + const char *name; + + PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS; + + colon = strrchr(fullname,':'); + name = colon ? colon + 1 : fullname; + + if ((*name == 'B' && strEQ(name, "BEGIN")) + || (*name == 'E' && strEQ(name, "END")) + || (*name == 'U' && strEQ(name, "UNITCHECK")) + || (*name == 'C' && strEQ(name, "CHECK")) + || (*name == 'I' && strEQ(name, "INIT"))) { + if (!isGV(gv)) { + (void)CvGV(cv); + assert(isGV(gv)); + } + GvCV_set(gv, NULL); + SvREFCNT_dec_NN(MUTABLE_SV(cv)); + } +} + +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) @@ -7660,6 +8109,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; dSP; + (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; PUSHSTACKi(PERLSI_REQUIRE); @@ -7674,23 +8124,24 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, POPSTACK; LEAVE; + return TRUE; } else - return; + return FALSE; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) @@ -7700,7 +8151,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) @@ -7710,11 +8161,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else - return; + return FALSE; DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ + return TRUE; } } @@ -7755,7 +8208,6 @@ CV * Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags, SV *sv) { - dVAR; CV* cv; const char *const file = CopFILE(PL_curcop); @@ -7935,7 +8387,6 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dVAR; CV *cv; GV *gv; @@ -8206,12 +8657,15 @@ Perl_ck_backtick(pTHX_ OP *o) { GV *gv; OP *newop = NULL; + 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 && cUNOPo->op_first->op_sibling - && (gv = gv_override("readpipe",8))) { - newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling); - cUNOPo->op_first->op_sibling = NULL; + if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first)) + && (gv = gv_override("readpipe",8))) + { + /* detach rest of siblings from o and its first child */ + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + newop = S_new_entersubop(aTHX_ gv, sibl); } else if (!(o->op_flags & OPf_KIDS)) newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); @@ -8226,8 +8680,6 @@ Perl_ck_backtick(pTHX_ OP *o) OP * Perl_ck_bitop(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_BITOP; o->op_private = (U8)(PL_hints & HINT_INTEGER); @@ -8237,7 +8689,7 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_XOR)) { const OP * const left = cBINOPo->op_first; - const OP * const right = left->op_sibling; + const OP * const right = OP_SIBLING(left); if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -8255,6 +8707,7 @@ PERL_STATIC_INLINE bool is_dollar_bracket(pTHX_ const OP * const o) { const OP *kid; + PERL_UNUSED_CONTEXT; return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS && (kid = cUNOPx(o)->op_first) && kid->op_type == OP_GV @@ -8267,14 +8720,16 @@ Perl_ck_cmp(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_CMP; if (ckWARN(WARN_SYNTAX)) { const OP *kid = cUNOPo->op_first; - if (kid && ( - ( - is_dollar_bracket(aTHX_ kid) - && kid->op_sibling && kid->op_sibling->op_type == OP_CONST + if (kid && + ( + ( is_dollar_bracket(aTHX_ kid) + && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST ) - || ( kid->op_type == OP_CONST - && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) - )) + || ( kid->op_type == OP_CONST + && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) + ) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); } @@ -8305,19 +8760,22 @@ Perl_ck_spair(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; + OP* kidkid; const OPCODE type = o->op_type; o = modkids(ck_fun(o), type); - kid = cUNOPo->op_first; - newop = kUNOP->op_first->op_sibling; + kid = cUNOPo->op_first; + kidkid = kUNOP->op_first; + newop = OP_SIBLING(kidkid); if (newop) { const OPCODE type = newop->op_type; - if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || + if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) || type == OP_PADAV || type == OP_PADHV || type == OP_RV2AV || type == OP_RV2HV) return o; } - op_free(kUNOP->op_first); - kUNOP->op_first = newop; + /* excise first sibling */ + op_sibling_splice(kid, NULL, 1, NULL); + op_free(kidkid); } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, * and OP_CHOMP into OP_SCHOMP */ @@ -8366,8 +8824,6 @@ Perl_ck_delete(pTHX_ OP *o) OP * Perl_ck_eof(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { @@ -8401,13 +8857,12 @@ Perl_ck_eval(pTHX_ OP *o) if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; - cUNOPo->op_first = 0; + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); op_free(o); - NewOp(1101, enter, 1, LOGOP); - enter->op_type = OP_ENTERTRY; + enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL); enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; - enter->op_private = 0; /* establish postfix order */ enter->op_next = (OP*)enter; @@ -8426,7 +8881,11 @@ Perl_ck_eval(pTHX_ OP *o) else { const U8 priv = o->op_private; op_free(o); - o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); + /* the newUNOP will recursively call ck_eval(), which will handle + * all the stuff at the end of this function, like adding + * OP_HINTSEVAL + */ + return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; @@ -8435,7 +8894,9 @@ Perl_ck_eval(pTHX_ OP *o) /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); - cUNOPo->op_first->op_sibling = hhop; + /* append hhop to only child */ + op_sibling_splice(o, cUNOPo->op_first, 0, hhop); + o->op_private |= OPpEVAL_HAS_HH; } if (!(o->op_private & OPpEVAL_BYTES) @@ -8452,7 +8913,7 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; o = ck_fun(o); - kid = cUNOPo->op_first->op_sibling; + kid = OP_SIBLING(cUNOPo->op_first); if (kid->op_type == OP_RV2GV) op_null(kid); } @@ -8464,8 +8925,6 @@ Perl_ck_exec(pTHX_ OP *o) OP * Perl_ck_exists(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EXISTS; o = ck_fun(o); @@ -8498,8 +8957,6 @@ Perl_ck_rvconst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RVCONST; o->op_private |= (PL_hints & HINT_STRICT_REFS); - if (o->op_type == OP_RV2CV) - o->op_private &= ~1; if (kid->op_type == OP_CONST) { int iscv; @@ -8507,31 +8964,7 @@ Perl_ck_rvconst(pTHX_ OP *o) SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ - if (SvROK(kidsv) && SvREADONLY(kidsv)) { - SV * const rsv = SvRV(kidsv); - const svtype type = SvTYPE(rsv); - const char *badtype = NULL; - - switch (o->op_type) { - case OP_RV2SV: - if (type > SVt_PVMG) - badtype = "a SCALAR"; - break; - case OP_RV2AV: - if (type != SVt_PVAV) - badtype = "an ARRAY"; - break; - case OP_RV2HV: - if (type != SVt_PVHV) - badtype = "a HASH"; - break; - case OP_RV2CV: - if (type != SVt_PVCV) - badtype = "a CODE"; - break; - } - if (badtype) - Perl_croak(aTHX_ "Constant is not %s reference", badtype); + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { return o; } if (SvTYPE(kidsv) == SVt_PVAV) return o; @@ -8564,10 +8997,12 @@ Perl_ck_rvconst(pTHX_ OP *o) * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - iscv = (o->op_type == OP_RV2CV) * 2; - do { - gv = gv_fetchsv(kidsv, - iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV @@ -8577,16 +9012,21 @@ Perl_ck_rvconst(pTHX_ OP *o) : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); - } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ assert (sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); @@ -8648,7 +9088,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dVAR; const int type = o->op_type; I32 oa = PL_opargs[type] >> OASHIFT; @@ -8662,17 +9101,16 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - OP **tokid = &cLISTOPo->op_first; + OP *prev_kid = NULL; OP *kid = cLISTOPo->op_first; - OP *sibl; I32 numargs = 0; bool seen_optional = FALSE; if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } if (kid && kid->op_type == OP_COREARGS) { bool optional = FALSE; @@ -8687,14 +9125,16 @@ Perl_ck_fun(pTHX_ OP *o) while (oa) { if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { - if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) - *tokid = kid = newDEFSVOP(); + if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { + kid = newDEFSVOP(); + /* append kid to chain */ + op_sibling_splice(o, prev_kid, 0, kid); + } seen_optional = TRUE; } if (!kid) break; numargs++; - sibl = kid->op_sibling; switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ @@ -8715,7 +9155,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !kid->op_sibling) + && !OP_HAS_SIBLING(kid)) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); @@ -8744,12 +9184,11 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_CVREF: { - OP * const newop = newUNOP(OP_NULL, 0, kid); - kid->op_sibling = 0; + /* replace kid with newop in chain */ + OP * const newop = + S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); newop->op_next = newop; kid = newop; - kid->op_sibling = sibl; - *tokid = kid; } break; case OA_FILEREF: @@ -8759,9 +9198,8 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); - if (!(o->op_private & 1) && /* if not unop */ - kid == cLISTOPo->op_last) - cLISTOPo->op_last = newop; + /* replace kid with newop in chain */ + op_sibling_splice(o, prev_kid, 1, newop); op_free(kid); kid = newop; } @@ -8862,13 +9300,12 @@ Perl_ck_fun(pTHX_ OP *o) if ( name_utf8 ) SvUTF8_on(namesv); } } - kid->op_sibling = 0; - kid = newUNOP(OP_RV2GV, flags, scalar(kid)); - kid->op_targ = targ; - kid->op_private |= priv; + scalar(kid); + kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, + OP_RV2GV, flags); + kid->op_targ = targ; + kid->op_private |= priv; } - kid->op_sibling = sibl; - *tokid = kid; } scalar(kid); break; @@ -8881,8 +9318,8 @@ Perl_ck_fun(pTHX_ OP *o) break; } oa >>= 4; - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } /* FIXME - should the numargs or-ing move after the too many * arguments check? */ @@ -8909,13 +9346,12 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { - dVAR; GV *gv; PERL_ARGS_ASSERT_CK_GLOB; o = ck_fun(o); - if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first)) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) @@ -8972,12 +9408,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(cLISTOPo->op_first->op_sibling)->op_first; + kid = cUNOPx(OP_SIBLING(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 = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) list(kid); else @@ -8985,17 +9421,13 @@ Perl_ck_grep(pTHX_ OP *o) o = ck_fun(o); if (PL_parser && PL_parser->error_count) return o; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(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; - NewOp(1101, gwop, 1, LOGOP); - gwop->op_type = type; + gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); gwop->op_ppaddr = PL_ppaddr[type]; - gwop->op_first = o; - gwop->op_flags |= OPf_KIDS; - gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { @@ -9007,8 +9439,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_targ = o->op_targ = offset; } - kid = cLISTOPo->op_first->op_sibling; - for (kid = kid->op_sibling; kid; kid = kid->op_sibling) + kid = OP_SIBLING(cLISTOPo->op_first); + for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; @@ -9020,9 +9452,9 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid) - kid = kid->op_sibling; /* get past "big" */ + kid = OP_SIBLING(kid); /* get past "big" */ if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; SV *sv = kSVOP->op_sv; @@ -9061,7 +9493,6 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ switch (cUNOPo->op_first->op_type) { case OP_RV2AV: case OP_PADAV: - case OP_AASSIGN: /* Is this a good idea? */ Perl_croak(aTHX_ "Can't use 'defined(@array)'" " (Maybe you should just omit the defined()?)"); break; @@ -9089,7 +9520,7 @@ Perl_ck_readline(pTHX_ OP *o) } else { OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); op_free(o); return newop; } @@ -9115,21 +9546,22 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; if (!kid) { - o = force_list(o); + o = force_list(o, 1); kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = kid->op_sibling; - else if (kid && !kid->op_sibling) { /* print HANDLE; */ + kid = OP_SIBLING(kid); + else if (kid && !OP_HAS_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 */ - kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOPo->op_first->op_sibling = kid; - cLISTOPo->op_last = kid; - kid = kid->op_sibling; + scalar(kid); + /* 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); } } @@ -9147,12 +9579,19 @@ 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 = first->op_sibling; + OP *second = OP_SIBLING(first); /* Implicitly take a reference to an array or hash */ - first->op_sibling = NULL; - first = cBINOPo->op_first = ref_array_or_hash(first); - second = first->op_sibling = ref_array_or_hash(second); + + /* remove the original two siblings, then add back the + * (possibly different) first and second sibs. + */ + op_sibling_splice(o, NULL, 1, NULL); + op_sibling_splice(o, NULL, 1, NULL); + first = ref_array_or_hash(first); + second = ref_array_or_hash(second); + op_sibling_splice(o, NULL, 0, second); + op_sibling_splice(o, NULL, 0, first); /* Implicitly take a reference to a regular expression */ if (first->op_type == OP_MATCH) { @@ -9184,7 +9623,7 @@ Perl_ck_sassign(pTHX_ OP *o) && !(kid->op_private & OPpTARGET_MY) ) { - OP * const kkid = kid->op_sibling; + OP * const kkid = OP_SIBLING(kid); /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV @@ -9192,17 +9631,19 @@ Perl_ck_sassign(pTHX_ OP *o) { kid->op_targ = kkid->op_targ; kkid->op_targ = 0; - /* Now we do not need PADSV and SASSIGN. */ - kid->op_sibling = o->op_sibling; /* NULL */ - cLISTOPo->op_first = NULL; + /* Now we do not need PADSV and SASSIGN. + * first replace the PADSV with OP_SIBLING(o), then + * detach kid and OP_SIBLING(o) from o */ + op_sibling_splice(o, kid, 1, OP_SIBLING(o)); + op_sibling_splice(o, NULL, -1, NULL); op_free(o); op_free(kkid); kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } } - if (kid->op_sibling) { - OP *kkid = kid->op_sibling; + if (OP_HAS_SIBLING(kid)) { + OP *kkid = OP_SIBLING(kid); /* For state variable assignment, kkid is a list op whose op_last is a padsv. */ if ((kkid->op_type == OP_PADSV || @@ -9211,7 +9652,7 @@ Perl_ck_sassign(pTHX_ OP *o) ) ) && (kkid->op_private & OPpLVAL_INTRO) - && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { + && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) { const PADOFFSET target = kkid->op_targ; OP *const other = newOP(OP_PADSV, kkid->op_flags @@ -9228,10 +9669,14 @@ Perl_ck_sassign(pTHX_ OP *o) other->op_targ = target; /* Because we change the type of the op here, we will skip the - assignment binop->op_last = binop->op_first->op_sibling; at the + assignment binop->op_last = OP_SIBLING(binop->op_first); at the end of Perl_newBINOP(). So need to do it here. */ - cBINOPo->op_last = cBINOPo->op_first->op_sibling; - + cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first); + cBINOPo->op_first->op_lastsib = 0; + cBINOPo->op_last ->op_lastsib = 1; +#ifdef PERL_OP_PARENT + cBINOPo->op_last->op_sibling = o; +#endif return nullop; } } @@ -9241,8 +9686,6 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { @@ -9294,8 +9737,6 @@ Perl_ck_null(pTHX_ OP *o) OP * Perl_ck_open(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_OPEN; S_io_hints(aTHX_ o); @@ -9310,13 +9751,13 @@ 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 = first->op_sibling) && /* The fh. */ - (oa = oa->op_sibling) && /* The mode. */ + (oa = OP_SIBLING(first)) && /* The fh. */ + (oa = OP_SIBLING(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 == oa->op_sibling)) /* The bareword. */ + (last == OP_SIBLING(oa))) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); @@ -9328,8 +9769,11 @@ Perl_ck_repeat(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_REPEAT; if (cBINOPo->op_first->op_flags & OPf_PARENS) { + OP* kids; o->op_private |= OPpREPEAT_DOLIST; - cBINOPo->op_first = force_list(cBINOPo->op_first); + kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */ + kids = force_list(kids, 1); /* promote them to a list */ + op_sibling_splice(o, NULL, 0, kids); /* and add back */ } else scalar(o); @@ -9339,19 +9783,21 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { - dVAR; GV* gv; PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - SV * const sv = kid->op_sv; - U32 was_readonly = SvREADONLY(sv); - char *s; - STRLEN len; + HEK *hek; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + dVAR; const char *end; if (was_readonly) { @@ -9371,7 +9817,33 @@ Perl_ck_require(pTHX_ OP *o) } SvEND_set(sv, end); sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { + dVAR; + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } } } @@ -9381,7 +9853,7 @@ Perl_ck_require(pTHX_ OP *o) OP *kid, *newop; if (o->op_flags & OPf_KIDS) { kid = cUNOPo->op_first; - cUNOPo->op_first = NULL; + op_sibling_splice(o, NULL, -1, NULL); } else { kid = newDEFSVOP(); @@ -9397,14 +9869,13 @@ Perl_ck_require(pTHX_ OP *o) OP * Perl_ck_return(pTHX_ OP *o) { - dVAR; OP *kid; PERL_ARGS_ASSERT_CK_RETURN; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (CvLVALUE(PL_compcv)) { - for (; kid; kid = kid->op_sibling) + for (; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_LEAVESUBLV); } @@ -9420,8 +9891,8 @@ Perl_ck_select(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SELECT; if (o->op_flags & OPf_KIDS) { - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (kid && kid->op_sibling) { + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && OP_HAS_SIBLING(kid)) { o->op_type = OP_SSELECT; o->op_ppaddr = PL_ppaddr[OP_SSELECT]; o = ck_fun(o); @@ -9429,7 +9900,7 @@ Perl_ck_select(pTHX_ OP *o) } } o = ck_fun(o); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; return o; @@ -9438,7 +9909,6 @@ Perl_ck_select(pTHX_ OP *o) OP * Perl_ck_shift(pTHX_ OP *o) { - dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_SHIFT; @@ -9461,7 +9931,6 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { - dVAR; OP *firstkid; OP *kid; HV * const hinthv = @@ -9483,7 +9952,7 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); - firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = OP_SIBLING(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 */ @@ -9502,11 +9971,38 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = kid; o->op_flags |= OPf_SPECIAL; } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv)); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; + cUNOPx(firstkid)->op_first = padop; + op_free(kid); + } + } + } - firstkid = firstkid->op_sibling; + firstkid = OP_SIBLING(firstkid); } - for (kid = firstkid; kid; kid = kid->op_sibling) { + for (kid = firstkid; kid; kid = OP_SIBLING(kid)) { /* provide list context for arguments */ list(kid); if (stacked) @@ -9529,8 +10025,7 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { - dVAR; - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ OP *k; int descending; GV *gv; @@ -9572,7 +10067,7 @@ S_simplify_sort(pTHX_ OP *o) kid = kBINOP->op_first; do { if (kid->op_type == OP_PADSV) { - SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ]; + SV * const name = PAD_COMPNAME_SV(kid->op_targ); if (SvCUR(name) == 2 && *SvPVX(name) == '$' && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b')) /* diag_listed_as: "my %s" used in sort comparison */ @@ -9581,7 +10076,7 @@ S_simplify_sort(pTHX_ OP *o) SvPAD_STATE(name) ? "state" : "my", SvPVX(name)); } - } while ((kid = kid->op_sibling)); + } while ((kid = OP_SIBLING(kid))); return; } kid = kBINOP->op_first; /* get past cmp */ @@ -9620,9 +10115,10 @@ 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 = cLISTOPo->op_first->op_sibling; - cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ - op_free(kid); /* then delete it */ + kid = OP_SIBLING(cLISTOPo->op_first); + /* cut out and delete old block (second sibling) */ + op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); + op_free(kid); } OP * @@ -9639,23 +10135,18 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); - kid = kid->op_sibling; - op_free(cLISTOPo->op_first); - if (kid) - cLISTOPo->op_first = kid; - else { - cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); - cLISTOPo->op_last = kid; /* There was only one element previously */ - } + /* 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(" "))); + op_free(kid); + kid = cLISTOPo->op_first; if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { - OP * const sibl = kid->op_sibling; - kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */ - if (cLISTOPo->op_first == cLISTOPo->op_last) - cLISTOPo->op_last = kid; - cLISTOPo->op_first = kid; - kid->op_sibling = sibl; + /* 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); + op_sibling_splice(o, NULL, 0, kid); } kid->op_type = OP_PUSHRE; @@ -9666,24 +10157,24 @@ Perl_ck_split(pTHX_ OP *o) "Use of /g modifier is meaningless in split"); } - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) op_append_elem(OP_SPLIT, o, newDEFSVOP()); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); assert(kid); scalar(kid); - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) { op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); o->op_private |= OPpSPLIT_IMPLIM; } - assert(kid->op_sibling); + assert(OP_HAS_SIBLING(kid)); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); scalar(kid); - if (kid->op_sibling) + if (OP_HAS_SIBLING(kid)) return too_many_arguments_pv(o,OP_DESC(o), 0); return o; @@ -9692,7 +10183,7 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - const OP * const kid = cLISTOPo->op_first->op_sibling; + const OP * const kid = OP_SIBLING(cLISTOPo->op_first); PERL_ARGS_ASSERT_CK_JOIN; @@ -9779,7 +10270,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) CV *cv; GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; - if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV)) + if (flags & ~RV2CVOPCV_FLAG_MASK) Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) return NULL; @@ -9791,6 +10282,16 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) switch (rvop->op_type) { case OP_GV: { gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } cv = GvCVu(gv); if (!cv) { if (flags & RV2CVOPCV_MARK_EARLY) @@ -9815,8 +10316,9 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if (!CvANON(cv) || !gv) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -9843,9 +10345,9 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) OP *aop; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { + for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) { list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -9885,7 +10387,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { STRLEN proto_len; const char *proto, *proto_end; - OP *aop, *prev, *cvop; + OP *aop, *prev, *cvop, *parent; int optional = 0; I32 arg = 0; I32 contextclass = 0; @@ -9899,17 +10401,25 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) else proto = SvPV(protosv, proto_len); proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; + parent = entersubop; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } prev = aop; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; while (aop != cvop) { OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -9947,31 +10457,6 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; /* autoconvert GLOB -> GLOBref */ else if (o3->op_type == OP_CONST) o3->op_private &= ~OPpCONST_STRICT; - else if (o3->op_type == OP_ENTERSUB) { - /* accidental subroutine, revert to bareword */ - OP *gvop = ((UNOP*)o3)->op_first; - if (gvop && gvop->op_type == OP_NULL) { - gvop = ((UNOP*)gvop)->op_first; - if (gvop) { - for (; gvop->op_sibling; gvop = gvop->op_sibling) - ; - if (gvop && - (gvop->op_private & OPpENTERSUB_NOPAREN) && - (gvop = ((UNOP*)gvop)->op_first) && - gvop->op_type == OP_GV) - { - GV * const gv = cGVOPx_gv(gvop); - OP * const sibling = aop->op_sibling; - SV * const n = newSVpvs(""); - op_free(aop); - gv_fullname4(n, gv, "", FALSE); - aop = newSVOP(OP_CONST, 0, n); - prev->op_sibling = aop; - aop->op_sibling = sibling; - } - } - } - } scalar(aop); break; case '+': @@ -10067,14 +10552,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) bad_type_gv(arg, "hash", namegv, 0, o3); break; wrapref: - { - OP* const kid = aop; - OP* const sib = kid->op_sibling; - kid->op_sibling = 0; - aop = newUNOP(OP_REFGEN, 0, kid); - aop->op_sibling = sib; - prev->op_sibling = aop; - } + aop = S_op_sibling_newUNOP(aTHX_ parent, prev, + OP_REFGEN, 0); if (contextclass && e) { proto = e + 1; contextclass = 0; @@ -10090,26 +10569,27 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL, 0)), + SVfARG(protosv)); } } op_lvalue(aop, OP_ENTERSUB); prev = aop; - aop = aop->op_sibling; + aop = OP_SIBLING(aop); } if (aop == cvop && *proto == '_') { /* generate an access to $_ */ - aop = newDEFSVOP(); - aop->op_sibling = prev->op_sibling; - prev->op_sibling = aop; /* instead of cvop */ + op_sibling_splice(parent, prev, 0, newDEFSVOP()); } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10161,10 +10641,10 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!opnum) { OP *cvop; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; if (aop != cvop) (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); @@ -10188,22 +10668,38 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) NOT_REACHED; } else { - OP *prev, *cvop; - U32 flags; - if (!aop->op_sibling) + OP *prev, *cvop, *first, *parent; + U32 flags = 0; + + parent = entersubop; + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } - prev = aop; - aop = aop->op_sibling; - prev->op_sibling = NULL; + first = prev = aop; + aop = OP_SIBLING(aop); + /* find last sibling */ for (cvop = aop; - cvop->op_sibling; - prev=cvop, cvop = cvop->op_sibling) + OP_HAS_SIBLING(cvop); + prev = cvop, cvop = OP_SIBLING(cvop)) ; - prev->op_sibling = NULL; - flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); + if (!(cvop->op_private & OPpENTERSUB_NOPAREN) + /* Usually, OPf_SPECIAL on a UNOP means that its arg had no + * 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) + flags |= OPf_SPECIAL; + /* excise cvop from end of sibling chain */ + op_sibling_splice(parent, prev, 1, NULL); op_free(cvop); if (aop == cvop) aop = NULL; + + /* detach remaining siblings from the first sibling, then + * dispose of original optree */ + + if (aop) + op_sibling_splice(parent, first, -1, NULL); op_free(entersubop); if (opnum == OP_ENTEREVAL @@ -10261,23 +10757,33 @@ by L. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree for a @@ -10294,15 +10800,25 @@ It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, -which may be replaced by the check function, and I is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I supplies +the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L. You can force perl to pass a GV by including +C in the I. + The current setting for a particular CV can be retrieved by L. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L, which passes it the +C flag for backward-compatibility. + =cut */ @@ -10310,6 +10826,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10328,7 +10852,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10342,12 +10867,12 @@ Perl_ck_subr(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SUBR; aop = cUNOPx(o)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10361,7 +10886,7 @@ Perl_ck_subr(pTHX_ OP *o) if (aop->op_type == OP_CONST) aop->op_private &= ~OPpCONST_STRICT; else if (aop->op_type == OP_LIST) { - OP * const sib = ((UNOP*)aop)->op_first->op_sibling; + OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); if (sib && sib->op_type == OP_CONST) sib->op_private &= ~OPpCONST_STRICT; } @@ -10372,21 +10897,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + 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 + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); } @@ -10427,7 +10955,7 @@ Perl_ck_trunc(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) - kid = (SVOP*)kid->op_sibling; + kid = (SVOP*)OP_SIBLING(kid); if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE) && !kid->op_folded) @@ -10449,7 +10977,7 @@ Perl_ck_substr(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid) kid->op_flags |= OPf_MOD; @@ -10464,7 +10992,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 && kid->op_sibling) kid = kid->op_sibling; + if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid); if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; } return o; @@ -10576,39 +11104,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 = modop_pushmark->op_sibling; + modop = OP_SIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) return; /* no other operation except sort/reverse */ - if (modop->op_sibling) + if (OP_HAS_SIBLING(modop)) return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; + if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ assert(oright->op_type == OP_NULL); - oright = oright->op_sibling; + oright = OP_SIBLING(oright); } - assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); - oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; + assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL); + oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first; assert(oleft_pushmark->op_type == OP_PUSHMARK); - oleft = oleft_pushmark->op_sibling; + oleft = OP_SIBLING(oleft_pushmark); /* Check the lhs is an array */ if (!oleft || (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || oleft->op_sibling + || OP_HAS_SIBLING(oleft) || (oleft->op_private & OPpLVAL_INTRO) ) return; /* Only one thing on the rhs */ - if (oright->op_sibling) + if (OP_HAS_SIBLING(oright)) return; /* check the array is the same on both sides */ @@ -10744,7 +11272,7 @@ Perl_rpeep(pTHX_ OP *o) OP *sibling; OP *other_pushmark; if (OP_TYPE_IS(o->op_next, OP_PUSHMARK) - && (sibling = o->op_sibling) + && (sibling = OP_SIBLING(o)) && sibling->op_type == OP_LIST /* This KIDS check is likely superfluous since OP_LIST * would otherwise be an OP_STUB. */ @@ -10783,25 +11311,25 @@ Perl_rpeep(pTHX_ OP *o) */ { OP *next = o->op_next; - OP *sibling = o->op_sibling; + OP *sibling = OP_SIBLING(o); if ( OP_TYPE_IS(next, OP_PUSHMARK) && OP_TYPE_IS(sibling, OP_RETURN) && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) && cUNOPx(sibling)->op_first == next - && next->op_sibling && next->op_sibling->op_next + && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next && next->op_next ) { /* Look through the PUSHMARK's siblings for one that * points to the RETURN */ - OP *top = next->op_sibling; + OP *top = OP_SIBLING(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 = top->op_sibling; + top = OP_SIBLING(top); } } } @@ -10836,35 +11364,45 @@ Perl_rpeep(pTHX_ OP *o) && (!CopLABEL((COP*)o)) /* Don't mess with labels */ && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ ) { - OP *first; - OP *last; - OP *newop; - - first = o->op_next; - last = o->op_next->op_next->op_next; - - newop = newLISTOP(OP_LIST, 0, first, last); + OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; + + pad1 = o->op_next; + ns2 = pad1->op_next; + pad2 = ns2->op_next; + ns3 = pad2->op_next; + + /* 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); + + /* create new listop, with children consisting of: + * a new pushmark, pad1, pad2. */ + OP_SIBLING_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; + newpm = cUNOPx(newop)->op_first; /* pushmark */ /* Kill nextstate2 between padop1/padop2 */ - op_free(first->op_next); - - first->op_next = last; /* padop2 */ - first->op_sibling = last; /* ... */ - o->op_next = cUNOPx(newop)->op_first; /* pushmark */ - o->op_next->op_next = first; /* padop1 */ - o->op_next->op_sibling = first; /* ... */ - newop->op_next = last->op_next; /* nextstate3 */ - newop->op_sibling = last->op_sibling; - last->op_next = newop; /* listop */ - last->op_sibling = NULL; - o->op_sibling = newop; /* ... */ + op_free(ns2); + + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + OP_SIBLING_set(o, newop); + OP_SIBLING_set(newop, ns3); + newop->op_lastsib = 0; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; /* Ensure pushmark has this flag if padops do */ - if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) { + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { o->op_next->op_flags |= OPf_MOD; } @@ -11005,7 +11543,7 @@ Perl_rpeep(pTHX_ OP *o) OP *rv2av, *q; p = o->op_next; if ( p->op_type == OP_GV - && (gv = cGVOPx_gv(p)) + && (gv = cGVOPx_gv(p)) && isGV(gv) && GvNAMELEN_get(gv) == 1 && *GvNAME_get(gv) == '_' && GvSTASH(gv) == PL_defstash @@ -11014,7 +11552,7 @@ Perl_rpeep(pTHX_ OP *o) && !(rv2av->op_flags & OPf_REF) && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) - && o->op_sibling == rv2av /* these two for Deparse */ + && OP_SIBLING(o) == rv2av /* these two for Deparse */ && cUNOPx(rv2av)->op_first == p ) { q = rv2av->op_next; @@ -11029,8 +11567,8 @@ Perl_rpeep(pTHX_ OP *o) if (!defav) { /* To allow Deparse to pessimise this, it needs to be able * to restore the pushmark's original op_next, which it - * will assume to be the same as op_sibling. */ - if (o->op_next != o->op_sibling) + * will assume to be the same as OP_SIBLING. */ + if (o->op_next != OP_SIBLING(o)) break; p = o; } @@ -11290,7 +11828,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_OR: case OP_DOR: fop = cLOGOP->op_first; - sop = fop->op_sibling; + sop = OP_SIBLING(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 @@ -11404,7 +11942,7 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_flags & OPf_SPECIAL) { /* first arg is a code block */ - OP * const nullop = cLISTOP->op_first->op_sibling; + OP * const nullop = OP_SIBLING(cLISTOP->op_first); OP * kid = cUNOPx(nullop)->op_first; assert(nullop->op_type == OP_NULL); @@ -11435,7 +11973,7 @@ Perl_rpeep(pTHX_ OP *o) break; /* reverse sort ... can be optimised. */ - if (!cUNOPo->op_sibling) { + if (!OP_HAS_SIBLING(cUNOPo)) { /* Nothing follows us on the list. */ OP * const reverse = o->op_next; @@ -11443,7 +11981,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) - && (cUNOPx(pushmark)->op_sibling == o)) { + && (OP_SIBLING(cUNOPx(pushmark)) == o)) { /* reverse -> pushmark -> sort */ o->op_private |= OPpSORT_REVERSE; op_null(reverse); @@ -11498,7 +12036,7 @@ Perl_rpeep(pTHX_ OP *o) || expushmark->op_targ != OP_PUSHMARK) break; - exlist = (LISTOP *) expushmark->op_sibling; + exlist = (LISTOP *) OP_SIBLING(expushmark); if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; @@ -11511,7 +12049,7 @@ Perl_rpeep(pTHX_ OP *o) if (!theirmark || theirmark->op_type != OP_PUSHMARK) break; - if (theirmark->op_sibling != o) { + if (OP_SIBLING(theirmark) != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ @@ -11526,8 +12064,8 @@ Perl_rpeep(pTHX_ OP *o) if (!ourlast || ourlast->op_next != o) break; - rv2av = ourmark->op_sibling; - if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 + rv2av = OP_SIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_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. */ @@ -11592,14 +12130,15 @@ Perl_rpeep(pTHX_ OP *o) * arg2 * ... */ - OP *left = right->op_sibling; + OP *left = OP_SIBLING(right); if (left->op_type == OP_SUBSTR && (left->op_private & 7) < 4) { op_null(o); - cBINOP->op_first = left; - right->op_sibling = - cBINOPx(left)->op_first->op_sibling; - cBINOPx(left)->op_first->op_sibling = right; + /* cut out right */ + op_sibling_splice(o, NULL, 1, NULL); + /* and insert it as second child of OP_SUBSTR */ + op_sibling_splice(left, cBINOPx(left)->op_first, 0, + right); left->op_private |= OPpSUBSTR_REPL_FIRST; left->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; @@ -11719,7 +12258,6 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) any.xop_peep = xop->xop_peep; break; default: - /* NOTREACHED */ NOT_REACHED; break; } @@ -11738,7 +12276,6 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) any.xop_peep = XOPd_xop_peep; break; default: - /* NOTREACHED */ NOT_REACHED; break; } @@ -12080,7 +12617,6 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, static void const_sv_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; SV *const sv = MUTABLE_SV(XSANY.any_ptr); PERL_UNUSED_ARG(items); @@ -12095,7 +12631,6 @@ const_sv_xsub(pTHX_ CV* cv) static void const_av_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; AV * const av = MUTABLE_AV(XSANY.any_ptr); SP -= items;