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.
#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+/* malloc a new op slab (suitable for attaching to PL_compcv) */
+
static OPSLAB *
S_new_slab(pTHX_ size_t sz)
{
PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
)
+/* Returns a sz-sized block of memory (suitable for holding an op) from
+ * a free slot in the chain of op slabs attached to PL_compcv.
+ * Allocates a new slab if necessary.
+ * if PL_compcv isn't compiling, malloc() instead.
+ */
+
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
}
#endif
+
+/* Return the block of memory used by an op to the free list of
+ * the OP slab associated with that op.
+ */
+
void
Perl_Slab_Free(pTHX_ void *op)
{
if (havepad) LEAVE;
}
+/* Free a chain of OP slabs. Should only be called after all ops contained
+ * in it have been freed. At this point, its reference count should be 1,
+ * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
+ * and just directly calls opslab_free().
+ * (Note that the reference count which PL_compcv held on the slab should
+ * have been removed once compilation of the sub was complete).
+ *
+ *
+ */
+
void
Perl_opslab_free(pTHX_ OPSLAB *slab)
{
} while (slab);
}
+/* like opslab_free(), but first calls op_free() on any ops in the slab
+ * not marked as OP_FREED
+ */
+
void
Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
/* 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;
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OpSIBLING(kid); /* Get before next freeing kid */
- if (!kid || 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;
- if (!ckWARN(WARN_SYNTAX)) 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;
- 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;
+ default:
+ 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:
+ 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);
+ /* Apply void context to all kids except the last, which
+ * is scalar (ignoring a trailing ex-nextstate in determining
+ * if it's the last kid). E.g.
+ * $scalar = do { void; void; scalar }
+ * Except that 'when's are always scalar, e.g.
+ * $scalar = do { given(..) {
+ * when (..) { scalar }
+ * when (..) { scalar }
+ * ...
+ * }}
+ */
+ if (!sib
+ || ( !OpHAS_SIBLING(sib)
+ && sib->op_type == OP_NULL
+ && ( sib->op_targ == OP_NEXTSTATE
+ || sib->op_targ == OP_DBSTATE )
+ )
+ )
+ {
+ /* tail call optimise calling scalar() on the last kid */
+ next_kid = kid;
+ goto do_next;
+ }
+ else if (kid->op_type == OP_LEAVEWHEN)
+ scalar(kid);
+ else
+ scalarvoid(kid);
+ kid = sib;
+ }
+ NOT_REACHED; /* NOTREACHED */
+ 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 */
+ 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 */
}
+
+/* apply void context to the optree arg */
+
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)
{
/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
* const fields. Also, convert CONST keys to HEK-in-SVs.
- * rop is the op that retrieves the hash;
+ * rop is the op that retrieves the hash;
* key_op is the first key
+ * real if false, only check (and possibly croak); don't update op
*/
STATIC void
-S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
+S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
{
PADNAME *lexname;
GV **fields;
if ( !SvIsCOW_shared_hash(sv = *svp)
&& SvTYPE(sv) < SVt_PVMG
&& SvOK(sv)
- && !SvROK(sv))
+ && !SvROK(sv)
+ && real)
{
SSize_t keylen;
const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
/* see if any strings would grow if converted to utf8 */
if (!utf8) {
- char *p = (char*)argp->p;
- STRLEN len = argp->len;
- while (len--) {
- U8 c = *p++;
- if (!UTF8_IS_INVARIANT(c))
- variant++;
- }
+ variant += variant_under_utf8_count((U8 *) argp->p,
+ (U8 *) argp->p + argp->len);
}
}
}
-/* 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.
check_keys:
if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
rop = NULL;
- S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
break;
}
case OP_NULL:
}
/*
-=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">.
start = LINKLIST(PL_main_root);
PL_main_root->op_next = 0;
S_process_optree(aTHX_ NULL, PL_main_root, start);
- cv_forget_slab(PL_compcv);
+ if (!PL_parser->error_count)
+ /* on error, leave CV slabbed so that ops left lying around
+ * will eb cleaned up. Else unslab */
+ cv_forget_slab(PL_compcv);
PL_compcv = 0;
/* Register with debugger */
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
{
dVAR;
LISTOP *listop;
+ /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
+ * pushmark is banned. So do it now while existing ops are in a
+ * consistent state, in case they suddenly get freed */
+ OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
|| type == OP_CUSTOM);
NewOp(1101, listop, 1, LISTOP);
-
OpTYPE_set(listop, type);
if (first || last)
flags |= OPf_KIDS;
OpMORESIB_set(first, last);
listop->op_first = first;
listop->op_last = last;
- if (type == OP_LIST) {
- OP* const pushop = newOP(OP_PUSHMARK, 0);
+
+ if (pushop) {
OpMORESIB_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
}
/*
-=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>
rx_flags |= RXf_SPLIT;
}
- /* Skip compiling if parser found an error for this pattern */
- if (pm->op_pmflags & PMf_HAS_ERROR) {
- return o;
- }
-
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
# endif
}
#endif
- /* But we know that one op is using this CV's slab. */
- cv_forget_slab(PL_compcv);
+ /* This LEAVE_SCOPE will restore PL_compcv to point to the
+ * outer CV (the one whose slab holds the pm op). The
+ * inner CV (which holds expr) will be freed later, once
+ * all the entries on the parse stack have been popped on
+ * return from this function. Which is why its safe to
+ * call op_free(expr) below.
+ */
LEAVE_SCOPE(floor);
pm->op_pmflags &= ~PMf_HAS_CV;
}
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
PM_SETRE(pm,
eng->op_comp
? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
}
else {
/* compile-time pattern that includes literal code blocks */
- REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+
+ REGEXP* re;
+
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
+ re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
rx_flags,
(pm->op_pmflags |
((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
}
/*
-=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
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
OP *veop, *imop;
- OP * const modname = newSVOP(OP_CONST, 0, name);
+ OP * modname;
+ I32 floor;
PERL_ARGS_ASSERT_VLOAD_MODULE;
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work.
+ * The ENTER/LEAVE pair protect callers from any side effects of use.
+ *
+ * start_subparse() creates a new PL_compcv. This means that any ops
+ * allocated below will be allocated from that CV's op slab, and so
+ * will be automatically freed if the utilise() fails
+ */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
+ floor = start_subparse(FALSE, 0);
+
+ modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
}
}
- /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
- * that it has a PL_parser to play with while doing that, and also
- * that it doesn't mess with any existing parser, by creating a tmp
- * new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work.
- * The ENTER/LEAVE pair protect callers from any side effects of use. */
-
- ENTER;
- SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, LEX_START_SAME_FILTER);
- utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
- veop, modname, imop);
+ utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
LEAVE;
}
/*
=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
list(force_list(listval, 1)) );
}
+#define ASSIGN_SCALAR 0
#define ASSIGN_LIST 1
#define ASSIGN_REF 2
+/* given the optree o on the LHS of an assignment, determine whether its:
+ * ASSIGN_SCALAR $x = ...
+ * ASSIGN_LIST ($x) = ...
+ * ASSIGN_REF \$x = ...
+ */
+
STATIC I32
S_assignment_type(pTHX_ const OP *o)
{
U8 ret;
if (!o)
- return TRUE;
+ return ASSIGN_LIST;
if (o->op_type == OP_SREFGEN)
{
o = cUNOPo->op_first;
flags = o->op_flags;
type = o->op_type;
- ret = 0;
+ ret = ASSIGN_SCALAR;
}
if (type == OP_COND_EXPR) {
return ASSIGN_LIST;
if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
yyerror("Assignment to both a list and a scalar");
- return FALSE;
+ return ASSIGN_SCALAR;
}
if (type == OP_LIST &&
type == OP_RV2AV || type == OP_RV2HV ||
type == OP_ASLICE || type == OP_HSLICE ||
type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
- return TRUE;
+ return ASSIGN_LIST;
if (type == OP_PADAV || type == OP_PADHV)
- return TRUE;
+ return ASSIGN_LIST;
if (type == OP_RV2SV)
return ret;
}
/*
-=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
return new_logop(type, flags, &first, &other);
}
+
+/* See if the optree o contains a single OP_CONST (plus possibly
+ * surrounding enter/nextstate/null etc). If so, return it, else return
+ * NULL.
+ */
+
STATIC OP *
S_search_const(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_SEARCH_CONST;
+ redo:
switch (o->op_type) {
case OP_CONST:
return o;
case OP_NULL:
- if (o->op_flags & OPf_KIDS)
- return search_const(cUNOPo->op_first);
+ if (o->op_flags & OPf_KIDS) {
+ o = cUNOPo->op_first;
+ goto redo;
+ }
break;
case OP_LEAVE:
case OP_SCOPE:
if (!(o->op_flags & OPf_KIDS))
return NULL;
kid = cLISTOPo->op_first;
+
do {
switch (kid->op_type) {
case OP_ENTER:
goto last;
}
} while (kid);
+
if (!kid)
kid = cLISTOPo->op_last;
last:
- return search_const(kid);
+ o = kid;
+ goto redo;
}
}
return NULL;
}
+
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
}
/*
-=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
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
if (block) {
+ bool free_file = CvFILE(cv) && CvDYNFILE(cv);
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(cv);
CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
CvFLAGS(compcv) |= other_flags;
- if (CvFILE(cv) && CvDYNFILE(cv)) {
+ if (free_file) {
Safefree(CvFILE(cv));
+ CvFILE(cv) = NULL;
}
/* inner references to compcv must be fixed up ... */
if (const_sv)
goto clone;
+ if (CvFILE(cv) && CvDYNFILE(cv))
+ Safefree(CvFILE(cv));
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
/*
-=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.
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
if (block) {
+ bool free_file = CvFILE(cv) && CvDYNFILE(cv);
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
CvFLAGS(PL_compcv) |= other_flags;
- if (CvFILE(cv) && CvDYNFILE(cv)) {
+ if (free_file) {
Safefree(CvFILE(cv));
}
CvFILE_set_from_cop(cv, PL_curcop);
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.
return cv;
}
+/* Add a stub CV to a typeglob.
+ * This is the implementation of a forward declaration, 'sub foo';'
+ */
+
CV *
Perl_newSTUB(pTHX_ GV *gv, bool fake)
{
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
* the extra hassle for those edge cases */
break;
- if (pass) {
+ {
UNOP *rop = NULL;
OP * helem_op = o->op_next;
ASSUME( helem_op->op_type == OP_HELEM
- || helem_op->op_type == OP_NULL);
+ || helem_op->op_type == OP_NULL
+ || pass == 0);
if (helem_op->op_type == OP_HELEM) {
rop = (UNOP*)(((BINOP*)helem_op)->op_first);
if ( helem_op->op_private & OPpLVAL_INTRO
)
rop = NULL;
}
- S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
+ /* on first pass just check; on second pass
+ * hekify */
+ S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
+ pass);
+ }
+ if (pass) {
#ifdef USE_ITHREADS
/* Relocate sv to the pad for thread safety */
op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#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
=cut
*/
+
+/* use PERL_MAGIC_ext to call a function to free the xop structure when
+ * freeing PL_custom_ops */
+
+static int
+custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
+{
+ XOP *xop;
+
+ PERL_UNUSED_ARG(mg);
+ xop = INT2PTR(XOP *, SvIV(sv));
+ Safefree(xop->xop_name);
+ Safefree(xop->xop_desc);
+ Safefree(xop);
+ return 0;
+}
+
+
+static const MGVTBL custom_op_register_vtbl = {
+ 0, /* get */
+ 0, /* set */
+ 0, /* len */
+ 0, /* clear */
+ custom_op_register_free, /* free */
+ 0, /* copy */
+ 0, /* dup */
+#ifdef MGf_LOCAL
+ 0, /* local */
+#endif
+};
+
+
XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
{
if (PL_custom_ops)
he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
- /* assume noone will have just registered a desc */
+ /* See if the op isn't registered, but its name *is* registered.
+ * That implies someone is using the pre-5.14 API,where only name and
+ * description could be registered. If so, fake up a real
+ * registration.
+ * We only check for an existing name, and assume no one will have
+ * just registered a desc */
if (!he && PL_custom_op_names &&
(he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
) {
XopENTRY_set(xop, xop_desc, savepvn(pv, l));
}
Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
+ he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
+ /* add magic to the SV so that the xop struct (pointed to by
+ * SvIV(sv)) is freed. Normally a static xop is registered, but
+ * for this backcompat hack, we've alloced one */
+ (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
+ &custom_op_register_vtbl, NULL, 0);
+
}
else {
if (!he)
}
/*
-=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.
Size_t size;
STRLEN *new_warnings;
- if (specialWARN(warnings))
+ if (warnings == NULL || specialWARN(warnings))
return warnings;
size = sizeof(*warnings) + *warnings;
https://perl5.git.perl.org / perl5.git / blobdiff