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);
+#ifdef PERL_OP_PARENT
+ /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
+ assert(!o->op_moresib);
+ assert(!o->op_sibparent);
+#endif
return (void *)o;
}
PERL_UNUSED_CONTEXT;
DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
assert(slab->opslab_refcnt == 1);
- for (; slab; slab = slab2) {
+ do {
slab2 = slab->opslab_next;
#ifdef DEBUGGING
slab->opslab_refcnt = ~(size_t)0;
#else
PerlMemShared_free(slab);
#endif
- }
+ slab = slab2;
+ } while (slab);
}
void
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
-#define CHANGE_TYPE(o,type) \
+#define OpTYPE_set(o,type) \
STMT_START { \
o->op_type = (OPCODE)type; \
o->op_ppaddr = PL_ppaddr[type]; \
}
STATIC void
-S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
{
PERL_ARGS_ASSERT_BAD_TYPE_PV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)), flags);
+ (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
}
+/* remove flags var, its unused in all callers, move to to right end since gv
+ and kid are always the same */
STATIC void
-S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
+S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
{
SV * const namesv = cv_name((CV *)gv, NULL, 0);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
- (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
+ (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
}
STATIC void
(name[1] == '_' && (*name == '$' || len > 2))))
{
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && isASCII(name[1])
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
if (o->op_flags & OPf_KIDS) {
OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
+ nextkid = OpSIBLING(kid); /* Get before next freeing kid */
if (!kid || kid->op_type == OP_FREED)
/* During the forced freeing of ops after
compilation failure, kidops may be freed before
Safefree(defer_stack);
}
+/* S_op_clear_gv(): free a GV attached to an OP */
+
+#ifdef USE_ITHREADS
+void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
+#else
+void S_op_clear_gv(pTHX_ OP *o, SV**svp)
+#endif
+{
+
+ GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
+ || o->op_type == OP_MULTIDEREF)
+#ifdef USE_ITHREADS
+ && PL_curpad
+ ? ((GV*)PAD_SVl(*ixp)) : NULL;
+#else
+ ? (GV*)(*svp) : NULL;
+#endif
+ /* It's possible during global destruction that the GV is freed
+ before the optree. Whilst the SvREFCNT_inc is happy to bump from
+ 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
+ will trigger an assertion failure, because the entry to sv_clear
+ checks that the scalar is not already freed. A check of for
+ !SvIS_FREED(gv) turns out to be invalid, because during global
+ destruction the reference count can be forced down to zero
+ (with SVf_BREAK set). In which case raising to 1 and then
+ dropping to 0 triggers cleanup before it should happen. I
+ *think* that this might actually be a general, systematic,
+ weakness of the whole idea of SVf_BREAK, in that code *is*
+ allowed to raise and lower references during global destruction,
+ so any *valid* code that happens to do this during global
+ destruction might well trigger premature cleanup. */
+ bool still_valid = gv && SvREFCNT(gv);
+
+ if (still_valid)
+ SvREFCNT_inc_simple_void(gv);
+#ifdef USE_ITHREADS
+ if (*ixp > 0) {
+ pad_swipe(*ixp, TRUE);
+ *ixp = 0;
+ }
+#else
+ SvREFCNT_dec(*svp);
+ *svp = NULL;
+#endif
+ if (still_valid) {
+ int try_downgrade = SvREFCNT(gv) == 2;
+ SvREFCNT_dec_NN(gv);
+ if (try_downgrade)
+ gv_try_downgrade(gv);
+ }
+}
+
+
void
Perl_op_clear(pTHX_ OP *o)
{
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- {
- GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
-#ifdef USE_ITHREADS
- && PL_curpad
-#endif
- ? cGVOPo_gv : NULL;
- /* It's possible during global destruction that the GV is freed
- before the optree. Whilst the SvREFCNT_inc is happy to bump from
- 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
- will trigger an assertion failure, because the entry to sv_clear
- checks that the scalar is not already freed. A check of for
- !SvIS_FREED(gv) turns out to be invalid, because during global
- destruction the reference count can be forced down to zero
- (with SVf_BREAK set). In which case raising to 1 and then
- dropping to 0 triggers cleanup before it should happen. I
- *think* that this might actually be a general, systematic,
- weakness of the whole idea of SVf_BREAK, in that code *is*
- allowed to raise and lower references during global destruction,
- so any *valid* code that happens to do this during global
- destruction might well trigger premature cleanup. */
- bool still_valid = gv && SvREFCNT(gv);
-
- if (still_valid)
- SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
- if (cPADOPo->op_padix > 0) {
- pad_swipe(cPADOPo->op_padix, TRUE);
- cPADOPo->op_padix = 0;
- }
+ S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
#else
- SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = NULL;
+ S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
#endif
- if (still_valid) {
- int try_downgrade = SvREFCNT(gv) == 2;
- SvREFCNT_dec_NN(gv);
- if (try_downgrade)
- gv_try_downgrade(gv);
- }
- }
break;
case OP_METHOD_REDIR:
case OP_METHOD_REDIR_SUPER:
/* FALLTHROUGH */
case OP_MATCH:
case OP_QR:
-clear_pmop:
+ clear_pmop:
if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
op_free(cPMOPo->op_code_list);
cPMOPo->op_code_list = NULL;
#endif
break;
+
+ case OP_MULTIDEREF:
+ {
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV actions = items->uv;
+ bool last = 0;
+ bool is_hash = FALSE;
+
+ while (!last) {
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padav_aelem:
+ pad_free((++items)->pad_offset);
+ goto do_elem;
+
+ case MDEREF_HV_gvhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvav_aelem:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ goto do_elem;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ pad_free((++items)->pad_offset);
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ do_vivify_rv2xv_elem:
+ case MDEREF_AV_pop_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem:
+ do_elem:
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ last = 1;
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hash) {
+#ifdef USE_ITHREADS
+ /* see RT #15654 */
+ pad_swipe((++items)->pad_offset, 1);
+#else
+ SvREFCNT_dec((++items)->sv);
+#endif
+ }
+ else
+ items++;
+ break;
+ case MDEREF_INDEX_padsv:
+ pad_free((++items)->pad_offset);
+ break;
+ case MDEREF_INDEX_gvsv:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ break;
+ }
+
+ if (actions & MDEREF_FLAG_last)
+ last = 1;
+ is_hash = FALSE;
+
+ break;
+
+ default:
+ assert(0);
+ last = 1;
+ break;
+
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+
+ /* start of malloc is at op_aux[-1], where the length is
+ * stored */
+ PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
+ }
+ break;
}
if (o->op_targ > 0) {
forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
}
}
}
return;
op_clear(o);
o->op_targ = o->op_type;
- CHANGE_TYPE(o, OP_NULL);
+ OpTYPE_set(o, OP_NULL);
}
void
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.
+updating the op_sibling/op_sibparent or op_moresib 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.
+parent is the parent node of the sibling chain. It may passed as NULL if
+the splicing doesn't affect the first or last op in the 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
splice(P, B, 0, X-Y) | | NULL
A-B-C-D A-B-X-Y-C-D
+
+For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
+see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
+
=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 *first;
OP *rest;
OP *last_del = NULL;
OP *last_ins = NULL;
- PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
+ if (start)
+ first = OpSIBLING(start);
+ else if (!parent)
+ goto no_parent;
+ else
+ first = cLISTOPx(parent)->op_first;
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;
+ while (--del_count && OpHAS_SIBLING(last_del))
+ last_del = OpSIBLING(last_del);
+ rest = OpSIBLING(last_del);
+ OpLASTSIB_set(last_del, NULL);
}
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;
+ while (OpHAS_SIBLING(last_ins))
+ last_ins = OpSIBLING(last_ins);
+ OpMAYBESIB_set(last_ins, rest, NULL);
}
else
insert = rest;
if (start) {
- OP_SIBLING_set(start, insert);
- start->op_lastsib = insert ? 0 : 1;
+ OpMAYBESIB_set(start, insert, NULL);
}
- else
+ else {
+ if (!parent)
+ goto no_parent;
cLISTOPx(parent)->op_first = insert;
+ if (insert)
+ parent->op_flags |= OPf_KIDS;
+ else
+ parent->op_flags &= ~OPf_KIDS;
+ }
if (!rest) {
/* update op_last etc */
- U32 type = parent->op_type;
+ U32 type;
OP *lastop;
- if (type == OP_NULL)
- type = parent->op_targ;
- type = PL_opargs[type] & OA_CLASS_MASK;
+ if (!parent)
+ goto no_parent;
+
+ /* ought to use OP_CLASS(parent) here, but that can't handle
+ * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
+ * either */
+ type = parent->op_type;
+ if (type == OP_CUSTOM) {
+ dTHX;
+ type = XopENTRYCUSTOM(parent, xop_class);
+ }
+ else {
+ 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
)
cLISTOPx(parent)->op_last = lastop;
- if (lastop) {
- lastop->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- lastop->op_sibling = parent;
-#endif
- }
+ if (lastop)
+ OpLASTSIB_set(lastop, parent);
}
return last_del ? first : NULL;
+
+ no_parent:
+ Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}
+
+#ifdef PERL_OP_PARENT
+
/*
=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.
+Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
*/
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
+ while (OpHAS_SIBLING(o))
+ o = OpSIBLING(o);
+ return o->op_sibparent;
}
+#endif
+
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- CHANGE_TYPE(logop, type);
+ OpTYPE_set(logop, 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
- }
+ while (kid && OpHAS_SIBLING(kid))
+ kid = OpSIBLING(kid);
+ if (kid)
+ OpLASTSIB_set(kid, (OP*)logop);
return logop;
}
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
- OP *sibl = OP_SIBLING(kid);
+ OP *sibl = OpSIBLING(kid);
if (sibl) {
kid->op_next = LINKLIST(sibl);
kid = sibl;
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
scalar(kid);
}
return o;
return;
kid = cLISTOPo->op_first;
- kid = OP_SIBLING(kid); /* get past pushmark */
+ kid = OpSIBLING(kid); /* get past pushmark */
/* weed out false positives: any ops that can return lists */
switch (kid->op_type) {
case OP_BACKTICK:
if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
return;
- assert(OP_SIBLING(kid));
- name = S_op_varname(aTHX_ OP_SIBLING(kid));
+ assert(OpSIBLING(kid));
+ name = S_op_varname(aTHX_ OpSIBLING(kid));
if (!name) /* XS module fiddling with the op tree */
return;
S_op_pretty(aTHX_ kid, &keysv, &key);
if (o->op_private & OPpREPEAT_DOLIST) {
kid = cLISTOPx(cUNOPo->op_first)->op_first;
assert(kid->op_type == OP_PUSHMARK);
- if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
+ if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
op_null(cLISTOPx(cUNOPo->op_first)->op_first);
o->op_private &=~ OPpREPEAT_DOLIST;
}
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
scalar(kid);
break;
/* FALLTHROUGH */
case OP_NULL:
default:
if (o->op_flags & OPf_KIDS) {
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
scalar(kid);
}
break;
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
scalar(kid);
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
do_kids:
while (kid) {
- OP *sib = OP_SIBLING(kid);
+ OP *sib = OpSIBLING(kid);
if (sib && kid->op_type != OP_LEAVEWHEN
- && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
+ && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
|| ( sib->op_targ != OP_NEXTSTATE
&& sib->op_targ != OP_DBSTATE )))
scalarvoid(kid);
if (!ckWARN(WARN_SYNTAX)) break;
kid = cLISTOPo->op_first;
- kid = OP_SIBLING(kid); /* get past pushmark */
- assert(OP_SIBLING(kid));
- name = S_op_varname(aTHX_ OP_SIBLING(kid));
+ kid = OpSIBLING(kid); /* get past pushmark */
+ assert(OpSIBLING(kid));
+ name = S_op_varname(aTHX_ OpSIBLING(kid));
if (!name) /* XS module fiddling with the op tree */
break;
S_op_pretty(aTHX_ kid, &keysv, &key);
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
+ if (o->op_type == OP_REPEAT)
+ scalar(cBINOPo->op_first);
goto func_ops;
case OP_SUBSTR:
if (o->op_private == 4)
case OP_RV2AV:
case OP_RV2HV:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
+ (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
useless = "a variable";
break;
break;
case OP_POSTINC:
- CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
break;
case OP_POSTDEC:
- CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
break;
case OP_I_POSTINC:
- CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
break;
case OP_I_POSTDEC:
- CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
break;
case OP_SASSIGN: {
if (kid->op_type == OP_NOT
&& (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
- CHANGE_TYPE(o, OP_OR);
+ OpTYPE_set(o, OP_OR);
} else {
- CHANGE_TYPE(o, OP_AND);
+ OpTYPE_set(o, OP_AND);
}
op_null(kid);
}
case OP_COND_EXPR:
case OP_ENTERGIVEN:
case OP_ENTERWHEN:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
if (!(kid->op_flags & OPf_KIDS))
scalarvoid(kid);
else
case OP_LEAVEGIVEN:
case OP_LEAVEWHEN:
kids:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
if (!(kid->op_flags & OPf_KIDS))
scalarvoid(kid);
else
optimisation would reject, then null the list and the pushmark.
*/
if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
- && ( !(kid = OP_SIBLING(kid))
+ && ( !(kid = OpSIBLING(kid))
|| ( kid->op_type != OP_PADSV
&& kid->op_type != OP_PADAV
&& kid->op_type != OP_PADHV)
|| kid->op_private & ~OPpLVAL_INTRO
- || !(kid = OP_SIBLING(kid))
+ || !(kid = OpSIBLING(kid))
|| ( kid->op_type != OP_PADSV
&& kid->op_type != OP_PADAV
&& kid->op_type != OP_PADHV)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
list(kid);
}
return o;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
list(kid);
break;
default:
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
list(kid);
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
do_kids:
while (kid) {
- OP *sib = OP_SIBLING(kid);
+ OP *sib = OpSIBLING(kid);
if (sib && kid->op_type != OP_LEAVEWHEN)
scalarvoid(kid);
else
{
OP *kid, *sib;
for (kid = cLISTOPo->op_first; kid; kid = sib) {
- if ((sib = OP_SIBLING(kid))
- && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
+ if ((sib = OpSIBLING(kid))
+ && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
|| ( sib->op_targ != OP_NEXTSTATE
&& sib->op_targ != OP_DBSTATE )))
{
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
op_lvalue(kid, type);
}
return o;
}
+
+/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
+ * const fields. Also, convert CONST keys to HEK-in-SVs.
+ * rop is the op that retrieves the hash;
+ * key_op is the first key
+ */
+
+void
+S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
+{
+ PADNAME *lexname;
+ GV **fields;
+ bool check_fields;
+
+ /* find the padsv corresponding to $lex->{} or @{$lex}{} */
+ if (rop) {
+ if (rop->op_first->op_type == OP_PADSV)
+ /* @$hash{qw(keys here)} */
+ rop = (UNOP*)rop->op_first;
+ else {
+ /* @{$hash}{qw(keys here)} */
+ if (rop->op_first->op_type == OP_SCOPE
+ && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
+ {
+ rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
+ }
+ else
+ rop = NULL;
+ }
+ }
+
+ lexname = NULL; /* just to silence compiler warnings */
+ fields = NULL; /* just to silence compiler warnings */
+
+ check_fields =
+ rop
+ && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
+ SvPAD_TYPED(lexname))
+ && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
+ && isGV(*fields) && GvHV(*fields);
+
+ for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
+ SV **svp, *sv;
+ if (key_op->op_type != OP_CONST)
+ continue;
+ svp = cSVOPx_svp(key_op);
+
+ /* Make the CONST have a shared SV */
+ if ( !SvIsCOW_shared_hash(sv = *svp)
+ && SvTYPE(sv) < SVt_PVMG
+ && SvOK(sv)
+ && !SvROK(sv))
+ {
+ SSize_t keylen;
+ const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
+ SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
+ SvREFCNT_dec_NN(sv);
+ *svp = nsv;
+ }
+
+ if ( check_fields
+ && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
+ {
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"PNf" of type %"HEKf,
+ SVfARG(*svp), PNfARG(lexname),
+ HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
+ }
+ }
+}
+
+
/*
=for apidoc finalize_optree
PL_curcop = ((COP*)o); /* for warnings */
break;
case OP_EXEC:
- if (OP_HAS_SIBLING(o)) {
- OP *sib = OP_SIBLING(o);
+ if (OpHAS_SIBLING(o)) {
+ OP *sib = OpSIBLING(o);
if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
&& ckWARN(WARN_EXEC)
- && OP_HAS_SIBLING(sib))
+ && OpHAS_SIBLING(sib))
{
- const OPCODE type = OP_SIBLING(sib)->op_type;
+ const OPCODE type = OpSIBLING(sib)->op_type;
if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
const line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, CopLINE((COP*)sib));
case OP_HELEM: {
UNOP *rop;
- PADNAME *lexname;
- GV **fields;
SVOP *key_op;
OP *kid;
- bool check_fields;
if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
break;
/* FALLTHROUGH */
case OP_KVHSLICE:
- kid = OP_SIBLING(cLISTOPo->op_first);
+ kid = OpSIBLING(cLISTOPo->op_first);
if (/* I bet there's always a pushmark... */
OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
&& OP_TYPE_ISNT_NN(kid, OP_CONST))
key_op = (SVOP*)(kid->op_type == OP_CONST
? kid
- : OP_SIBLING(kLISTOP->op_first));
+ : OpSIBLING(kLISTOP->op_first));
rop = (UNOP*)((LISTOP*)o)->op_last;
check_keys:
- if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
- rop = NULL;
- else if (rop->op_first->op_type == OP_PADSV)
- /* @$hash{qw(keys here)} */
- rop = (UNOP*)rop->op_first;
- else {
- /* @{$hash}{qw(keys here)} */
- if (rop->op_first->op_type == OP_SCOPE
- && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
- {
- rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
- }
- else
- rop = NULL;
- }
-
- lexname = NULL; /* just to silence compiler warnings */
- fields = NULL; /* just to silence compiler warnings */
-
- check_fields =
- rop
- && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
- SvPAD_TYPED(lexname))
- && (fields =
- (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
- && isGV(*fields) && GvHV(*fields);
- for (; key_op;
- key_op = (SVOP*)OP_SIBLING(key_op)) {
- SV **svp, *sv;
- if (key_op->op_type != OP_CONST)
- continue;
- svp = cSVOPx_svp(key_op);
-
- /* Make the CONST have a shared SV */
- if ((!SvIsCOW_shared_hash(sv = *svp))
- && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
- SSize_t keylen;
- const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
- SV *nsv = newSVpvn_share(key,
- SvUTF8(sv) ? -keylen : keylen, 0);
- SvREFCNT_dec_NN(sv);
- *svp = nsv;
- }
-
- if (check_fields
- && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
- Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
- "in variable %"PNf" of type %"HEKf,
- SVfARG(*svp), PNfARG(lexname),
- HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
- }
- }
+ if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
+ rop = NULL;
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
break;
}
case OP_ASLICE:
#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 */
+ * the last op_sibling/op_sibparent 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;
assert( has_last /* has op_first and op_last, or ...
... has (or may have) op_first: */
|| family == OA_UNOP
+ || family == OA_UNOP_AUX
|| family == OA_LOGOP
|| family == OA_BASEOP_OR_UNOP
|| family == OA_FILESTATOP
|| type == OP_CUSTOM
|| type == OP_NULL /* new_logop does this */
);
- /* XXX list form of 'x' is has a null op_last. This is wrong,
- * but requires too much hacking (e.g. in Deparse) to fix for
- * now */
- if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
- assert(has_last);
- has_last = 0;
- }
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
# ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(kid)) {
+ if (!OpHAS_SIBLING(kid)) {
if (has_last)
assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibling == o);
+ assert(kid->op_sibparent == o);
}
# else
- if (OP_HAS_SIBLING(kid)) {
- assert(!kid->op_lastsib);
- }
- else {
- assert(kid->op_lastsib);
- if (has_last)
- assert(kid == cLISTOPo->op_last);
- }
+ if (has_last && !OpHAS_SIBLING(kid))
+ assert(kid == cLISTOPo->op_last);
# endif
}
#endif
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
finalize_op(kid);
}
}
OP *kid;
switch (o->op_type) {
case OP_COND_EXPR:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid;
- kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid;
+ kid = OpSIBLING(kid))
S_lvref(aTHX_ kid, type);
/* FALLTHROUGH */
case OP_PUSHMARK:
return;
}
slurpy:
- CHANGE_TYPE(o, OP_LVAVREF);
+ OpTYPE_set(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
case OP_RV2CV:
kid = cUNOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = cUNOPx(kUNOP->op_first->op_sibling)
+ kid = cUNOPx(OpSIBLING(kUNOP->op_first))
->op_first;
o->op_private = OPpLVREF_CV;
if (kid->op_type == OP_GV)
break;
case OP_ASLICE:
case OP_HSLICE:
- CHANGE_TYPE(o, OP_LVREFSLICE);
+ OpTYPE_set(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
}
/* FALLTHROUGH */
case OP_LIST:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
S_lvref(aTHX_ kid, type);
}
? "do block"
: OP_DESC(o),
PL_op_desc[type]));
- return;
}
- CHANGE_TYPE(o, OP_LVREF);
+ OpTYPE_set(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
(long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
}
- while (OP_HAS_SIBLING(kid))
- kid = OP_SIBLING(kid);
+ while (OpHAS_SIBLING(kid))
+ kid = OpSIBLING(kid);
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
break; /* Postpone until runtime */
}
case OP_COND_EXPR:
localize = 1;
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
op_lvalue(kid, type);
break;
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
if (o->op_flags & OPf_KIDS)
- op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
+ op_lvalue(OpSIBLING(cBINOPo->op_first), type);
break;
case OP_AELEM:
/* FALLTHROUGH */
case OP_LIST:
localize = 0;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
/* elements might be in void context because the list is
in scalar context or because they are attribute sub calls */
if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
|| !S_vivifies(cLOGOPo->op_first->op_type))
op_lvalue(cLOGOPo->op_first, type);
if (type == OP_LEAVESUBLV
- || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
- op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
+ || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
+ op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
goto nomod;
case OP_SREFGEN:
goto nomod;
/* Don’t bother applying lvalue context to the ex-list. */
kid = cUNOPx(cUNOPo->op_first)->op_first;
- assert (!OP_HAS_SIBLING(kid));
+ assert (!OpHAS_SIBLING(kid));
goto kid_2lvref;
case OP_REFGEN:
if (type != OP_AASSIGN) goto nomod;
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
ref(kid, type);
}
return o;
PERL_ARGS_ASSERT_DOREF;
- if (!o || (PL_parser && PL_parser->error_count))
+ if (PL_parser && PL_parser->error_count)
return o;
switch (o->op_type) {
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
break;
case OP_COND_EXPR:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
rop = NULL;
- for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
+ for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
if (o->op_type == OP_CONST)
rop = op_append_elem(OP_LIST, rop,
newSVOP(OP_CONST, o->op_flags,
newSVOP(OP_CONST, 0, stashsv),
op_prepend_elem(OP_LIST,
newUNOP(OP_REFGEN, 0,
- op_lvalue(arg, OP_REFGEN)),
+ arg),
dup_attrlist(attrs)));
/* Fake up a method call to import */
assert(o->op_flags & OPf_KIDS);
lasto = cLISTOPo->op_first;
assert(lasto->op_type == OP_PUSHMARK);
- for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
+ for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
}
/* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
would get pulled in with no real need */
- if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
+ if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
op_free(*attrs);
*attrs = NULL;
}
if (type == OP_LIST) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
my_kid(kid, attrs, imopsp);
return o;
} else if (type == OP_UNDEF || type == OP_STUB) {
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
+ pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
}
OP *
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- CHANGE_TYPE(o, OP_LEAVE);
+ OpTYPE_set(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- CHANGE_TYPE(o, OP_SCOPE);
+ OpTYPE_set(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
/* The following deals with things like 'do {1 for 1}' */
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
if (kid &&
(kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
op_null(kid);
{
if (o && o->op_type == OP_LINESEQ) {
OP *kid = cLISTOPo->op_first;
- for(; kid; kid = OP_SIBLING(kid))
+ for(; kid; kid = OpSIBLING(kid))
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
op_null(kid);
}
*/
OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
- for (;; kid = OP_SIBLING(kid)) {
+ for (;; kid = OpSIBLING(kid)) {
OP *newkid = newOP(OP_CLONECV, 0);
newkid->op_targ = kid->op_targ;
o = op_append_elem(OP_LINESEQ, o, newkid);
#endif
break;
case OP_PACK:
- if (!OP_HAS_SIBLING(cLISTOPo->op_first)
- || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
+ if (!OpHAS_SIBLING(cLISTOPo->op_first)
+ || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
goto nope;
{
- SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
+ SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
{
const char *s = SvPVX_const(sv);
SvPADTMP_on(sv);
SvREADONLY_on(sv);
}
- if (type == OP_RV2GV)
- newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
- else
- {
- newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
- if (!is_stringify) newop->op_folded = 1;
- }
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ if (!is_stringify) newop->op_folded = 1;
return newop;
nope:
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
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() */
if (last->op_type != (unsigned)type)
return op_append_elem(type, first, last);
- ((LISTOP*)first)->op_last->op_lastsib = 0;
- OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
+ OpMORESIB_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
+ OpLASTSIB_set(((LISTOP*)first)->op_last, first);
first->op_flags |= (last->op_flags & OPf_KIDS);
-
S_op_destroy(aTHX_ last);
return first;
A list-type op is usually constructed one kid at a time via C<newLISTOP>,
C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
-C<op_convert> to make it the right type.
+C<op_convert_list> to make it the right type.
=cut
*/
if (!o || o->op_type != OP_LIST)
o = force_list(o, 0);
else
+ {
o->op_flags &= ~OPf_WANT;
+ o->op_private &= ~OPpLVAL_INTRO;
+ }
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
else {
- OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
+ OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
if (kid2 && kid2->op_type == OP_COREARGS) {
op_null(cLISTOPo->op_first);
kid2->op_private |= OPpCOREARGS_PUSHMARK;
}
}
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags |= flags;
if (flags & OPf_FOLDED)
o->op_folded = 1;
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;
+ rest = OpSIBLING(o);
+ OpLASTSIB_set(o, NULL);
}
o = newLISTOP(OP_LIST, 0, o, NULL);
if (rest)
supply up to two ops to be direct children of the list op; they are
consumed by this function and become part of the constructed op tree.
+For most list operators, the check function expects all the kid ops to be
+present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
+appropriate. What you want to do in that case is create an op of type
+OP_LIST, append more children to it, and then call L</op_convert_list>.
+See L</op_convert_list> for more information.
+
+
=cut
*/
dVAR;
LISTOP *listop;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
+ || type == OP_CUSTOM);
NewOp(1101, listop, 1, LISTOP);
- CHANGE_TYPE(listop, type);
+ OpTYPE_set(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
else if (!first && last)
first = last;
else if (first)
- OP_SIBLING_set(first, last);
+ OpMORESIB_set(first, last);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
- pushop->op_lastsib = 0;
- OP_SIBLING_set(pushop, first);
+ OpMORESIB_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
- }
+ if (listop->op_last)
+ OpLASTSIB_set(listop->op_last, (OP*)listop);
return CHECKOP(type, listop);
}
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
|| type == OP_SASSIGN
|| type == OP_ENTERTRY
+ || type == OP_CUSTOM
|| type == OP_NULL );
if (!first)
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- CHANGE_TYPE(unop, type);
+ OpTYPE_set(unop, type);
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
+ if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
+ OpLASTSIB_set(first, (OP*)unop);
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
}
/*
+=for apidoc newUNOP_AUX
+
+Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
+initialised to aux
+
+=cut
+*/
+
+OP *
+Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
+{
+ dVAR;
+ UNOP_AUX *unop;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
+ || type == OP_CUSTOM);
+
+ NewOp(1101, unop, 1, UNOP_AUX);
+ unop->op_type = (OPCODE)type;
+ unop->op_ppaddr = PL_ppaddr[type];
+ unop->op_first = first;
+ unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
+ unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
+ unop->op_aux = aux;
+
+ if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
+ OpLASTSIB_set(first, (OP*)unop);
+
+ unop = (UNOP_AUX*) CHECKOP(type, unop);
+
+ return op_std_init((OP *) unop);
+}
+
+/*
=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
Constructs, checks, and returns an op of method type with a method name
dVAR;
METHOP *methop;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
+ || type == OP_CUSTOM);
NewOp(1101, methop, 1, METHOP);
if (dynamic_meth) {
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
-#ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(dynamic_meth))
- dynamic_meth->op_sibling = (OP*)methop;
-#endif
+ if (!OpHAS_SIBLING(dynamic_meth))
+ OpLASTSIB_set(dynamic_meth, (OP*)methop);
}
else {
assert(const_meth);
methop->op_rclass_sv = NULL;
#endif
- CHANGE_TYPE(methop, type);
- methop = (METHOP*) CHECKOP(type, methop);
-
- if (methop->op_next) return (OP*)methop;
-
- return fold_constants(op_integerize(op_std_init((OP *) methop)));
+ OpTYPE_set(methop, type);
+ return CHECKOP(type, methop);
}
OP *
BINOP *binop;
ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
- || type == OP_SASSIGN || type == OP_NULL );
+ || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
NewOp(1101, binop, 1, BINOP);
if (!first)
first = newOP(OP_NULL, 0);
- CHANGE_TYPE(binop, type);
+ OpTYPE_set(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
}
else {
binop->op_private = (U8)(2 | (flags >> 8));
- OP_SIBLING_set(first, last);
- first->op_lastsib = 0;
+ OpMORESIB_set(first, last);
}
-#ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
- last->op_sibling = (OP*)binop;
-#endif
+ if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
+ OpLASTSIB_set(last, (OP*)binop);
- binop->op_last = OP_SIBLING(binop->op_first);
-#ifdef PERL_OP_PARENT
+ binop->op_last = OpSIBLING(binop->op_first);
if (binop->op_last)
- binop->op_last->op_sibling = (OP*)binop;
-#endif
+ OpLASTSIB_set(binop->op_last, (OP*)binop);
binop = (BINOP*)CHECKOP(type, binop);
if (binop->op_next || binop->op_type != (OPCODE)type)
dVAR;
PMOP *pmop;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
+ || type == OP_CUSTOM);
NewOp(1101, pmop, 1, PMOP);
- CHANGE_TYPE(pmop, type);
+ OpTYPE_set(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
+ if (PL_opargs[type] & OA_RETSCALAR)
+ scalar((OP *)pmop);
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
* isreg indicates that the pattern is part of a regex construct, eg
* $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
* split "pattern", which aren't. In the former case, expr will be a list
- * if the pattern contains more than one term (eg /a$b/) or if it contains
- * a replacement, ie s/// or tr///.
+ * if the pattern contains more than one term (eg /a$b/).
*
* When the pattern has been compiled within a new anon CV (for
* qr/(?{...})/ ), then floor indicates the savestack level just before
*/
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
{
- dVAR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
- OP* repl = NULL;
bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
bool is_compiletime;
bool has_code;
PERL_ARGS_ASSERT_PMRUNTIME;
- /* for s/// and tr///, last element in list is the replacement; pop it */
-
- if (is_trans || o->op_type == OP_SUBST) {
- OP* kid;
- repl = cLISTOPx(expr)->op_last;
- kid = cLISTOPx(expr)->op_first;
- while (OP_SIBLING(kid) != repl)
- kid = OP_SIBLING(kid);
- op_sibling_splice(expr, kid, 1, NULL);
- }
-
- /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
-
if (is_trans) {
- OP *first, *last;
-
- assert(expr->op_type == OP_LIST);
- first = cLISTOPx(expr)->op_first;
- last = cLISTOPx(expr)->op_last;
- assert(first->op_type == OP_PUSHMARK);
- assert(OP_SIBLING(first) == last);
-
- /* cut 'last' from sibling chain, then free everything else */
- op_sibling_splice(expr, first, 1, NULL);
- op_free(expr);
-
- return pmtrans(o, last, repl);
+ return pmtrans(o, expr, repl);
}
/* find whether we have any runtime or code elements;
has_code = 0;
if (expr->op_type == OP_LIST) {
OP *o;
- for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
+ for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
has_code = 1;
assert(!o->op_next);
- if (UNLIKELY(!OP_HAS_SIBLING(o))) {
+ if (UNLIKELY(!OpHAS_SIBLING(o))) {
assert(PL_parser && PL_parser->error_count);
/* This can happen with qr/ (?{(^{})/. Just fake up
the op we were expecting to see, to avoid crashing
op_sibling_splice(expr, o, 0,
newSVOP(OP_CONST, 0, &PL_sv_no));
}
- o->op_next = OP_SIBLING(o);
+ o->op_next = OpSIBLING(o);
}
else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
is_compiletime = 0;
if (expr->op_type == OP_LIST) {
OP *o;
- for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
+ for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
assert( !(o->op_flags & OPf_WANT));
LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
/* skip ENTER */
assert(leaveop->op_first->op_type == OP_ENTER);
- assert(OP_HAS_SIBLING(leaveop->op_first));
- o->op_next = OP_SIBLING(leaveop->op_first);
+ assert(OpHAS_SIBLING(leaveop->op_first));
+ o->op_next = OpSIBLING(leaveop->op_first);
/* skip leave */
assert(leaveop->op_flags & OPf_KIDS);
assert(leaveop->op_last->op_next == (OP*)leaveop);
{
OP *sib;
OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
- if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
- && !OP_HAS_SIBLING(sib))
+ if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
+ && !OpHAS_SIBLING(sib))
curop = sib;
}
if (curop->op_type == OP_CONST)
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
- || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || type == OP_CUSTOM);
NewOp(1101, svop, 1, SVOP);
- CHANGE_TYPE(svop, type);
+ OpTYPE_set(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
- || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || type == OP_CUSTOM);
NewOp(1101, padop, 1, PADOP);
- CHANGE_TYPE(padop, type);
+ OpTYPE_set(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
flags &= ~SVf_UTF8;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
- || type == OP_RUNCV
+ || type == OP_RUNCV || type == OP_CUSTOM
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- CHANGE_TYPE(pvop, type);
+ OpTYPE_set(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
flags = o->op_flags;
type = o->op_type;
if (type == OP_COND_EXPR) {
- OP * const sib = OP_SIBLING(cLOGOPo->op_first);
+ OP * const sib = OpSIBLING(cLOGOPo->op_first);
const I32 t = assignment_type(sib);
- const I32 f = assignment_type(OP_SIBLING(sib));
+ const I32 f = assignment_type(OpSIBLING(sib));
if (t == ASSIGN_LIST && f == ASSIGN_LIST)
return ASSIGN_LIST;
S_aassign_common_vars(pTHX_ OP* o)
{
OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
+ for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
|| curop->op_type == OP_AELEMFAST) {
S_aassign_common_vars_aliases_only(pTHX_ OP *o)
{
OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
+ for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
if ((curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
/* Other ops in the list. */
maybe_common_vars = TRUE;
}
- lop = OP_SIBLING(lop);
+ lop = OpSIBLING(lop);
}
}
else if ((left->op_private & OPpLVAL_INTRO)
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- CHANGE_TYPE(cop, OP_DBSTATE);
+ OpTYPE_set(cop, OP_DBSTATE);
}
else {
- CHANGE_TYPE(cop, OP_NEXTSTATE);
+ OpTYPE_set(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
case OP_ENTER:
case OP_NULL:
case OP_NEXTSTATE:
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
break;
default:
if (kid != cLISTOPo->op_last)
} while (kid);
if (!kid)
kid = cLISTOPo->op_last;
-last:
+ last:
return search_const(kid);
}
}
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
+ || type == OP_CUSTOM);
scalarboolean(first);
/* optimize AND and OR ops that have NOTs as children */
if ( ! (o2->op_type == OP_LIST
&& (( o2 = cUNOPx(o2)->op_first))
&& o2->op_type == OP_PUSHMARK
- && (( o2 = OP_SIBLING(o2))) )
+ && (( o2 = OpSIBLING(o2))) )
)
o2 = other;
if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
&& ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
{
const OP * const k1 = ((UNOP*)first)->op_first;
- const OP * const k2 = OP_SIBLING(k1);
+ const OP * const k2 = OpSIBLING(k1);
OPCODE warnop = 0;
switch (first->op_type)
{
/* establish postfix order */
logop->op_next = LINKLIST(first);
first->op_next = (OP*)logop;
- assert(!OP_HAS_SIBLING(first));
+ assert(!OpHAS_SIBLING(first));
op_sibling_splice((OP*)logop, first, 0, other);
CHECKOP(type,logop);
- o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
+ o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
+ PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
+ (OP*)logop);
other->op_next = o;
return o;
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
- dVAR;
LOGOP *range;
OP *flip;
OP *flop;
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
const OP * const k1 = ((UNOP*)expr)->op_first;
- const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
+ const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
const OP * const k1 = ((UNOP*)expr)->op_first;
- const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
+ const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
if (!loop) {
NewOp(1101,loop,1,LOOP);
- CHANGE_TYPE(loop, OP_ENTERLOOP);
+ OpTYPE_set(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- CHANGE_TYPE(sv, OP_RV2GV);
+ OpTYPE_set(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
- OP* const right = OP_SIBLING(left);
+ OP* const right = OpSIBLING(left);
LISTOP* listop;
range->op_flags &= ~OPf_KIDS;
expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
- loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
- op_append_elem(OP_LIST, expr, scalar(sv))));
+ loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
+ op_append_elem(OP_LIST, list(expr),
+ scalar(sv)));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
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 */
+ assert(loop->op_last->op_sibparent == (OP*)loop);
+ OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
{
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
#ifdef PERL_OP_PARENT
- loop->op_last->op_sibling = (OP *)loop;
+ OpLASTSIB_set(loop->op_last, (OP*)loop);
#endif
}
loop->op_targ = padoff;
PERL_ARGS_ASSERT_NEWLOOPEX;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
+ || type == OP_CUSTOM);
if (type != OP_GOTO) {
/* "last()" means "last" */
case OP_AND:
{
- OP* sibl = OP_SIBLING(cLOGOPo->op_first);
+ OP* sibl = OpSIBLING(cLOGOPo->op_first);
ASSUME(sibl);
return (
looks_like_bool(cLOGOPo->op_first)
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
- OP *start;
+ OP *start = NULL;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
if (slab)
Slab_to_ro(slab);
#endif
- if (o) op_free(o);
+ op_free(o);
return cv;
}
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
- OP *start;
+ bool evanescent = FALSE;
+ OP *start = NULL;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
- bool special = FALSE;
#endif
if (o_is_gv) {
: PL_curstash != CopSTASH(PL_curcop)
|| memchr(name, ':', namlen) || memchr(name, '\'', namlen)
? gv_fetch_flags
- : GV_ADDMULTI | GV_NOINIT;
+ : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
const_sv = NULL;
else
const_sv =
- S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
if (PL_parser && PL_parser->error_count)
clear_special_blocks(name, gv, cv);
else
-#ifdef PERL_DEBUG_READONLY_OPS
- special =
-#endif
+ evanescent =
process_special_blocks(floor, name, gv, cv);
}
}
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+ if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
- /* Watch out for BEGIN blocks */
- if (!special && slab)
+ if (slab)
Slab_to_ro(slab);
#endif
+ if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
+ pad_add_weakref(cv);
+ }
return cv;
}
}
}
+/* Returns true if the sub has been freed. */
STATIC bool
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
POPSTACK;
LEAVE;
- return TRUE;
+ return !PL_savebegin;
}
else
return FALSE;
DEBUG_x( dump_sub(gv) );
(void)CvGV(cv);
GvCV_set(gv,0); /* cv has been hijacked */
- return TRUE;
+ return FALSE;
}
}
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
- if (!subaddr)
- Perl_croak_nocontext("panic: no address for '%s' in '%s'",
- name, filename ? filename : PL_xsubfilename);
+
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+ PL_compiling.cop_seq = 0;
}
OP *
OP *
Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
{
- return newUNOP(OP_REFGEN, 0,
+ SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
+ OP * anoncode =
newSVOP(OP_ANONCODE, 0,
- MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
+ cv);
+ if (CvANONCONST(cv))
+ anoncode = newUNOP(OP_ANONCONST, 0,
+ op_convert_list(OP_ENTERSUB,
+ OPf_STACKED|OPf_WANT_SCALAR,
+ anoncode));
+ return newUNOP(OP_REFGEN, 0, anoncode);
}
OP *
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- CHANGE_TYPE(o, OP_RV2HV);
+ OpTYPE_set(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- CHANGE_TYPE(o, OP_PADCV);
+ OpTYPE_set(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADSV);
+ OpTYPE_set(o, OP_PADSV);
+ scalar(o);
return o;
}
return newUNOP(OP_RV2SV, 0, scalar(o));
OP *sibl;
PERL_ARGS_ASSERT_CK_BACKTICK;
/* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
- if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
+ if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
&& (gv = gv_override("readpipe",8)))
{
/* detach rest of siblings from o and its first child */
PERL_ARGS_ASSERT_CK_BITOP;
o->op_private = (U8)(PL_hints & HINT_INTEGER);
+
+ if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
+ || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
+ || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
+ || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
+ "The bitwise feature is experimental");
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
- && (o->op_type == OP_BIT_OR
- || o->op_type == OP_BIT_AND
- || o->op_type == OP_BIT_XOR))
+ && OP_IS_INFIX_BIT(o->op_type))
{
const OP * const left = cBINOPo->op_first;
- const OP * const right = OP_SIBLING(left);
+ const OP * const right = OpSIBLING(left);
if ((OP_IS_NUMCOMPARE(left->op_type) &&
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
(right->op_flags & OPf_PARENS) == 0))
Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Possible precedence problem on bitwise %c operator",
- o->op_type == OP_BIT_OR ? '|'
- : o->op_type == OP_BIT_AND ? '&' : '^'
+ "Possible precedence problem on bitwise %s operator",
+ o->op_type == OP_BIT_OR
+ ||o->op_type == OP_NBIT_OR ? "|"
+ : o->op_type == OP_BIT_AND
+ ||o->op_type == OP_NBIT_AND ? "&"
+ : o->op_type == OP_BIT_XOR
+ ||o->op_type == OP_NBIT_XOR ? "^"
+ : o->op_type == OP_SBIT_OR ? "|."
+ : o->op_type == OP_SBIT_AND ? "&." : "^."
);
}
return o;
if (kid &&
(
( is_dollar_bracket(aTHX_ kid)
- && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
+ && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
)
|| ( kid->op_type == OP_CONST
- && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
+ && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
)
)
)
o = modkids(ck_fun(o), type);
kid = cUNOPo->op_first;
kidkid = kUNOP->op_first;
- newop = OP_SIBLING(kidkid);
+ newop = OpSIBLING(kidkid);
if (newop) {
const OPCODE type = newop->op_type;
- if (OP_HAS_SIBLING(newop))
+ if (OpHAS_SIBLING(newop))
return o;
if (o->op_type == OP_REFGEN
&& ( type == OP_RV2CV
&& ( type == OP_RV2AV || type == OP_PADAV
|| type == OP_RV2HV || type == OP_PADHV))))
NOOP; /* OK (allow srefgen for \@a and \%h) */
- else if (!(PL_opargs[type] & OA_RETSCALAR))
+ else if (OP_GIMME(newop,0) != G_SCALAR)
return o;
}
/* excise first sibling */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
assert(kid);
- if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
+ if (o->op_type == OP_ENTERTRY) {
LOGOP *enter;
/* cut whole sibling chain free from o */
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- CHANGE_TYPE(o, OP_LEAVETRY);
+ OpTYPE_set(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
if (o->op_flags & OPf_STACKED) {
OP *kid;
o = ck_fun(o);
- kid = OP_SIBLING(cUNOPo->op_first);
+ kid = OpSIBLING(cUNOPo->op_first);
if (kid->op_type == OP_RV2GV)
op_null(kid);
}
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- CHANGE_TYPE(kid, OP_GV);
+ OpTYPE_set(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
}
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
- if (PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT) {
+ if (type != OP_STAT && type != OP_LSTAT
+ && PL_check[kidtype] == Perl_ck_ftst
+ && kidtype != OP_STAT && kidtype != OP_LSTAT
+ ) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
if (kidtype == OP_FTTTY && (
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
{
prev_kid = kid;
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
}
if (kid && kid->op_type == OP_COREARGS) {
bool optional = FALSE;
break;
case OA_AVREF:
if ((type == OP_PUSH || type == OP_UNSHIFT)
- && !OP_HAS_SIBLING(kid))
+ && !OpHAS_SIBLING(kid))
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
"Useless use of %s with no values",
PL_op_desc[type]);
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
- bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
+ bad_type_pv(numargs, "array", o, kid);
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
break;
case OA_HVREF:
if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
+ bad_type_pv(numargs, "hash", o, kid);
op_lvalue(kid, type);
break;
case OA_CVREF:
}
else if (kid->op_type == OP_READLINE) {
/* neophyte patrol: open(<FH>), close(<FH>) etc. */
- bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
+ bad_type_pv(numargs, "HANDLE", o, kid);
}
else {
I32 flags = OPf_SPECIAL;
}
oa >>= 4;
prev_kid = kid;
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
}
/* FIXME - should the numargs or-ing move after the too many
* arguments check? */
PERL_ARGS_ASSERT_CK_GLOB;
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
+ if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
OP *
Perl_ck_grep(pTHX_ OP *o)
{
- dVAR;
LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
- kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
+ kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
return no_fh_allowed(o);
o->op_flags &= ~OPf_STACKED;
}
- kid = OP_SIBLING(cLISTOPo->op_first);
+ kid = OpSIBLING(cLISTOPo->op_first);
if (type == OP_MAPWHILE)
list(kid);
else
o = ck_fun(o);
if (PL_parser && PL_parser->error_count)
return o;
- kid = OP_SIBLING(cLISTOPo->op_first);
+ kid = OpSIBLING(cLISTOPo->op_first);
if (kid->op_type != OP_NULL)
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
gwop->op_targ = o->op_targ = offset;
}
- kid = OP_SIBLING(cLISTOPo->op_first);
- for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
+ kid = OpSIBLING(cLISTOPo->op_first);
+ for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_GREPSTART);
return (OP*)gwop;
PERL_ARGS_ASSERT_CK_INDEX;
if (o->op_flags & OPf_KIDS) {
- OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid)
- kid = OP_SIBLING(kid); /* get past "big" */
+ kid = OpSIBLING(kid); /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
SV *sv = kSVOP->op_sv;
}
else {
OP * const newop
- = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+ = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
op_free(o);
return newop;
}
kid = cLISTOPo->op_first;
}
if (kid->op_type == OP_PUSHMARK)
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
if (kid && o->op_flags & OPf_STACKED)
- kid = OP_SIBLING(kid);
- else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
+ kid = OpSIBLING(kid);
+ else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
&& !kid->op_folded) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
/* replace old const op with new OP_RV2GV parent */
kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
OP_RV2GV, OPf_REF);
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
}
}
PERL_ARGS_ASSERT_CK_SMARTMATCH;
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
- OP *second = OP_SIBLING(first);
+ OP *second = OpSIBLING(first);
/* Implicitly take a reference to an array or hash */
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- CHANGE_TYPE(first, OP_QR);
+ OpTYPE_set(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- CHANGE_TYPE(second, OP_QR);
+ OpTYPE_set(second, OP_QR);
}
}
static OP *
S_maybe_targlex(pTHX_ OP *o)
{
- dVAR;
OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_private & OPpTARGET_MY)
)
{
- OP * const kkid = OP_SIBLING(kid);
+ OP * const kkid = OpSIBLING(kid);
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
PERL_ARGS_ASSERT_CK_SASSIGN;
- if (OP_HAS_SIBLING(kid)) {
- OP *kkid = OP_SIBLING(kid);
+ if (OpHAS_SIBLING(kid)) {
+ OP *kkid = OpSIBLING(kid);
/* For state variable assignment with attributes, kkid is a list op
whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
OP *const nullop =
+ newCONDOP(0, first, o, other);
+ /* XXX targlex disabled for now; see ticket #124160
newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
+ */
OP *const condop = first->op_next;
- CHANGE_TYPE(condop, OP_ONCE);
+ OpTYPE_set(condop, OP_ONCE);
other->op_targ = target;
+ nullop->op_flags |= OPf_WANT_SCALAR;
/* Store the initializedness of state vars in a separate
pad entry. */
if ((last->op_type == OP_CONST) && /* The bareword. */
(last->op_private & OPpCONST_BARE) &&
(last->op_private & OPpCONST_STRICT) &&
- (oa = OP_SIBLING(first)) && /* The fh. */
- (oa = OP_SIBLING(oa)) && /* The mode. */
+ (oa = OpSIBLING(first)) && /* The fh. */
+ (oa = OpSIBLING(oa)) && /* The mode. */
(oa->op_type == OP_CONST) &&
SvPOK(((SVOP*)oa)->op_sv) &&
(mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
mode[0] == '>' && mode[1] == '&' && /* A dup open. */
- (last == OP_SIBLING(oa))) /* The bareword. */
+ (last == OpSIBLING(oa))) /* The bareword. */
last->op_private &= ~OPpCONST_STRICT;
}
return ck_fun(o);
}
OP *
+Perl_ck_prototype(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_PROTOTYPE;
+ if (!(o->op_flags & OPf_KIDS)) {
+ op_free(o);
+ return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
+ }
+ return o;
+}
+
+OP *
Perl_ck_refassign(pTHX_ OP *o)
{
OP * const right = cLISTOPo->op_first;
- OP * const left = OP_SIBLING(right);
+ OP * const left = OpSIBLING(right);
OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
bool stacked = 0;
case OP_RV2AV:
o->op_private |= OPpLVREF_AV;
goto checkgv;
+ NOT_REACHED; /* NOTREACHED */
case OP_RV2HV:
o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
case OP_RV2SV:
checkgv:
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
break;
case OP_RV2CV: {
OP * const kidparent =
- cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
OP * const kid = cUNOPx(kidparent)->op_first;
o->op_private |= OPpLVREF_CV;
if (kid->op_type == OP_GV) {
unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
}
- else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
+ && !SvVOK(sv)) {
s = SvPV(sv, len);
if (SvREFCNT(sv) > 1) {
kid->op_sv = newSVpvn_share(
return newop;
}
- return scalar(ck_fun(o));
+ return ck_fun(o);
}
OP *
PERL_ARGS_ASSERT_CK_RETURN;
- kid = OP_SIBLING(cLISTOPo->op_first);
+ kid = OpSIBLING(cLISTOPo->op_first);
if (CvLVALUE(PL_compcv)) {
- for (; kid; kid = OP_SIBLING(kid))
+ for (; kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
PERL_ARGS_ASSERT_CK_SELECT;
if (o->op_flags & OPf_KIDS) {
- kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
- if (kid && OP_HAS_SIBLING(kid)) {
- CHANGE_TYPE(o, OP_SSELECT);
+ kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
+ if (kid && OpHAS_SIBLING(kid)) {
+ OpTYPE_set(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
}
o = ck_fun(o);
- kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && kid->op_type == OP_RV2GV)
kid->op_private &= ~HINT_STRICT_REFS;
return o;
if (o->op_flags & OPf_STACKED)
simplify_sort(o);
- firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
else {
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
- cUNOPx(firstkid)->op_first = padop;
-#ifdef PERL_OP_PARENT
- padop->op_sibling = firstkid;
-#endif
+ /* replace the const op with the pad op */
+ op_sibling_splice(firstkid, NULL, 1, padop);
op_free(kid);
}
}
}
- firstkid = OP_SIBLING(firstkid);
+ firstkid = OpSIBLING(firstkid);
}
- for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
+ for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
/* provide list context for arguments */
list(kid);
if (stacked)
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
- OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
OP *k;
int descending;
GV *gv;
: "my",
PadnamePV(name));
}
- } while ((kid = OP_SIBLING(kid)));
+ } while ((kid = OpSIBLING(kid)));
return;
}
kid = kBINOP->op_first; /* get past cmp */
o->op_private |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
- kid = OP_SIBLING(cLISTOPo->op_first);
+ kid = OpSIBLING(cLISTOPo->op_first);
/* cut out and delete old block (second sibling) */
op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
op_free(kid);
Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
/* delete leading NULL node, then add a CONST if no other nodes */
op_sibling_splice(o, NULL, 1,
- OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
+ OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
op_free(kid);
kid = cLISTOPo->op_first;
/* remove kid, and replace with new optree */
op_sibling_splice(o, NULL, 1, NULL);
/* OPf_SPECIAL is used to trigger split " " behavior */
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
- CHANGE_TYPE(kid, OP_PUSHRE);
+ OpTYPE_set(kid, OP_PUSHRE);
+ /* target implies @ary=..., so wipe it */
+ kid->op_targ = 0;
scalar(kid);
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
"Use of /g modifier is meaningless in split");
}
- if (!OP_HAS_SIBLING(kid))
+ if (!OpHAS_SIBLING(kid))
op_append_elem(OP_SPLIT, o, newDEFSVOP());
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
assert(kid);
scalar(kid);
- if (!OP_HAS_SIBLING(kid))
+ if (!OpHAS_SIBLING(kid))
{
op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
o->op_private |= OPpSPLIT_IMPLIM;
}
- assert(OP_HAS_SIBLING(kid));
+ assert(OpHAS_SIBLING(kid));
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
scalar(kid);
- if (OP_HAS_SIBLING(kid))
+ if (OpHAS_SIBLING(kid))
return too_many_arguments_pv(o,OP_DESC(o), 0);
return o;
OP *
Perl_ck_stringify(pTHX_ OP *o)
{
- OP * const kid = OP_SIBLING(cUNOPo->op_first);
+ OP * const kid = OpSIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
- || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
- || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
{
- assert(!OP_HAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
return kid;
OP *
Perl_ck_join(pTHX_ OP *o)
{
- OP * const kid = OP_SIBLING(cLISTOPo->op_first);
+ OP * const kid = OpSIBLING(cLISTOPo->op_first);
PERL_ARGS_ASSERT_CK_JOIN;
|| ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
&& !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
{
- const OP * const bairn = OP_SIBLING(kid); /* the list */
- if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
- && PL_opargs[bairn->op_type] & OA_RETSCALAR)
+ const OP * const bairn = OpSIBLING(kid); /* the list */
+ if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
+ && OP_GIMME(bairn,0) == G_SCALAR)
{
OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
op_sibling_splice(o, kid, 1, NULL));
CV *compcv = PL_compcv;
while (PadnameOUTER(name)) {
assert(PARENT_PAD_INDEX(name));
- compcv = CvOUTSIDE(PL_compcv);
+ compcv = CvOUTSIDE(compcv);
name = PadlistNAMESARRAY(CvPADLIST(compcv))
[off = PARENT_PAD_INDEX(name)];
}
OP *aop;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
aop = cUNOPx(entersubop)->op_first;
- if (!OP_HAS_SIBLING(aop))
+ if (!OpHAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
+ for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
list(aop);
op_lvalue(aop, OP_ENTERSUB);
}
proto_end = proto + proto_len;
parent = entersubop;
aop = cUNOPx(entersubop)->op_first;
- if (!OP_HAS_SIBLING(aop)) {
+ if (!OpHAS_SIBLING(aop)) {
parent = aop;
aop = cUNOPx(aop)->op_first;
}
prev = aop;
- aop = OP_SIBLING(aop);
- for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
+ aop = OpSIBLING(aop);
+ for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
while (aop != cvop) {
OP* o3 = aop;
!= OP_ANONCODE
&& cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
!= OP_RV2CV))
- bad_type_gv(arg,
- arg == 1 ? "block or sub {}" : "sub {}",
- namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3,
+ arg == 1 ? "block or sub {}" : "sub {}");
break;
case '*':
/* '*' allows any scalar type, including bareword */
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
- (int)(end - p), p),
- namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3,
+ Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
} else
goto oops;
break;
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type_gv(arg, "symbol", namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3, "symbol");
break;
case '&':
if (o3->op_type == OP_ENTERSUB
&& !(o3->op_flags & OPf_STACKED))
goto wrapref;
if (!contextclass)
- bad_type_gv(arg, "subroutine", namegv, 0,
- o3);
+ bad_type_gv(arg, namegv, o3, "subroutine");
break;
case '$':
if (o3->op_type == OP_RV2SV ||
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type_gv(arg, "scalar", namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3, "scalar");
}
break;
case '@':
goto wrapref;
}
if (!contextclass)
- bad_type_gv(arg, "array", namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3, "array");
break;
case '%':
if (o3->op_type == OP_RV2HV ||
goto wrapref;
}
if (!contextclass)
- bad_type_gv(arg, "hash", namegv, 0, o3);
+ bad_type_gv(arg, namegv, o3, "hash");
break;
wrapref:
aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
op_lvalue(aop, OP_ENTERSUB);
prev = aop;
- aop = OP_SIBLING(aop);
+ aop = OpSIBLING(aop);
}
if (aop == cvop && *proto == '_') {
/* generate an access to $_ */
if (!opnum) {
OP *cvop;
- if (!OP_HAS_SIBLING(aop))
+ if (!OpHAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- aop = OP_SIBLING(aop);
- for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
+ aop = OpSIBLING(aop);
+ for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
if (aop != cvop)
(void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
)
);
}
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
}
else {
OP *prev, *cvop, *first, *parent;
U32 flags = 0;
parent = entersubop;
- if (!OP_HAS_SIBLING(aop)) {
+ if (!OpHAS_SIBLING(aop)) {
parent = aop;
aop = cUNOPx(aop)->op_first;
}
first = prev = aop;
- aop = OP_SIBLING(aop);
+ aop = OpSIBLING(aop);
/* find last sibling */
for (cvop = aop;
- OP_HAS_SIBLING(cvop);
- prev = cvop, cvop = OP_SIBLING(cvop))
+ OpHAS_SIBLING(cvop);
+ prev = cvop, cvop = OpSIBLING(cvop))
;
if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
- /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
+ /* Usually, OPf_SPECIAL on an op with no args means that it had
* parens, but these have their own meaning for that flag: */
&& opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
&& opnum != OP_DELETE && opnum != OP_EXISTS)
return op_convert_list(opnum,0,aop);
}
}
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
return entersubop;
}
argument for it is returned in I<*ckobj_p>. The function is intended
to be called in this manner:
- entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
+ entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
In this call, I<entersubop> is a pointer to the C<entersub> op,
which may be replaced by the check function, and I<namegv> is a GV
}
}
+static void
+S_entersub_alloc_targ(pTHX_ OP * const o)
+{
+ o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
+ o->op_private |= OPpENTERSUB_HASTARG;
+}
+
OP *
Perl_ck_subr(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_SUBR;
aop = cUNOPx(o)->op_first;
- if (!OP_HAS_SIBLING(aop))
+ if (!OpHAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- aop = OP_SIBLING(aop);
- for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
+ aop = OpSIBLING(aop);
+ for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
o->op_private &= ~1;
- o->op_private |= OPpENTERSUB_HASTARG;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
const_class = &cSVOPx(aop)->op_sv;
}
else if (aop->op_type == OP_LIST) {
- OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
+ OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
if (sib && sib->op_type == OP_CONST) {
sib->op_private &= ~OPpCONST_STRICT;
const_class = &cSVOPx(sib)->op_sv;
}
/* make class name a shared cow string to speedup method calls */
/* constant string might be replaced with object, f.e. bigint */
- if (const_class && !SvROK(*const_class)) {
+ if (const_class && SvPOK(*const_class)) {
STRLEN len;
const char* str = SvPV(*const_class, len);
if (len) {
SV* const shared = newSVpvn_share(
- str, SvUTF8(*const_class) ? -len : len, 0
+ str, SvUTF8(*const_class)
+ ? -(SSize_t)len : (SSize_t)len,
+ 0
);
+ if (SvREADONLY(*const_class))
+ SvREADONLY_on(shared);
SvREFCNT_dec(*const_class);
*const_class = shared;
}
}
if (!cv) {
+ S_entersub_alloc_targ(aTHX_ o);
return ck_entersub_args_list(o);
} else {
Perl_call_checker ckfun;
SV *ckobj;
U8 flags;
S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ if (CvISXSUB(cv) || !CvROOT(cv))
+ S_entersub_alloc_targ(aTHX_ o);
if (!namegv) {
/* The original call checker API guarantees that a GV will be
be provided with the right name. So, if the old API was
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = (SVOP*)OP_SIBLING(kid);
+ kid = (SVOP*)OpSIBLING(kid);
if (kid && kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE) &&
!kid->op_folded)
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = OP_SIBLING(kid);
+ kid = OpSIBLING(kid);
if (kid)
kid->op_flags |= OPf_MOD;
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first;
- if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
+ if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
}
return o;
break;
case OP_PADAV:
case OP_RV2AV:
- CHANGE_TYPE(o, array_type);
+ OpTYPE_set(o, array_type);
break;
case OP_CONST:
if (kid->op_private == OPpCONST_BARE
/* we let ck_fun handle it */
break;
default:
- CHANGE_TYPE(o, ref_type);
+ OpTYPE_set(o, ref_type);
scalar(kid);
}
}
assert(cUNOPo->op_first->op_type == OP_NULL);
modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
assert(modop_pushmark->op_type == OP_PUSHMARK);
- modop = OP_SIBLING(modop_pushmark);
+ modop = OpSIBLING(modop_pushmark);
if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
return;
/* no other operation except sort/reverse */
- if (OP_HAS_SIBLING(modop))
+ if (OpHAS_SIBLING(modop))
return;
assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
- if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
+ if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
if (modop->op_flags & OPf_STACKED) {
/* skip sort subroutine/block */
assert(oright->op_type == OP_NULL);
- oright = OP_SIBLING(oright);
+ oright = OpSIBLING(oright);
}
- assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
- oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
+ assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
assert(oleft_pushmark->op_type == OP_PUSHMARK);
- oleft = OP_SIBLING(oleft_pushmark);
+ oleft = OpSIBLING(oleft_pushmark);
/* Check the lhs is an array */
if (!oleft ||
(oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
- || OP_HAS_SIBLING(oleft)
+ || OpHAS_SIBLING(oleft)
|| (oleft->op_private & OPpLVAL_INTRO)
)
return;
/* Only one thing on the rhs */
- if (OP_HAS_SIBLING(oright))
+ if (OpHAS_SIBLING(oright))
return;
/* check the array is the same on both sides */
+/* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
+ * that potentially represent a series of one or more aggregate derefs
+ * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
+ * the whole chain to a single OP_MULTIDEREF op (maybe with a few
+ * additional ops left in too).
+ *
+ * The caller will have already verified that the first few ops in the
+ * chain following 'start' indicate a multideref candidate, and will have
+ * set 'orig_o' to the point further on in the chain where the first index
+ * expression (if any) begins. 'orig_action' specifies what type of
+ * beginning has already been determined by the ops between start..orig_o
+ * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
+ *
+ * 'hints' contains any hints flags that need adding (currently just
+ * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
+ */
+
+void
+S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
+{
+ dVAR;
+ int pass;
+ UNOP_AUX_item *arg_buf = NULL;
+ bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
+ int index_skip = -1; /* don't output index arg on this action */
+
+ /* similar to regex compiling, do two passes; the first pass
+ * determines whether the op chain is convertible and calculates the
+ * buffer size; the second pass populates the buffer and makes any
+ * changes necessary to ops (such as moving consts to the pad on
+ * threaded builds).
+ *
+ * NB: for things like Coverity, note that both passes take the same
+ * path through the logic tree (except for 'if (pass)' bits), since
+ * both passes are following the same op_next chain; and in
+ * particular, if it would return early on the second pass, it would
+ * already have returned early on the first pass.
+ */
+ for (pass = 0; pass < 2; pass++) {
+ OP *o = orig_o;
+ UV action = orig_action;
+ OP *first_elem_op = NULL; /* first seen aelem/helem */
+ OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
+ int action_count = 0; /* number of actions seen so far */
+ int action_ix = 0; /* action_count % (actions per IV) */
+ bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
+ bool is_last = FALSE; /* no more derefs to follow */
+ bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
+ UNOP_AUX_item *arg = arg_buf;
+ UNOP_AUX_item *action_ptr = arg_buf;
+
+ if (pass)
+ action_ptr->uv = 0;
+ arg++;
+
+ switch (action) {
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ case MDEREF_HV_gvhv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+ case MDEREF_AV_gvav_aelem:
+ if (pass) {
+#ifdef USE_ITHREADS
+ arg->pad_offset = cPADOPx(start)->op_padix;
+ /* stop it being swiped when nulled */
+ cPADOPx(start)->op_padix = 0;
+#else
+ arg->sv = cSVOPx(start)->op_sv;
+ cSVOPx(start)->op_sv = NULL;
+#endif
+ }
+ arg++;
+ break;
+
+ case MDEREF_HV_padhv_helem:
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem:
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ if (pass) {
+ arg->pad_offset = start->op_targ;
+ /* we skip setting op_targ = 0 for now, since the intact
+ * OP_PADXV is needed by S_check_hash_fields_and_hekify */
+ reset_start_targ = TRUE;
+ }
+ arg++;
+ break;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_pop_rv2av_aelem:
+ break;
+
+ default:
+ NOT_REACHED; /* NOTREACHED */
+ return;
+ }
+
+ while (!is_last) {
+ /* look for another (rv2av/hv; get index;
+ * aelem/helem/exists/delele) sequence */
+
+ OP *kid;
+ bool is_deref;
+ bool ok;
+ UV index_type = MDEREF_INDEX_none;
+
+ if (action_count) {
+ /* if this is not the first lookup, consume the rv2av/hv */
+
+ /* for N levels of aggregate lookup, we normally expect
+ * that the first N-1 [ah]elem ops will be flagged as
+ * /DEREF (so they autovivifiy if necessary), and the last
+ * lookup op not to be.
+ * For other things (like @{$h{k1}{k2}}) extra scope or
+ * leave ops can appear, so abandon the effort in that
+ * case */
+ if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
+ return;
+
+ /* rv2av or rv2hv sKR/1 */
+
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
+ return;
+
+ /* at this point, we wouldn't expect any of these
+ * possible private flags:
+ * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
+ * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
+ */
+ ASSUME(!(o->op_private &
+ ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
+
+ hints = (o->op_private & OPpHINT_STRICT_REFS);
+
+ /* make sure the type of the previous /DEREF matches the
+ * type of the next lookup */
+ ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
+ top_op = o;
+
+ action = next_is_hash
+ ? MDEREF_HV_vivify_rv2hv_helem
+ : MDEREF_AV_vivify_rv2av_aelem;
+ o = o->op_next;
+ }
+
+ /* if this is the second pass, and we're at the depth where
+ * previously we encountered a non-simple index expression,
+ * stop processing the index at this point */
+ if (action_count != index_skip) {
+
+ /* look for one or more simple ops that return an array
+ * index or hash key */
+
+ switch (o->op_type) {
+ case OP_PADSV:
+ /* it may be a lexical var index */
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ ASSUME(!(o->op_private &
+ ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
+
+ if ( OP_GIMME(o,0) == G_SCALAR
+ && !(o->op_flags & (OPf_REF|OPf_MOD))
+ && o->op_private == 0)
+ {
+ if (pass)
+ arg->pad_offset = o->op_targ;
+ arg++;
+ index_type = MDEREF_INDEX_padsv;
+ o = o->op_next;
+ }
+ break;
+
+ case OP_CONST:
+ if (next_is_hash) {
+ /* it's a constant hash index */
+ if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
+ /* "use constant foo => FOO; $h{+foo}" for
+ * some weird FOO, can leave you with constants
+ * that aren't simple strings. It's not worth
+ * the extra hassle for those edge cases */
+ break;
+
+ if (pass) {
+ UNOP *rop = NULL;
+ OP * helem_op = o->op_next;
+
+ ASSUME( helem_op->op_type == OP_HELEM
+ || helem_op->op_type == OP_NULL);
+ if (helem_op->op_type == OP_HELEM) {
+ rop = (UNOP*)(((BINOP*)helem_op)->op_first);
+ if ( helem_op->op_private & OPpLVAL_INTRO
+ || rop->op_type != OP_RV2HV
+ )
+ rop = NULL;
+ }
+ S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
+
+#ifdef USE_ITHREADS
+ /* Relocate sv to the pad for thread safety */
+ op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
+ arg->pad_offset = o->op_targ;
+ o->op_targ = 0;
+#else
+ arg->sv = cSVOPx_sv(o);
+#endif
+ }
+ }
+ else {
+ /* it's a constant array index */
+ IV iv;
+ SV *ix_sv = cSVOPo->op_sv;
+ if (!SvIOK(ix_sv))
+ break;
+ iv = SvIV(ix_sv);
+
+ if ( action_count == 0
+ && iv >= -128
+ && iv <= 127
+ && ( action == MDEREF_AV_padav_aelem
+ || action == MDEREF_AV_gvav_aelem)
+ )
+ maybe_aelemfast = TRUE;
+
+ if (pass) {
+ arg->iv = iv;
+ SvREFCNT_dec_NN(cSVOPo->op_sv);
+ }
+ }
+ if (pass)
+ /* we've taken ownership of the SV */
+ cSVOPo->op_sv = NULL;
+ arg++;
+ index_type = MDEREF_INDEX_const;
+ o = o->op_next;
+ break;
+
+ case OP_GV:
+ /* it may be a package var index */
+
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
+ ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
+ if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
+ || o->op_private != 0
+ )
+ break;
+
+ kid = o->op_next;
+ if (kid->op_type != OP_RV2SV)
+ break;
+
+ ASSUME(!(kid->op_flags &
+ ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
+ |OPf_SPECIAL|OPf_PARENS)));
+ ASSUME(!(kid->op_private &
+ ~(OPpARG1_MASK
+ |OPpHINT_STRICT_REFS|OPpOUR_INTRO
+ |OPpDEREF|OPpLVAL_INTRO)));
+ if( (kid->op_flags &~ OPf_PARENS)
+ != (OPf_WANT_SCALAR|OPf_KIDS)
+ || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
+ )
+ break;
+
+ if (pass) {
+#ifdef USE_ITHREADS
+ arg->pad_offset = cPADOPx(o)->op_padix;
+ /* stop it being swiped when nulled */
+ cPADOPx(o)->op_padix = 0;
+#else
+ arg->sv = cSVOPx(o)->op_sv;
+ cSVOPo->op_sv = NULL;
+#endif
+ }
+ arg++;
+ index_type = MDEREF_INDEX_gvsv;
+ o = kid->op_next;
+ break;
+
+ } /* switch */
+ } /* action_count != index_skip */
+
+ action |= index_type;
+
+
+ /* at this point we have either:
+ * * detected what looks like a simple index expression,
+ * and expect the next op to be an [ah]elem, or
+ * an nulled [ah]elem followed by a delete or exists;
+ * * found a more complex expression, so something other
+ * than the above follows.
+ */
+
+ /* possibly an optimised away [ah]elem (where op_next is
+ * exists or delete) */
+ if (o->op_type == OP_NULL)
+ o = o->op_next;
+
+ /* at this point we're looking for an OP_AELEM, OP_HELEM,
+ * OP_EXISTS or OP_DELETE */
+
+ /* if something like arybase (a.k.a $[ ) is in scope,
+ * abandon optimisation attempt */
+ if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
+ && PL_check[o->op_type] != Perl_ck_null)
+ return;
+
+ if ( o->op_type != OP_AELEM
+ || (o->op_private &
+ (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
+ )
+ maybe_aelemfast = FALSE;
+
+ /* look for aelem/helem/exists/delete. If it's not the last elem
+ * lookup, it *must* have OPpDEREF_AV/HV, but not many other
+ * flags; if it's the last, then it mustn't have
+ * OPpDEREF_AV/HV, but may have lots of other flags, like
+ * OPpLVAL_INTRO etc
+ */
+
+ if ( index_type == MDEREF_INDEX_none
+ || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
+ && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
+ )
+ ok = FALSE;
+ else {
+ /* we have aelem/helem/exists/delete with valid simple index */
+
+ is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
+ && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
+ || (o->op_private & OPpDEREF) == OPpDEREF_HV);
+
+ if (is_deref) {
+ ASSUME(!(o->op_flags &
+ ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
+ ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
+
+ ok = (o->op_flags &~ OPf_PARENS)
+ == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
+ && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
+ }
+ else if (o->op_type == OP_EXISTS) {
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
+ ok = !(o->op_private & ~OPpARG1_MASK);
+ }
+ else if (o->op_type == OP_DELETE) {
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ ASSUME(!(o->op_private &
+ ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
+ /* don't handle slices or 'local delete'; the latter
+ * is fairly rare, and has a complex runtime */
+ ok = !(o->op_private & ~OPpARG1_MASK);
+ if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
+ /* skip handling run-tome error */
+ ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
+ }
+ else {
+ ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
+ |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
+ ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
+ |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
+ ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
+ }
+ }
+
+ if (ok) {
+ if (!first_elem_op)
+ first_elem_op = o;
+ top_op = o;
+ if (is_deref) {
+ next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
+ o = o->op_next;
+ }
+ else {
+ is_last = TRUE;
+ action |= MDEREF_FLAG_last;
+ }
+ }
+ else {
+ /* at this point we have something that started
+ * promisingly enough (with rv2av or whatever), but failed
+ * to find a simple index followed by an
+ * aelem/helem/exists/delete. If this is the first action,
+ * give up; but if we've already seen at least one
+ * aelem/helem, then keep them and add a new action with
+ * MDEREF_INDEX_none, which causes it to do the vivify
+ * from the end of the previous lookup, and do the deref,
+ * but stop at that point. So $a[0][expr] will do one
+ * av_fetch, vivify and deref, then continue executing at
+ * expr */
+ if (!action_count)
+ return;
+ is_last = TRUE;
+ index_skip = action_count;
+ action |= MDEREF_FLAG_last;
+ }
+
+ if (pass)
+ action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
+ action_ix++;
+ action_count++;
+ /* if there's no space for the next action, create a new slot
+ * for it *before* we start adding args for that action */
+ if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
+ action_ptr = arg;
+ if (pass)
+ arg->uv = 0;
+ arg++;
+ action_ix = 0;
+ }
+ } /* while !is_last */
+
+ /* success! */
+
+ if (pass) {
+ OP *mderef;
+ OP *p, *q;
+
+ mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
+ if (index_skip == -1) {
+ mderef->op_flags = o->op_flags
+ & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
+ if (o->op_type == OP_EXISTS)
+ mderef->op_private = OPpMULTIDEREF_EXISTS;
+ else if (o->op_type == OP_DELETE)
+ mderef->op_private = OPpMULTIDEREF_DELETE;
+ else
+ mderef->op_private = o->op_private
+ & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
+ }
+ /* accumulate strictness from every level (although I don't think
+ * they can actually vary) */
+ mderef->op_private |= hints;
+
+ /* integrate the new multideref op into the optree and the
+ * op_next chain.
+ *
+ * In general an op like aelem or helem has two child
+ * sub-trees: the aggregate expression (a_expr) and the
+ * index expression (i_expr):
+ *
+ * aelem
+ * |
+ * a_expr - i_expr
+ *
+ * The a_expr returns an AV or HV, while the i-expr returns an
+ * index. In general a multideref replaces most or all of a
+ * multi-level tree, e.g.
+ *
+ * exists
+ * |
+ * ex-aelem
+ * |
+ * rv2av - i_expr1
+ * |
+ * helem
+ * |
+ * rv2hv - i_expr2
+ * |
+ * aelem
+ * |
+ * a_expr - i_expr3
+ *
+ * With multideref, all the i_exprs will be simple vars or
+ * constants, except that i_expr1 may be arbitrary in the case
+ * of MDEREF_INDEX_none.
+ *
+ * The bottom-most a_expr will be either:
+ * 1) a simple var (so padXv or gv+rv2Xv);
+ * 2) a simple scalar var dereferenced (e.g. $r->[0]):
+ * so a simple var with an extra rv2Xv;
+ * 3) or an arbitrary expression.
+ *
+ * 'start', the first op in the execution chain, will point to
+ * 1),2): the padXv or gv op;
+ * 3): the rv2Xv which forms the last op in the a_expr
+ * execution chain, and the top-most op in the a_expr
+ * subtree.
+ *
+ * For all cases, the 'start' node is no longer required,
+ * but we can't free it since one or more external nodes
+ * may point to it. E.g. consider
+ * $h{foo} = $a ? $b : $c
+ * Here, both the op_next and op_other branches of the
+ * cond_expr point to the gv[*h] of the hash expression, so
+ * we can't free the 'start' op.
+ *
+ * For expr->[...], we need to save the subtree containing the
+ * expression; for the other cases, we just need to save the
+ * start node.
+ * So in all cases, we null the start op and keep it around by
+ * making it the child of the multideref op; for the expr->
+ * case, the expr will be a subtree of the start node.
+ *
+ * So in the simple 1,2 case the optree above changes to
+ *
+ * ex-exists
+ * |
+ * multideref
+ * |
+ * ex-gv (or ex-padxv)
+ *
+ * with the op_next chain being
+ *
+ * -> ex-gv -> multideref -> op-following-ex-exists ->
+ *
+ * In the 3 case, we have
+ *
+ * ex-exists
+ * |
+ * multideref
+ * |
+ * ex-rv2xv
+ * |
+ * rest-of-a_expr
+ * subtree
+ *
+ * and
+ *
+ * -> rest-of-a_expr subtree ->
+ * ex-rv2xv -> multideref -> op-following-ex-exists ->
+ *
+ *
+ * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
+ * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
+ * multideref attached as the child, e.g.
+ *
+ * exists
+ * |
+ * ex-aelem
+ * |
+ * ex-rv2av - i_expr1
+ * |
+ * multideref
+ * |
+ * ex-whatever
+ *
+ */
+
+ /* if we free this op, don't free the pad entry */
+ if (reset_start_targ)
+ start->op_targ = 0;
+
+
+ /* Cut the bit we need to save out of the tree and attach to
+ * the multideref op, then free the rest of the tree */
+
+ /* find parent of node to be detached (for use by splice) */
+ p = first_elem_op;
+ if ( orig_action == MDEREF_AV_pop_rv2av_aelem
+ || orig_action == MDEREF_HV_pop_rv2hv_helem)
+ {
+ /* there is an arbitrary expression preceding us, e.g.
+ * expr->[..]? so we need to save the 'expr' subtree */
+ if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
+ p = cUNOPx(p)->op_first;
+ ASSUME( start->op_type == OP_RV2AV
+ || start->op_type == OP_RV2HV);
+ }
+ else {
+ /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
+ * above for exists/delete. */
+ while ( (p->op_flags & OPf_KIDS)
+ && cUNOPx(p)->op_first != start
+ )
+ p = cUNOPx(p)->op_first;
+ }
+ ASSUME(cUNOPx(p)->op_first == start);
+
+ /* detach from main tree, and re-attach under the multideref */
+ op_sibling_splice(mderef, NULL, 0,
+ op_sibling_splice(p, NULL, 1, NULL));
+ op_null(start);
+
+ start->op_next = mderef;
+
+ mderef->op_next = index_skip == -1 ? o->op_next : o;
+
+ /* excise and free the original tree, and replace with
+ * the multideref op */
+ p = op_sibling_splice(top_op, NULL, -1, mderef);
+ while (p) {
+ q = OpSIBLING(p);
+ op_free(p);
+ p = q;
+ }
+ op_null(top_op);
+ }
+ else {
+ Size_t size = arg - arg_buf;
+
+ if (maybe_aelemfast && action_count == 1)
+ return;
+
+ arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
+ sizeof(UNOP_AUX_item) * (size + 1));
+ /* for dumping etc: store the length in a hidden first slot;
+ * we set the op_aux pointer to the second slot */
+ arg_buf->uv = size;
+ arg_buf++;
+ }
+ } /* for (pass = ...) */
+}
+
+
+
/* mechanism for deferring recursion in rpeep() */
#define MAX_DEFERRED 4
o->op_opt = 1;
PL_op = o;
+ /* look for a series of 1 or more aggregate derefs, e.g.
+ * $a[1]{foo}[$i]{$k}
+ * and replace with a single OP_MULTIDEREF op.
+ * Each index must be either a const, or a simple variable,
+ *
+ * First, look for likely combinations of starting ops,
+ * corresponding to (global and lexical variants of)
+ * $a[...] $h{...}
+ * $r->[...] $r->{...}
+ * (preceding expression)->[...]
+ * (preceding expression)->{...}
+ * and if so, call maybe_multideref() to do a full inspection
+ * of the op chain and if appropriate, replace with an
+ * OP_MULTIDEREF
+ */
+ {
+ UV action;
+ OP *o2 = o;
+ U8 hints = 0;
+
+ switch (o2->op_type) {
+ case OP_GV:
+ /* $pkg[..] : gv[*pkg]
+ * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
+
+ /* Fail if there are new op flag combinations that we're
+ * not aware of, rather than:
+ * * silently failing to optimise, or
+ * * silently optimising the flag away.
+ * If this ASSUME starts failing, examine what new flag
+ * has been added to the op, and decide whether the
+ * optimisation should still occur with that flag, then
+ * update the code accordingly. This applies to all the
+ * other ASSUMEs in the block of code too.
+ */
+ ASSUME(!(o2->op_flags &
+ ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
+ ASSUME(!(o2->op_private & ~OPpEARLY_CV));
+
+ o2 = o2->op_next;
+
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_gvav_aelem;
+ goto do_deref;
+ }
+
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_gvhv_helem;
+ goto do_deref;
+ }
+
+ if (o2->op_type != OP_RV2SV)
+ break;
+
+ /* at this point we've seen gv,rv2sv, so the only valid
+ * construct left is $pkg->[] or $pkg->{} */
+
+ ASSUME(!(o2->op_flags & OPf_STACKED));
+ if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_MOD))
+ break;
+
+ ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
+ |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
+ if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
+ break;
+ if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
+ && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
+ break;
+
+ o2 = o2->op_next;
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
+ goto do_deref;
+ }
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
+ goto do_deref;
+ }
+ break;
+
+ case OP_PADSV:
+ /* $lex->[...]: padsv[$lex] sM/DREFAV */
+
+ ASSUME(!(o2->op_flags &
+ ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ if ((o2->op_flags &
+ (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_MOD))
+ break;
+
+ ASSUME(!(o2->op_private &
+ ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
+ /* skip if state or intro, or not a deref */
+ if ( o2->op_private != OPpDEREF_AV
+ && o2->op_private != OPpDEREF_HV)
+ break;
+
+ o2 = o2->op_next;
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_padsv_vivify_rv2av_aelem;
+ goto do_deref;
+ }
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_padsv_vivify_rv2hv_helem;
+ goto do_deref;
+ }
+ break;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ /* $lex[..]: padav[@lex:1,2] sR *
+ * or $lex{..}: padhv[%lex:1,2] sR */
+ ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
+ OPf_REF|OPf_SPECIAL)));
+ if ((o2->op_flags &
+ (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_REF))
+ break;
+ if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
+ break;
+ /* OPf_PARENS isn't currently used in this case;
+ * if that changes, let us know! */
+ ASSUME(!(o2->op_flags & OPf_PARENS));
+
+ /* at this point, we wouldn't expect any of the remaining
+ * possible private flags:
+ * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
+ * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
+ *
+ * OPpSLICEWARNING shouldn't affect runtime
+ */
+ ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
+
+ action = o2->op_type == OP_PADAV
+ ? MDEREF_AV_padav_aelem
+ : MDEREF_HV_padhv_helem;
+ o2 = o2->op_next;
+ S_maybe_multideref(aTHX_ o, o2, action, 0);
+ break;
+
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ action = o2->op_type == OP_RV2AV
+ ? MDEREF_AV_pop_rv2av_aelem
+ : MDEREF_HV_pop_rv2hv_helem;
+ /* FALLTHROUGH */
+ do_deref:
+ /* (expr)->[...]: rv2av sKR/1;
+ * (expr)->{...}: rv2hv sKR/1; */
+
+ ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
+
+ ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
+ if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
+ break;
+
+ /* at this point, we wouldn't expect any of these
+ * possible private flags:
+ * OPpMAYBE_LVSUB, OPpLVAL_INTRO
+ * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
+ */
+ ASSUME(!(o2->op_private &
+ ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
+ |OPpOUR_INTRO)));
+ hints |= (o2->op_private & OPpHINT_STRICT_REFS);
+
+ o2 = o2->op_next;
+
+ S_maybe_multideref(aTHX_ o, o2, action, hints);
+ break;
+
+ default:
+ break;
+ }
+ }
+
switch (o->op_type) {
case OP_DBSTATE:
*/
{
OP *next = o->op_next;
- OP *sibling = OP_SIBLING(o);
+ OP *sibling = OpSIBLING(o);
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
||OP_TYPE_IS(sibling->op_next->op_next,
OP_LEAVESUBLV))
&& cUNOPx(sibling)->op_first == next
- && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
+ && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
&& next->op_next
) {
/* Look through the PUSHMARK's siblings for one that
* points to the RETURN */
- OP *top = OP_SIBLING(next);
+ OP *top = OpSIBLING(next);
while (top && top->op_next) {
if (top->op_next == sibling) {
top->op_next = sibling->op_next;
o->op_next = next->op_next;
break;
}
- top = OP_SIBLING(top);
+ top = OpSIBLING(top);
}
}
}
/* we assume here that the op_next chain is the same as
* the op_sibling chain */
- assert(OP_SIBLING(o) == pad1);
- assert(OP_SIBLING(pad1) == ns2);
- assert(OP_SIBLING(ns2) == pad2);
- assert(OP_SIBLING(pad2) == ns3);
+ assert(OpSIBLING(o) == pad1);
+ assert(OpSIBLING(pad1) == ns2);
+ assert(OpSIBLING(ns2) == pad2);
+ assert(OpSIBLING(pad2) == ns3);
+
+ /* excise and delete ns2 */
+ op_sibling_splice(NULL, pad1, 1, NULL);
+ op_free(ns2);
+
+ /* excise pad1 and pad2 */
+ op_sibling_splice(NULL, o, 2, NULL);
/* 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(ns2);
+ /* insert newop between o and ns3 */
+ op_sibling_splice(NULL, o, 0, newop);
+ /*fixup op_next chain */
+ newpm = cUNOPx(newop)->op_first; /* pushmark */
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 (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
- o->op_next->op_flags |= OPf_MOD;
+ newpm->op_flags |= OPf_MOD;
}
break;
op_free(cBINOPo->op_last );
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
- assert(sizeof(OP) <= sizeof(BINOP));
- CHANGE_TYPE(o, OP_STUB);
+ STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
+ OpTYPE_set(o, OP_STUB);
o->op_private = 0;
break;
}
U8 count = 0;
U8 intro = 0;
PADOFFSET base = 0; /* init only to stop compiler whining */
- U8 gimme = 0; /* init only to stop compiler whining */
+ bool gvoid = 0; /* init only to stop compiler whining */
bool defav = 0; /* seen (...) = @_ */
bool reuse = 0; /* reuse an existing padrange op */
if (count == 0) {
intro = (p->op_private & OPpLVAL_INTRO);
base = p->op_targ;
- gimme = (p->op_flags & OPf_WANT);
+ gvoid = OP_GIMME(p,0) == G_VOID;
}
else {
if ((p->op_private & OPpLVAL_INTRO) != intro)
if (p->op_targ != base + count)
break;
assert(p->op_targ == base + count);
- /* all the padops should be in the same context */
- if (gimme != (p->op_flags & OPf_WANT))
+ /* Either all the padops or none of the padops should
+ be in void context. Since we only do the optimisa-
+ tion for av/hv when the aggregate itself is pushed
+ on to the stack (one item), there is no need to dis-
+ tinguish list from scalar context. */
+ if (gvoid != (OP_GIMME(p,0) == G_VOID))
break;
}
/* for AV, HV, only when we're not flattening */
if ( p->op_type != OP_PADSV
- && gimme != OPf_WANT_VOID
+ && !gvoid
&& !(p->op_flags & OPf_REF)
)
break;
* the stack) makes no difference in void context.
*/
assert(followop);
- if (gimme == OPf_WANT_VOID) {
+ if (gvoid) {
if (followop->op_type == OP_LIST
- && gimme == (followop->op_flags & OPf_WANT)
+ && OP_GIMME(followop,0) == G_VOID
)
{
followop = followop->op_next; /* skip OP_LIST */
* *always* formerly a pushmark */
assert(o->op_type == OP_PUSHMARK);
o->op_next = followop;
- CHANGE_TYPE(o, OP_PADRANGE);
+ OpTYPE_set(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
- | gimme | (defav ? OPf_SPECIAL : 0));
+ | gvoid * OPf_WANT_VOID
+ | (defav ? OPf_SPECIAL : 0));
}
break;
}
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- CHANGE_TYPE(o, OP_GVSV);
+ OpTYPE_set(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- CHANGE_TYPE(o, OP_RCATLINE);
+ OpTYPE_set(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
op_null(o->op_next->op_next);
op_null(o->op_next);
case OP_OR:
case OP_DOR:
fop = cLOGOP->op_first;
- sop = OP_SIBLING(fop);
+ sop = OpSIBLING(fop);
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
while (o->op_next && ( o->op_type == o->op_next->op_type
if (o->op_flags & OPf_SPECIAL) {
/* first arg is a code block */
- OP * const nullop = OP_SIBLING(cLISTOP->op_first);
+ OP * const nullop = OpSIBLING(cLISTOP->op_first);
OP * kid = cUNOPx(nullop)->op_first;
assert(nullop->op_type == OP_NULL);
break;
/* reverse sort ... can be optimised. */
- if (!OP_HAS_SIBLING(cUNOPo)) {
+ if (!OpHAS_SIBLING(cUNOPo)) {
/* Nothing follows us on the list. */
OP * const reverse = o->op_next;
(reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
OP * const pushmark = cUNOPx(reverse)->op_first;
if (pushmark && (pushmark->op_type == OP_PUSHMARK)
- && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
+ && (OpSIBLING(cUNOPx(pushmark)) == o)) {
/* reverse -> pushmark -> sort */
o->op_private |= OPpSORT_REVERSE;
op_null(reverse);
|| expushmark->op_targ != OP_PUSHMARK)
break;
- exlist = (LISTOP *) OP_SIBLING(expushmark);
+ exlist = (LISTOP *) OpSIBLING(expushmark);
if (!exlist || exlist->op_type != OP_NULL
|| exlist->op_targ != OP_LIST)
break;
if (!theirmark || theirmark->op_type != OP_PUSHMARK)
break;
- if (OP_SIBLING(theirmark) != o) {
+ if (OpSIBLING(theirmark) != o) {
/* There's something between the mark and the reverse, eg
for (1, reverse (...))
so no go. */
if (!ourlast || ourlast->op_next != o)
break;
- 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)) {
+ rv2av = OpSIBLING(ourmark);
+ if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
/* We're just reversing a single array. */
rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
enter->op_flags |= OPf_STACKED;
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- CHANGE_TYPE(o, OP_CONST);
+ OpTYPE_set(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
* arg2
* ...
*/
- OP *left = OP_SIBLING(right);
+ OP *left = OpSIBLING(right);
if (left->op_type == OP_SUBSTR
&& (left->op_private & 7) < 4) {
op_null(o);
(as formerly), so that all lexical vars that get aliased are
marked as such before we do the check. */
/* There can’t be common vars if the lhs is a stub. */
- if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
== cLISTOPx(cBINOPo->op_last)->op_last
&& cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
{
any.xop_peep = xop->xop_peep;
break;
default:
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
break;
}
} else {
any.xop_peep = XOPd_xop_peep;
break;
default:
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
break;
}
}
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff