#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* remove any leading "empty" ops from the op_next chain whose first
+ * node's address is stored in op_p. Store the updated address of the
+ * first node in op_p.
+ */
+
+STATIC void
+S_prune_chain_head(OP** op_p)
+{
+ while (*op_p
+ && ( (*op_p)->op_type == OP_NULL
+ || (*op_p)->op_type == OP_SCOPE
+ || (*op_p)->op_type == OP_SCALAR
+ || (*op_p)->op_type == OP_LINESEQ)
+ )
+ *op_p = (*op_p)->op_next;
+}
+
+
/* See the explanatory comments above struct opslab in op.h. */
#ifdef PERL_DEBUG_READONLY_OPS
#else
OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
+#ifndef WIN32
+ /* The context is unused in non-Windows */
+ PERL_UNUSED_CONTEXT;
+#endif
slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
return slab;
}
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
- dVAR;
OPSLAB *slab;
OPSLAB *slab2;
OPSLOT *slot;
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
if (slab->opslab_freed) {
OP **too = &slab->opslab_freed;
o = *too;
- DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
+ DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
DEBUG_S_warn((aTHX_ "Alas! too small"));
o = *(too = &o->op_next);
- if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
+ if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
}
if (o) {
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
- return (void *)o;
+ goto gotit;
}
}
< SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
slot = &slab2->opslab_slots;
INIT_OPSLOT;
- DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
+ 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;
}
void
Perl_Slab_Free(pTHX_ void *op)
{
- dVAR;
OP * const o = (OP *)op;
OPSLAB *slab;
o->op_type = OP_FREED;
o->op_next = slab->opslab_freed;
slab->opslab_freed = o;
- DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
+ DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
OpslabREFCNT_dec_padok(slab);
}
void
Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
{
- dVAR;
const bool havepad = !!PL_comppad;
PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
if (havepad) {
void
Perl_opslab_free(pTHX_ OPSLAB *slab)
{
- dVAR;
OPSLAB *slab2;
PERL_ARGS_ASSERT_OPSLAB_FREE;
- DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
+ PERL_UNUSED_CONTEXT;
+ DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
assert(slab->opslab_refcnt == 1);
for (; slab; slab = slab2) {
slab2 = slab->opslab_next;
#endif
#ifdef PERL_DEBUG_READONLY_OPS
DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
- slab));
+ (void*)slab));
if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
perror("munmap failed");
abort();
S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
- yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
SvUTF8(namesv) | flags);
return o;
}
{
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
- if (PL_madskills)
- return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
PADOFFSET
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
- dVAR;
PADOFFSET off;
const bool is_our = (PL_parser->in_my == KEY_our);
}
/*
+=head1 Optree Manipulation Functions
+
=for apidoc alloccopstash
Available only under threaded builds, this function allocates an entry in
void
Perl_op_free(pTHX_ OP *o)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
OPCODE type;
/* Though ops may be freed twice, freeing the op after its slab is a
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:
if (o->op_flags & OPf_KIDS) {
OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = kid->op_sibling; /* Get before next freeing kid */
+ nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
op_free(kid);
}
}
PERL_ARGS_ASSERT_OP_CLEAR;
-#ifdef PERL_MAD
- mad_free(o->op_madprop);
- o->op_madprop = 0;
-#endif
-
- retry:
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
- if (PL_madskills && o->op_targ != OP_NULL) {
- o->op_type = (Optype)o->op_targ;
- o->op_targ = 0;
- goto retry;
- }
+ /* FALLTHROUGH */
case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
if (!(o->op_flags & OPf_REF)
|| (PL_check[o->op_type] != Perl_ck_ftst))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
case OP_REDO:
if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_TRANS:
case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
#else
SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_MATCH:
case OP_QR:
clear_pmop:
forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
}
}
}
if (o->op_type == OP_NULL)
return;
- if (!PL_madskills)
- op_clear(o);
+ op_clear(o);
o->op_targ = o->op_type;
o->op_type = OP_NULL;
o->op_ppaddr = PL_ppaddr[OP_NULL];
void
Perl_op_refcnt_lock(pTHX)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
}
void
Perl_op_refcnt_unlock(pTHX)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
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 */
/*
default:
Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
(long) context);
- return o;
}
}
/*
-=head1 Optree Manipulation Functions
=for apidoc Am|OP*|op_linklist|OP *o
This function is the implementation of the L</LINKLIST> macro. It should
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
- if (kid->op_sibling) {
- kid->op_next = LINKLIST(kid->op_sibling);
- kid = kid->op_sibling;
+ OP *sibl = OP_SIBLING(kid);
+ if (sibl) {
+ kid->op_next = LINKLIST(sibl);
+ kid = sibl;
} else {
kid->op_next = o;
break;
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
scalar(kid);
}
return o;
STATIC OP *
S_scalarboolean(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_SCALARBOOLEAN;
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
return;
kid = cLISTOPo->op_first;
- kid = kid->op_sibling; /* get past pushmark */
+ kid = OP_SIBLING(kid); /* get past pushmark */
/* weed out false positives: any ops that can return lists */
switch (kid->op_type) {
case OP_BACKTICK:
if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
return;
- assert(kid->op_sibling);
- name = S_op_varname(aTHX_ kid->op_sibling);
+ assert(OP_SIBLING(kid));
+ name = S_op_varname(aTHX_ OP_SIBLING(kid));
if (!name) /* XS module fiddling with the op tree */
return;
S_op_pretty(aTHX_ kid, &keysv, &key);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value @%"SVf"%c%"SVf"%c better written as $%"
SVf"%c%"SVf"%c",
- SVfARG(name), lbrack, keysv, rbrack,
- SVfARG(name), lbrack, keysv, rbrack);
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
OP *
Perl_scalar(pTHX_ OP *o)
{
- dVAR;
OP *kid;
/* assumes no premature commitment */
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
scalar(kid);
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SPLIT:
case OP_MATCH:
case OP_QR:
case OP_NULL:
default:
if (o->op_flags & OPf_KIDS) {
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
scalar(kid);
}
break;
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
scalar(kid);
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
do_kids:
while (kid) {
- OP *sib = kid->op_sibling;
+ OP *sib = OP_SIBLING(kid);
if (sib && kid->op_type != OP_LEAVEWHEN)
scalarvoid(kid);
else
if (!ckWARN(WARN_SYNTAX)) break;
kid = cLISTOPo->op_first;
- kid = kid->op_sibling; /* get past pushmark */
- assert(kid->op_sibling);
- name = S_op_varname(aTHX_ kid->op_sibling);
+ kid = OP_SIBLING(kid); /* get past pushmark */
+ assert(OP_SIBLING(kid));
+ name = S_op_varname(aTHX_ OP_SIBLING(kid));
if (!name) /* XS module fiddling with the op tree */
break;
S_op_pretty(aTHX_ kid, &keysv, &key);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%%%"SVf"%c%"SVf"%c in scalar context better "
"written as $%"SVf"%c%"SVf"%c",
- SVfARG(name), lbrack, keysv, rbrack,
- SVfARG(name), lbrack, keysv, rbrack);
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
}
return o;
PERL_ARGS_ASSERT_SCALARVOID;
- /* trailing mad null ops don't count as "there" for void processing */
- if (PL_madskills &&
- o->op_type != OP_NULL &&
- o->op_sibling &&
- o->op_sibling->op_type == OP_NULL)
- {
- OP *sib;
- for (sib = o->op_sibling;
- sib && sib->op_type == OP_NULL;
- sib = sib->op_sibling) ;
-
- if (!sib)
- return o;
- }
-
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
default:
if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
case OP_SUBSTR:
if (o->op_private == 4)
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
case OP_RV2AV:
case OP_RV2HV:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
+ (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
useless = "a variable";
break;
SvREFCNT_dec_NN(dsv);
}
else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
}
else
useless = "a constant (undef)";
case OP_AND:
kid = cLOGOPo->op_first;
if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)
- && !PL_madskills) {
+ && (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
o->op_type = OP_OR;
o->op_ppaddr = PL_ppaddr[OP_OR];
}
op_null(kid);
}
+ /* FALLTHROUGH */
case OP_DOR:
case OP_COND_EXPR:
case OP_ENTERGIVEN:
case OP_ENTERWHEN:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
scalarvoid(kid);
break;
case OP_NULL:
if (o->op_flags & OPf_STACKED)
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
case OP_ENTERTRY:
case OP_ENTER:
if (!(o->op_flags & OPf_KIDS))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
case OP_LIST:
case OP_LEAVEGIVEN:
case OP_LEAVEWHEN:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
scalarvoid(kid);
break;
case OP_ENTEREVAL:
/* mortalise it, in case warnings are fatal. */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Useless use of %"SVf" in void context",
- sv_2mortal(useless_sv));
+ SVfARG(sv_2mortal(useless_sv)));
}
else if (useless) {
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
list(kid);
}
return o;
OP *
Perl_list(pTHX_ OP *o)
{
- dVAR;
OP *kid;
/* assumes no premature commitment */
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
list(kid);
break;
default:
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
list(kid);
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
do_kids:
while (kid) {
- OP *sib = kid->op_sibling;
+ OP *sib = OP_SIBLING(kid);
if (sib && kid->op_type != OP_LEAVEWHEN)
scalarvoid(kid);
else
static OP *
S_scalarseq(pTHX_ OP *o)
{
- dVAR;
if (o) {
const OPCODE type = o->op_type;
type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling) {
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+ if (OP_HAS_SIBLING(kid)) {
scalarvoid(kid);
}
}
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
op_lvalue(kid, type);
}
return o;
{
PERL_ARGS_ASSERT_FINALIZE_OP;
-#if defined(PERL_MAD) && defined(USE_ITHREADS)
- {
- /* Make sure mad ops are also thread-safe */
- MADPROP *mp = o->op_madprop;
- while (mp) {
- if (mp->mad_type == MAD_OP && mp->mad_vlen) {
- OP *prop_op = (OP *) mp->mad_val;
- /* We only need "Relocate sv to the pad for thread safety.", but this
- easiest way to make sure it traverses everything */
- if (prop_op->op_type == OP_CONST)
- cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
- finalize_op(prop_op);
- }
- mp = mp->mad_next;
- }
- }
-#endif
switch (o->op_type) {
case OP_NEXTSTATE:
PL_curcop = ((COP*)o); /* for warnings */
break;
case OP_EXEC:
- if ( o->op_sibling
- && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
- && ckWARN(WARN_EXEC))
- {
- if (o->op_sibling->op_sibling) {
- const OPCODE type = o->op_sibling->op_sibling->op_type;
+ if (OP_HAS_SIBLING(o)) {
+ OP *sib = OP_SIBLING(o);
+ if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
+ && ckWARN(WARN_EXEC)
+ && OP_HAS_SIBLING(sib))
+ {
+ const OPCODE type = OP_SIBLING(sib)->op_type;
if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
const line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
+ CopLINE_set(PL_curcop, CopLINE((COP*)sib));
Perl_warner(aTHX_ packWARN(WARN_EXEC),
"Statement unlikely to be reached");
Perl_warner(aTHX_ packWARN(WARN_EXEC),
"\t(Maybe you meant system() when you said exec()?)\n");
CopLINE_set(PL_curcop, oldline);
}
- }
}
+ }
break;
case OP_GV:
case OP_HSLICE:
S_scalar_slice_warning(aTHX_ o);
+ /* FALLTHROUGH */
case OP_KVHSLICE:
- kid = cLISTOPo->op_first->op_sibling;
+ kid = OP_SIBLING(cLISTOPo->op_first);
if (/* I bet there's always a pushmark... */
OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
&& OP_TYPE_ISNT_NN(kid, OP_CONST))
key_op = (SVOP*)(kid->op_type == OP_CONST
? kid
- : kLISTOP->op_first->op_sibling);
+ : OP_SIBLING(kLISTOP->op_first));
rop = (UNOP*)((LISTOP*)o)->op_last;
&& (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
&& isGV(*fields) && GvHV(*fields);
for (; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
+ key_op = (SVOP*)OP_SIBLING(key_op)) {
SV **svp, *sv;
if (key_op->op_type != OP_CONST)
continue;
if (o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+
+#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);
}
}
PL_modcount++;
return o;
case OP_STUB:
- if ((o->op_flags & OPf_PARENS) || PL_madskills)
+ if ((o->op_flags & OPf_PARENS))
break;
goto nomod;
case OP_ENTERSUB:
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 */
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
+ GV *gv;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
(long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
}
- while (kid->op_sibling)
- kid = kid->op_sibling;
+ while (OP_HAS_SIBLING(kid))
+ kid = OP_SIBLING(kid);
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
break; /* Postpone until runtime */
}
break;
}
- cv = GvCV(kGVOP_gv);
+ gv = kGVOP_gv;
+ cv = isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : NULL;
if (!cv)
break;
if (CvLVALUE(cv))
break;
}
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
nomod:
if (flags & OP_LVALUE_NO_CROAK) return NULL;
case OP_COND_EXPR:
localize = 1;
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
op_lvalue(kid, type);
break;
PL_modcount = RETURN_UNLIMITED_NUMBER;
return o; /* Treat \(@foo) like ordinary list. */
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_RV2GV:
if (scalar_mod_type(o, type))
goto nomod;
ref(cUNOPo->op_first, o->op_type);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_ASLICE:
case OP_HSLICE:
localize = 1;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_AASSIGN:
/* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
if (type == OP_LEAVESUBLV && (
|| (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
))
o->op_private |= OPpMAYBE_LVSUB;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
case OP_RV2SV:
ref(cUNOPo->op_first, o->op_type);
localize = 1;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GV:
PL_hints |= HINT_BLOCK_SCOPE;
+ /* FALLTHROUGH */
case OP_SASSIGN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
&& type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
case OP_SUBSTR:
if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
goto nomod;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_POS:
case OP_VEC:
lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
if (o->op_flags & OPf_KIDS)
- op_lvalue(cBINOPo->op_first->op_sibling, type);
+ op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
break;
case OP_AELEM:
case OP_LEAVE:
case OP_LEAVELOOP:
o->op_private |= OPpLVALUE;
+ /* FALLTHROUGH */
case OP_SCOPE:
case OP_ENTER:
case OP_LINESEQ:
op_lvalue(cBINOPo->op_first, type);
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_LIST:
localize = 0;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
/* elements might be in void context because the list is
in scalar context or because they are attribute sub calls */
if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
|| !S_vivifies(cLOGOPo->op_first->op_type))
op_lvalue(cLOGOPo->op_first, type);
if (type == OP_LEAVESUBLV
- || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
- op_lvalue(cLOGOPo->op_first->op_sibling, type);
+ || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
+ op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
goto nomod;
}
case OP_SASSIGN:
if (o && o->op_type == OP_RV2GV)
return FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PREINC:
case OP_PREDEC:
case OP_POSTINC:
case OP_SOCKPAIR:
if (numargs == 2)
return TRUE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SYSOPEN:
case OP_OPEN:
case OP_SELECT: /* XXX c.f. SelectSaver.pm */
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
ref(kid, type);
}
return o;
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
break;
case OP_COND_EXPR:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
doref(cUNOPo->op_first, o->op_type, set_op_ref);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
case OP_RV2HV:
if (set_op_ref)
o->op_flags |= OPf_REF;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
case OP_SCOPE:
case OP_LEAVE:
set_op_ref = FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_ENTER:
case OP_LIST:
if (!(o->op_flags & OPf_KIDS))
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- dVAR;
OP *rop;
PERL_ARGS_ASSERT_DUP_ATTRLIST;
*/
if (o->op_type == OP_CONST)
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
-#ifdef PERL_MAD
- else if (o->op_type == OP_NULL)
- rop = NULL;
-#endif
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
rop = NULL;
- for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
if (o->op_type == OP_CONST)
rop = op_append_elem(OP_LIST, rop,
newSVOP(OP_CONST, o->op_flags,
STATIC void
S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
- dVAR;
SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
PERL_ARGS_ASSERT_APPLY_ATTRS;
STATIC void
S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
{
- dVAR;
OP *pack, *imop, *arg;
SV *meth, *stashsv, **svp;
*attrs = NULL;
}
} else if (o->op_type == OP_LIST) {
- OP * lasto = NULL;
+ OP * lasto;
assert(o->op_flags & OPf_KIDS);
- assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
- /* Counting on the first op to hit the lasto = o line */
- for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ lasto = cLISTOPo->op_first;
+ assert(lasto->op_type == OP_PUSHMARK);
+ for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
else if (new_proto)
op_free(new_proto);
new_proto = o;
- lasto->op_sibling = o->op_sibling;
+ /* excise new_proto from the list */
+ op_sibling_splice(*attrs, lasto, 1, NULL);
+ o = lasto;
continue;
}
}
}
/* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
would get pulled in with no real need */
- if (!cLISTOPx(*attrs)->op_first->op_sibling) {
+ if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
op_free(*attrs);
*attrs = NULL;
}
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
- dVAR;
I32 type;
const bool stately = PL_parser && PL_parser->in_my == KEY_state;
return o;
type = o->op_type;
- if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
- (void)my_kid(cUNOPo->op_first, attrs, imopsp);
- return o;
- }
if (type == OP_LIST) {
OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
my_kid(kid, attrs, imopsp);
return o;
} else if (type == OP_UNDEF || type == OP_STUB) {
S_cant_declare(aTHX_ o);
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
+ assert(PL_parser);
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
+ assert(PL_parser);
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- dVAR;
OP *rops;
int maybe_scalar = 0;
lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
{
OP * const pushmark = lrops->op_first;
- lrops->op_first = pushmark->op_sibling;
+ /* excise pushmark */
+ op_sibling_splice(rops, NULL, 1, NULL);
op_free(pushmark);
}
o = op_append_list(OP_LIST, o, rops);
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %"SVf" will act on scalar(%"SVf")",
- desc, name, name);
+ desc, SVfARG(name), SVfARG(name));
else {
const char * const sample = (isary
? "@array" : "%hash");
op_null(kid);
/* The following deals with things like 'do {1 for 1}' */
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
if (kid &&
(kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
op_null(kid);
{
if (o && o->op_type == OP_LINESEQ) {
OP *kid = cLISTOPo->op_first;
- for(; kid; kid = kid->op_sibling)
+ for(; kid; kid = OP_SIBLING(kid))
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
op_null(kid);
}
int
Perl_block_start(pTHX_ int full)
{
- dVAR;
const int retval = PL_savestack_ix;
pad_block_start(full);
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
- dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
OP *o;
*/
OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
- for (;; kid = kid->op_sibling) {
+ for (;; kid = OP_SIBLING(kid)) {
OP *newkid = newOP(OP_CLONECV, 0);
newkid->op_targ = kid->op_targ;
o = op_append_elem(OP_LINESEQ, o, newkid);
STATIC OP *
S_newDEFSVOP(pTHX)
{
- dVAR;
const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
void
Perl_newPROG(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
ENTER;
CALL_PEEP(PL_eval_start);
finalize_optree(PL_eval_root);
+ S_prune_chain_head(&PL_eval_start);
LEAVE;
PL_savestack_ix = i;
}
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
finalize_optree(PL_main_root);
+ S_prune_chain_head(&PL_main_start);
cv_forget_slab(PL_compcv);
PL_compcv = 0;
OP *
Perl_localize(pTHX_ OP *o, I32 lex)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOCALIZE;
if (o->op_flags & OPf_PARENS)
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
+ U8 oldwarn = PL_dowarn;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
case OP_UC:
case OP_LC:
case OP_FC:
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_COMPILETIME(LC_CTYPE))
+ goto nope;
+#endif
+ break;
case OP_SLT:
case OP_SGT:
case OP_SLE:
case OP_SGE:
case OP_SCMP:
+#ifdef USE_LOCALE_COLLATE
+ if (IN_LC_COMPILETIME(LC_COLLATE))
+ goto nope;
+#endif
+ break;
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (IN_LOCALE_COMPILETIME)
+#ifdef USE_LOCALE_NUMERIC
+ if (IN_LC_COMPILETIME(LC_NUMERIC))
goto nope;
+#endif
break;
case OP_PACK:
- if (!cLISTOPo->op_first->op_sibling
- || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
+ if (!OP_HAS_SIBLING(cLISTOPo->op_first)
+ || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
goto nope;
{
- SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
+ SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
{
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);
sv = *(PL_stack_sp--);
if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
-#ifdef PERL_MAD
- /* Can't simply swipe the SV from the pad, because that relies on
- the op being freed "real soon now". Under MAD, this doesn't
- happen (see the #ifdef below). */
- sv = newSVsv(sv);
-#else
pad_swipe(o->op_targ, FALSE);
-#endif
}
else if (SvTEMP(sv)) { /* grab mortal temp? */
SvREFCNT_inc_simple_void(sv);
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;
if (ret)
goto nope;
-#ifndef PERL_MAD
op_free(o);
-#endif
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
else if (!SvIMMORTAL(sv)) {
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
if (type != OP_STRINGIFY) newop->op_folded = 1;
}
- op_getmad(o,newop,'f');
return newop;
nope:
if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
- PL_op = curop = LINKLIST(o);
+ curop = LINKLIST(o);
o->op_next = 0;
CALL_PEEP(curop);
+ S_prune_chain_head(&curop);
+ PL_op = curop;
Perl_pp_pushmark(aTHX);
CALLRUNOPS(aTHX);
PL_op = curop;
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);
}
-#ifdef PERL_MAD
- op_getmad(curop,o,'O');
-#else
- op_free(curop);
-#endif
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;
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
else {
- OP * const kid2 = cLISTOPo->op_first->op_sibling;
+ OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
if (kid2 && kid2->op_type == OP_COREARGS) {
op_null(cLISTOPo->op_first);
kid2->op_private |= OPpCOREARGS_PUSHMARK;
return newLISTOP(type, 0, first, last);
}
- if (first->op_flags & OPf_KIDS)
- ((LISTOP*)first)->op_last->op_sibling = 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_sibling = ((LISTOP*)last)->op_first;
+ ((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);
-#ifdef PERL_MAD
- if (((LISTOP*)last)->op_first && first->op_madprop) {
- MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
- if (mp) {
- while (mp->mad_next)
- mp = mp->mad_next;
- mp->mad_next = first->op_madprop;
- }
- else {
- ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
- }
- }
- first->op_madprop = last->op_madprop;
- last->op_madprop = 0;
-#endif
S_op_destroy(aTHX_ last);
if (last->op_type == (unsigned)type) {
if (type == OP_LIST) { /* already a PUSHMARK there */
- first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
- ((LISTOP*)last)->op_first->op_sibling = 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;
- }
- first->op_sibling = ((LISTOP*)last)->op_first;
- ((LISTOP*)last)->op_first = first;
- }
+ else
+ op_sibling_splice(last, NULL, 0, first);
last->op_flags |= OPf_KIDS;
return last;
}
/* Constructors */
-#ifdef PERL_MAD
-
-TOKEN *
-Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
-{
- TOKEN *tk;
- Newxz(tk, 1, TOKEN);
- tk->tk_type = (OPCODE)optype;
- tk->tk_type = 12345;
- tk->tk_lval = lval;
- tk->tk_mad = madprop;
- return tk;
-}
-
-void
-Perl_token_free(pTHX_ TOKEN* tk)
-{
- PERL_ARGS_ASSERT_TOKEN_FREE;
-
- if (tk->tk_type != 12345)
- return;
- mad_free(tk->tk_mad);
- Safefree(tk);
-}
-
-void
-Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
-{
- MADPROP* mp;
- MADPROP* tm;
-
- PERL_ARGS_ASSERT_TOKEN_GETMAD;
-
- if (tk->tk_type != 12345) {
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Invalid TOKEN object ignored");
- return;
- }
- tm = tk->tk_mad;
- if (!tm)
- return;
-
- /* faked up qw list? */
- if (slot == '(' &&
- tm->mad_type == MAD_SV &&
- SvPVX((SV *)tm->mad_val)[0] == 'q')
- slot = 'x';
-
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- token_getmad(tk,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
- mp = mp->mad_next;
- }
- else {
- o->op_madprop = tm;
- mp = o->op_madprop;
- }
- if (mp->mad_key == 'X')
- mp->mad_key = slot; /* just change the first one */
-
- tk->tk_mad = 0;
- }
- else
- mad_free(tm);
- Safefree(tk);
-}
-
-void
-Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
-{
- MADPROP* mp;
- if (!from)
- return;
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- op_getmad(from,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
- }
- else {
- o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
- }
- }
-}
-
-void
-Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
-{
- MADPROP* mp;
- if (!from)
- return;
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- op_getmad(from,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
- }
- else {
- o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
- }
- }
- else {
- PerlIO_printf(PerlIO_stderr(),
- "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
- op_free(from);
- }
-}
-
-void
-Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
-{
- MADPROP* tm;
- if (!mp || !o)
- return;
- if (slot)
- mp->mad_key = slot;
- tm = o->op_madprop;
- o->op_madprop = mp;
- for (;;) {
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
-}
-
-void
-Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
-{
- if (!o)
- return;
- addmad(tm, &(o->op_madprop), slot);
-}
-
-void
-Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
-{
- MADPROP* mp;
- if (!tm || !root)
- return;
- if (slot)
- tm->mad_key = slot;
- mp = *root;
- if (!mp) {
- *root = tm;
- return;
- }
- for (;;) {
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
-}
-
-MADPROP *
-Perl_newMADsv(pTHX_ char key, SV* sv)
-{
- PERL_ARGS_ASSERT_NEWMADSV;
-
- return newMADPROP(key, MAD_SV, sv, 0);
-}
-
-MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
-{
- MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
- mp->mad_next = 0;
- mp->mad_key = key;
- mp->mad_vlen = vlen;
- mp->mad_type = type;
- mp->mad_val = val;
-/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
- return mp;
-}
-
-void
-Perl_mad_free(pTHX_ MADPROP* mp)
-{
-/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
- if (!mp)
- return;
- if (mp->mad_next)
- mad_free(mp->mad_next);
-/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
- PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
- switch (mp->mad_type) {
- case MAD_NULL:
- break;
- case MAD_PV:
- Safefree(mp->mad_val);
- break;
- case MAD_OP:
- if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
- op_free((OP*)mp->mad_val);
- break;
- case MAD_SV:
- sv_free(MUTABLE_SV(mp->mad_val));
- break;
- default:
- PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
- break;
- }
- PerlMemShared_free(mp);
-}
-
-#endif
/*
=head1 Optree construction
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;
}
else if (!first && last)
first = last;
else if (first)
- first->op_sibling = last;
+ OP_SIBLING_set(first, last);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
- pushop->op_sibling = first;
+ 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);
}
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));
- first->op_sibling = last;
+ 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 = binop->op_first->op_sibling;
+ 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)));
}
static OP *
S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
- dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
SV * const rstr =
-#ifdef PERL_MAD
- (repl->op_type == OP_NULL)
- ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
-#endif
((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
rend = r + len;
}
-/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
+/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
* encoded chars in native encoding which makes ranges in the EBCDIC 0..255
* odd. */
Safefree(tsave);
Safefree(rsave);
-#ifdef PERL_MAD
- op_getmad(expr,o,'e');
- op_getmad(repl,o,'r');
-#else
op_free(expr);
op_free(repl);
-#endif
return o;
}
if (grows)
o->op_private |= OPpTRANS_GROWS;
-#ifdef PERL_MAD
- op_getmad(expr,o,'e');
- op_getmad(repl,o,'r');
-#else
op_free(expr);
op_free(repl);
-#endif
return o;
}
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
- if (IN_LOCALE_COMPILETIME) {
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_COMPILETIME(LC_CTYPE)) {
set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
- else if ((! (PL_hints & HINT_BYTES))
- /* Both UNI_8_BIT and locale :not_characters imply Unicode */
- && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
- {
+ else
+#endif
+ if (IN_UNI_8_BIT) {
set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
OP* kid;
repl = cLISTOPx(expr)->op_last;
kid = cLISTOPx(expr)->op_first;
- while (kid->op_sibling != repl)
- kid = kid->op_sibling;
- kid->op_sibling = NULL;
- cLISTOPx(expr)->op_last = kid;
+ while (OP_SIBLING(kid) != repl)
+ kid = OP_SIBLING(kid);
+ op_sibling_splice(expr, kid, 1, NULL);
}
/* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
if (is_trans) {
- OP* const oe = expr;
- assert(expr->op_type == OP_LIST);
- assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
- assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
- expr = cLISTOPx(oe)->op_last;
- cLISTOPx(oe)->op_first->op_sibling = NULL;
- cLISTOPx(oe)->op_last = NULL;
- op_free(oe);
+ OP *first, *last;
- return pmtrans(o, expr, repl);
+ assert(expr->op_type == OP_LIST);
+ first = cLISTOPx(expr)->op_first;
+ last = cLISTOPx(expr)->op_last;
+ assert(first->op_type == OP_PUSHMARK);
+ assert(OP_SIBLING(first) == last);
+
+ /* cut 'last' from sibling chain, then free everything else */
+ op_sibling_splice(expr, first, 1, NULL);
+ op_free(expr);
+
+ return pmtrans(o, last, repl);
}
/* find whether we have any runtime or code elements;
has_code = 0;
if (expr->op_type == OP_LIST) {
OP *o;
- for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
has_code = 1;
- assert(!o->op_next && o->op_sibling);
- o->op_next = o->op_sibling;
+ assert(!o->op_next && OP_HAS_SIBLING(o));
+ o->op_next = OP_SIBLING(o);
}
else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
is_compiletime = 0;
if (expr->op_type == OP_LIST) {
OP *o;
- for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
assert( !(o->op_flags & OPf_WANT));
LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
/* skip ENTER */
assert(leaveop->op_first->op_type == OP_ENTER);
- assert(leaveop->op_first->op_sibling);
- o->op_next = leaveop->op_first->op_sibling;
+ assert(OP_HAS_SIBLING(leaveop->op_first));
+ o->op_next = OP_SIBLING(leaveop->op_first);
/* skip leave */
assert(leaveop->op_flags & OPf_KIDS);
assert(leaveop->op_last->op_next == (OP*)leaveop);
/* have to peep the DOs individually as we've removed it from
* the op_next chain */
CALL_PEEP(o);
+ S_prune_chain_head(&(o->op_next));
if (is_compiletime)
/* runtime finalizes as part of finalizing whole tree */
finalize_optree(o);
: Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
rx_flags, pm->op_pmflags)
);
-#ifdef PERL_MAD
- op_getmad(expr,(OP*)pm,'e');
-#else
op_free(expr);
-#endif
}
else {
/* compile-time pattern that includes literal code blocks */
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/(?{..})/ */
/* If we are looking at s//.../e with a single statement, get past
the implicit do{}. */
if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
- && cUNOPx(curop)->op_first->op_type == OP_SCOPE
- && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+ && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+ && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
+ {
+ OP *sib;
OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
- if (kid->op_type == OP_NULL && kid->op_sibling
- && !kid->op_sibling->op_sibling)
- curop = kid->op_sibling;
+ if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
+ && !OP_HAS_SIBLING(sib))
+ curop = sib;
}
if (curop->op_type == OP_CONST)
konst = TRUE;
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);
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWGVOP;
#ifdef USE_ITHREADS
return CHECKOP(type, pvop);
}
-#ifdef PERL_MAD
-OP*
-#else
void
-#endif
Perl_package(pTHX_ OP *o)
{
- dVAR;
SV *const sv = cSVOPo->op_sv;
-#ifdef PERL_MAD
- OP *pegop;
-#endif
PERL_ARGS_ASSERT_PACKAGE;
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
-#ifndef PERL_MAD
op_free(o);
-#else
- if (!PL_madskills) {
- op_free(o);
- return NULL;
- }
-
- pegop = newOP(OP_NULL,0);
- op_getmad(o,pegop,'P');
- return pegop;
-#endif
}
void
Perl_package_version( pTHX_ OP *v )
{
- dVAR;
U32 savehints = PL_hints;
PERL_ARGS_ASSERT_PACKAGE_VERSION;
PL_hints &= ~HINT_STRICT_VARS;
op_free(v);
}
-#ifdef PERL_MAD
-OP*
-#else
void
-#endif
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
- dVAR;
OP *pack;
OP *imop;
OP *veop;
-#ifdef PERL_MAD
- OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
-#endif
SV *use_version = NULL;
PERL_ARGS_ASSERT_UTILIZE;
if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
- if (PL_madskills)
- op_getmad(idop,pegop,'U');
-
veop = NULL;
if (version) {
SV * const vesv = ((SVOP*)version)->op_sv;
- if (PL_madskills)
- op_getmad(version,pegop,'V');
if (!arg && !SvNIOKp(vesv)) {
arg = version;
}
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB) {
- if (PL_madskills)
- op_getmad(arg,pegop,'S');
imop = arg; /* no import on explicit () */
}
else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
else {
SV *meth;
- if (PL_madskills)
- op_getmad(arg,pegop,'A');
-
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
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++;
-#ifdef PERL_MAD
- return pegop;
-#endif
}
/*
void
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
- dVAR;
OP *veop, *imop;
OP * const modname = newSVOP(OP_CONST, 0, name);
OP *
Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
- dVAR;
OP *doop;
GV *gv;
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
flags = o->op_flags;
type = o->op_type;
if (type == OP_COND_EXPR) {
- const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
- const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
+ OP * const sib = OP_SIBLING(cLOGOPo->op_first);
+ const I32 t = is_list_assignment(sib);
+ const I32 f = is_list_assignment(OP_SIBLING(sib));
if (t && f)
return TRUE;
S_aassign_common_vars(pTHX_ OP* o)
{
OP *curop;
- for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
+ for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
OP *
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
- dVAR;
OP *o;
if (optype) {
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))
/* Other ops in the list. */
maybe_common_vars = TRUE;
}
- lop = lop->op_sibling;
+ lop = OP_SIBLING(lop);
}
}
else if ((left->op_private & OPpLVAL_INTRO)
LINKLIST(o);
}
- if (right && right->op_type == OP_SPLIT && !PL_madskills) {
+ if (right && right->op_type == OP_SPLIT) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
#endif
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
- tmpop->op_sibling = 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;
OP *
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWLOGOP;
return new_logop(type, flags, &first, &other);
case OP_ENTER:
case OP_NULL:
case OP_NEXTSTATE:
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
break;
default:
if (kid != cLISTOPo->op_last)
&& (first->op_flags & OPf_KIDS)
&& ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
|| (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
- && !PL_madskills) {
+ ) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
- if (PL_madskills) {
- OP *newop = newUNOP(OP_NULL, 0, other);
- op_getmad(first, newop, '1');
- newop->op_targ = type; /* set "was" field */
- return newop;
- }
op_free(first);
if (other->op_type == OP_LEAVE)
other = newUNOP(OP_NULL, OPf_SPECIAL, other);
if ( ! (o2->op_type == OP_LIST
&& (( o2 = cUNOPx(o2)->op_first))
&& o2->op_type == OP_PUSHMARK
- && (( o2 = o2->op_sibling)) )
+ && (( o2 = OP_SIBLING(o2))) )
)
o2 = other;
if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
*otherp = NULL;
if (cstop->op_type == OP_CONST)
cstop->op_private |= OPpCONST_SHORTCIRCUIT;
- if (PL_madskills) {
- first = newUNOP(OP_NULL, 0, first);
- op_getmad(other, first, '2');
- first->op_targ = type; /* set "was" field */
- }
- else
- op_free(other);
+ op_free(other);
return first;
}
}
&& ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
{
const OP * const k1 = ((UNOP*)first)->op_first;
- const OP * const k2 = k1->op_sibling;
+ const OP * const k2 = OP_SIBLING(k1);
OPCODE warnop = 0;
switch (first->op_type)
{
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;
- first->op_sibling = other;
+ assert(!OP_HAS_SIBLING(first));
+ op_sibling_splice((OP*)logop, first, 0, other);
CHECKOP(type,logop);
cstop->op_private & OPpCONST_STRICT) {
no_bareword_allowed(cstop);
}
- if (PL_madskills) {
- /* This is all dead code when PERL_MAD is not defined. */
- live = newUNOP(OP_NULL, 0, live);
- op_getmad(first, live, 'C');
- op_getmad(dead, live, left ? 'e' : 't');
- } else {
- op_free(first);
- op_free(dead);
- }
+ op_free(first);
+ op_free(dead);
if (live->op_type == OP_LEAVE)
live = newUNOP(OP_NULL, OPf_SPECIAL, live);
else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
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;
- first->op_sibling = trueop;
- trueop->op_sibling = 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));
- left->op_sibling = 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);
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
- dVAR;
OP* listop;
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
const OP * const k1 = ((UNOP*)expr)->op_first;
- const OP * const k2 = k1 ? k1->op_sibling : NULL;
+ const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
const OP * const k1 = ((UNOP*)expr)->op_first;
- const OP * const k2 = (k1) ? k1->op_sibling : NULL;
+ const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
- OP *madsv = NULL;
PERL_ARGS_ASSERT_NEWFOROP;
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
padoff = sv->op_targ;
- if (PL_madskills)
- madsv = sv;
- else {
- sv->op_targ = 0;
- op_free(sv);
- }
+ sv->op_targ = 0;
+ op_free(sv);
sv = NULL;
}
else
}
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 &&
const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
- OP* const right = left->op_sibling;
+ OP* const right = OP_SIBLING(left);
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;
right->op_next = (OP*)listop;
listop->op_next = listop->op_first;
-#ifdef PERL_MAD
- op_getmad(expr,(OP*)listop,'O');
-#else
op_free(expr);
-#endif
expr = (OP*)(listop);
op_null(expr);
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;
}
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
- if (madsv)
- op_getmad(madsv, (OP*)loop, 'v');
return wop;
}
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
- dVAR;
OP *o = NULL;
PERL_ARGS_ASSERT_NEWLOOPEX;
/* If we have already created an op, we do not need the label. */
if (o)
-#ifdef PERL_MAD
- op_getmad(label,o,'L');
-#else
op_free(label);
-#endif
else o = newUNOP(type, OPf_STACKED, label);
PL_hints |= HINT_BLOCK_SCOPE;
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);
- cond->op_sibling = 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;
STATIC bool
S_looks_like_bool(pTHX_ const OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
switch(o->op_type) {
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(cLOGOPo->op_first->op_sibling));
+ && looks_like_bool(sibl));
+ }
case OP_NULL:
case OP_SCALAR:
else
return FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
return FALSE;
}
OP *
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
- dVAR;
PERL_ARGS_ASSERT_NEWGIVENOP;
return newGIVWHENOP(
ref_array_or_hash(cond),
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
+/* must not conflict with SVf_UTF8 */
+#define CV_CKPROTO_CURSTASH 0x1
+
void
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
SV *name = NULL, *msg;
- const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+ const char * cvp = SvROK(cv)
+ ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
+ ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
+ : ""
+ : CvPROTO(cv);
STRLEN clen = CvPROTOLEN(cv), plen = len;
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
gv_efullname3(name = sv_newmortal(), gv, NULL);
else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+ else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
+ name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
+ sv_catpvs(name, "::");
+ if (SvROK(gv)) {
+ assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
+ assert (CvNAMED(SvRV_const(gv)));
+ sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
+ }
+ else sv_catsv(name, (SV *)gv);
+ }
else name = (SV *)gv;
}
sv_setpvs(msg, "Prototype mismatch:");
=cut
*/
SV *
-Perl_cv_const_sv(pTHX_ const CV *const cv)
+Perl_cv_const_sv(const CV *const cv)
{
SV *sv;
- PERL_UNUSED_CONTEXT;
if (!cv)
return NULL;
if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
}
SV *
-Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
+Perl_cv_const_sv_or_av(const CV * const cv)
{
- PERL_UNUSED_CONTEXT;
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;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ * examine the clone prototype, and if contains only a single
+ * OP_CONST referencing a pad const, or a single PADSV referencing
+ * an outer lexical, return a non-zero value to indicate the CV is
+ * a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ * We have just cloned an anon prototype that was marked as a const
+ * candidate. Try to grab the current value, and in the case of
+ * PADSV, ignore it if it has multiple references. In this case we
+ * return a newly created *copy* of the value.
*/
SV *
-Perl_op_const_sv(pTHX_ const OP *o)
+Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
{
- dVAR;
SV *sv = NULL;
- if (PL_madskills)
- return NULL;
-
if (!o)
return NULL;
if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = cLISTOPo->op_first->op_sibling;
+ o = OP_SIBLING(cLISTOPo->op_first);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
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)
+ return NULL;
+ }
+ else if (cv && type == OP_PADSV) {
+ if (CvCONST(cv)) { /* newly cloned anon */
+ sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+ /* the candidate should have 1 ref from this pad and 1 ref
+ * from the parent */
+ if (!sv || SvREFCNT(sv) != 2)
+ return NULL;
+ sv = newSVsv(sv);
+ SvREADONLY_on(sv);
+ return sv;
+ }
+ else {
+ if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ sv = &PL_sv_undef; /* an arbitrary non-null value */
+ }
+ }
else {
return NULL;
}
assert (o || name);
assert (const_svp);
if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
SvREFCNT_inc_simple_void_NN(PL_compcv);
CopLINE_set(PL_curcop, oldline);
}
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SAVEFREESV(cv);
- }
+ SAVEFREESV(cv);
return TRUE;
}
CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- dVAR;
CV **spot;
SV **svspot;
const char *ps;
else
ps = NULL;
- if (!PL_madskills) {
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- }
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
if (PL_parser && PL_parser->error_count) {
op_free(block);
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);
if (!block || !ps || *ps || attrs
|| (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)
const_sv = NULL;
else
- const_sv = op_const_sv(block);
+ const_sv = op_const_sv(block, NULL);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
- if (PL_madskills)
- goto install_block;
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
) {
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
*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;
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- install_block:
if (!block)
goto attrs;
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
-#ifdef PERL_MAD
- op_getmad(block,newblock,'B');
-#else
op_free(block);
-#endif
block = newblock;
}
CvROOT(cv) = CvLVALUE(cv)
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
/* now that optimizer has done its work, adjust pad values */
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ if (CvCLONE(cv)) {
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
+ }
+
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
OP *block, bool o_is_gv)
{
- dVAR;
GV *gv;
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
- full GV and CV. If anything is present then it will take a full CV to
+ full CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
= ec ? GV_NOADD_NOINIT :
- (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
- || PL_madskills)
+ (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
const char * const name =
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
+ bool special = FALSE;
if (o_is_gv) {
gv = (GV*)o;
o = NULL;
has_name = TRUE;
} else if (name) {
- gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ /* Try to optimise and avoid creating a GV. Instead, the CV’s name
+ hek and CvSTASH pointer together can imply the GV. If the name
+ contains a package name, then GvSTASH(CvGV(cv)) may differ from
+ CvSTASH, so forego the optimisation if we find any.
+ Also, we may be called from load_module at run time, so
+ PL_curstash (which sets CvSTASH) may not point to the stash the
+ sub is stored in. */
+ const I32 flags =
+ ec ? GV_NOADD_NOINIT
+ : PL_curstash != CopSTASH(PL_curcop)
+ || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
+ ? gv_fetch_flags
+ : GV_ADDMULTI | GV_NOINIT;
+ gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
-
if (!ec)
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs,
+ isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
if (proto) {
assert(proto->op_type == OP_CONST);
else
ps = NULL;
- if (!PL_madskills) {
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- }
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
if (ec) {
op_free(block);
goto done;
}
- if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
- maximum a prototype before. */
+ if (!block && SvTYPE(gv) != SVt_PVGV) {
+ /* If we are not defining a new sub and the existing one is not a
+ full GV + CV... */
+ if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+ /* We are applying attributes to an existing sub, so we need it
+ upgraded if it is a constant. */
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_init_pvn(gv, PL_curstash, name, namlen,
+ SVf_UTF8 * name_is_utf8);
+ }
+ else { /* Maybe prototype now, and had at maximum
+ a prototype or const/sub ref before. */
if (SvTYPE(gv) > SVt_NULL) {
cv_ckproto_len_flags((const CV *)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;
goto done;
+ }
}
- cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
+ cv = (!name || (isGV(gv) && GvCVGEN(gv)))
+ ? NULL
+ : isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? (CV *)SvRV(gv)
+ : NULL;
+
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)
const_sv = NULL;
else
- const_sv = op_const_sv(block);
+ const_sv = op_const_sv(block, NULL);
+
+ if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
+ assert (block);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
+ if (SvROK(gv)) {
+ /* All the other code for sub redefinition warnings expects the
+ clobbered sub to be a CV. Instead of making all those code
+ paths more complex, just inline the RV version here. */
+ const line_t oldline = CopLINE(PL_curcop);
+ assert(IN_PERL_COMPILETIME);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+
+ if (ckWARN(WARN_REDEFINE)
+ || ( ckWARN_d(WARN_REDEFINE)
+ && ( !const_sv || SvRV(gv) == const_sv
+ || sv_cmp(SvRV(gv), const_sv) )))
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Constant subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
+
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ SvREFCNT_dec(SvRV(gv));
+ }
+ }
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
if (exists || SvPOK(cv))
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
- if (exists || GvASSUMECV(gv)) {
+ if (exists || (isGV(gv) && GvASSUMECV(gv))) {
if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
cv = NULL;
else {
CvISXSUB_on(cv);
}
else {
- GvCV_set(gv, NULL);
- cv = newCONSTSUB_flags(
- NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
- const_sv
- );
+ if (isGV(gv)) {
+ if (name) GvCV_set(gv, NULL);
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
+ }
+ else {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, const_sv);
+ }
}
- if (PL_madskills)
- goto install_block;
op_free(block);
SvREFCNT_dec(PL_compcv);
PL_compcv = NULL;
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
OP * const cvstart = CvSTART(cv);
- CvGV_set(cv,gv);
- assert(!CvCVGV_RC(cv));
- assert(CvGV(cv) == gv);
+ if (isGV(gv)) {
+ CvGV_set(cv,gv);
+ assert(!CvCVGV_RC(cv));
+ assert(CvGV(cv) == gv);
+ }
+ else {
+ U32 hash;
+ PERL_HASH(hash, name, namlen);
+ CvNAME_HEK_set(cv,
+ share_hek(name,
+ name_is_utf8 ? -namlen : namlen,
+ hash));
+ }
SvPOK_off(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
+ | CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvPADLIST(cv) = CvPADLIST(PL_compcv);
}
else {
cv = PL_compcv;
- if (name) {
+ if (name && isGV(gv)) {
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
gv_method_changed(gv);
}
+ else if (name) {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, (SV *)cv);
+ }
}
- if (!CvGV(cv)) {
- CvGV_set(cv, gv);
+ if (!CvHASGV(cv)) {
+ if (isGV(gv)) CvGV_set(cv, gv);
+ else {
+ U32 hash;
+ PERL_HASH(hash, name, namlen);
+ CvNAME_HEK_set(cv, share_hek(name,
+ name_is_utf8 ? -namlen : namlen,
+ hash));
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- install_block:
if (!block)
goto attrs;
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
-#ifdef PERL_MAD
- op_getmad(block,newblock,'B');
-#else
op_free(block);
-#endif
block = newblock;
}
CvROOT(cv) = CvLVALUE(cv)
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
/* now that optimizer has done its work, adjust pad values */
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ if (CvCLONE(cv)) {
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
+ }
+
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
+ ? GvSTASH(CvGV(cv))
+ : PL_curstash;
if (!name) SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
if (!name) SvREFCNT_inc_simple_void_NN(cv);
if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const tmpstr = sv_newmortal();
+ SV * const tmpstr = cv_name(cv,NULL);
GV * const db_postponed = gv_fetchpvs("DB::postponed",
GV_ADDMULTI, SVt_PVHV);
HV *hv;
CopFILE(PL_curcop),
(long)PL_subline,
(long)CopLINE(PL_curcop));
- gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
}
}
- 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
+ special = process_special_blocks(floor, name, gv, cv);
+ }
}
done:
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+ if (!special) Slab_to_ro(slab);
#endif
return cv;
}
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"))) {
+ if (!isGV(gv)) {
+ (void)CvGV(cv);
+ assert(isGV(gv));
+ }
+ GvCV_set(gv, NULL);
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
+ }
+}
+
+STATIC bool
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
dSP;
+ (void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
PUSHSTACKi(PERLSI_REQUIRE);
POPSTACK;
LEAVE;
+ return TRUE;
}
else
- return;
+ return FALSE;
} else {
if (*name == 'E') {
if strEQ(name, "END") {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
- return;
+ return FALSE;
} else if (*name == 'U') {
if (strEQ(name, "UNITCHECK")) {
/* It's never too late to run a unitcheck block */
Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else
- return;
+ return FALSE;
DEBUG_x( dump_sub(gv) );
+ (void)CvGV(cv);
GvCV_set(gv,0); /* cv has been hijacked */
+ return TRUE;
}
}
Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
U32 flags, SV *sv)
{
- dVAR;
CV* cv;
const char *const file = CopFILE(PL_curcop);
);
}
-#ifdef PERL_MAD
-OP *
-#else
void
-#endif
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
- dVAR;
CV *cv;
-#ifdef PERL_MAD
- OP* pegop = newOP(OP_NULL, 0);
-#endif
GV *gv;
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
cv_forget_slab(cv);
finish:
-#ifdef PERL_MAD
- op_getmad(o,pegop,'n');
- op_getmad_weak(block, pegop, 'b');
-#else
op_free(o);
-#endif
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
-#ifdef PERL_MAD
- return pegop;
-#endif
}
OP *
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Using an array as a reference is deprecated");
+ Perl_croak(aTHX_ "Can't use an array as a reference");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
}
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Using a hash as a reference is deprecated");
+ Perl_croak(aTHX_ "Can't use a hash as a reference");
}
return newUNOP(OP_RV2HV, 0, scalar(o));
}
PERL_ARGS_ASSERT_CK_ANONCODE;
cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
- if (!PL_madskills)
- cSVOPo->op_sv = NULL;
+ cSVOPo->op_sv = NULL;
return o;
}
static void
S_io_hints(pTHX_ OP *o)
{
+#if O_BINARY != 0 || O_TEXT != 0
HV * const table =
PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
if (table) {
STRLEN len = 0;
const char *d = SvPV_const(*svp, len);
const I32 mode = mode_from_discipline(d, len);
+ /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
+# if O_BINARY != 0
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
- else if (mode & O_TEXT)
+# endif
+# if O_TEXT != 0
+ if (mode & O_TEXT)
o->op_private |= OPpOPEN_IN_CRLF;
+# endif
}
svp = hv_fetchs(table, "open_OUT", FALSE);
STRLEN len = 0;
const char *d = SvPV_const(*svp, len);
const I32 mode = mode_from_discipline(d, len);
+ /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
+# if O_BINARY != 0
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
- else if (mode & O_TEXT)
+# endif
+# if O_TEXT != 0
+ if (mode & O_TEXT)
o->op_private |= OPpOPEN_OUT_CRLF;
+# endif
}
}
+#else
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(o);
+#endif
}
OP *
{
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 && cUNOPo->op_first->op_sibling
- && (gv = gv_override("readpipe",8))) {
- newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
- cUNOPo->op_first->op_sibling = 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 (newop) {
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
S_io_hints(aTHX_ o);
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_BITOP;
o->op_private = (U8)(PL_hints & HINT_INTEGER);
|| o->op_type == OP_BIT_XOR))
{
const OP * const left = cBINOPo->op_first;
- const OP * const right = left->op_sibling;
+ const OP * const right = OP_SIBLING(left);
if ((OP_IS_NUMCOMPARE(left->op_type) &&
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
is_dollar_bracket(pTHX_ const OP * const o)
{
const OP *kid;
+ PERL_UNUSED_CONTEXT;
return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
&& (kid = cUNOPx(o)->op_first)
&& kid->op_type == OP_GV
PERL_ARGS_ASSERT_CK_CMP;
if (ckWARN(WARN_SYNTAX)) {
const OP *kid = cUNOPo->op_first;
- if (kid && (
- (
- is_dollar_bracket(aTHX_ kid)
- && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
+ if (kid &&
+ (
+ ( is_dollar_bracket(aTHX_ kid)
+ && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
)
- || ( kid->op_type == OP_CONST
- && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
- ))
+ || ( kid->op_type == OP_CONST
+ && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
+ )
+ )
+ )
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"$[ used in %s (did you mean $] ?)", OP_DESC(o));
}
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 = kUNOP->op_first->op_sibling;
+ kid = cUNOPo->op_first;
+ kidkid = kUNOP->op_first;
+ newop = OP_SIBLING(kidkid);
if (newop) {
const OPCODE type = newop->op_type;
- if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
+ if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
type == OP_PADAV || type == OP_PADHV ||
type == OP_RV2AV || type == OP_RV2HV)
return o;
}
-#ifdef PERL_MAD
- op_getmad(kUNOP->op_first,newop,'K');
-#else
- op_free(kUNOP->op_first);
-#endif
- 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 */
switch (kid->op_type) {
case OP_ASLICE:
o->op_flags |= OPf_SPECIAL;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_HSLICE:
o->op_private |= OPpSLICE;
break;
case OP_AELEM:
o->op_flags |= OPf_SPECIAL;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_HELEM:
break;
case OP_KVASLICE:
OP *
Perl_ck_eof(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_EOF;
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
o = newop;
}
o = ck_fun(o);
if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
-#ifdef PERL_MAD
- OP* const oldo = o;
-#endif
- cUNOPo->op_first = 0;
-#ifndef PERL_MAD
+ /* cut whole sibling chain free from o */
+ op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
-#endif
- 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;
o->op_type = OP_LEAVETRY;
o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
enter->op_other = o;
- op_getmad(oldo,o,'O');
return o;
}
else {
}
else {
const U8 priv = o->op_private;
-#ifdef PERL_MAD
- OP* const oldo = o;
-#else
op_free(o);
-#endif
- o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
- op_getmad(oldo,o,'O');
+ /* 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))));
- cUNOPo->op_first->op_sibling = 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)
if (o->op_flags & OPf_STACKED) {
OP *kid;
o = ck_fun(o);
- kid = cUNOPo->op_first->op_sibling;
+ kid = OP_SIBLING(cUNOPo->op_first);
if (kid->op_type == OP_RV2GV)
op_null(kid);
}
OP *
Perl_ck_exists(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_EXISTS;
o = ck_fun(o);
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;
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;
* or we get possible typo warnings. OPpCONST_ENTERED says
* 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),
+ iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
+ gv = gv_fetchsv(kidsv,
+ o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_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) {
+ if (!isGV(gv)) {
+ assert(iscv);
+ assert(SvROK(gv));
+ if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
+ && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
+ }
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);
&& !kid->op_folded) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
}
}
else {
-#ifdef PERL_MAD
- OP* const oldo = o;
-#else
op_free(o);
-#endif
if (type == OP_FTTTY)
o = newGVOP(type, OPf_REF, PL_stdingv);
else
o = newUNOP(type, 0, newDEFSVOP());
- op_getmad(oldo,o,'O');
}
return o;
}
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- dVAR;
const int type = o->op_type;
I32 oa = PL_opargs[type] >> OASHIFT;
}
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;
- kid = kid->op_sibling;
+ prev_kid = kid;
+ kid = OP_SIBLING(kid);
}
if (kid && kid->op_type == OP_COREARGS) {
bool optional = FALSE;
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 = kid->op_sibling;
-#ifdef PERL_MAD
- if (!sibl && kid->op_type == OP_STUB) {
- numargs--;
- break;
- }
-#endif
switch (oa & 7) {
case OA_SCALAR:
/* list seen where single (scalar) arg expected? */
break;
case OA_AVREF:
if ((type == OP_PUSH || type == OP_UNSHIFT)
- && !kid->op_sibling)
+ && !OP_HAS_SIBLING(kid))
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
"Useless use of %s with no values",
PL_op_desc[type]);
- if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- OP * const newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
- op_free(kid);
-#endif
- kid = newop;
- kid->op_sibling = sibl;
- *tokid = kid;
- }
- else if (kid->op_type == OP_CONST
+ if (kid->op_type == OP_CONST
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
}
break;
case OA_HVREF:
- if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- OP * const newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
- op_free(kid);
-#endif
- kid = newop;
- kid->op_sibling = sibl;
- *tokid = kid;
- }
- else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
+ if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
op_lvalue(kid, type);
break;
case OA_CVREF:
{
- OP * const newop = newUNOP(OP_NULL, 0, kid);
- kid->op_sibling = 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;
- kid->op_sibling = 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;
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
+ /* replace kid with newop in chain */
+ op_sibling_splice(o, prev_kid, 1, newop);
op_free(kid);
-#endif
kid = newop;
}
else if (kid->op_type == OP_READLINE) {
if ( name_utf8 ) SvUTF8_on(namesv);
}
}
- kid->op_sibling = 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;
}
- kid->op_sibling = sibl;
- *tokid = kid;
}
scalar(kid);
break;
break;
}
oa >>= 4;
- tokid = &kid->op_sibling;
- kid = kid->op_sibling;
+ prev_kid = kid;
+ kid = OP_SIBLING(kid);
}
-#ifdef PERL_MAD
- if (kid && kid->op_type != OP_STUB)
- return too_many_arguments_pv(o,OP_DESC(o), 0);
- o->op_private |= numargs;
-#else
- /* FIXME - should the numargs move as for the PERL_MAD case? */
+ /* FIXME - should the numargs or-ing move after the too many
+ * arguments check? */
o->op_private |= numargs;
if (kid)
return too_many_arguments_pv(o,OP_DESC(o), 0);
-#endif
listkids(o);
}
else if (PL_opargs[type] & OA_DEFGV) {
-#ifdef PERL_MAD
- OP *newop = newUNOP(type, 0, newDEFSVOP());
- op_getmad(o,newop,'O');
- return newop;
-#else
/* Ordering of these two is important to keep f_map.t passing. */
op_free(o);
return newUNOP(type, 0, newDEFSVOP());
-#endif
}
if (oa) {
OP *
Perl_ck_glob(pTHX_ OP *o)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_CK_GLOB;
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
+ if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
- kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
+ kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
return no_fh_allowed(o);
o->op_flags &= ~OPf_STACKED;
}
- kid = cLISTOPo->op_first->op_sibling;
+ kid = OP_SIBLING(cLISTOPo->op_first);
if (type == OP_MAPWHILE)
list(kid);
else
o = ck_fun(o);
if (PL_parser && PL_parser->error_count)
return o;
- kid = cLISTOPo->op_first->op_sibling;
+ kid = OP_SIBLING(cLISTOPo->op_first);
if (kid->op_type != OP_NULL)
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- 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)) {
gwop->op_targ = o->op_targ = offset;
}
- kid = cLISTOPo->op_first->op_sibling;
- for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
+ kid = OP_SIBLING(cLISTOPo->op_first);
+ for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
op_lvalue(kid, OP_GREPSTART);
return (OP*)gwop;
PERL_ARGS_ASSERT_CK_INDEX;
if (o->op_flags & OPf_KIDS) {
- OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid)
- kid = kid->op_sibling; /* get past "big" */
+ kid = OP_SIBLING(kid); /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
SV *sv = kSVOP->op_sv;
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
case OP_PADAV:
- case OP_AASSIGN: /* Is this a good idea? */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "defined(@array) is deprecated");
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "\t(Maybe you should just omit the defined()?)\n");
+ Perl_croak(aTHX_ "Can't use 'defined(@array)'"
+ " (Maybe you should just omit the defined()?)");
break;
case OP_RV2HV:
case OP_PADHV:
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "defined(%%hash) is deprecated");
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "\t(Maybe you should just omit the defined()?)\n");
+ Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
+ " (Maybe you should just omit the defined()?)");
break;
default:
/* no warning */
else {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
return o;
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)
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
if (kid && o->op_flags & OPf_STACKED)
- kid = kid->op_sibling;
- else if (kid && !kid->op_sibling) { /* print HANDLE; */
+ kid = OP_SIBLING(kid);
+ else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
&& !kid->op_folded) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
- kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
- cLISTOPo->op_first->op_sibling = kid;
- cLISTOPo->op_last = kid;
- kid = kid->op_sibling;
+ 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);
}
}
PERL_ARGS_ASSERT_CK_SMARTMATCH;
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
- OP *second = first->op_sibling;
+ OP *second = OP_SIBLING(first);
/* Implicitly take a reference to an array or hash */
- first->op_sibling = NULL;
- first = cBINOPo->op_first = ref_array_or_hash(first);
- second = first->op_sibling = ref_array_or_hash(second);
+
+ /* 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_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_flags & OPf_STACKED)
/* Cannot steal the second time! */
&& !(kid->op_private & OPpTARGET_MY)
- /* Keep the full thing for madskills */
- && !PL_madskills
)
{
- OP * const kkid = kid->op_sibling;
+ OP * const kkid = OP_SIBLING(kid);
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
- /* Now we do not need PADSV and SASSIGN. */
- kid->op_sibling = o->op_sibling; /* 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 */
return kid;
}
}
- if (kid->op_sibling) {
- OP *kkid = kid->op_sibling;
+ if (OP_HAS_SIBLING(kid)) {
+ OP *kkid = OP_SIBLING(kid);
/* For state variable assignment, kkid is a list op whose op_last
is a padsv. */
if ((kkid->op_type == OP_PADSV ||
)
)
&& (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
other->op_targ = target;
/* Because we change the type of the op here, we will skip the
- assignment binop->op_last = binop->op_first->op_sibling; at the
+ assignment binop->op_last = OP_SIBLING(binop->op_first); at the
end of Perl_newBINOP(). So need to do it here. */
- cBINOPo->op_last = cBINOPo->op_first->op_sibling;
-
+ 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;
}
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
kSVOP->op_sv = NULL;
}
cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
-#ifdef PERL_MAD
- op_getmad(o,cmop,'O');
-#else
op_free(o);
-#endif
return cmop;
}
}
OP *
Perl_ck_open(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_OPEN;
S_io_hints(aTHX_ o);
if ((last->op_type == OP_CONST) && /* The bareword. */
(last->op_private & OPpCONST_BARE) &&
(last->op_private & OPpCONST_STRICT) &&
- (oa = first->op_sibling) && /* The fh. */
- (oa = oa->op_sibling) && /* The mode. */
+ (oa = OP_SIBLING(first)) && /* The fh. */
+ (oa = OP_SIBLING(oa)) && /* The mode. */
(oa->op_type == OP_CONST) &&
SvPOK(((SVOP*)oa)->op_sv) &&
(mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
mode[0] == '>' && mode[1] == '&' && /* A dup open. */
- (last == oa->op_sibling)) /* The bareword. */
+ (last == OP_SIBLING(oa))) /* The bareword. */
last->op_private &= ~OPpCONST_STRICT;
}
return ck_fun(o);
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);
OP *
Perl_ck_require(pTHX_ OP *o)
{
- dVAR;
GV* gv;
PERL_ARGS_ASSERT_CK_REQUIRE;
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();
}
-#ifndef PERL_MAD
op_free(o);
-#endif
newop = S_new_entersubop(aTHX_ gv, kid);
- op_getmad(o,newop,'O');
return newop;
}
OP *
Perl_ck_return(pTHX_ OP *o)
{
- dVAR;
OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
- kid = cLISTOPo->op_first->op_sibling;
+ kid = OP_SIBLING(cLISTOPo->op_first);
if (CvLVALUE(PL_compcv)) {
- for (; kid; kid = kid->op_sibling)
+ for (; kid; kid = OP_SIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
PERL_ARGS_ASSERT_CK_SELECT;
if (o->op_flags & OPf_KIDS) {
- kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
- if (kid && kid->op_sibling) {
+ kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
+ if (kid && OP_HAS_SIBLING(kid)) {
o->op_type = OP_SSELECT;
o->op_ppaddr = PL_ppaddr[OP_SSELECT];
o = ck_fun(o);
}
}
o = ck_fun(o);
- kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && kid->op_type == OP_RV2GV)
kid->op_private &= ~HINT_STRICT_REFS;
return o;
OP *
Perl_ck_shift(pTHX_ OP *o)
{
- dVAR;
const I32 type = o->op_type;
PERL_ARGS_ASSERT_CK_SHIFT;
}
argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
-#ifdef PERL_MAD
- {
- OP * const oldo = o;
- o = newUNOP(type, 0, scalar(argop));
- op_getmad(oldo,o,'O');
- return o;
- }
-#else
op_free(o);
return newUNOP(type, 0, scalar(argop));
-#endif
}
return scalar(ck_fun(o));
}
OP *
Perl_ck_sort(pTHX_ OP *o)
{
- dVAR;
OP *firstkid;
OP *kid;
HV * const hinthv =
if (o->op_flags & OPf_STACKED)
simplify_sort(o);
- firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
o->op_flags |= OPf_SPECIAL;
}
- firstkid = firstkid->op_sibling;
+ firstkid = OP_SIBLING(firstkid);
}
- for (kid = firstkid; kid; kid = kid->op_sibling) {
+ for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
/* provide list context for arguments */
list(kid);
if (stacked)
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
- dVAR;
- OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
OP *k;
int descending;
GV *gv;
kid = kBINOP->op_first;
do {
if (kid->op_type == OP_PADSV) {
- SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
+ SV * const name = PAD_COMPNAME_SV(kid->op_targ);
if (SvCUR(name) == 2 && *SvPVX(name) == '$'
&& (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
/* diag_listed_as: "my %s" used in sort comparison */
SvPAD_STATE(name) ? "state" : "my",
SvPVX(name));
}
- } while ((kid = kid->op_sibling));
+ } while ((kid = OP_SIBLING(kid)));
return;
}
kid = kBINOP->op_first; /* get past cmp */
o->op_private |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
- kid = cLISTOPo->op_first->op_sibling;
- cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
-#ifdef PERL_MAD
- op_getmad(kid,o,'S'); /* then delete it */
-#else
- op_free(kid); /* then delete it */
-#endif
+ kid = OP_SIBLING(cLISTOPo->op_first);
+ /* 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 = kid->op_sibling;
- 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 = kid->op_sibling;
- kid->op_sibling = 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;
- kid->op_sibling = 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;
"Use of /g modifier is meaningless in split");
}
- if (!kid->op_sibling)
+ if (!OP_HAS_SIBLING(kid))
op_append_elem(OP_SPLIT, o, newDEFSVOP());
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
+ assert(kid);
scalar(kid);
- if (!kid->op_sibling)
+ if (!OP_HAS_SIBLING(kid))
{
op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
o->op_private |= OPpSPLIT_IMPLIM;
}
- assert(kid->op_sibling);
+ assert(OP_HAS_SIBLING(kid));
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
scalar(kid);
- if (kid->op_sibling)
+ if (OP_HAS_SIBLING(kid))
return too_many_arguments_pv(o,OP_DESC(o), 0);
return o;
OP *
Perl_ck_join(pTHX_ OP *o)
{
- const OP * const kid = cLISTOPo->op_first->op_sibling;
+ const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
PERL_ARGS_ASSERT_CK_JOIN;
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 (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
+ cv = MUTABLE_CV(SvRV(gv));
+ gv = NULL;
+ break;
+ }
+ if (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
} break;
default: {
return NULL;
- } break;
+ } NOT_REACHED; /* NOTREACHED */
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if (!CvANON(cv) || !gv)
+ if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
+ if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
+ && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
gv = CvGV(cv);
return (CV*)gv;
} else {
OP *aop;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
aop = cUNOPx(entersubop)->op_first;
- if (!aop->op_sibling)
+ if (!OP_HAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
- if (!(PL_madskills && aop->op_type == OP_STUB)) {
- list(aop);
- op_lvalue(aop, OP_ENTERSUB);
- }
+ for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
+ list(aop);
+ op_lvalue(aop, OP_ENTERSUB);
}
return entersubop;
}
{
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 (!aop->op_sibling)
+ if (!OP_HAS_SIBLING(aop)) {
+ parent = aop;
aop = cUNOPx(aop)->op_first;
+ }
prev = aop;
- aop = aop->op_sibling;
- for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ aop = OP_SIBLING(aop);
+ for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
while (aop != cvop) {
- OP* o3;
- if (PL_madskills && aop->op_type == OP_STUB) {
- aop = aop->op_sibling;
- continue;
- }
- if (PL_madskills && aop->op_type == OP_NULL)
- o3 = ((UNOP*)aop)->op_first;
- else
- o3 = aop;
+ OP* o3 = aop;
if (proto >= proto_end)
return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
/* _ must be at the end */
if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
+ /* FALLTHROUGH */
case '$':
proto++;
arg++;
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 (; gvop->op_sibling; gvop = gvop->op_sibling)
- ;
- 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 = aop->op_sibling;
- SV * const n = newSVpvs("");
-#ifdef PERL_MAD
- OP * const oldaop = aop;
-#else
- op_free(aop);
-#endif
- gv_fullname4(n, gv, "", FALSE);
- aop = newSVOP(OP_CONST, 0, n);
- op_getmad(oldaop,aop,'O');
- prev->op_sibling = aop;
- aop->op_sibling = sibling;
- }
- }
- }
- }
scalar(aop);
break;
case '+':
break;
case '[': case ']':
goto oops;
- break;
+
case '\\':
proto++;
arg++;
else
goto oops;
goto again;
- break;
+
case ']':
if (contextclass) {
const char *p = proto;
bad_type_gv(arg, "hash", namegv, 0, o3);
break;
wrapref:
- {
- OP* const kid = aop;
- OP* const sib = kid->op_sibling;
- kid->op_sibling = 0;
- aop = newUNOP(OP_REFGEN, 0, kid);
- aop->op_sibling = sib;
- prev->op_sibling = aop;
- }
+ aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
+ OP_REFGEN, 0);
if (contextclass && e) {
proto = e + 1;
contextclass = 0;
op_lvalue(aop, OP_ENTERSUB);
prev = aop;
- aop = aop->op_sibling;
+ aop = OP_SIBLING(aop);
}
if (aop == cvop && *proto == '_') {
/* generate an access to $_ */
- aop = newDEFSVOP();
- aop->op_sibling = prev->op_sibling;
- prev->op_sibling = aop; /* instead of cvop */
+ op_sibling_splice(parent, prev, 0, newDEFSVOP());
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
if (!opnum) {
OP *cvop;
- if (!aop->op_sibling)
+ if (!OP_HAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- aop = aop->op_sibling;
- for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
- if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
- aop = aop->op_sibling;
- }
+ aop = OP_SIBLING(aop);
+ for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
if (aop != cvop)
(void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
NOT_REACHED;
}
else {
- OP *prev, *cvop;
- U32 flags;
-#ifdef PERL_MAD
- bool seenarg = FALSE;
-#endif
- if (!aop->op_sibling)
+ OP *prev, *cvop, *first, *parent;
+ U32 flags = 0;
+
+ parent = entersubop;
+ if (!OP_HAS_SIBLING(aop)) {
+ parent = aop;
aop = cUNOPx(aop)->op_first;
+ }
- prev = aop;
- aop = aop->op_sibling;
- prev->op_sibling = NULL;
+ first = prev = aop;
+ aop = OP_SIBLING(aop);
+ /* find last sibling */
for (cvop = aop;
- cvop->op_sibling;
- prev=cvop, cvop = cvop->op_sibling)
-#ifdef PERL_MAD
- if (PL_madskills && cvop->op_sibling
- && cvop->op_type != OP_STUB) seenarg = TRUE
-#endif
+ OP_HAS_SIBLING(cvop);
+ prev = cvop, cvop = OP_SIBLING(cvop))
;
- prev->op_sibling = 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
return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
-#ifdef PERL_MAD
- if (!PL_madskills || seenarg)
-#endif
(void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
op_free(aop);
}
=cut
*/
-void
-Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+static void
+S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
+ U8 *flagsp)
{
MAGIC *callmg;
- PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
if (callmg) {
*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
*ckobj_p = callmg->mg_obj;
+ if (flagsp) *flagsp = callmg->mg_flags;
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
+ if (flagsp) *flagsp = MGf_REQUIRE_GV;
}
}
+void
+Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+{
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
+ PERL_UNUSED_CONTEXT;
+ return S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+}
+
/*
-=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
Sets the function that will be used to fix up a call to I<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
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
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and I<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> op if it needs to emit any diagnostics.
It is permitted to apply the check function in non-standard situations,
such as to a call to a different subroutine or to a method call.
+I<namegv> may not actually be a GV. For efficiency, perl may pass a
+CV or other SV instead. Whatever is passed can be used as the first
+argument to L</cv_name>. You can force perl to pass a GV by including
+C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
+
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker>.
+=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+
+The original form of L</cv_set_call_checker_flags>, which passes it the
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+
=cut
*/
Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
{
PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
+ cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
+}
+
+void
+Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
+ SV *ckobj, U32 flags)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
if (SvMAGICAL((SV*)cv))
mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
MAGIC *callmg;
sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
+ assert(callmg);
if (callmg->mg_flags & MGf_REFCOUNTED) {
SvREFCNT_dec(callmg->mg_obj);
callmg->mg_flags &= ~MGf_REFCOUNTED;
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
- callmg->mg_flags |= MGf_COPY;
+ callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
+ | (flags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
PERL_ARGS_ASSERT_CK_SUBR;
aop = cUNOPx(o)->op_first;
- if (!aop->op_sibling)
+ if (!OP_HAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- aop = aop->op_sibling;
- for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ aop = OP_SIBLING(aop);
+ for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
- namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
if (aop->op_type == OP_CONST)
aop->op_private &= ~OPpCONST_STRICT;
else if (aop->op_type == OP_LIST) {
- OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
+ OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
if (sib && sib->op_type == OP_CONST)
sib->op_private &= ~OPpCONST_STRICT;
}
} else {
Perl_call_checker ckfun;
SV *ckobj;
- cv_get_call_checker(cv, &ckfun, &ckobj);
- if (!namegv) { /* expletive! */
- /* XXX The call checker API is public. And it guarantees that
- a GV will be provided with the right name. So we have
- to create a GV. But it is still not correct, as its
- stringification will include the package. What we
- really need is a new call checker API that accepts a
- GV or string (or GV or CV). */
- HEK * const hek = CvNAME_HEK(cv);
+ U8 flags;
+ S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ 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
+ used (or the REQUIRE_GV flag was passed), we have to reify
+ the CV’s GV, unless this is an anonymous sub. This is not
+ ideal for lexical subs, as its stringification will include
+ the package. But it is the best we can do. */
+ if (flags & MGf_REQUIRE_GV) {
+ if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
+ namegv = CvGV(cv);
+ }
+ else namegv = MUTABLE_GV(cv);
/* After a syntax error in a lexical sub, the cv that
rv2cv_op_cv returns may be a nameless stub. */
- if (!hek) return ck_entersub_args_list(o);;
- namegv = (GV *)sv_newmortal();
- gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
- SVf_UTF8 * !!HEK_UTF8(hek));
+ if (!namegv) return ck_entersub_args_list(o);
+
}
return ckfun(aTHX_ o, namegv, ckobj);
}
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = (SVOP*)kid->op_sibling;
+ kid = (SVOP*)OP_SIBLING(kid);
if (kid && kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE) &&
!kid->op_folded)
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
if (kid)
kid->op_flags |= OPf_MOD;
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first;
- if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
+ if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
}
return o;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"length() used on %"SVf" (did you mean \"scalar(%s%"SVf
")\"?)",
- name, hash ? "keys " : "", name
+ SVfARG(name), hash ? "keys " : "", SVfARG(name)
);
else if (hash)
/* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
assert(cUNOPo->op_first->op_type == OP_NULL);
modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
assert(modop_pushmark->op_type == OP_PUSHMARK);
- modop = modop_pushmark->op_sibling;
+ modop = OP_SIBLING(modop_pushmark);
if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
return;
/* no other operation except sort/reverse */
- if (modop->op_sibling)
+ if (OP_HAS_SIBLING(modop))
return;
assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
- if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
+ if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
if (modop->op_flags & OPf_STACKED) {
/* skip sort subroutine/block */
assert(oright->op_type == OP_NULL);
- oright = oright->op_sibling;
+ oright = OP_SIBLING(oright);
}
- assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
- oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+ assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
assert(oleft_pushmark->op_type == OP_PUSHMARK);
- oleft = oleft_pushmark->op_sibling;
+ oleft = OP_SIBLING(oleft_pushmark);
/* Check the lhs is an array */
if (!oleft ||
(oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
- || oleft->op_sibling
+ || OP_HAS_SIBLING(oleft)
|| (oleft->op_private & OPpLVAL_INTRO)
)
return;
/* Only one thing on the rhs */
- if (oright->op_sibling)
+ if (OP_HAS_SIBLING(oright))
return;
/* check the array is the same on both sides */
op_null(oleft);
}
+
+
+/* mechanism for deferring recursion in rpeep() */
+
#define MAX_DEFERRED 4
#define DEFER(o) \
STMT_START { \
if (defer_ix == (MAX_DEFERRED-1)) { \
- CALL_RPEEP(defer_queue[defer_base]); \
+ OP **defer = defer_queue[defer_base]; \
+ CALL_RPEEP(*defer); \
+ S_prune_chain_head(defer); \
defer_base = (defer_base + 1) % MAX_DEFERRED; \
defer_ix--; \
} \
- defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
} STMT_END
#define IS_AND_OP(o) (o->op_type == OP_AND)
#define IS_OR_OP(o) (o->op_type == OP_OR)
+
STATIC void
S_null_listop_in_list_context(pTHX_ OP *o)
{
dVAR;
OP* oldop = NULL;
OP* oldoldop = NULL;
- OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+ OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
+ OP *fop;
+ OP *sop;
if (!o || o->op_opt)
return;
if (o && o->op_opt)
o = NULL;
if (!o) {
- while (defer_ix >= 0)
- CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
+ while (defer_ix >= 0) {
+ OP **defer =
+ defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
+ CALL_RPEEP(*defer);
+ S_prune_chain_head(defer);
+ }
break;
}
OP *sibling;
OP *other_pushmark;
if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
- && (sibling = o->op_sibling)
+ && (sibling = OP_SIBLING(o))
&& sibling->op_type == OP_LIST
/* This KIDS check is likely superfluous since OP_LIST
* would otherwise be an OP_STUB. */
*/
{
OP *next = o->op_next;
- OP *sibling = o->op_sibling;
+ OP *sibling = OP_SIBLING(o);
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
&& OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
&& cUNOPx(sibling)->op_first == next
- && next->op_sibling && next->op_sibling->op_next
+ && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
&& next->op_next
) {
/* Look through the PUSHMARK's siblings for one that
* points to the RETURN */
- OP *top = next->op_sibling;
+ OP *top = OP_SIBLING(next);
while (top && top->op_next) {
if (top->op_next == sibling) {
top->op_next = sibling->op_next;
o->op_next = next->op_next;
break;
}
- top = top->op_sibling;
+ top = OP_SIBLING(top);
}
}
}
&& (!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 */
- first->op_sibling = last; /* ... */
- o->op_next = cUNOPx(newop)->op_first; /* pushmark */
- o->op_next->op_next = first; /* padop1 */
- o->op_next->op_sibling = first; /* ... */
- newop->op_next = last->op_next; /* nextstate3 */
- newop->op_sibling = last->op_sibling;
- last->op_next = newop; /* listop */
- last->op_sibling = NULL;
- o->op_sibling = 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;
}
though (See 20010220.007). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
nothin:
- if (oldop && o->op_next) {
+ if (oldop) {
oldop->op_next = o->op_next;
o->op_opt = 0;
continue;
OP *rv2av, *q;
p = o->op_next;
if ( p->op_type == OP_GV
- && (gv = cGVOPx_gv(p))
+ && (gv = cGVOPx_gv(p)) && isGV(gv)
&& GvNAMELEN_get(gv) == 1
&& *GvNAME_get(gv) == '_'
&& GvSTASH(gv) == PL_defstash
&& !(rv2av->op_flags & OPf_REF)
&& !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
&& ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
- && o->op_sibling == rv2av /* these two for Deparse */
+ && OP_SIBLING(o) == rv2av /* these two for Deparse */
&& cUNOPx(rv2av)->op_first == p
) {
q = rv2av->op_next;
if (!defav) {
/* To allow Deparse to pessimise this, it needs to be able
* to restore the pushmark's original op_next, which it
- * will assume to be the same as op_sibling. */
- if (o->op_next != o->op_sibling)
+ * will assume to be the same as OP_SIBLING. */
+ if (o->op_next != OP_SIBLING(o))
break;
p = o;
}
break;
- {
- OP *fop;
- OP *sop;
-
#define HV_OR_SCALARHV(op) \
( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
? (op) \
case OP_OR:
case OP_DOR:
fop = cLOGOP->op_first;
- sop = fop->op_sibling;
+ sop = OP_SIBLING(fop);
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
while (o->op_next && ( o->op_type == o->op_next->op_type
if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
fop->op_private |= OPpTRUEBOOL;
#undef HV_OR_SCALARHV
- /* GERONIMO! */
- }
+ /* GERONIMO! */ /* FALLTHROUGH */
case OP_MAPWHILE:
case OP_GREPWHILE:
DEFER(cLOOP->op_lastop);
break;
+ case OP_ENTERTRY:
+ assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
+ DEFER(cLOGOPo->op_other);
+ break;
+
case OP_SUBST:
assert(!(cPMOP->op_pmflags & PMf_ONCE));
while (cPMOP->op_pmstashstartu.op_pmreplstart &&
if (o->op_flags & OPf_SPECIAL) {
/* first arg is a code block */
- OP * const nullop = cLISTOP->op_first->op_sibling;
+ OP * const nullop = OP_SIBLING(cLISTOP->op_first);
OP * kid = cUNOPx(nullop)->op_first;
assert(nullop->op_type == OP_NULL);
break;
/* reverse sort ... can be optimised. */
- if (!cUNOPo->op_sibling) {
+ if (!OP_HAS_SIBLING(cUNOPo)) {
/* Nothing follows us on the list. */
OP * const reverse = o->op_next;
(reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
OP * const pushmark = cUNOPx(reverse)->op_first;
if (pushmark && (pushmark->op_type == OP_PUSHMARK)
- && (cUNOPx(pushmark)->op_sibling == o)) {
+ && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
/* reverse -> pushmark -> sort */
o->op_private |= OPpSORT_REVERSE;
op_null(reverse);
|| expushmark->op_targ != OP_PUSHMARK)
break;
- exlist = (LISTOP *) expushmark->op_sibling;
+ exlist = (LISTOP *) OP_SIBLING(expushmark);
if (!exlist || exlist->op_type != OP_NULL
|| exlist->op_targ != OP_LIST)
break;
if (!theirmark || theirmark->op_type != OP_PUSHMARK)
break;
- if (theirmark->op_sibling != o) {
+ if (OP_SIBLING(theirmark) != o) {
/* There's something between the mark and the reverse, eg
for (1, reverse (...))
so no go. */
if (!ourlast || ourlast->op_next != o)
break;
- rv2av = ourmark->op_sibling;
- if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
+ rv2av = OP_SIBLING(ourmark);
+ if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
&& rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
&& enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
/* We're just reversing a single array. */
if (OP_GIMME(o,0) == G_VOID) {
OP *right = cBINOP->op_first;
if (right) {
- OP *left = right->op_sibling;
+ /* sassign
+ * RIGHT
+ * substr
+ * pushmark
+ * arg1
+ * arg2
+ * ...
+ * becomes
+ *
+ * ex-sassign
+ * substr
+ * pushmark
+ * RIGHT
+ * arg1
+ * arg2
+ * ...
+ */
+ OP *left = OP_SIBLING(right);
if (left->op_type == OP_SUBSTR
&& (left->op_private & 7) < 4) {
op_null(o);
- cBINOP->op_first = left;
- right->op_sibling =
- cBINOPx(left)->op_first->op_sibling;
- cBINOPx(left)->op_first->op_sibling = 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;
}
}
- oldoldop = oldop;
- oldop = o;
+ /* did we just null the current op? If so, re-process it to handle
+ * eliding "empty" ops from the chain */
+ if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
+ o->op_opt = 0;
+ o = oldop;
+ }
+ else {
+ oldoldop = oldop;
+ oldop = o;
+ }
}
LEAVE;
}
}
}
}
+ /* Some gcc releases emit a warning for this function:
+ * op.c: In function 'Perl_custom_op_get_field':
+ * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
+ * Whether this is true, is currently unknown. */
return any;
}
}
}
/*
-=head1 Functions in file op.c
=for apidoc core_prototype
+
This function assigns the prototype of the named core function to C<sv>, or
to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
NULL if the core function has no prototype. C<code> is a code as returned
OP_SSELECT),
coresub_op(coreargssv, 0, OP_SELECT)
);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_BASEOP:
is_const
? "Constant subroutine %"SVf" redefined"
: "Subroutine %"SVf" redefined",
- name);
+ SVfARG(name));
}
/*
{
dVAR;
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
if (*old_checker_p) return;
OP_CHECK_MUTEX_LOCK;
static void
const_sv_xsub(pTHX_ CV* cv)
{
- dVAR;
dXSARGS;
SV *const sv = MUTABLE_SV(XSANY.any_ptr);
PERL_UNUSED_ARG(items);
static void
const_av_xsub(pTHX_ CV* cv)
{
- dVAR;
dXSARGS;
AV * const av = MUTABLE_AV(XSANY.any_ptr);
SP -= items;
https://perl5.git.perl.org / perl5.git / blobdiff