}
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
+ S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
+#else
+ S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
#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);
+ break;
+ case OP_METHOD_REDIR:
+ case OP_METHOD_REDIR_SUPER:
#ifdef USE_ITHREADS
- if (cPADOPo->op_padix > 0) {
- pad_swipe(cPADOPo->op_padix, TRUE);
- cPADOPo->op_padix = 0;
- }
+ if (cMETHOPx(o)->op_rclass_targ) {
+ pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
+ cMETHOPx(o)->op_rclass_targ = 0;
+ }
#else
- SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = NULL;
+ SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
+ cMETHOPx(o)->op_rclass_sv = NULL;
#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_NAMED:
case OP_METHOD_SUPER:
SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
/* 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);
}
}
}
OP *
Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
{
- OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
+ OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
OP *rest;
OP *last_del = NULL;
OP *last_ins = NULL;
if (del_count && first) {
last_del = first;
- while (--del_count && OP_HAS_SIBLING(last_del))
- last_del = OP_SIBLING(last_del);
- rest = OP_SIBLING(last_del);
- OP_SIBLING_set(last_del, NULL);
+ while (--del_count && OpHAS_SIBLING(last_del))
+ last_del = OpSIBLING(last_del);
+ rest = OpSIBLING(last_del);
+ OpSIBLING_set(last_del, NULL);
last_del->op_lastsib = 1;
}
else
if (insert) {
last_ins = insert;
- while (OP_HAS_SIBLING(last_ins))
- last_ins = OP_SIBLING(last_ins);
- OP_SIBLING_set(last_ins, rest);
+ while (OpHAS_SIBLING(last_ins))
+ last_ins = OpSIBLING(last_ins);
+ OpSIBLING_set(last_ins, rest);
last_ins->op_lastsib = rest ? 0 : 1;
}
else
insert = rest;
if (start) {
- OP_SIBLING_set(start, insert);
+ OpSIBLING_set(start, insert);
start->op_lastsib = insert ? 0 : 1;
}
- else
+ else {
cLISTOPx(parent)->op_first = insert;
+ if (insert)
+ parent->op_flags |= OPf_KIDS;
+ else
+ parent->op_flags &= ~OPf_KIDS;
+ }
if (!rest) {
/* update op_last etc */
{
PERL_ARGS_ASSERT_OP_PARENT;
#ifdef PERL_OP_PARENT
- while (OP_HAS_SIBLING(o))
- o = OP_SIBLING(o);
+ while (OpHAS_SIBLING(o))
+ o = OpSIBLING(o);
return o->op_sibling;
#else
PERL_UNUSED_ARG(o);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
- while (kid && OP_HAS_SIBLING(kid))
- kid = OP_SIBLING(kid);
+ while (kid && OpHAS_SIBLING(kid))
+ kid = OpSIBLING(kid);
if (kid) {
kid->op_lastsib = 1;
#ifdef PERL_OP_PARENT
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;
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));
/* Relocate all the METHOP's SVs to the pad for thread safety. */
case OP_METHOD_NAMED:
case OP_METHOD_SUPER:
+ case OP_METHOD_REDIR:
+ case OP_METHOD_REDIR_SUPER:
op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
break;
#endif
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:
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);
}
# else
- if (OP_HAS_SIBLING(kid)) {
+ if (OpHAS_SIBLING(kid)) {
assert(!kid->op_lastsib);
}
else {
}
#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:
}
/* 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);
}
(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;
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,
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 *
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);
OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
- bool folded;
+ bool is_stringify;
SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
#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);
if (ret)
goto nope;
- folded = cBOOL(o->op_folded);
+ /* OP_STRINGIFY and constant folding are used to implement qq.
+ Here the constant folding is an implementation detail that we
+ want to hide. If the stringify op is itself already marked
+ folded, however, then it is actually a folded join. */
+ is_stringify = type == OP_STRINGIFY && !o->op_folded;
op_free(o);
assert(sv);
- if (type == OP_STRINGIFY) SvPADTMP_off(sv);
+ if (is_stringify)
+ SvPADTMP_off(sv);
else if (!SvIMMORTAL(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));
- /* OP_STRINGIFY and constant folding are used to implement qq.
- Here the constant folding is an implementation detail that we
- want to hide. If the stringify op is itself already marked
- folded, however, then it is actually a folded join. */
- if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
- }
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ if (!is_stringify) newop->op_folded = 1;
return newop;
nope:
return op_append_elem(type, first, last);
((LISTOP*)first)->op_last->op_lastsib = 0;
- OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
+ OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
((LISTOP*)first)->op_last->op_lastsib = 1;
#ifdef PERL_OP_PARENT
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 (!(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);
o->op_flags |= flags;
+ if (flags & OPf_FOLDED)
+ o->op_folded = 1;
o = CHECKOP(type, o);
if (o->op_type != (unsigned)type)
OP *rest = NULL;
if (o) {
/* manually detach any siblings then add them back later */
- rest = OP_SIBLING(o);
- OP_SIBLING_set(o, NULL);
+ rest = OpSIBLING(o);
+ OpSIBLING_set(o, NULL);
o->op_lastsib = 1;
}
o = newLISTOP(OP_LIST, 0, o, NULL);
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);
else if (!first && last)
first = last;
else if (first)
- OP_SIBLING_set(first, last);
+ OpSIBLING_set(first, last);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
pushop->op_lastsib = 0;
- OP_SIBLING_set(pushop, first);
+ OpSIBLING_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
if (!last)
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
|| type == OP_SASSIGN
|| type == OP_ENTERTRY
+ || type == OP_CUSTOM
|| type == OP_NULL );
if (!first)
unop->op_private = (U8)(1 | (flags >> 8));
#ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+ if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
first->op_sibling = (OP*)unop;
#endif
}
/*
+=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;
+
+#ifdef PERL_OP_PARENT
+ if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
+ first->op_sibling = (OP*)unop;
+#endif
+
+ 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_private = (U8)(1 | (flags >> 8));
#ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(dynamic_meth))
+ if (!OpHAS_SIBLING(dynamic_meth))
dynamic_meth->op_sibling = (OP*)methop;
#endif
}
methop->op_next = (OP*)methop;
}
- CHANGE_TYPE(methop, type);
- methop = (METHOP*) CHECKOP(type, methop);
-
- if (methop->op_next) return (OP*)methop;
+#ifdef USE_ITHREADS
+ methop->op_rclass_targ = 0;
+#else
+ methop->op_rclass_sv = NULL;
+#endif
- return fold_constants(op_integerize(op_std_init((OP *) methop)));
+ CHANGE_TYPE(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);
}
else {
binop->op_private = (U8)(2 | (flags >> 8));
- OP_SIBLING_set(first, last);
+ OpSIBLING_set(first, last);
first->op_lastsib = 0;
}
#ifdef PERL_OP_PARENT
- if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
+ if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
last->op_sibling = (OP*)binop;
#endif
- binop->op_last = OP_SIBLING(binop->op_first);
+ binop->op_last = OpSIBLING(binop->op_first);
#ifdef PERL_OP_PARENT
if (binop->op_last)
binop->op_last->op_sibling = (OP*)binop;
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);
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);
* were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
* that isn't required now. Note that we have to be pretty
* confident that nothing used that CV's pad while the
- * regex was parsed */
- assert(AvFILLp(PL_comppad) == 0); /* just @_ */
+ * regex was parsed, except maybe op targets for \Q etc.
+ * If there were any op targets, though, they should have
+ * been stolen by constant folding.
+ */
+#ifdef DEBUGGING
+ SSize_t i = 0;
+ assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
+ while (++i <= AvFILLp(PL_comppad)) {
+ assert(!PL_curpad[i]);
+ }
+#endif
/* But we know that one op is using this CV's slab. */
cv_forget_slab(PL_compcv);
LEAVE_SCOPE(floor);
{
OP *sib;
OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
- if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
- && !OP_HAS_SIBLING(sib))
+ if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
+ && !OpHAS_SIBLING(sib))
curop = sib;
}
if (curop->op_type == OP_CONST)
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);
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);
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);
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)
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)
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;
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)
SAVEFREESV(sv);
}
else if (allow_lex && type == OP_PADSV) {
- if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
{
sv = &PL_sv_undef; /* an arbitrary non-null value */
padsv = TRUE;
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
- OP *start;
+ OP *start = NULL;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
cv = *spot;
else {
- MAGIC *mg;
- SvUPGRADE((SV *)name, SVt_PVMG);
- mg = mg_find((SV *)name, PERL_MAGIC_proto);
assert (SvTYPE(*spot) == SVt_PVCV);
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
);
CvLEXICAL_on(*spot);
}
- if (mg) {
- assert(mg->mg_obj);
- cv = (CV *)mg->mg_obj;
- }
- else {
- sv_magic((SV *)name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
- mg = mg_find((SV *)name, PERL_MAGIC_proto);
- }
- spot = (CV **)(svspot = &mg->mg_obj);
+ cv = PadnamePROTOCV(name);
+ svspot = (SV **)(spot = &PadnamePROTOCV(name));
}
if (block) {
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;
}
}
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 *
if (o->op_type == OP_PADANY) {
CHANGE_TYPE(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 */
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);
}
(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;
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 */
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 ||
CHANGE_TYPE(condop, OP_ONCE);
other->op_targ = target;
+ nullop->op_flags |= OPf_WANT_SCALAR;
/* Store the initializedness of state vars in a separate
pad entry. */
OP *
Perl_ck_method(pTHX_ OP *o)
{
- SV *sv, *methsv;
+ SV *sv, *methsv, *rclass;
const char* method;
char* compatptr;
int utf8;
STRLEN len, nsplit = 0, i;
+ OP* new_op;
OP * const kid = cUNOPo->op_first;
PERL_ARGS_ASSERT_CK_METHOD;
return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
}
- return o;
+ /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
+ if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
+ rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
+ new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
+ } else {
+ rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
+ new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
+ }
+#ifdef USE_ITHREADS
+ op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
+#else
+ cMETHOPx(new_op)->op_rclass_sv = rclass;
+#endif
+ op_free(o);
+ return new_op;
}
OP *
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;
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)) {
+ kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
+ if (kid && OpHAS_SIBLING(kid)) {
CHANGE_TYPE(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
}
o = ck_fun(o);
- kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && kid->op_type == OP_RV2GV)
kid->op_private &= ~HINT_STRICT_REFS;
return o;
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 */
}
}
- 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);
"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)
{
- assert(!OP_HAS_SIBLING(kid));
+ assert(!OpHAS_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, 0,
+ OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
op_sibling_splice(o, kid, 1, NULL));
op_free(o);
- ret->op_folded = 1;
return ret;
}
}
[off = PARENT_PAD_INDEX(name)];
}
assert(!PadnameIsOUR(name));
- if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
- MAGIC * mg = mg_find((SV *)name, PERL_MAGIC_proto);
- assert(mg);
- assert(mg->mg_obj);
- return (CV *)mg->mg_obj;
+ if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
+ return PadnamePROTOCV(name);
}
return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
}
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);
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)
}
}
+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;
case OP_METHOD:
case OP_METHOD_NAMED:
case OP_METHOD_SUPER:
+ case OP_METHOD_REDIR:
+ case OP_METHOD_REDIR_SUPER:
if (aop->op_type == OP_CONST) {
aop->op_private &= ~OPpCONST_STRICT;
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
);
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;
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)
+ */
+ 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;
+ 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;
+
+ 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 */
+ op_free(op_sibling_splice(top_op, NULL, -1, mderef));
+ 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_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);
/* create new listop, with children consisting of:
* a new pushmark, pad1, pad2. */
- OP_SIBLING_set(pad2, NULL);
+ OpSIBLING_set(pad2, NULL);
newop = newLISTOP(OP_LIST, 0, pad1, pad2);
newop->op_flags |= OPf_PARENS;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
pad2 ->op_next = newop; /* listop */
newop->op_next = ns3;
- OP_SIBLING_set(o, newop);
- OP_SIBLING_set(newop, ns3);
+ OpSIBLING_set(o, newop);
+ OpSIBLING_set(newop, ns3);
newop->op_lastsib = 0;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
op_free(cBINOPo->op_last );
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
- assert(sizeof(OP) <= sizeof(BINOP));
+ STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
CHANGE_TYPE(o, OP_STUB);
o->op_private = 0;
break;
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 */
/* 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;
}
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 = OpSIBLING(ourmark);
+ if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
&& rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
&& enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
/* We're just reversing a single array. */
* 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)
{
https://perl5.git.perl.org / perl5.git / blobdiff