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
/* 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;
}
do {
SV *useless_sv = NULL;
const char* useless = NULL;
- bool useless_is_grep = FALSE;
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
case OP_HELEM:
case OP_HSLICE:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- useless = OP_DESC(o);
- break;
- case OP_GREPWHILE:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) {
/* Otherwise it's "Useless use of grep iterator" */
- useless = "grep";
- useless_is_grep = TRUE;
- }
+ useless = OP_DESC(o);
break;
case OP_SPLIT:
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);
}
SVfARG(sv_2mortal(useless_sv)));
}
else if (useless) {
- if (useless_is_grep) {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID_UNUSUAL),
- "Unusual use of %s in void context",
- useless);
- } else {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %s in void context",
- useless);
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
}
} while ( (o = POP_DEFERRED_OP()) );
#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;
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)
{
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);
}
}
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;
}
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, cBOOL(CvCLONE(PL_compcv)));
+ const_sv = NULL;
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
{
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;
}
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);
}
}
| ((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;
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;
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
}
/* 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) {
? -(SSize_t)len : (SSize_t)len,
0
);
+ if (SvREADONLY(*const_class))
+ SvREADONLY_on(shared);
SvREFCNT_dec(*const_class);
*const_class = shared;
}
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:
- NOT_REACHED;
+ 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;
}
else {
/* it's a constant array index */
+ IV iv;
SV *ix_sv = cSVOPo->op_sv;
- if (pass && 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
if (pass) {
OP *mderef;
- OP *p;
+ OP *p, *q;
mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
if (index_skip == -1) {
/* 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 {
* 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_flags &
+ ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
ASSUME(!(o2->op_private & ~OPpEARLY_CV));
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;
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
- CHANGE_TYPE(o, OP_STUB);
+ OpTYPE_set(o, OP_STUB);
o->op_private = 0;
break;
}
* *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_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:
*/