static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
-/* Used to avoid recursion through the op tree in scalarvoid() and
- op_free()
-*/
-
-#define dDEFER_OP \
- SSize_t defer_stack_alloc = 0; \
- SSize_t defer_ix = -1; \
- OP **defer_stack = NULL;
-#define DEFER_OP_CLEANUP Safefree(defer_stack)
-#define DEFERRED_OP_STEP 100
-#define DEFER_OP(o) \
- STMT_START { \
- if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
- defer_stack_alloc += DEFERRED_OP_STEP; \
- assert(defer_stack_alloc > 0); \
- Renew(defer_stack, defer_stack_alloc, OP *); \
- } \
- defer_stack[++defer_ix] = o; \
- } STMT_END
-#define DEFER_REVERSE(count) \
- STMT_START { \
- UV cnt = (count); \
- if (cnt > 1) { \
- OP **top = defer_stack + defer_ix; \
- /* top - (cnt) + 1 isn't safe here */ \
- OP **bottom = top - (cnt - 1); \
- OP *tmp; \
- assert(bottom >= defer_stack); \
- while (top > bottom) { \
- tmp = *top; \
- *top-- = *bottom; \
- *bottom++ = tmp; \
- } \
- } \
- } STMT_END;
-
-#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
-
/* 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.
/* Destructor */
/*
-=for apidoc Am|void|op_free|OP *o
+=for apidoc op_free
-Free an op. Only use this when an op is no longer linked to from any
-optree.
+Free an op and its children. Only use this when an op is no longer linked
+to from any optree.
=cut
*/
{
dVAR;
OPCODE type;
- dDEFER_OP;
+ OP *top_op = o;
+ OP *next_op = o;
+ bool went_up = FALSE; /* whether we reached the current node by
+ following the parent pointer from a child, and
+ so have already seen this node */
- do {
+ if (!o || o->op_type == OP_FREED)
+ return;
+
+ if (o->op_private & OPpREFCOUNTED) {
+ /* if base of tree is refcounted, just decrement */
+ switch (o->op_type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from
+ * the list we maintain for reset(). */
+ find_and_forget_pmops(o);
+ return;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
+
+ while (next_op) {
+ o = next_op;
+
+ /* free child ops before ourself, (then free ourself "on the
+ * way back up") */
+
+ if (!went_up && o->op_flags & OPf_KIDS) {
+ next_op = cUNOPo->op_first;
+ continue;
+ }
+
+ /* find the next node to visit, *then* free the current node
+ * (can't rely on o->op_* fields being valid after o has been
+ * freed) */
+
+ /* The next node to visit will be either the sibling, or the
+ * parent if no siblings left, or NULL if we've worked our way
+ * back up to the top node in the tree */
+ next_op = (o == top_op) ? NULL : o->op_sibparent;
+ went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
+
+ /* Now process the current node */
/* Though ops may be freed twice, freeing the op after its slab is a
big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
/* During the forced freeing of ops after compilation failure, kidops
may be freed before their parents. */
if (!o || o->op_type == OP_FREED)
* we can't spot faults in the main code, only
* evaled/required code */
#ifdef DEBUGGING
- if ( o->op_ppaddr == PL_ppaddr[o->op_type]
+ if ( o->op_ppaddr == PL_ppaddr[type]
&& PL_parser
&& !PL_parser->error_count)
{
}
#endif
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- if (refcnt) {
- /* Need to find and remove any pattern match ops from the list
- we maintain for reset(). */
- find_and_forget_pmops(o);
- continue;
- }
- }
- break;
- default:
- break;
- }
- }
/* Call the op_free hook if it has been set. Do it now so that it's called
* at the right time for refcounted ops, but still before all of the kids
* are freed. */
CALL_OPFREEHOOK(o);
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OpSIBLING(kid); /* Get before next freeing kid */
- if (kid->op_type == OP_FREED)
- /* During the forced freeing of ops after
- compilation failure, kidops may be freed before
- their parents. */
- continue;
- if (!(kid->op_flags & OPf_KIDS))
- /* If it has no kids, just free it now */
- op_free(kid);
- else
- DEFER_OP(kid);
- }
- }
if (type == OP_NULL)
type = (OPCODE)o->op_targ;
FreeOp(o);
if (PL_op == o)
PL_op = NULL;
- } while ( (o = POP_DEFERRED_OP()) );
-
- DEFER_OP_CLEANUP;
+ }
}
+
/* S_op_clear_gv(): free a GV attached to an OP */
STATIC
o->op_targ = 0;
break;
default:
- if (!(o->op_flags & OPf_REF)
- || (PL_check[o->op_type] != Perl_ck_ftst))
+ if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
break;
/* FALLTHROUGH */
case OP_GVSV:
}
/*
-=for apidoc Am|void|op_null|OP *o
+=for apidoc op_null
Neutralizes an op when it is no longer needed, but is still linked to from
other ops.
/* Contextualizers */
/*
-=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
+=for apidoc op_contextualize
Applies a syntactic context to an op tree representing an expression.
C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
/*
-=for apidoc Am|OP*|op_linklist|OP *o
+=for apidoc op_linklist
This function is the implementation of the L</LINKLIST> macro. It should
not be called directly.
SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
+
+
+/* apply scalar context to the o subtree */
+
OP *
Perl_scalar(pTHX_ OP *o)
{
- OP *kid;
+ OP * top_op = o;
- /* assumes no premature commitment */
- if (!o || (PL_parser && PL_parser->error_count)
- || (o->op_flags & OPf_WANT)
- || o->op_type == OP_RETURN)
- {
- return o;
- }
+ while (1) {
+ OP *next_kid = NULL; /* what op (if any) to process next */
+ OP *kid;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
+ /* assumes no premature commitment */
+ if (!o || (PL_parser && PL_parser->error_count)
+ || (o->op_flags & OPf_WANT)
+ || o->op_type == OP_RETURN)
+ {
+ goto do_next;
+ }
- switch (o->op_type) {
- case OP_REPEAT:
- scalar(cBINOPo->op_first);
- if (o->op_private & OPpREPEAT_DOLIST) {
- kid = cLISTOPx(cUNOPo->op_first)->op_first;
- assert(kid->op_type == OP_PUSHMARK);
- if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
- op_null(cLISTOPx(cUNOPo->op_first)->op_first);
- o->op_private &=~ OPpREPEAT_DOLIST;
- }
- }
- break;
- case OP_OR:
- case OP_AND:
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- scalar(kid);
- break;
- /* FALLTHROUGH */
- case OP_SPLIT:
- case OP_MATCH:
- case OP_QR:
- case OP_SUBST:
- case OP_NULL:
- default:
- if (o->op_flags & OPf_KIDS) {
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- scalar(kid);
- }
- break;
- case OP_LEAVE:
- case OP_LEAVETRY:
- kid = cLISTOPo->op_first;
- scalar(kid);
- kid = OpSIBLING(kid);
- do_kids:
- while (kid) {
- OP *sib = OpSIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN
- && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
- || ( sib->op_targ != OP_NEXTSTATE
- && sib->op_targ != OP_DBSTATE )))
- scalarvoid(kid);
- else
- scalar(kid);
- kid = sib;
- }
- PL_curcop = &PL_compiling;
- break;
- case OP_SCOPE:
- case OP_LINESEQ:
- case OP_LIST:
- kid = cLISTOPo->op_first;
- goto do_kids;
- case OP_SORT:
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
- break;
- case OP_KVHSLICE:
- case OP_KVASLICE:
- {
- /* Warn about scalar context */
- const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
- const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
- SV *name;
- SV *keysv;
- const char *key = NULL;
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
- /* This warning can be nonsensical when there is a syntax error. */
- if (PL_parser && PL_parser->error_count)
- break;
+ switch (o->op_type) {
+ case OP_REPEAT:
+ scalar(cBINOPo->op_first);
+ /* convert what initially looked like a list repeat into a
+ * scalar repeat, e.g. $s = (1) x $n
+ */
+ if (o->op_private & OPpREPEAT_DOLIST) {
+ kid = cLISTOPx(cUNOPo->op_first)->op_first;
+ assert(kid->op_type == OP_PUSHMARK);
+ if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
+ op_null(cLISTOPx(cUNOPo->op_first)->op_first);
+ o->op_private &=~ OPpREPEAT_DOLIST;
+ }
+ }
+ break;
+
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ /* impose scalar context on everything except the condition */
+ next_kid = OpSIBLING(cUNOPo->op_first);
+ break;
- if (!ckWARN(WARN_SYNTAX)) break;
+ default:
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
- kid = cLISTOPo->op_first;
- kid = OpSIBLING(kid); /* get past pushmark */
- assert(OpSIBLING(kid));
- name = S_op_varname(aTHX_ OpSIBLING(kid));
- if (!name) /* XS module fiddling with the op tree */
- break;
- S_op_pretty(aTHX_ kid, &keysv, &key);
- assert(SvPOK(name));
- sv_chop(name,SvPVX(name)+1);
- if (key)
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%s%c in scalar context better written "
- "as $%" SVf "%c%s%c",
- SVfARG(name), lbrack, key, rbrack, SVfARG(name),
- lbrack, key, rbrack);
- else
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%" SVf "%c in scalar context better "
- "written as $%" SVf "%c%" SVf "%c",
- SVfARG(name), lbrack, SVfARG(keysv), rbrack,
- SVfARG(name), lbrack, SVfARG(keysv), rbrack);
- }
- }
- return o;
+ /* the children of these ops are usually a list of statements,
+ * except the leaves, whose first child is a corresponding enter
+ */
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ scalar(kid);
+ kid = OpSIBLING(kid);
+ do_kids:
+ while (kid) {
+ OP *sib = OpSIBLING(kid);
+ if (sib && kid->op_type != OP_LEAVEWHEN
+ && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
+ || ( sib->op_targ != OP_NEXTSTATE
+ && sib->op_targ != OP_DBSTATE )))
+ scalarvoid(kid);
+ else
+ scalar(kid);
+ kid = sib;
+ }
+ PL_curcop = &PL_compiling;
+ break;
+
+ case OP_SORT:
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
+
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ {
+ /* Warn about scalar context */
+ const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
+ const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
+ SV *name;
+ SV *keysv;
+ const char *key = NULL;
+
+ /* This warning can be nonsensical when there is a syntax error. */
+ if (PL_parser && PL_parser->error_count)
+ break;
+
+ if (!ckWARN(WARN_SYNTAX)) break;
+
+ kid = cLISTOPo->op_first;
+ kid = OpSIBLING(kid); /* get past pushmark */
+ assert(OpSIBLING(kid));
+ name = S_op_varname(aTHX_ OpSIBLING(kid));
+ if (!name) /* XS module fiddling with the op tree */
+ break;
+ S_op_pretty(aTHX_ kid, &keysv, &key);
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ if (key)
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%s%c in scalar context better written "
+ "as $%" SVf "%c%s%c",
+ SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+ lbrack, key, rbrack);
+ else
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%" SVf "%c in scalar context better "
+ "written as $%" SVf "%c%" SVf "%c",
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
+ }
+ } /* switch */
+
+ /* If next_kid is set, someone in the code above wanted us to process
+ * that kid and all its remaining siblings. Otherwise, work our way
+ * back up the tree */
+ do_next:
+ while (!next_kid) {
+ if (o == top_op)
+ return top_op; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
+
+ }
+ o = next_kid;
+ } /* while */
}
+
OP *
Perl_scalarvoid(pTHX_ OP *arg)
{
OP *kid;
SV* sv;
OP *o = arg;
- dDEFER_OP;
PERL_ARGS_ASSERT_SCALARVOID;
- do {
+ while (1) {
U8 want;
SV *useless_sv = NULL;
const char* useless = NULL;
+ OP * next_kid = NULL;
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
|| (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
{
- continue;
+ goto get_next_op;
}
if ((o->op_private & OPpTARGET_MY)
{
/* newASSIGNOP has already applied scalar context, which we
leave, as if this op is inside SASSIGN. */
- continue;
+ goto get_next_op;
}
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
case OP_COND_EXPR:
case OP_ENTERGIVEN:
case OP_ENTERWHEN:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- if (!(kid->op_flags & OPf_KIDS))
- scalarvoid(kid);
- else
- DEFER_OP(kid);
+ next_kid = OpSIBLING(cUNOPo->op_first);
break;
case OP_NULL:
case OP_LEAVEGIVEN:
case OP_LEAVEWHEN:
kids:
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
- if (!(kid->op_flags & OPf_KIDS))
- scalarvoid(kid);
- else
- DEFER_OP(kid);
+ next_kid = cLISTOPo->op_first;
break;
case OP_LIST:
/* If the first kid after pushmark is something that the padrange
"Useless use of %s in void context",
useless);
}
- } while ( (o = POP_DEFERRED_OP()) );
- DEFER_OP_CLEANUP;
+ get_next_op:
+ /* if a kid hasn't been nominated to process, continue with the
+ * next sibling, or if no siblings left, go back to the parent's
+ * siblings and so on
+ */
+ while (!next_kid) {
+ if (o == arg)
+ return arg; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
+ o = next_kid;
+ }
return arg;
}
+
static OP *
S_listkids(pTHX_ OP *o)
{
return o;
}
+
+/* apply list context to the o subtree */
+
OP *
Perl_list(pTHX_ OP *o)
{
- OP *kid;
+ OP * top_op = o;
- /* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN)
- {
- return o;
- }
+ while (1) {
+ OP *next_kid = NULL; /* what op (if any) to process next */
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return o; /* As if inside SASSIGN */
- }
+ OP *kid;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+ /* assumes no premature commitment */
+ if (!o || (o->op_flags & OPf_WANT)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN)
+ {
+ goto do_next;
+ }
- switch (o->op_type) {
- case OP_FLOP:
- list(cBINOPo->op_first);
- break;
- case OP_REPEAT:
- if (o->op_private & OPpREPEAT_DOLIST
- && !(o->op_flags & OPf_STACKED))
- {
- list(cBINOPo->op_first);
- kid = cBINOPo->op_last;
- if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
- && SvIVX(kSVOP_sv) == 1)
- {
- op_null(o); /* repeat */
- op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
- /* const (rhs): */
- op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
- }
- }
- break;
- case OP_OR:
- case OP_AND:
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- list(kid);
- break;
- default:
- case OP_MATCH:
- case OP_QR:
- case OP_SUBST:
- case OP_NULL:
- if (!(o->op_flags & OPf_KIDS))
- break;
- if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
- list(cBINOPo->op_first);
- return gen_constant_list(o);
- }
- listkids(o);
- break;
- case OP_LIST:
- listkids(o);
- if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
- }
- break;
- case OP_LEAVE:
- case OP_LEAVETRY:
- kid = cLISTOPo->op_first;
- list(kid);
- kid = OpSIBLING(kid);
- do_kids:
- while (kid) {
- OP *sib = OpSIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN)
- scalarvoid(kid);
- else
- list(kid);
- kid = sib;
- }
- PL_curcop = &PL_compiling;
- break;
- case OP_SCOPE:
- case OP_LINESEQ:
- kid = cLISTOPo->op_first;
- goto do_kids;
- }
- return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ goto do_next; /* As if inside SASSIGN */
+ }
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+
+ switch (o->op_type) {
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST
+ && !(o->op_flags & OPf_STACKED))
+ {
+ list(cBINOPo->op_first);
+ kid = cBINOPo->op_last;
+ /* optimise away (.....) x 1 */
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
+ && SvIVX(kSVOP_sv) == 1)
+ {
+ op_null(o); /* repeat */
+ op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
+ /* const (rhs): */
+ op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
+ }
+ }
+ break;
+
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ /* impose list context on everything except the condition */
+ next_kid = OpSIBLING(cUNOPo->op_first);
+ break;
+
+ default:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* possibly flatten 1..10 into a constant array */
+ if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
+ list(cBINOPo->op_first);
+ gen_constant_list(o);
+ goto do_next;
+ }
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
+
+ case OP_LIST:
+ if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
+
+ /* the children of these ops are usually a list of statements,
+ * except the leaves, whose first child is a corresponding enter
+ */
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ list(kid);
+ kid = OpSIBLING(kid);
+ do_kids:
+ while (kid) {
+ OP *sib = OpSIBLING(kid);
+ /* Apply void context to all kids except the last, which
+ * is list. E.g.
+ * @a = do { void; void; list }
+ * Except that 'when's are always list context, e.g.
+ * @a = do { given(..) {
+ * when (..) { list }
+ * when (..) { list }
+ * ...
+ * }}
+ */
+ if (!sib) {
+ /* tail call optimise calling list() on the last kid */
+ next_kid = kid;
+ goto do_next;
+ }
+ else if (kid->op_type == OP_LEAVEWHEN)
+ list(kid);
+ else
+ scalarvoid(kid);
+ kid = sib;
+ }
+ NOT_REACHED; /* NOTREACHED */
+ break;
+
+ }
+
+ /* If next_kid is set, someone in the code above wanted us to process
+ * that kid and all its remaining siblings. Otherwise, work our way
+ * back up the tree */
+ do_next:
+ while (!next_kid) {
+ if (o == top_op)
+ return top_op; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else {
+ o = o->op_sibparent; /*try parent's next sibling */
+ switch (o->op_type) {
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ /* should really restore PL_curcop to its old value, but
+ * setting it to PL_compiling is better than do nothing */
+ PL_curcop = &PL_compiling;
+ }
+ }
+
+
+ }
+ o = next_kid;
+ } /* while */
}
+
static OP *
S_scalarseq(pTHX_ OP *o)
{
}
-/* helper for optimize_optree() which optimises on op then recurses
+/* helper for optimize_optree() which optimises one op then recurses
* to optimise any children.
*/
STATIC void
S_optimize_op(pTHX_ OP* o)
{
- dDEFER_OP;
+ OP *top_op = o;
PERL_ARGS_ASSERT_OPTIMIZE_OP;
- do {
+
+ while (1) {
+ OP * next_kid = NULL;
+
assert(o->op_type != OP_FREED);
switch (o->op_type) {
break;
case OP_SUBST:
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
+ /* we can't assume that op_pmreplroot->op_sibparent == o
+ * and that it is thus possible to walk back up the tree
+ * past op_pmreplroot. So, although we try to avoid
+ * recursing through op trees, do it here. After all,
+ * there are unlikely to be many nested s///e's within
+ * the replacement part of a s///e.
+ */
+ optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ }
break;
default:
break;
}
- if (o->op_flags & OPf_KIDS) {
- OP *kid;
- IV child_count = 0;
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
- DEFER_OP(kid);
- ++child_count;
- }
- DEFER_REVERSE(child_count);
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first;
+
+ /* if a kid hasn't been nominated to process, continue with the
+ * next sibling, or if no siblings left, go back to the parent's
+ * siblings and so on
+ */
+ while (!next_kid) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
}
- } while ( ( o = POP_DEFERRED_OP() ) );
- DEFER_OP_CLEANUP;
+ /* this label not yet used. Goto here if any code above sets
+ * next-kid
+ get_next_op:
+ */
+ o = next_kid;
+ }
}
#endif
/*
-=for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
+=for apidoc traverse_op_tree
Return the next op in a depth-first traversal of the op tree,
returning NULL when the traversal is complete.
}
/*
-=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
+=for apidoc op_lvalue
Propagate lvalue ("modifiable") context to an op and its children.
C<type> represents the context type, roughly based on the type of op that
/* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
- if (type == OP_REFGEN &&
- PL_check[o->op_type] == Perl_ck_ftst)
+ if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
return o;
if (type != OP_LEAVESUBLV)
}
/*
-=for apidoc Amx|OP *|op_scope|OP *o
+=for apidoc op_scope
Wraps up an op tree with some additional ops so that at runtime a dynamic
scope will be created. The original ops run in the new dynamic scope,
}
/*
-=for apidoc Am|int|block_start|int full
+=for apidoc block_start
Handles compile-time scope entry.
Arranges for hints to be restored on block
}
/*
-=for apidoc Am|OP *|block_end|I32 floor|OP *seq
+=for apidoc block_end
Handles compile-time scope exit. C<floor>
is the savestack index returned by
/*
=head1 Compile-time scope hooks
-=for apidoc Aox||blockhook_register
+=for apidoc blockhook_register
Register a set of hooks to be called when the Perl lexical scope changes
at compile time. See L<perlguts/"Compile-time scope hooks">.
return o;
}
-static OP *
+/* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
+ * the constant value being an AV holding the flattened range.
+ */
+
+static void
S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
list(o);
if (PL_parser && PL_parser->error_count)
- return o; /* Don't attempt to run with errors */
+ return; /* Don't attempt to run with errors */
curop = LINKLIST(o);
old_next = o->op_next;
delete_eval_scope();
}
if (ret)
- return o;
+ return;
OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
SvREADONLY_on(*svp);
}
LINKLIST(o);
- return list(o);
+ list(o);
+ return;
}
/*
/* List constructors */
/*
-=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
+=for apidoc op_append_elem
Append an item to the list of ops contained directly within a list-type
op, returning the lengthened list. C<first> is the list-type op,
}
/*
-=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
+=for apidoc op_append_list
Concatenate the lists of ops contained directly within two list-type ops,
returning the combined list. C<first> and C<last> are the list-type ops
}
/*
-=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
+=for apidoc op_prepend_elem
Prepend an item to the list of ops contained directly within a list-type
op, returning the lengthened list. C<first> is the op to prepend to the
}
/*
-=for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
+=for apidoc op_convert_list
Converts C<o> into a list op if it is not one already, and then converts it
into the specified C<type>, calling its check function, allocating a target if
/*
=head1 Optree construction
-=for apidoc Am|OP *|newNULLLIST
+=for apidoc newNULLLIST
Constructs, checks, and returns a new C<stub> op, which represents an
empty list expression.
}
/*
-=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
+=for apidoc newLISTOP
Constructs, checks, and returns an op of any list type. C<type> is
the opcode. C<flags> gives the eight bits of C<op_flags>, except that
}
/*
-=for apidoc Am|OP *|newOP|I32 type|I32 flags
+=for apidoc newOP
Constructs, checks, and returns an op of any base type (any type that
has no extra fields). C<type> is the opcode. C<flags> gives the
}
/*
-=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
+=for apidoc newUNOP
Constructs, checks, and returns an op of any unary type. C<type> is
the opcode. C<flags> gives the eight bits of C<op_flags>, except that
}
/*
-=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
+=for apidoc newMETHOP
Constructs, checks, and returns an op of method type with a method name
evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
}
/*
-=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
+=for apidoc newMETHOP_named
Constructs, checks, and returns an op of method type with a constant
method name. C<type> is the opcode. C<flags> gives the eight bits of
}
/*
-=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
+=for apidoc newBINOP
Constructs, checks, and returns an op of any binary type. C<type>
is the opcode. C<flags> gives the eight bits of C<op_flags>, except
/*
-=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
+=for apidoc newPMOP
Constructs, checks, and returns an op of any pattern matching type.
C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
}
/*
-=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
+=for apidoc newSVOP
Constructs, checks, and returns an op of any type that involves an
embedded SV. C<type> is the opcode. C<flags> gives the eight bits
}
/*
-=for apidoc Am|OP *|newDEFSVOP|
+=for apidoc newDEFSVOP
Constructs and returns an op to access C<$_>.
#ifdef USE_ITHREADS
/*
-=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
+=for apidoc newPADOP
Constructs, checks, and returns an op of any type that involves a
reference to a pad element. C<type> is the opcode. C<flags> gives the
#endif /* USE_ITHREADS */
/*
-=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
+=for apidoc newGVOP
Constructs, checks, and returns an op of any type that involves an
embedded reference to a GV. C<type> is the opcode. C<flags> gives the
}
/*
-=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
+=for apidoc newPVOP
Constructs, checks, and returns an op of any type that involves an
embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
/*
=head1 Optree construction
-=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
+=for apidoc newSLICEOP
Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
}
/*
-=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
+=for apidoc newASSIGNOP
Constructs, checks, and returns an assignment op. C<left> and C<right>
supply the parameters of the assignment; they are consumed by this
}
/*
-=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
+=for apidoc newSTATEOP
Constructs a state op (COP). The state op is normally a C<nextstate> op,
but will be a C<dbstate> op if debugging is enabled for currently-compiled
}
/*
-=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
+=for apidoc newLOGOP
Constructs, checks, and returns a logical (flow control) op. C<type>
is the opcode. C<flags> gives the eight bits of C<op_flags>, except
}
/*
-=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
+=for apidoc newCONDOP
Constructs, checks, and returns a conditional-expression (C<cond_expr>)
op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
}
/*
-=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
+=for apidoc newRANGE
Constructs and returns a C<range> op, with subordinate C<flip> and
C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
}
/*
-=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
+=for apidoc newLOOPOP
Constructs, checks, and returns an op tree expressing a loop. This is
only a loop in the control flow through the op tree; it does not have
))
/* Return the block now, so that S_new_logop does not try to
fold it away. */
- return block; /* do {} while 0 does once */
+ {
+ op_free(expr);
+ return block; /* do {} while 0 does once */
+ }
+
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
}
/*
-=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
+=for apidoc newWHILEOP
Constructs, checks, and returns an op tree expressing a C<while> loop.
This is a heavyweight loop, with structure that allows exiting the loop
}
/*
-=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
+=for apidoc newFOROP
Constructs, checks, and returns an op tree expressing a C<foreach>
loop (iteration through a list of values). This is a heavyweight loop,
}
/*
-=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
+=for apidoc newLOOPEX
Constructs, checks, and returns a loop-exiting op (such as C<goto>
or C<last>). C<type> is the opcode. C<label> supplies the parameter
}
/*
-=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
+=for apidoc newGIVENOP
Constructs, checks, and returns an op tree expressing a C<given> block.
C<cond> supplies the expression to whose value C<$_> will be locally
}
/*
-=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
+=for apidoc newWHENOP
Constructs, checks, and returns an op tree expressing a C<when> block.
C<cond> supplies the test expression, and C<block> supplies the block
}
/*
-=for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
+=for apidoc newATTRSUB_x
Construct a Perl subroutine, also performing some surrounding jobs.
return FALSE;
} else {
if (*name == 'E') {
- if strEQ(name, "END") {
+ if (strEQ(name, "END")) {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
}
/*
-=for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
+=for apidoc newCONSTSUB
Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
rather than of counted length, and no flags are set. (This means that
}
/*
-=for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
+=for apidoc newCONSTSUB_flags
Construct a constant subroutine, also performing some surrounding
jobs. A scalar constant-valued subroutine is eligible for inlining
}
/*
-=for apidoc U||newXS
+=for apidoc newXS
Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
static storage, as it is used directly as CvFILE(), without a copy being made.
}
/*
-=for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
+=for apidoc newXS_len_flags
Construct an XS subroutine, also performing some surrounding jobs.
scalar((OP *) kid);
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
- if (type != OP_STAT && type != OP_LSTAT
- && PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT
+ if (OP_IS_FILETEST(type)
+ && OP_IS_FILETEST(kidtype)
) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ scalar(kid);
}
else {
OP * const newop
OP * const kid = cUNOPx(kidparent)->op_first;
o->op_private |= OPpLVREF_CV;
if (kid->op_type == OP_GV) {
+ SV *sv = (SV*)cGVOPx_gv(kid);
varop = kidparent;
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ /* a CVREF here confuses pp_refassign, so make sure
+ it gets a GV */
+ CV *const cv = (CV*)SvRV(sv);
+ SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
+ (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
+ assert(SvTYPE(sv) == SVt_PVGV);
+ }
goto detach_and_stack;
}
if (kid->op_type != OP_PADCV) goto bad;
*tmpbuf = '&';
assert (len < 256);
Copy(name, tmpbuf+1, len, char);
- off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+ off = pad_findmy_pvn(tmpbuf, len+1, 0);
if (off != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(off)) {
SV * const fq =
}
/*
-=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
+=for apidoc rv2cv_op_cv
Examines an op, which is expected to identify a subroutine at runtime,
and attempts to determine at compile time which subroutine it identifies.
}
/*
-=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
+=for apidoc ck_entersub_args_list
Performs the default fixup of the arguments part of an C<entersub>
op tree. This consists of applying list context to each of the
}
/*
-=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
+=for apidoc ck_entersub_args_proto
Performs the fixup of the arguments part of an C<entersub> op tree
based on a subroutine prototype. This makes various modifications to
}
/*
-=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
+=for apidoc ck_entersub_args_proto_or_list
Performs the fixup of the arguments part of an C<entersub> op tree either
based on a subroutine prototype or using default list-context processing.
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
case OA_FILESTATOP:
- return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
+ if (!aop)
+ return newOP(opnum,flags); /* zero args */
+ if (aop == prev)
+ return newUNOP(opnum,flags,aop); /* one arg */
+ /* too many args */
+ /* FALLTHROUGH */
case OA_BASEOP:
if (aop) {
- SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ SV *namesv;
+ OP *nextop;
+
+ namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
- op_free(aop);
+ while (aop) {
+ nextop = OpSIBLING(aop);
+ op_free(aop);
+ aop = nextop;
+ }
+
}
return opnum == OP_RUNCV
? newPVOP(OP_RUNCV,0,NULL)
}
/*
-=for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
+=for apidoc cv_get_call_checker_flags
Retrieves the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
(for which see above). All other bits should be clear.
-=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+=for apidoc cv_get_call_checker
The original form of L</cv_get_call_checker_flags>, which does not return
checker flags. When using a checker function returned by this function,
}
/*
-=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
+=for apidoc cv_set_call_checker_flags
Sets the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker_flags>.
-=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+=for apidoc cv_set_call_checker
The original form of L</cv_set_call_checker_flags>, which passes it the
C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
#ifdef DEBUGGING
OP *n = o->op_next;
while (n && ( n->op_type == OP_NULL
- || n->op_type == OP_LIST))
+ || n->op_type == OP_LIST
+ || n->op_type == OP_SCALAR))
n = n->op_next;
assert(n && n->op_type == OP_LEAVE);
#endif
/*
=head1 Custom Operators
-=for apidoc Ao||custom_op_xop
+=for apidoc custom_op_xop
Return the XOP structure for a given custom op. This macro should be
considered internal to C<OP_NAME> and the other access macros: use them instead.
This macro does call a function. Prior
PERL_UNUSED_ARG(mg);
xop = INT2PTR(XOP *, SvIV(sv));
- safefree((void*)xop->xop_name);
- safefree((void*)xop->xop_desc);
- safefree(xop);
+ Safefree(xop->xop_name);
+ Safefree(xop->xop_desc);
+ Safefree(xop);
return 0;
}
}
/*
-=for apidoc Ao||custom_op_register
+=for apidoc custom_op_register
Register a custom op. See L<perlguts/"Custom Operators">.
=cut
Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
const int opnum)
{
- OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP * const argop = (opnum == OP_SELECT && code) ? NULL :
+ newSVOP(OP_COREARGS,0,coreargssv);
OP *o;
PERL_ARGS_ASSERT_CORESUB_OP;
*/
/*
-=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
+=for apidoc wrap_op_checker
Puts a C function into the chain of check functions for a specified op
type. This is the preferred way to manipulate the L</PL_check> array.
https://perl5.git.perl.org / perl5.git / blobdiff