don't use a slab, but allocate the OP directly from the heap. */
if (!PL_compcv || CvROOT(PL_compcv)
|| (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
- return PerlMemShared_calloc(1, sz);
+ {
+ o = (OP*)PerlMemShared_calloc(1, sz);
+ goto gotit;
+ }
/* While the subroutine is under construction, the slabs are accessed via
CvSTART(), to avoid needing to expand PVCV by one pointer for something
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
- return (void *)o;
+ goto gotit;
}
}
slot = &slab2->opslab_slots;
INIT_OPSLOT;
DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
+
+ gotit:
+ /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
+ o->op_lastsib = 1;
+ assert(!o->op_sibling);
+
return (void *)o;
}
return;
type = o->op_type;
+
+ /* an op should only ever acquire op_private flags that we know about.
+ * If this fails, you may need to fix something in regen/op_private */
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
case OP_LEAVESUB:
OP_REFCNT_UNLOCK;
}
+
+/*
+=for apidoc op_sibling_splice
+
+A general function for editing the structure of an existing chain of
+op_sibling nodes. By analogy with the perl-level splice() function, allows
+you to delete zero or more sequential nodes, replacing them with zero or
+more different nodes. Performs the necessary op_first/op_last
+housekeeping on the parent node and op_sibling manipulation on the
+children. The last deleted node will be marked as as the last node by
+updating the op_sibling or op_lastsib field as appropriate.
+
+Note that op_next is not manipulated, and nodes are not freed; that is the
+responsibility of the caller. It also won't create a new list op for an
+empty list etc; use higher-level functions like op_append_elem() for that.
+
+parent is the parent node of the sibling chain.
+
+start is the node preceding the first node to be spliced. Node(s)
+following it will be deleted, and ops will be inserted after it. If it is
+NULL, the first node onwards is deleted, and nodes are inserted at the
+beginning.
+
+del_count is the number of nodes to delete. If zero, no nodes are deleted.
+If -1 or greater than or equal to the number of remaining kids, all
+remaining kids are deleted.
+
+insert is the first of a chain of nodes to be inserted in place of the nodes.
+If NULL, no nodes are inserted.
+
+The head of the chain of deleted ops is returned, or NULL if no ops were
+deleted.
+
+For example:
+
+ action before after returns
+ ------ ----- ----- -------
+
+ P P
+ splice(P, A, 2, X-Y-Z) | | B-C
+ A-B-C-D A-X-Y-Z-D
+
+ P P
+ splice(P, NULL, 1, X-Y) | | A
+ A-B-C-D X-Y-B-C-D
+
+ P P
+ splice(P, NULL, 3, NULL) | | A-B-C
+ A-B-C-D D
+
+ P P
+ splice(P, B, 0, X-Y) | | NULL
+ A-B-C-D A-B-X-Y-C-D
+
+=cut
+*/
+
+OP *
+Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
+{
+ OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
+ OP *rest;
+ OP *last_del = NULL;
+ OP *last_ins = NULL;
+
+ PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
+
+ assert(del_count >= -1);
+
+ if (del_count && first) {
+ last_del = first;
+ while (--del_count && OP_HAS_SIBLING(last_del))
+ last_del = OP_SIBLING(last_del);
+ rest = OP_SIBLING(last_del);
+ OP_SIBLING_set(last_del, NULL);
+ last_del->op_lastsib = 1;
+ }
+ else
+ rest = first;
+
+ if (insert) {
+ last_ins = insert;
+ while (OP_HAS_SIBLING(last_ins))
+ last_ins = OP_SIBLING(last_ins);
+ OP_SIBLING_set(last_ins, rest);
+ last_ins->op_lastsib = rest ? 0 : 1;
+ }
+ else
+ insert = rest;
+
+ if (start) {
+ OP_SIBLING_set(start, insert);
+ start->op_lastsib = insert ? 0 : 1;
+ }
+ else
+ cLISTOPx(parent)->op_first = insert;
+
+ if (!rest) {
+ /* update op_last etc */
+ U32 type = parent->op_type;
+ OP *lastop;
+
+ if (type == OP_NULL)
+ type = parent->op_targ;
+ type = PL_opargs[type] & OA_CLASS_MASK;
+
+ lastop = last_ins ? last_ins : start ? start : NULL;
+ if ( type == OA_BINOP
+ || type == OA_LISTOP
+ || type == OA_PMOP
+ || type == OA_LOOP
+ )
+ cLISTOPx(parent)->op_last = lastop;
+
+ if (lastop) {
+ lastop->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ lastop->op_sibling = parent;
+#endif
+ }
+ }
+ return last_del ? first : NULL;
+}
+
+/*
+=for apidoc op_parent
+
+returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
+work.
+
+=cut
+*/
+
+OP *
+Perl_op_parent(OP *o)
+{
+ PERL_ARGS_ASSERT_OP_PARENT;
+#ifdef PERL_OP_PARENT
+ while (OP_HAS_SIBLING(o))
+ o = OP_SIBLING(o);
+ return o->op_sibling;
+#else
+ PERL_UNUSED_ARG(o);
+ return NULL;
+#endif
+}
+
+
+/* replace the sibling following start with a new UNOP, which becomes
+ * the parent of the original sibling; e.g.
+ *
+ * op_sibling_newUNOP(P, A, unop-args...)
+ *
+ * P P
+ * | becomes |
+ * A-B-C A-U-C
+ * |
+ * B
+ *
+ * where U is the new UNOP.
+ *
+ * parent and start args are the same as for op_sibling_splice();
+ * type and flags args are as newUNOP().
+ *
+ * Returns the new UNOP.
+ */
+
+OP *
+S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
+{
+ OP *kid, *newop;
+
+ kid = op_sibling_splice(parent, start, 1, NULL);
+ newop = newUNOP(type, flags, kid);
+ op_sibling_splice(parent, start, 0, newop);
+ return newop;
+}
+
+
+/* lowest-level newLOGOP-style function - just allocates and populates
+ * the struct. Higher-level stuff should be done by S_new_logop() /
+ * newLOGOP(). This function exists mainly to avoid op_first assignment
+ * being spread throughout this file.
+ */
+
+LOGOP *
+S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+{
+ LOGOP *logop;
+ OP *kid = first;
+ NewOp(1101, logop, 1, LOGOP);
+ logop->op_type = (OPCODE)type;
+ logop->op_first = first;
+ logop->op_other = other;
+ logop->op_flags = OPf_KIDS;
+ while (kid && OP_HAS_SIBLING(kid))
+ kid = OP_SIBLING(kid);
+ if (kid) {
+ kid->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ kid->op_sibling = (OP*)logop;
+#endif
+ }
+ return logop;
+}
+
+
/* Contextualizers */
/*
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
- if (OP_HAS_SIBLING(kid)) {
- kid->op_next = LINKLIST(OP_SIBLING(kid));
- kid = OP_SIBLING(kid);
+ OP *sibl = OP_SIBLING(kid);
+ if (sibl) {
+ kid->op_next = LINKLIST(sibl);
+ kid = sibl;
} else {
kid->op_next = o;
break;
if (o->op_flags & OPf_KIDS) {
OP *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 */
+ U32 type = o->op_type;
+ U32 family;
+ bool has_last;
+
+ if (type == OP_NULL) {
+ type = o->op_targ;
+ /* ck_glob creates a null UNOP with ex-type GLOB
+ * (which is a list op. So pretend it wasn't a listop */
+ if (type == OP_GLOB)
+ type = OP_NULL;
+ }
+ family = PL_opargs[type] & OA_CLASS_MASK;
+
+ has_last = ( family == OA_BINOP
+ || family == OA_LISTOP
+ || family == OA_PMOP
+ || family == OA_LOOP
+ );
+ assert( has_last /* has op_first and op_last, or ...
+ ... has (or may have) op_first: */
+ || family == OA_UNOP
+ || family == OA_LOGOP
+ || family == OA_BASEOP_OR_UNOP
+ || family == OA_FILESTATOP
+ || family == OA_LOOPEXOP
+ /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
+ || type == OP_SASSIGN
+ || type == OP_CUSTOM
+ || type == OP_NULL /* new_logop does this */
+ );
+ /* XXX list form of 'x' is has a null op_last. This is wrong,
+ * but requires too much hacking (e.g. in Deparse) to fix for
+ * now */
+ if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
+ assert(has_last);
+ has_last = 0;
+ }
+
+ for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+# ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(kid)) {
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ assert(kid->op_sibling == o);
+ }
+# else
+ if (OP_HAS_SIBLING(kid)) {
+ assert(!kid->op_lastsib);
+ }
+ else {
+ assert(kid->op_lastsib);
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ }
+# endif
+ }
+#endif
+
for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
finalize_op(kid);
}
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* Both ENTERSUB and RV2CV use this bit, but for different pur-
- poses, so we need it clear. */
- o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
- o->op_private &= ~1;
}
else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
else if (new_proto)
op_free(new_proto);
new_proto = o;
- OP_SIBLING_set(lasto, OP_SIBLING(o));
+ /* excise new_proto from the list */
+ op_sibling_splice(*attrs, lasto, 1, NULL);
+ o = lasto;
continue;
}
}
lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
{
OP * const pushmark = lrops->op_first;
- lrops->op_first = OP_SIBLING(pushmark);
+ /* excise pushmark */
+ op_sibling_splice(rops, NULL, 1, NULL);
op_free(pushmark);
}
o = op_append_list(OP_LIST, o, rops);
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
+ U8 oldwarn = PL_dowarn;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
{
const char *s = SvPVX_const(sv);
while (s < SvEND(sv)) {
- if (*s == 'p' || *s == 'P') goto nope;
+ if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
s++;
}
}
PL_diehook = NULL;
JMPENV_PUSH(ret);
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
switch (ret) {
case 0:
CALLRUNOPS(aTHX);
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
JMPENV_POP;
+ PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
- curop = ((UNOP*)o)->op_first;
av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
- ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
+
+ /* replace subtree with an OP_CONST */
+ curop = ((UNOP*)o)->op_first;
+ op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
+ op_free(curop);
+
if (AvFILLp(av) != -1)
for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
{
SvPADTMP_on(*svp);
SvREADONLY_on(*svp);
}
- op_free(curop);
LINKLIST(o);
return list(o);
}
+/* convert o (and any siblings) into a list if not already, then
+ * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
+ */
+
OP *
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
- o = newLISTOP(OP_LIST, 0, o, NULL);
+ o = force_list(o, 0);
else
o->op_flags &= ~OPf_WANT;
return newLISTOP(type, 0, first, last);
}
- if (first->op_flags & OPf_KIDS)
- OP_SIBLING_set(((LISTOP*)first)->op_last, last);
- else {
- first->op_flags |= OPf_KIDS;
- ((LISTOP*)first)->op_first = last;
- }
- ((LISTOP*)first)->op_last = last;
+ op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
+ first->op_flags |= OPf_KIDS;
return first;
}
if (last->op_type != (unsigned)type)
return op_append_elem(type, first, last);
+ ((LISTOP*)first)->op_last->op_lastsib = 0;
OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
+ ((LISTOP*)first)->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ ((LISTOP*)first)->op_last->op_sibling = first;
+#endif
first->op_flags |= (last->op_flags & OPf_KIDS);
if (last->op_type == (unsigned)type) {
if (type == OP_LIST) { /* already a PUSHMARK there */
- OP_SIBLING_set(first, OP_SIBLING(((LISTOP*)last)->op_first));
- OP_SIBLING_set(((LISTOP*)last)->op_first, first);
+ /* insert 'first' after pushmark */
+ op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
if (!(first->op_flags & OPf_PARENS))
last->op_flags &= ~OPf_PARENS;
}
- else {
- if (!(last->op_flags & OPf_KIDS)) {
- ((LISTOP*)last)->op_last = first;
- last->op_flags |= OPf_KIDS;
- }
- OP_SIBLING_set(first, ((LISTOP*)last)->op_first);
- ((LISTOP*)last)->op_first = first;
- }
+ else
+ op_sibling_splice(last, NULL, 0, first);
last->op_flags |= OPf_KIDS;
return last;
}
return newOP(OP_STUB, 0);
}
+/* promote o and any siblings to be a list if its not already; i.e.
+ *
+ * o - A - B
+ *
+ * becomes
+ *
+ * list
+ * |
+ * pushmark - o - A - B
+ *
+ * If nullit it true, the list op is nulled.
+ */
+
static OP *
-S_force_list(pTHX_ OP *o)
-{
- if (!o || o->op_type != OP_LIST)
+S_force_list(pTHX_ OP *o, bool nullit)
+{
+ if (!o || o->op_type != OP_LIST) {
+ OP *rest = NULL;
+ if (o) {
+ /* manually detach any siblings then add them back later */
+ rest = OP_SIBLING(o);
+ OP_SIBLING_set(o, NULL);
+ o->op_lastsib = 1;
+ }
o = newLISTOP(OP_LIST, 0, o, NULL);
- op_null(o);
+ if (rest)
+ op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
+ }
+ if (nullit)
+ op_null(o);
return o;
}
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
+ pushop->op_lastsib = 0;
OP_SIBLING_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
if (!last)
listop->op_last = pushop;
}
+ if (first)
+ first->op_lastsib = 0;
+ if (listop->op_last) {
+ listop->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ listop->op_last->op_sibling = (OP*)listop;
+#endif
+ }
return CHECKOP(type, listop);
}
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
-
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET)
if (!first)
first = newOP(OP_STUB, 0);
if (PL_opargs[type] & OA_MARK)
- first = force_list(first);
+ first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
unop->op_type = (OPCODE)type;
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+ first->op_sibling = (OP*)unop;
+#endif
+
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
return (OP*)unop;
else {
binop->op_private = (U8)(2 | (flags >> 8));
OP_SIBLING_set(first, last);
+ first->op_lastsib = 0;
}
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
+ last->op_sibling = (OP*)binop;
+#endif
+
binop = (BINOP*)CHECKOP(type, binop);
if (binop->op_next || binop->op_type != (OPCODE)type)
return (OP*)binop;
binop->op_last = OP_SIBLING(binop->op_first);
+#ifdef PERL_OP_PARENT
+ if (binop->op_last)
+ binop->op_last->op_sibling = (OP*)binop;
+#endif
return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
kid = cLISTOPx(expr)->op_first;
while (OP_SIBLING(kid) != repl)
kid = OP_SIBLING(kid);
- OP_SIBLING_set(kid, NULL);
- cLISTOPx(expr)->op_last = kid;
+ op_sibling_splice(expr, kid, 1, NULL);
}
/* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
if (is_trans) {
- OP* const oe = expr;
- assert(expr->op_type == OP_LIST);
- assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
- assert(OP_SIBLING(cLISTOPx(expr)->op_first) == cLISTOPx(expr)->op_last);
- expr = cLISTOPx(oe)->op_last;
- OP_SIBLING_set(cLISTOPx(oe)->op_first, NULL);
- cLISTOPx(oe)->op_last = NULL;
- op_free(oe);
+ OP *first, *last;
+
+ assert(expr->op_type == OP_LIST);
+ first = cLISTOPx(expr)->op_first;
+ last = cLISTOPx(expr)->op_last;
+ assert(first->op_type == OP_PUSHMARK);
+ assert(OP_SIBLING(first) == last);
- return pmtrans(o, expr, repl);
+ /* cut 'last' from sibling chain, then free everything else */
+ op_sibling_splice(expr, first, 1, NULL);
+ op_free(expr);
+
+ return pmtrans(o, last, repl);
}
/* find whether we have any runtime or code elements;
cv_targ = expr->op_targ;
expr = newUNOP(OP_REFGEN, 0, expr);
- expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
+ expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
- NewOp(1101, rcop, 1, LOGOP);
- rcop->op_type = OP_REGCOMP;
+ rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
- rcop->op_first = scalar(expr);
- rcop->op_flags |= OPf_KIDS
- | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
- | (reglist ? OPf_STACKED : 0);
- rcop->op_private = 0;
- rcop->op_other = o;
+ rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
+ | (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- NewOp(1101, rcop, 1, LOGOP);
- rcop->op_type = OP_SUBSTCONT;
+ rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
- rcop->op_first = scalar(repl);
- rcop->op_flags |= OPf_KIDS;
rcop->op_private = 1;
- rcop->op_other = o;
/* establish postfix order */
rcop->op_next = LINKLIST(repl);
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
- padop->op_padix = pad_alloc(type, SVs_PADTMP);
+ padop->op_padix =
+ pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
op_free(o);
}
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
PL_cop_seqmax++;
Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
{
return newBINOP(OP_LSLICE, flags,
- list(force_list(subscript)),
- list(force_list(listval)) );
+ list(force_list(subscript, 1)),
+ list(force_list(listval, 1)) );
}
STATIC I32
PL_modcount = 0;
left = op_lvalue(left, OP_AASSIGN);
- curop = list(force_list(left));
- o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
+ curop = list(force_list(left, 1));
+ o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
o->op_private = (U8)(0 | (flags >> 8));
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
#endif
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
- OP_SIBLING_set(tmpop, NULL); /* don't free split */
+ /* detach rest of siblings from o subtree,
+ * and free subtree */
+ op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
right->op_next = tmpop->op_next; /* fix starting loc */
op_free(o); /* blow off assign */
right->op_flags &= ~OPf_WANT;
if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
- NewOp(1101, logop, 1, LOGOP);
-
- logop->op_type = (OPCODE)type;
+ logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
logop->op_ppaddr = PL_ppaddr[type];
- logop->op_first = first;
- logop->op_flags = (U8)(flags | OPf_KIDS);
- logop->op_other = LINKLIST(other);
+ logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
/* establish postfix order */
logop->op_next = LINKLIST(first);
first->op_next = (OP*)logop;
- OP_SIBLING_set(first, other);
+ assert(!OP_HAS_SIBLING(first));
+ op_sibling_splice((OP*)logop, first, 0, other);
CHECKOP(type,logop);
live->op_folded = 1;
return live;
}
- NewOp(1101, logop, 1, LOGOP);
- logop->op_type = OP_COND_EXPR;
+ logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
- logop->op_first = first;
- logop->op_flags = (U8)(flags | OPf_KIDS);
+ logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
- logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
start = LINKLIST(first);
first->op_next = (OP*)logop;
- OP_SIBLING_set(first, trueop);
- OP_SIBLING_set(trueop, falseop);
+ /* make first, trueop, falseop siblings */
+ op_sibling_splice((OP*)logop, first, 0, trueop);
+ op_sibling_splice((OP*)logop, trueop, 0, falseop);
+
o = newUNOP(OP_NULL, 0, (OP*)logop);
trueop->op_next = falseop->op_next = o;
PERL_ARGS_ASSERT_NEWRANGE;
- NewOp(1101, range, 1, LOGOP);
-
- range->op_type = OP_RANGE;
+ range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
range->op_ppaddr = PL_ppaddr[OP_RANGE];
- range->op_first = left;
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
- range->op_other = LINKLIST(right);
range->op_private = (U8)(1 | (flags >> 8));
- OP_SIBLING_set(left, right);
+ /* make left and right siblings */
+ op_sibling_splice((OP*)range, left, 0, right);
range->op_next = (OP*)range;
flip = newUNOP(OP_FLIP, flags, (OP*)range);
}
iterpflags |= OPpITER_DEF;
}
+
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
- expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
+ expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
iterflags |= OPf_STACKED;
}
else if (expr->op_type == OP_NULL &&
LISTOP* listop;
range->op_flags &= ~OPf_KIDS;
- range->op_first = NULL;
+ /* detach range's children */
+ op_sibling_splice((OP*)range, NULL, -1, NULL);
listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
listop->op_first->op_next = range->op_next;
iterflags |= OPf_STACKED;
}
else {
- expr = op_lvalue(force_list(expr), OP_GREPSTART);
+ expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
+#ifdef PERL_OP_PARENT
+ assert(loop->op_last->op_sibling == (OP*)loop);
+ loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
+#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
PERL_ARGS_ASSERT_NEWGIVWHENOP;
- NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = (Optype)enter_opcode;
+ enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
enterop->op_ppaddr = PL_ppaddr[enter_opcode];
- enterop->op_flags = (U8) OPf_KIDS;
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
enterop->op_private = 0;
o = newUNOP(leave_opcode, 0, (OP *) enterop);
if (cond) {
- enterop->op_first = scalar(cond);
- OP_SIBLING_set(cond, block);
+ /* prepend cond if we have one */
+ op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
o->op_next = LINKLIST(cond);
cond->op_next = (OP *) enterop;
}
else {
/* This is a default {} block */
- enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
o ->op_flags |= OPf_SPECIAL;
return looks_like_bool(cLOGOPo->op_first);
case OP_AND:
+ {
+ OP* sibl = OP_SIBLING(cLOGOPo->op_first);
+ ASSUME(sibl);
return (
looks_like_bool(cLOGOPo->op_first)
- && looks_like_bool(OP_SIBLING(cLOGOPo->op_first)));
+ && looks_like_bool(sibl));
+ }
case OP_NULL:
case OP_SCALAR:
{
if (!cv)
return NULL;
+ if (SvROK(cv)) return SvRV((SV *)cv);
assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
+ else if (type == OP_UNDEF && !o->op_private) {
+ sv = newSV(0);
+ SAVEFREESV(sv);
+ }
else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
CvNAME_HEK_set(*spot, hek =
share_hek(
PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
)
);
+ CvLEXICAL_on(*spot);
}
if (mg) {
assert(mg->mg_obj);
*spot = cv;
}
setname:
+ CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
- CvNAME_HEK_set(cv,
- hek
- ? share_hek_hek(hek)
- : share_hek(PadnamePV(name)+1,
+ if (hek) (void)share_hek_hek(hek);
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
+ hek = share_hek(PadnamePV(name)+1,
PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
- 0)
- );
+ hash);
+ }
+ CvNAME_HEK_set(cv, hek);
}
if (const_sv) goto clone;
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
-
if (!ec)
move_proto_attr(&proto, &attrs, gv);
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8);
}
- if (ps) {
+ if (!SvROK(gv)) {
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
+ }
+ else
sv_setiv(MUTABLE_SV(gv), -1);
+ }
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
CvISXSUB_on(cv);
}
else {
- GvCV_set(gv, NULL);
+ if (name) GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
}
}
- if (name && ! (PL_parser && PL_parser->error_count))
- process_special_blocks(floor, name, gv, cv);
+ if (name) {
+ if (PL_parser && PL_parser->error_count)
+ clear_special_blocks(name, gv, cv);
+ else
+ process_special_blocks(floor, name, gv, cv);
+ }
}
done:
}
STATIC void
+S_clear_special_blocks(pTHX_ const char *const fullname,
+ GV *const gv, CV *const cv) {
+ const char *colon;
+ const char *name;
+
+ PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
+
+ colon = strrchr(fullname,':');
+ name = colon ? colon + 1 : fullname;
+
+ if ((*name == 'B' && strEQ(name, "BEGIN"))
+ || (*name == 'E' && strEQ(name, "END"))
+ || (*name == 'U' && strEQ(name, "UNITCHECK"))
+ || (*name == 'C' && strEQ(name, "CHECK"))
+ || (*name == 'I' && strEQ(name, "INIT"))) {
+ GvCV_set(gv, NULL);
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
+ }
+}
+
+STATIC void
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
{
GV *gv;
OP *newop = NULL;
+ OP *sibl;
PERL_ARGS_ASSERT_CK_BACKTICK;
/* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
- if (o->op_flags & OPf_KIDS && OP_SIBLING(cUNOPo->op_first)
- && (gv = gv_override("readpipe",8))) {
- newop = S_new_entersubop(aTHX_ gv, OP_SIBLING(cUNOPo->op_first));
- OP_SIBLING_set(cUNOPo->op_first, NULL);
+ if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
+ && (gv = gv_override("readpipe",8)))
+ {
+ /* detach rest of siblings from o and its first child */
+ op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
+ newop = S_new_entersubop(aTHX_ gv, sibl);
}
else if (!(o->op_flags & OPf_KIDS))
newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
+ OP* kidkid;
const OPCODE type = o->op_type;
o = modkids(ck_fun(o), type);
- kid = cUNOPo->op_first;
- newop = OP_SIBLING(kUNOP->op_first);
+ kid = cUNOPo->op_first;
+ kidkid = kUNOP->op_first;
+ newop = OP_SIBLING(kidkid);
if (newop) {
const OPCODE type = newop->op_type;
if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
type == OP_RV2AV || type == OP_RV2HV)
return o;
}
- op_free(kUNOP->op_first);
- kUNOP->op_first = newop;
+ /* excise first sibling */
+ op_sibling_splice(kid, NULL, 1, NULL);
+ op_free(kidkid);
}
/* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
* and OP_CHOMP into OP_SCHOMP */
if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
- cUNOPo->op_first = 0;
+ /* cut whole sibling chain free from o */
+ op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
- NewOp(1101, enter, 1, LOGOP);
- enter->op_type = OP_ENTERTRY;
+ enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
- enter->op_private = 0;
/* establish postfix order */
enter->op_next = (OP*)enter;
else {
const U8 priv = o->op_private;
op_free(o);
- o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
+ /* the newUNOP will recursively call ck_eval(), which will handle
+ * all the stuff at the end of this function, like adding
+ * OP_HINTSEVAL
+ */
+ return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
}
o->op_targ = (PADOFFSET)PL_hints;
if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
- OP_SIBLING_set(cUNOPo->op_first, hhop);
+ /* append hhop to only child */
+ op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
+
o->op_private |= OPpEVAL_HAS_HH;
}
if (!(o->op_private & OPpEVAL_BYTES)
PERL_ARGS_ASSERT_CK_RVCONST;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
- if (o->op_type == OP_RV2CV)
- o->op_private &= ~1;
if (kid->op_type == OP_CONST) {
int iscv;
+ const int noexpand = o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
+ : 0;
GV *gv;
SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
- if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV * const rsv = SvRV(kidsv);
- const svtype type = SvTYPE(rsv);
- const char *badtype = NULL;
-
- switch (o->op_type) {
- case OP_RV2SV:
- if (type > SVt_PVMG)
- badtype = "a SCALAR";
- break;
- case OP_RV2AV:
- if (type != SVt_PVAV)
- badtype = "an ARRAY";
- break;
- case OP_RV2HV:
- if (type != SVt_PVHV)
- badtype = "a HASH";
- break;
- case OP_RV2CV:
- if (type != SVt_PVCV)
- badtype = "a CODE";
- break;
- }
- if (badtype)
- Perl_croak(aTHX_ "Constant is not %s reference", badtype);
+ if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
return o;
}
if (SvTYPE(kidsv) == SVt_PVAV) return o;
* whether the lexer already added THIS instance of this symbol.
*/
iscv = (o->op_type == OP_RV2CV) * 2;
- do {
- gv = gv_fetchsv(kidsv,
- iscv | !(kid->op_private & OPpCONST_ENTERED),
+ gv = gv_fetchsv(kidsv,
+ noexpand
+ ? noexpand
+ : iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
: o->op_type == OP_RV2SV
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
- } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
if (gv) {
kid->op_type = OP_GV;
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
assert (sizeof(PADOP) <= sizeof(SVOP));
- kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+ kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- GvIN_PAD_on(gv);
+ if (isGV(gv)) GvIN_PAD_on(gv);
PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
}
if (o->op_flags & OPf_KIDS) {
- OP **tokid = &cLISTOPo->op_first;
+ OP *prev_kid = NULL;
OP *kid = cLISTOPo->op_first;
- OP *sibl;
I32 numargs = 0;
bool seen_optional = FALSE;
if (kid->op_type == OP_PUSHMARK ||
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
{
- tokid = &kid->op_sibling;
+ prev_kid = kid;
kid = OP_SIBLING(kid);
}
if (kid && kid->op_type == OP_COREARGS) {
while (oa) {
if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
- if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
- *tokid = kid = newDEFSVOP();
+ if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
+ kid = newDEFSVOP();
+ /* append kid to chain */
+ op_sibling_splice(o, prev_kid, 0, kid);
+ }
seen_optional = TRUE;
}
if (!kid) break;
numargs++;
- sibl = OP_SIBLING(kid);
switch (oa & 7) {
case OA_SCALAR:
/* list seen where single (scalar) arg expected? */
break;
case OA_CVREF:
{
- OP * const newop = newUNOP(OP_NULL, 0, kid);
- OP_SIBLING_set(kid, 0);
+ /* replace kid with newop in chain */
+ OP * const newop =
+ S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
newop->op_next = newop;
kid = newop;
- OP_SIBLING_set(kid, sibl);
- *tokid = kid;
}
break;
case OA_FILEREF:
{
OP * const newop = newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
- if (!(o->op_private & 1) && /* if not unop */
- kid == cLISTOPo->op_last)
- cLISTOPo->op_last = newop;
+ /* replace kid with newop in chain */
+ op_sibling_splice(o, prev_kid, 1, newop);
op_free(kid);
kid = newop;
}
if ( name_utf8 ) SvUTF8_on(namesv);
}
}
- OP_SIBLING_set(kid, 0);
- kid = newUNOP(OP_RV2GV, flags, scalar(kid));
- kid->op_targ = targ;
- kid->op_private |= priv;
+ scalar(kid);
+ kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
+ OP_RV2GV, flags);
+ kid->op_targ = targ;
+ kid->op_private |= priv;
}
- OP_SIBLING_set(kid, sibl);
- *tokid = kid;
}
scalar(kid);
break;
break;
}
oa >>= 4;
- tokid = &kid->op_sibling;
+ prev_kid = kid;
kid = OP_SIBLING(kid);
}
/* FIXME - should the numargs or-ing move after the too many
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- NewOp(1101, gwop, 1, LOGOP);
- gwop->op_type = type;
+ gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
gwop->op_ppaddr = PL_ppaddr[type];
- gwop->op_first = o;
- gwop->op_flags |= OPf_KIDS;
- gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
case OP_PADAV:
- case OP_AASSIGN: /* Is this a good idea? */
Perl_croak(aTHX_ "Can't use 'defined(@array)'"
" (Maybe you should just omit the defined()?)");
break;
kid = cLISTOPo->op_first;
if (!kid) {
- o = force_list(o);
+ o = force_list(o, 1);
kid = cLISTOPo->op_first;
}
if (kid->op_type == OP_PUSHMARK)
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
&& !kid->op_folded) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
- kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
- OP_SIBLING_set(cLISTOPo->op_first, kid);
- cLISTOPo->op_last = kid;
+ scalar(kid);
+ /* replace old const op with new OP_RV2GV parent */
+ kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
+ OP_RV2GV, OPf_REF);
kid = OP_SIBLING(kid);
}
}
OP *second = OP_SIBLING(first);
/* Implicitly take a reference to an array or hash */
- OP_SIBLING_set(first, NULL);
- first = cBINOPo->op_first = ref_array_or_hash(first);
+
+ /* remove the original two siblings, then add back the
+ * (possibly different) first and second sibs.
+ */
+ op_sibling_splice(o, NULL, 1, NULL);
+ op_sibling_splice(o, NULL, 1, NULL);
+ first = ref_array_or_hash(first);
second = ref_array_or_hash(second);
- OP_SIBLING_set(first, second);
+ op_sibling_splice(o, NULL, 0, second);
+ op_sibling_splice(o, NULL, 0, first);
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
- /* Now we do not need PADSV and SASSIGN. */
- OP_SIBLING_set(kid, OP_SIBLING(o)); /* NULL */
- cLISTOPo->op_first = NULL;
+ /* Now we do not need PADSV and SASSIGN.
+ * first replace the PADSV with OP_SIBLING(o), then
+ * detach kid and OP_SIBLING(o) from o */
+ op_sibling_splice(o, kid, 1, OP_SIBLING(o));
+ op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
assignment binop->op_last = OP_SIBLING(binop->op_first); at the
end of Perl_newBINOP(). So need to do it here. */
cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
-
+ cBINOPo->op_first->op_lastsib = 0;
+ cBINOPo->op_last ->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ cBINOPo->op_last->op_sibling = o;
+#endif
return nullop;
}
}
PERL_ARGS_ASSERT_CK_REPEAT;
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
+ OP* kids;
o->op_private |= OPpREPEAT_DOLIST;
- cBINOPo->op_first = force_list(cBINOPo->op_first);
+ kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
+ kids = force_list(kids, 1); /* promote them to a list */
+ op_sibling_splice(o, NULL, 0, kids); /* and add back */
}
else
scalar(o);
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- SV * const sv = kid->op_sv;
- U32 was_readonly = SvREADONLY(sv);
- char *s;
- STRLEN len;
+ HEK *hek;
+ U32 hash;
+ char *s;
+ STRLEN len;
+ if (kid->op_type == OP_CONST) {
+ SV * const sv = kid->op_sv;
+ U32 const was_readonly = SvREADONLY(sv);
+ if (kid->op_private & OPpCONST_BARE) {
+ dVAR;
const char *end;
if (was_readonly) {
}
SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
+ PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
+ hek = share_hek(SvPVX(sv),
+ (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
+ }
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ s = SvPV(sv, len);
+ if (SvREFCNT(sv) > 1) {
+ kid->op_sv = newSVpvn_share(
+ s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
+ SvREFCNT_dec_NN(sv);
+ }
+ else {
+ dVAR;
+ if (was_readonly) SvREADONLY_off(sv);
+ PERL_HASH(hash, s, len);
+ hek = share_hek(s,
+ SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
+ SvFLAGS(sv) |= was_readonly;
+ }
+ }
}
}
OP *kid, *newop;
if (o->op_flags & OPf_KIDS) {
kid = cUNOPo->op_first;
- cUNOPo->op_first = NULL;
+ op_sibling_splice(o, NULL, -1, NULL);
}
else {
kid = newDEFSVOP();
if (k->op_type == OP_I_NCMP)
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
kid = OP_SIBLING(cLISTOPo->op_first);
- OP_SIBLING_set(cLISTOPo->op_first, OP_SIBLING(kid)); /* bypass old block */
- op_free(kid); /* then delete it */
+ /* cut out and delete old block (second sibling) */
+ op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
+ op_free(kid);
}
OP *
kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
- kid = OP_SIBLING(kid);
- op_free(cLISTOPo->op_first);
- if (kid)
- cLISTOPo->op_first = kid;
- else {
- cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
- cLISTOPo->op_last = kid; /* There was only one element previously */
- }
+ /* delete leading NULL node, then add a CONST if no other nodes */
+ op_sibling_splice(o, NULL, 1,
+ OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
+ op_free(kid);
+ kid = cLISTOPo->op_first;
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- OP * const sibl = OP_SIBLING(kid);
- OP_SIBLING_set(kid, 0);
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
- if (cLISTOPo->op_first == cLISTOPo->op_last)
- cLISTOPo->op_last = kid;
- cLISTOPo->op_first = kid;
- OP_SIBLING_set(kid, sibl);
+ /* remove kid, and replace with new optree */
+ op_sibling_splice(o, NULL, 1, NULL);
+ /* OPf_SPECIAL is used to trigger split " " behavior */
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
+ op_sibling_splice(o, NULL, 0, kid);
}
kid->op_type = OP_PUSHRE;
CV *cv;
GV *gv;
PERL_ARGS_ASSERT_RV2CV_OP_CV;
- if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+ if (flags & ~RV2CVOPCV_FLAG_MASK)
Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
if (cvop->op_type != OP_RV2CV)
return NULL;
switch (rvop->op_type) {
case OP_GV: {
gv = cGVOPx_gv(rvop);
+ if (!isGV(gv)) {
+ if (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if (!CvANON(cv) || !gv)
+ if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv))
gv = CvGV(cv);
return (CV*)gv;
} else {
{
STRLEN proto_len;
const char *proto, *proto_end;
- OP *aop, *prev, *cvop;
+ OP *aop, *prev, *cvop, *parent;
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
else proto = SvPV(protosv, proto_len);
proto = S_strip_spaces(aTHX_ proto, &proto_len);
proto_end = proto + proto_len;
+ parent = entersubop;
aop = cUNOPx(entersubop)->op_first;
- if (!OP_HAS_SIBLING(aop))
+ if (!OP_HAS_SIBLING(aop)) {
+ parent = aop;
aop = cUNOPx(aop)->op_first;
+ }
prev = aop;
aop = OP_SIBLING(aop);
for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
goto wrapref; /* autoconvert GLOB -> GLOBref */
else if (o3->op_type == OP_CONST)
o3->op_private &= ~OPpCONST_STRICT;
- else if (o3->op_type == OP_ENTERSUB) {
- /* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o3)->op_first;
- if (gvop && gvop->op_type == OP_NULL) {
- gvop = ((UNOP*)gvop)->op_first;
- if (gvop) {
- for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
- ;
- if (gvop &&
- (gvop->op_private & OPpENTERSUB_NOPAREN) &&
- (gvop = ((UNOP*)gvop)->op_first) &&
- gvop->op_type == OP_GV)
- {
- GV * const gv = cGVOPx_gv(gvop);
- OP * const sibling = OP_SIBLING(aop);
- SV * const n = newSVpvs("");
- op_free(aop);
- gv_fullname4(n, gv, "", FALSE);
- aop = newSVOP(OP_CONST, 0, n);
- OP_SIBLING_set(prev, aop);
- OP_SIBLING_set(aop, sibling);
- }
- }
- }
- }
scalar(aop);
break;
case '+':
bad_type_gv(arg, "hash", namegv, 0, o3);
break;
wrapref:
- {
- OP* const kid = aop;
- OP* const sib = OP_SIBLING(kid);
- OP_SIBLING_set(kid, 0);
- aop = newUNOP(OP_REFGEN, 0, kid);
- OP_SIBLING_set(aop, sib);
- OP_SIBLING_set(prev, aop);
- }
+ aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
+ OP_REFGEN, 0);
if (contextclass && e) {
proto = e + 1;
contextclass = 0;
}
if (aop == cvop && *proto == '_') {
/* generate an access to $_ */
- aop = newDEFSVOP();
- OP_SIBLING_set(aop, OP_SIBLING(prev));
- OP_SIBLING_set(prev, aop); /* instead of cvop */
+ op_sibling_splice(parent, prev, 0, newDEFSVOP());
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
NOT_REACHED;
}
else {
- OP *prev, *cvop;
- U32 flags;
- if (!OP_HAS_SIBLING(aop))
+ OP *prev, *cvop, *first, *parent;
+ U32 flags = 0;
+
+ parent = entersubop;
+ if (!OP_HAS_SIBLING(aop)) {
+ parent = aop;
aop = cUNOPx(aop)->op_first;
+ }
- prev = aop;
+ first = prev = aop;
aop = OP_SIBLING(aop);
- OP_SIBLING_set(prev, NULL);
+ /* find last sibling */
for (cvop = aop;
OP_HAS_SIBLING(cvop);
prev = cvop, cvop = OP_SIBLING(cvop))
;
- OP_SIBLING_set(prev, NULL);
- flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
+ /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
+ * parens, but these have their own meaning for that flag: */
+ && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
+ && opnum != OP_DELETE && opnum != OP_EXISTS)
+ flags |= OPf_SPECIAL;
+ /* excise cvop from end of sibling chain */
+ op_sibling_splice(parent, prev, 1, NULL);
op_free(cvop);
if (aop == cvop) aop = NULL;
+
+ /* detach remaining siblings from the first sibling, then
+ * dispose of original optree */
+
+ if (aop)
+ op_sibling_splice(parent, first, -1, NULL);
op_free(entersubop);
if (opnum == OP_ENTEREVAL
&& (!CopLABEL((COP*)o)) /* Don't mess with labels */
&& (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
) {
- OP *first;
- OP *last;
- OP *newop;
-
- first = o->op_next;
- last = o->op_next->op_next->op_next;
-
- newop = newLISTOP(OP_LIST, 0, first, last);
+ OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
+
+ pad1 = o->op_next;
+ ns2 = pad1->op_next;
+ pad2 = ns2->op_next;
+ ns3 = pad2->op_next;
+
+ /* we assume here that the op_next chain is the same as
+ * the op_sibling chain */
+ assert(OP_SIBLING(o) == pad1);
+ assert(OP_SIBLING(pad1) == ns2);
+ assert(OP_SIBLING(ns2) == pad2);
+ assert(OP_SIBLING(pad2) == ns3);
+
+ /* create new listop, with children consisting of:
+ * a new pushmark, pad1, pad2. */
+ OP_SIBLING_set(pad2, NULL);
+ newop = newLISTOP(OP_LIST, 0, pad1, pad2);
newop->op_flags |= OPf_PARENS;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ newpm = cUNOPx(newop)->op_first; /* pushmark */
/* Kill nextstate2 between padop1/padop2 */
- op_free(first->op_next);
-
- first->op_next = last; /* padop2 */
- OP_SIBLING_set(first, last); /* ... */
- o->op_next = cUNOPx(newop)->op_first; /* pushmark */
- o->op_next->op_next = first; /* padop1 */
- OP_SIBLING_set(o->op_next, first); /* ... */
- newop->op_next = last->op_next; /* nextstate3 */
- OP_SIBLING_set(newop, OP_SIBLING(last));
- last->op_next = newop; /* listop */
- OP_SIBLING_set(last, NULL);
- OP_SIBLING_set(o, newop); /* ... */
+ op_free(ns2);
+
+ o ->op_next = newpm;
+ newpm->op_next = pad1;
+ pad1 ->op_next = pad2;
+ pad2 ->op_next = newop; /* listop */
+ newop->op_next = ns3;
+
+ OP_SIBLING_set(o, newop);
+ OP_SIBLING_set(newop, ns3);
+ newop->op_lastsib = 0;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
/* Ensure pushmark has this flag if padops do */
- if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
+ if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
o->op_next->op_flags |= OPf_MOD;
}
if (left->op_type == OP_SUBSTR
&& (left->op_private & 7) < 4) {
op_null(o);
- cBINOP->op_first = left;
- OP_SIBLING_set(right,
- OP_SIBLING(cBINOPx(left)->op_first));
- OP_SIBLING_set(cBINOPx(left)->op_first, right);
+ /* cut out right */
+ op_sibling_splice(o, NULL, 1, NULL);
+ /* and insert it as second child of OP_SUBSTR */
+ op_sibling_splice(left, cBINOPx(left)->op_first, 0,
+ right);
left->op_private |= OPpSUBSTR_REPL_FIRST;
left->op_flags =
(o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;