DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
gotit:
- /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
- o->op_lastsib = 1;
- assert(!o->op_sibling);
+#ifdef PERL_OP_PARENT
+ /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
+ assert(!o->op_moresib);
+ assert(!o->op_sibparent);
+#endif
return (void *)o;
}
PERL_UNUSED_CONTEXT;
DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
assert(slab->opslab_refcnt == 1);
- for (; slab; slab = slab2) {
+ do {
slab2 = slab->opslab_next;
#ifdef DEBUGGING
slab->opslab_refcnt = ~(size_t)0;
#else
PerlMemShared_free(slab);
#endif
- }
+ slab = slab2;
+ } while (slab);
}
void
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
-#define CHANGE_TYPE(o,type) \
+#define OpTYPE_set(o,type) \
STMT_START { \
o->op_type = (OPCODE)type; \
o->op_ppaddr = PL_ppaddr[type]; \
}
STATIC void
-S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
{
PERL_ARGS_ASSERT_BAD_TYPE_PV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)), flags);
+ (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
}
+/* remove flags var, its unused in all callers, move to to right end since gv
+ and kid are always the same */
STATIC void
-S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
+S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
{
SV * const namesv = cv_name((CV *)gv, NULL, 0);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
- (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
+ (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
}
STATIC void
(name[1] == '_' && (*name == '$' || len > 2))))
{
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && isASCII(name[1])
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
/* 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;
return;
op_clear(o);
o->op_targ = o->op_type;
- CHANGE_TYPE(o, OP_NULL);
+ OpTYPE_set(o, OP_NULL);
}
void
more different nodes. Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
children. The last deleted node will be marked as as the last node by
-updating the op_sibling or op_lastsib field as appropriate.
+updating the op_sibling/op_sibparent or op_moresib field as appropriate.
Note that op_next is not manipulated, and nodes are not freed; that is the
responsibility of the caller. It also won't create a new list op for an
empty list etc; use higher-level functions like op_append_elem() for that.
-parent is the parent node of the sibling chain.
+parent is the parent node of the sibling chain. It may passed as NULL if
+the splicing doesn't affect the first or last op in the chain.
start is the node preceding the first node to be spliced. Node(s)
following it will be deleted, and ops will be inserted after it. If it is
splice(P, B, 0, X-Y) | | NULL
A-B-C-D A-B-X-Y-C-D
+
+For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
+see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
+
=cut
*/
OP *
Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
{
- OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
+ OP *first;
OP *rest;
OP *last_del = NULL;
OP *last_ins = NULL;
- PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
+ if (start)
+ first = OpSIBLING(start);
+ else if (!parent)
+ goto no_parent;
+ else
+ first = cLISTOPx(parent)->op_first;
assert(del_count >= -1);
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;
+ OpLASTSIB_set(last_del, NULL);
}
else
rest = first;
last_ins = insert;
while (OpHAS_SIBLING(last_ins))
last_ins = OpSIBLING(last_ins);
- OpSIBLING_set(last_ins, rest);
- last_ins->op_lastsib = rest ? 0 : 1;
+ OpMAYBESIB_set(last_ins, rest, NULL);
}
else
insert = rest;
if (start) {
- OpSIBLING_set(start, insert);
- start->op_lastsib = insert ? 0 : 1;
+ OpMAYBESIB_set(start, insert, NULL);
}
else {
+ if (!parent)
+ goto no_parent;
cLISTOPx(parent)->op_first = insert;
if (insert)
parent->op_flags |= OPf_KIDS;
if (!rest) {
/* update op_last etc */
- U32 type = parent->op_type;
+ U32 type;
OP *lastop;
- if (type == OP_NULL)
- type = parent->op_targ;
- type = PL_opargs[type] & OA_CLASS_MASK;
+ if (!parent)
+ goto no_parent;
+
+ /* ought to use OP_CLASS(parent) here, but that can't handle
+ * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
+ * either */
+ type = parent->op_type;
+ if (type == OP_CUSTOM) {
+ dTHX;
+ type = XopENTRYCUSTOM(parent, xop_class);
+ }
+ else {
+ if (type == OP_NULL)
+ type = parent->op_targ;
+ type = PL_opargs[type] & OA_CLASS_MASK;
+ }
lastop = last_ins ? last_ins : start ? start : NULL;
if ( type == OA_BINOP
)
cLISTOPx(parent)->op_last = lastop;
- if (lastop) {
- lastop->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- lastop->op_sibling = parent;
-#endif
- }
+ if (lastop)
+ OpLASTSIB_set(lastop, parent);
}
return last_del ? first : NULL;
+
+ no_parent:
+ Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}
+
+#ifdef PERL_OP_PARENT
+
/*
=for apidoc op_parent
-returns the parent OP of o, if it has a parent. Returns NULL otherwise.
-(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
-work.
+Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
*/
Perl_op_parent(OP *o)
{
PERL_ARGS_ASSERT_OP_PARENT;
-#ifdef PERL_OP_PARENT
while (OpHAS_SIBLING(o))
o = OpSIBLING(o);
- return o->op_sibling;
-#else
- PERL_UNUSED_ARG(o);
- return NULL;
-#endif
+ return o->op_sibparent;
}
+#endif
+
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- CHANGE_TYPE(logop, type);
+ OpTYPE_set(logop, type);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
while (kid && OpHAS_SIBLING(kid))
kid = OpSIBLING(kid);
- if (kid) {
- kid->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- kid->op_sibling = (OP*)logop;
-#endif
- }
+ if (kid)
+ OpLASTSIB_set(kid, (OP*)logop);
return logop;
}
case OP_LOCALTIME:
case OP_GMTIME:
case OP_ENTEREVAL:
- case OP_REACH:
- case OP_RKEYS:
- case OP_RVALUES:
return;
}
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)
break;
case OP_POSTINC:
- CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
break;
case OP_POSTDEC:
- CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
break;
case OP_I_POSTINC:
- CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
break;
case OP_I_POSTDEC:
- CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
break;
case OP_SASSIGN: {
if (kid->op_type == OP_NOT
&& (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
- CHANGE_TYPE(o, OP_OR);
+ OpTYPE_set(o, OP_OR);
} else {
- CHANGE_TYPE(o, OP_AND);
+ OpTYPE_set(o, OP_AND);
}
op_null(kid);
}
#ifdef DEBUGGING
/* check that op_last points to the last sibling, and that
- * the last op_sibling field points back to the parent, and
- * that the only ops with KIDS are those which are entitled to
- * them */
+ * the last op_sibling/op_sibparent field points back to the
+ * parent, and that the only ops with KIDS are those which are
+ * entitled to them */
U32 type = o->op_type;
U32 family;
bool has_last;
|| 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 = OpSIBLING(kid)) {
# ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(kid)) {
if (has_last)
assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibling == o);
+ assert(kid->op_sibparent == o);
}
# else
- if (OpHAS_SIBLING(kid)) {
- assert(!kid->op_lastsib);
- }
- else {
- assert(kid->op_lastsib);
- if (has_last)
- assert(kid == cLISTOPo->op_last);
- }
+ if (has_last && !OpHAS_SIBLING(kid))
+ assert(kid == cLISTOPo->op_last);
# endif
}
#endif
return;
}
slurpy:
- CHANGE_TYPE(o, OP_LVAVREF);
+ OpTYPE_set(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
case OP_RV2CV:
kid = cUNOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = cUNOPx(kUNOP->op_first->op_sibling)
+ kid = cUNOPx(OpSIBLING(kUNOP->op_first))
->op_first;
o->op_private = OPpLVREF_CV;
if (kid->op_type == OP_GV)
break;
case OP_ASLICE:
case OP_HSLICE:
- CHANGE_TYPE(o, OP_LVREFSLICE);
+ OpTYPE_set(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
? "do block"
: OP_DESC(o),
PL_op_desc[type]));
- return;
}
- CHANGE_TYPE(o, OP_LVREF);
+ OpTYPE_set(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
break;
case OP_KEYS:
- case OP_RKEYS:
if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
PERL_ARGS_ASSERT_DOREF;
- if (!o || (PL_parser && PL_parser->error_count))
+ if (PL_parser && PL_parser->error_count)
return o;
switch (o->op_type) {
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
STATIC void
S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
- SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
-
PERL_ARGS_ASSERT_APPLY_ATTRS;
+ {
+ SV * const stashsv = newSVhek(HvNAME_HEK(stash));
- /* fake up C<use attributes $pkg,$rv,@attrs> */
+ /* fake up C<use attributes $pkg,$rv,@attrs> */
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvs(ATTRSMODULE),
- NULL,
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(target)),
- dup_attrlist(attrs))));
+ Perl_load_module(
+ aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvs(ATTRSMODULE),
+ NULL,
+ op_prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ op_prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV(target)),
+ dup_attrlist(attrs))));
+ }
}
STATIC void
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
/* Build up the real arg-list. */
- stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
+ stashsv = newSVhek(HvNAME_HEK(stash));
arg = newOP(OP_PADSV, 0);
arg->op_targ = target->op_targ;
newSVOP(OP_CONST, 0, stashsv),
op_prepend_elem(OP_LIST,
newUNOP(OP_REFGEN, 0,
- op_lvalue(arg, OP_REFGEN)),
+ arg),
dup_attrlist(attrs)));
/* Fake up a method call to import */
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
+ pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
}
OP *
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- CHANGE_TYPE(o, OP_LEAVE);
+ OpTYPE_set(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- CHANGE_TYPE(o, OP_SCOPE);
+ OpTYPE_set(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
if (last->op_type != (unsigned)type)
return op_append_elem(type, first, last);
- ((LISTOP*)first)->op_last->op_lastsib = 0;
- OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
+ OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
- ((LISTOP*)first)->op_last->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- ((LISTOP*)first)->op_last->op_sibling = first;
-#endif
+ OpLASTSIB_set(((LISTOP*)first)->op_last, first);
first->op_flags |= (last->op_flags & OPf_KIDS);
-
S_op_destroy(aTHX_ last);
return first;
if (!o || o->op_type != OP_LIST)
o = force_list(o, 0);
else
+ {
o->op_flags &= ~OPf_WANT;
+ o->op_private &= ~OPpLVAL_INTRO;
+ }
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
}
}
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags |= flags;
if (flags & OPf_FOLDED)
o->op_folded = 1;
if (o) {
/* manually detach any siblings then add them back later */
rest = OpSIBLING(o);
- OpSIBLING_set(o, NULL);
- o->op_lastsib = 1;
+ OpLASTSIB_set(o, NULL);
}
o = newLISTOP(OP_LIST, 0, o, NULL);
if (rest)
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
+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.
NewOp(1101, listop, 1, LISTOP);
- CHANGE_TYPE(listop, type);
+ OpTYPE_set(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
else if (!first && last)
first = last;
else if (first)
- OpSIBLING_set(first, last);
+ OpMORESIB_set(first, last);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
- pushop->op_lastsib = 0;
- OpSIBLING_set(pushop, first);
+ OpMORESIB_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
if (!last)
listop->op_last = pushop;
}
- if (first)
- first->op_lastsib = 0;
- if (listop->op_last) {
- listop->op_last->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- listop->op_last->op_sibling = (OP*)listop;
-#endif
- }
+ if (listop->op_last)
+ OpLASTSIB_set(listop->op_last, (OP*)listop);
return CHECKOP(type, listop);
}
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- CHANGE_TYPE(unop, type);
+ OpTYPE_set(unop, type);
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
- first->op_sibling = (OP*)unop;
-#endif
+ OpLASTSIB_set(first, (OP*)unop);
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
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
+ OpLASTSIB_set(first, (OP*)unop);
unop = (UNOP_AUX*) CHECKOP(type, unop);
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(dynamic_meth))
- dynamic_meth->op_sibling = (OP*)methop;
-#endif
+ OpLASTSIB_set(dynamic_meth, (OP*)methop);
}
else {
assert(const_meth);
methop->op_rclass_sv = NULL;
#endif
- CHANGE_TYPE(methop, type);
+ OpTYPE_set(methop, type);
return CHECKOP(type, methop);
}
if (!first)
first = newOP(OP_NULL, 0);
- CHANGE_TYPE(binop, type);
+ OpTYPE_set(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
}
else {
binop->op_private = (U8)(2 | (flags >> 8));
- OpSIBLING_set(first, last);
- first->op_lastsib = 0;
+ OpMORESIB_set(first, last);
}
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
- last->op_sibling = (OP*)binop;
-#endif
+ OpLASTSIB_set(last, (OP*)binop);
binop->op_last = OpSIBLING(binop->op_first);
-#ifdef PERL_OP_PARENT
if (binop->op_last)
- binop->op_last->op_sibling = (OP*)binop;
-#endif
+ OpLASTSIB_set(binop->op_last, (OP*)binop);
binop = (BINOP*)CHECKOP(type, binop);
if (binop->op_next || binop->op_type != (OPCODE)type)
|| type == OP_CUSTOM);
NewOp(1101, pmop, 1, PMOP);
- CHANGE_TYPE(pmop, type);
+ OpTYPE_set(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
* 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 (OpSIBLING(kid) != repl)
- kid = OpSIBLING(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(OpSIBLING(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;
|| type == OP_CUSTOM);
NewOp(1101, svop, 1, SVOP);
- CHANGE_TYPE(svop, type);
+ OpTYPE_set(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
|| type == OP_CUSTOM);
NewOp(1101, padop, 1, PADOP);
- CHANGE_TYPE(padop, type);
+ OpTYPE_set(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- CHANGE_TYPE(pvop, type);
+ OpTYPE_set(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- CHANGE_TYPE(cop, OP_DBSTATE);
+ OpTYPE_set(cop, OP_DBSTATE);
}
else {
- CHANGE_TYPE(cop, OP_NEXTSTATE);
+ OpTYPE_set(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
} while (kid);
if (!kid)
kid = cLISTOPo->op_last;
-last:
+ last:
return search_const(kid);
}
}
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
- dVAR;
LOGOP *range;
OP *flip;
OP *flop;
if (!loop) {
NewOp(1101,loop,1,LOOP);
- CHANGE_TYPE(loop, OP_ENTERLOOP);
+ OpTYPE_set(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- CHANGE_TYPE(sv, OP_RV2GV);
+ OpTYPE_set(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
- loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
- op_append_elem(OP_LIST, expr, scalar(sv))));
+ loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
+ op_append_elem(OP_LIST, list(expr),
+ scalar(sv)));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
#ifdef PERL_OP_PARENT
- assert(loop->op_last->op_sibling == (OP*)loop);
- loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
+ assert(loop->op_last->op_sibparent == (OP*)loop);
+ OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
{
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
#ifdef PERL_OP_PARENT
- loop->op_last->op_sibling = (OP *)loop;
+ OpLASTSIB_set(loop->op_last, (OP*)loop);
#endif
}
loop->op_targ = padoff;
/* anonlist now needs a list from this op, was previously used in
* scalar context */
- cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
+ cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
cond->op_flags |= OPf_WANT_LIST;
return newANONLIST(op_lvalue(cond, OP_ANONLIST));
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
start = LINKLIST(block);
block->op_next = 0;
+ if (ps && !*ps && !attrs && !CvLVALUE(compcv))
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
+ else
+ const_sv = NULL;
}
-
- if (!block || !ps || *ps || attrs
- || CvLVALUE(compcv)
- )
- const_sv = NULL;
else
- const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
+ const_sv = NULL;
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
if (slab)
Slab_to_ro(slab);
#endif
- if (o) op_free(o);
+ op_free(o);
return cv;
}
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
- bool is_begin = FALSE;
+ bool evanescent = FALSE;
OP *start = NULL;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
- if (!ec)
- move_proto_attr(&proto, &attrs,
- isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
+ if (!ec) {
+ if (isGV(gv)) {
+ move_proto_attr(&proto, &attrs, gv);
+ } else {
+ assert(cSVOPo);
+ move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
+ }
+ }
if (proto) {
assert(proto->op_type == OP_CONST);
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
start = LINKLIST(block);
block->op_next = 0;
+ if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ else
+ const_sv = NULL;
}
-
- if (!block || !ps || *ps || attrs
- || CvLVALUE(PL_compcv)
- )
- const_sv = NULL;
else
- const_sv =
- S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ const_sv = NULL;
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
- is_begin =
+ evanescent =
process_special_blocks(floor, name, gv, cv);
}
}
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
- if (!is_begin) {
+ if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
- if (!is_begin && slab)
+ if (slab)
Slab_to_ro(slab);
#endif
if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(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;
{
PERL_ARGS_ASSERT_NEWXS_DEFFILE;
return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ name, strlen(name), subaddr, NULL, NULL, NULL, 0
);
}
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
- if (!subaddr)
- Perl_croak_nocontext("panic: no address for '%s' in '%s'",
- name, filename ? filename : PL_xsubfilename);
+
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
OP *
Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
{
- return newUNOP(OP_REFGEN, 0,
+ SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
+ OP * anoncode =
newSVOP(OP_ANONCODE, 0,
- MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
+ cv);
+ if (CvANONCONST(cv))
+ anoncode = newUNOP(OP_ANONCONST, 0,
+ op_convert_list(OP_ENTERSUB,
+ OPf_STACKED|OPf_WANT_SCALAR,
+ anoncode));
+ return newUNOP(OP_REFGEN, 0, anoncode);
}
OP *
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- CHANGE_TYPE(o, OP_RV2HV);
+ OpTYPE_set(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- CHANGE_TYPE(o, OP_PADCV);
+ OpTYPE_set(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADSV);
+ OpTYPE_set(o, OP_PADSV);
scalar(o);
return o;
}
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 = OpSIBLING(left);
(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;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
assert(kid);
- if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
+ if (o->op_type == OP_ENTERTRY) {
LOGOP *enter;
/* cut whole sibling chain free from o */
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- CHANGE_TYPE(o, OP_LEAVETRY);
+ OpTYPE_set(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- CHANGE_TYPE(kid, OP_GV);
+ OpTYPE_set(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
}
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
- if (PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT) {
+ if (type != OP_STAT && type != OP_LSTAT
+ && PL_check[kidtype] == Perl_ck_ftst
+ && kidtype != OP_STAT && kidtype != OP_LSTAT
+ ) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
if (kidtype == OP_FTTTY && (
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
- bad_type_pv(numargs, "array", PL_op_desc[type], 0, 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);
- else {
- scalar(kid);
- /* diag_listed_as: push on reference is experimental */
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__AUTODEREF),
- "%s on reference is experimental",
- PL_op_desc[type]);
+ bad_type_pv(numargs, "array", o, kid);
+ else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
+ yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
+ PL_op_desc[type]), 0);
}
+ else {
+ 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;
OP *
Perl_ck_grep(pTHX_ OP *o)
{
- dVAR;
LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
}
else {
OP * const newop
- = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+ = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
op_free(o);
return newop;
}
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- CHANGE_TYPE(first, OP_QR);
+ OpTYPE_set(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- CHANGE_TYPE(second, OP_QR);
+ OpTYPE_set(second, OP_QR);
}
}
static OP *
S_maybe_targlex(pTHX_ OP *o)
{
- dVAR;
OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
OP *const nullop =
+ newCONDOP(0, first, o, other);
+ /* XXX targlex disabled for now; see ticket #124160
newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
+ */
OP *const condop = first->op_next;
- CHANGE_TYPE(condop, OP_ONCE);
+ OpTYPE_set(condop, OP_ONCE);
other->op_targ = target;
nullop->op_flags |= OPf_WANT_SCALAR;
}
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;
case OP_RV2AV:
o->op_private |= OPpLVREF_AV;
goto checkgv;
+ NOT_REACHED; /* NOTREACHED */
case OP_RV2HV:
o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
case OP_RV2SV:
checkgv:
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
break;
case OP_RV2CV: {
OP * const kidparent =
- cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
OP * const kid = cUNOPx(kidparent)->op_first;
o->op_private |= OPpLVREF_CV;
if (kid->op_type == OP_GV) {
unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
}
- else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
+ && !SvVOK(sv)) {
s = SvPV(sv, len);
if (SvREFCNT(sv) > 1) {
kid->op_sv = newSVpvn_share(
if (o->op_flags & OPf_KIDS) {
kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && OpHAS_SIBLING(kid)) {
- CHANGE_TYPE(o, OP_SSELECT);
+ OpTYPE_set(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
else {
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
- cUNOPx(firstkid)->op_first = padop;
-#ifdef PERL_OP_PARENT
- padop->op_sibling = firstkid;
-#endif
+ /* replace the const op with the pad op */
+ op_sibling_splice(firstkid, NULL, 1, padop);
op_free(kid);
}
}
/* remove kid, and replace with new optree */
op_sibling_splice(o, NULL, 1, NULL);
/* OPf_SPECIAL is used to trigger split " " behavior */
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
- CHANGE_TYPE(kid, OP_PUSHRE);
+ OpTYPE_set(kid, OP_PUSHRE);
+ /* target implies @ary=..., so wipe it */
+ kid->op_targ = 0;
scalar(kid);
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
{
OP * const kid = OpSIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
- || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
- || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
{
- assert(!OpHAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
return kid;
CV *compcv = PL_compcv;
while (PadnameOUTER(name)) {
assert(PARENT_PAD_INDEX(name));
- compcv = CvOUTSIDE(PL_compcv);
+ compcv = CvOUTSIDE(compcv);
name = PadlistNAMESARRAY(CvPADLIST(compcv))
[off = PARENT_PAD_INDEX(name)];
}
case '&':
proto++;
arg++;
- if (o3->op_type != OP_SREFGEN
- || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
- != 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);
+ if ( o3->op_type != OP_UNDEF
+ && (o3->op_type != OP_SREFGEN
+ || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_ANONCODE
+ && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_RV2CV)))
+ 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,
)
);
}
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
}
else {
OP *prev, *cvop, *first, *parent;
prev = cvop, cvop = OpSIBLING(cvop))
;
if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
- /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
+ /* Usually, OPf_SPECIAL on an op with no args means that it had
* parens, but these have their own meaning for that flag: */
&& opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
&& opnum != OP_DELETE && opnum != OP_EXISTS)
return op_convert_list(opnum,0,aop);
}
}
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
return entersubop;
}
argument for it is returned in I<*ckobj_p>. The function is intended
to be called in this manner:
- entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
+ entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
In this call, I<entersubop> is a pointer to the C<entersub> op,
which may be replaced by the check function, and I<namegv> is a GV
}
}
+static void
+S_entersub_alloc_targ(pTHX_ OP * const o)
+{
+ o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
+ o->op_private |= OPpENTERSUB_HASTARG;
+}
+
OP *
Perl_ck_subr(pTHX_ OP *o)
{
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;
}
/* make class name a shared cow string to speedup method calls */
/* constant string might be replaced with object, f.e. bigint */
- if (const_class && !SvROK(*const_class)) {
+ if (const_class && SvPOK(*const_class)) {
STRLEN len;
const char* str = SvPV(*const_class, len);
if (len) {
SV* const shared = newSVpvn_share(
- str, SvUTF8(*const_class) ? -len : len, 0
+ str, SvUTF8(*const_class)
+ ? -(SSize_t)len : (SSize_t)len,
+ 0
);
+ if (SvREADONLY(*const_class))
+ SvREADONLY_on(shared);
SvREFCNT_dec(*const_class);
*const_class = shared;
}
}
if (!cv) {
+ S_entersub_alloc_targ(aTHX_ o);
return ck_entersub_args_list(o);
} else {
Perl_call_checker ckfun;
SV *ckobj;
U8 flags;
S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ if (CvISXSUB(cv) || !CvROOT(cv))
+ S_entersub_alloc_targ(aTHX_ o);
if (!namegv) {
/* The original call checker API guarantees that a GV will be
be provided with the right name. So, if the old API was
SV * const sv = cSVOPo->op_sv;
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) sv_force_normal(sv);
-#elif defined(PERL_NEW_COPY_ON_WRITE)
+#ifdef PERL_COPY_ON_WRITE
/* Since the read-only flag may be used to protect a string buffer, we
cannot do copy-on-write with existing read-only scalars that are not
already copy-on-write scalars. To allow $_ = "hello" to do COW with
dVAR;
OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
const unsigned orig_type = o->op_type;
- const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
- : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
- const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
- : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
PERL_ARGS_ASSERT_CK_EACH;
break;
case OP_PADAV:
case OP_RV2AV:
- CHANGE_TYPE(o, array_type);
+ OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
+ : orig_type == OP_KEYS ? OP_AKEYS
+ : OP_AVALUES);
break;
case OP_CONST:
if (kid->op_private == OPpCONST_BARE
/* we let ck_fun handle it */
break;
default:
- CHANGE_TYPE(o, ref_type);
- scalar(kid);
+ Perl_croak_nocontext(
+ "Experimental %s on scalar is now forbidden",
+ PL_op_desc[orig_type]);
+ break;
}
}
- /* if treating as a reference, defer additional checks to runtime */
- if (o->op_type == ref_type) {
- /* diag_listed_as: keys on reference is experimental */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
- "%s is experimental", PL_op_desc[ref_type]);
- return o;
- }
return ck_fun(o);
}
* 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)
+ * threaded builds).
+ *
+ * NB: for things like Coverity, note that both passes take the same
+ * path through the logic tree (except for 'if (pass)' bits), since
+ * both passes are following the same op_next chain; and in
+ * particular, if it would return early on the second pass, it would
+ * already have returned early on the first pass.
*/
for (pass = 0; pass < 2; pass++) {
OP *o = orig_o;
break;
default:
- assert(0);
+ NOT_REACHED; /* NOTREACHED */
return;
}
/* look for another (rv2av/hv; get index;
* aelem/helem/exists/delele) sequence */
- IV iv;
OP *kid;
bool is_deref;
bool ok;
/* rv2av or rv2hv sKR/1 */
- assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
|OPf_REF|OPf_MOD|OPf_SPECIAL)));
if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
return;
* OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
* OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
*/
- assert(!(o->op_private &
+ ASSUME(!(o->op_private &
~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
hints = (o->op_private & OPpHINT_STRICT_REFS);
/* make sure the type of the previous /DEREF matches the
* type of the next lookup */
- assert(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
+ ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
top_op = o;
action = next_is_hash
switch (o->op_type) {
case OP_PADSV:
/* it may be a lexical var index */
- assert(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
|OPf_REF|OPf_MOD|OPf_SPECIAL)));
- assert(!(o->op_private &
+ ASSUME(!(o->op_private &
~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
- if ( o->op_flags == OPf_WANT_SCALAR
+ if ( OP_GIMME(o,0) == G_SCALAR
+ && !(o->op_flags & (OPf_REF|OPf_MOD))
&& o->op_private == 0)
{
if (pass)
UNOP *rop = NULL;
OP * helem_op = o->op_next;
- assert( helem_op->op_type == OP_HELEM
+ ASSUME( helem_op->op_type == OP_HELEM
|| helem_op->op_type == OP_NULL);
if (helem_op->op_type == OP_HELEM) {
rop = (UNOP*)(((BINOP*)helem_op)->op_first);
}
else {
/* it's a constant array index */
+ IV iv;
SV *ix_sv = cSVOPo->op_sv;
- if (UNLIKELY(SvROK(ix_sv) && !SvGAMAGIC(ix_sv)
- && ckWARN(WARN_MISC)))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Use of reference \"%"SVf"\" as array index",
- SVfARG(ix_sv));
+ if (!SvIOK(ix_sv))
+ break;
iv = SvIV(ix_sv);
if ( action_count == 0
case OP_GV:
/* it may be a package var index */
- assert(!(o->op_flags & ~(OPf_WANT)));
- assert(!(o->op_private & ~(OPpEARLY_CV)));
- if ( o->op_flags != OPf_WANT_SCALAR
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
+ ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
+ if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
|| o->op_private != 0
)
break;
if (kid->op_type != OP_RV2SV)
break;
- assert(!(kid->op_flags &
- ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF|OPf_SPECIAL)));
- assert(!(kid->op_private &
+ ASSUME(!(kid->op_flags &
+ ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
+ |OPf_SPECIAL|OPf_PARENS)));
+ ASSUME(!(kid->op_private &
~(OPpARG1_MASK
|OPpHINT_STRICT_REFS|OPpOUR_INTRO
|OPpDEREF|OPpLVAL_INTRO)));
- if( kid->op_flags != (OPf_WANT_SCALAR|OPf_KIDS)
+ if( (kid->op_flags &~ OPf_PARENS)
+ != (OPf_WANT_SCALAR|OPf_KIDS)
|| (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
)
break;
/* if something like arybase (a.k.a $[ ) is in scope,
* abandon optimisation attempt */
- if (o->op_type == OP_AELEM && PL_check[OP_AELEM] != Perl_ck_null)
+ if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
+ && PL_check[o->op_type] != Perl_ck_null)
return;
if ( o->op_type != OP_AELEM
|| (o->op_private & OPpDEREF) == OPpDEREF_HV);
if (is_deref) {
- assert(!(o->op_flags &
+ ASSUME(!(o->op_flags &
~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
- assert(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
+ ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
- ok = o->op_flags == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
+ ok = (o->op_flags &~ OPf_PARENS)
+ == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
&& !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
}
else if (o->op_type == OP_EXISTS) {
- assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
|OPf_REF|OPf_MOD|OPf_SPECIAL)));
- assert(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
+ ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
ok = !(o->op_private & ~OPpARG1_MASK);
}
else if (o->op_type == OP_DELETE) {
- assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
|OPf_REF|OPf_MOD|OPf_SPECIAL)));
- assert(!(o->op_private &
+ ASSUME(!(o->op_private &
~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
/* don't handle slices or 'local delete'; the latter
* is fairly rare, and has a complex runtime */
ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
}
else {
- assert(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
- assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
+ ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
|OPf_PARENS|OPf_REF|OPf_SPECIAL)));
- assert(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
+ ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
|OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
}
if (pass) {
OP *mderef;
- OP *p;
+ OP *p, *q;
mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
if (index_skip == -1) {
* expr->[..]? so we need to save the 'expr' subtree */
if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
p = cUNOPx(p)->op_first;
- assert( start->op_type == OP_RV2AV
+ ASSUME( start->op_type == OP_RV2AV
|| start->op_type == OP_RV2HV);
}
else {
)
p = cUNOPx(p)->op_first;
}
- assert(cUNOPx(p)->op_first == start);
+ ASSUME(cUNOPx(p)->op_first == start);
/* detach from main tree, and re-attach under the multideref */
op_sibling_splice(mderef, NULL, 0,
/* excise and free the original tree, and replace with
* the multideref op */
- op_free(op_sibling_splice(top_op, NULL, -1, mderef));
+ p = op_sibling_splice(top_op, NULL, -1, mderef);
+ while (p) {
+ q = OpSIBLING(p);
+ op_free(p);
+ p = q;
+ }
op_null(top_op);
}
else {
* not aware of, rather than:
* * silently failing to optimise, or
* * silently optimising the flag away.
- * If this assert starts failing, examine what new flag
+ * If this ASSUME starts failing, examine what new flag
* has been added to the op, and decide whether the
* optimisation should still occur with that flag, then
* update the code accordingly. This applies to all the
- * other asserts in the block of code too.
+ * other ASSUMEs in the block of code too.
*/
- assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD)));
- assert(!(o2->op_private & ~OPpEARLY_CV));
+ ASSUME(!(o2->op_flags &
+ ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
+ ASSUME(!(o2->op_private & ~OPpEARLY_CV));
o2 = o2->op_next;
/* at this point we've seen gv,rv2sv, so the only valid
* construct left is $pkg->[] or $pkg->{} */
- assert(!(o2->op_flags & OPf_STACKED));
+ ASSUME(!(o2->op_flags & OPf_STACKED));
if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
!= (OPf_WANT_SCALAR|OPf_MOD))
break;
- assert(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
+ ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
|OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
break;
case OP_PADSV:
/* $lex->[...]: padsv[$lex] sM/DREFAV */
- assert(!(o2->op_flags &
+ ASSUME(!(o2->op_flags &
~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
if ((o2->op_flags &
(OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
!= (OPf_WANT_SCALAR|OPf_MOD))
break;
- assert(!(o2->op_private &
+ ASSUME(!(o2->op_private &
~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
/* skip if state or intro, or not a deref */
if ( o2->op_private != OPpDEREF_AV
case OP_PADHV:
/* $lex[..]: padav[@lex:1,2] sR *
* or $lex{..}: padhv[%lex:1,2] sR */
- assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
+ ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
OPf_REF|OPf_SPECIAL)));
if ((o2->op_flags &
(OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
break;
/* OPf_PARENS isn't currently used in this case;
* if that changes, let us know! */
- assert(!(o2->op_flags & OPf_PARENS));
+ ASSUME(!(o2->op_flags & OPf_PARENS));
/* at this point, we wouldn't expect any of the remaining
* possible private flags:
*
* OPpSLICEWARNING shouldn't affect runtime
*/
- assert(!(o2->op_private & ~(OPpSLICEWARNING)));
+ ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
action = o2->op_type == OP_PADAV
? MDEREF_AV_padav_aelem
/* (expr)->[...]: rv2av sKR/1;
* (expr)->{...}: rv2hv sKR/1; */
- assert(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
+ ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
- assert(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
|OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
break;
/* at this point, we wouldn't expect any of these
* possible private flags:
- * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
+ * OPpMAYBE_LVSUB, OPpLVAL_INTRO
* OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
*/
- assert(!(o2->op_private &
- ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
+ ASSUME(!(o2->op_private &
+ ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
+ |OPpOUR_INTRO)));
hints |= (o2->op_private & OPpHINT_STRICT_REFS);
o2 = o2->op_next;
assert(OpSIBLING(ns2) == pad2);
assert(OpSIBLING(pad2) == ns3);
+ /* excise and delete ns2 */
+ op_sibling_splice(NULL, pad1, 1, NULL);
+ op_free(ns2);
+
+ /* excise pad1 and pad2 */
+ op_sibling_splice(NULL, o, 2, NULL);
+
/* create new listop, with children consisting of:
* a new pushmark, pad1, pad2. */
- 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;
- newpm = cUNOPx(newop)->op_first; /* pushmark */
- /* Kill nextstate2 between padop1/padop2 */
- op_free(ns2);
+ /* insert newop between o and ns3 */
+ op_sibling_splice(NULL, o, 0, newop);
+ /*fixup op_next chain */
+ newpm = cUNOPx(newop)->op_first; /* pushmark */
o ->op_next = newpm;
newpm->op_next = pad1;
pad1 ->op_next = pad2;
pad2 ->op_next = newop; /* listop */
newop->op_next = ns3;
- OpSIBLING_set(o, newop);
- OpSIBLING_set(newop, ns3);
- newop->op_lastsib = 0;
-
- newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
-
/* Ensure pushmark has this flag if padops do */
if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
- o->op_next->op_flags |= OPf_MOD;
+ newpm->op_flags |= OPf_MOD;
}
break;
op_free(cBINOPo->op_last );
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
- assert(sizeof(OP) <= sizeof(BINOP));
- CHANGE_TYPE(o, OP_STUB);
+ STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
+ OpTYPE_set(o, OP_STUB);
o->op_private = 0;
break;
}
U8 count = 0;
U8 intro = 0;
PADOFFSET base = 0; /* init only to stop compiler whining */
- U8 gimme = 0; /* init only to stop compiler whining */
+ bool gvoid = 0; /* init only to stop compiler whining */
bool defav = 0; /* seen (...) = @_ */
bool reuse = 0; /* reuse an existing padrange op */
if (count == 0) {
intro = (p->op_private & OPpLVAL_INTRO);
base = p->op_targ;
- gimme = (p->op_flags & OPf_WANT);
+ gvoid = OP_GIMME(p,0) == G_VOID;
}
else {
if ((p->op_private & OPpLVAL_INTRO) != intro)
if (p->op_targ != base + count)
break;
assert(p->op_targ == base + count);
- /* all the padops should be in the same context */
- if (gimme != (p->op_flags & OPf_WANT))
+ /* Either all the padops or none of the padops should
+ be in void context. Since we only do the optimisa-
+ tion for av/hv when the aggregate itself is pushed
+ on to the stack (one item), there is no need to dis-
+ tinguish list from scalar context. */
+ if (gvoid != (OP_GIMME(p,0) == G_VOID))
break;
}
/* for AV, HV, only when we're not flattening */
if ( p->op_type != OP_PADSV
- && gimme != OPf_WANT_VOID
+ && !gvoid
&& !(p->op_flags & OPf_REF)
)
break;
* the stack) makes no difference in void context.
*/
assert(followop);
- if (gimme == OPf_WANT_VOID) {
+ if (gvoid) {
if (followop->op_type == OP_LIST
- && gimme == (followop->op_flags & OPf_WANT)
+ && OP_GIMME(followop,0) == G_VOID
)
{
followop = followop->op_next; /* skip OP_LIST */
* *always* formerly a pushmark */
assert(o->op_type == OP_PUSHMARK);
o->op_next = followop;
- CHANGE_TYPE(o, OP_PADRANGE);
+ OpTYPE_set(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
- | gimme | (defav ? OPf_SPECIAL : 0));
+ | gvoid * OPf_WANT_VOID
+ | (defav ? OPf_SPECIAL : 0));
}
break;
}
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- CHANGE_TYPE(o, OP_GVSV);
+ OpTYPE_set(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- CHANGE_TYPE(o, OP_RCATLINE);
+ OpTYPE_set(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
op_null(o->op_next->op_next);
op_null(o->op_next);
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)) {
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
/* We're just reversing a single array. */
rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
enter->op_flags |= OPf_STACKED;
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- CHANGE_TYPE(o, OP_CONST);
+ OpTYPE_set(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
any.xop_peep = xop->xop_peep;
break;
default:
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
break;
}
} else {
any.xop_peep = XOPd_xop_peep;
break;
default:
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
break;
}
}
case KEY_x : case KEY_xor :
if (!opnum) return NULL; nullret = TRUE; goto findopnum;
case KEY_glob: retsetpvs("_;", OP_GLOB);
- case KEY_keys: retsetpvs("+", OP_KEYS);
- case KEY_values: retsetpvs("+", OP_VALUES);
- case KEY_each: retsetpvs("+", OP_EACH);
- case KEY_push: retsetpvs("+@", OP_PUSH);
- case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
- case KEY_pop: retsetpvs(";+", OP_POP);
- case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
+ case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
+ case KEY_each: retsetpvs("\\[%@]", OP_EACH);
+ case KEY_push: retsetpvs("\\@@", OP_PUSH);
+ case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
+ case KEY_pop: retsetpvs(";\\@", OP_POP);
+ case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
case KEY_splice:
- retsetpvs("+;$$@", OP_SPLICE);
+ retsetpvs("\\@;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
case KEY_evalbytes:
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff