#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) */
+/* requires double parens and aTHX_ */
+#define DEBUG_S_warn(args) \
+ DEBUG_S( \
+ PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
+ )
+
+
+/* malloc a new op slab (suitable for attaching to PL_compcv).
+ * sz is in units of pointers */
static OPSLAB *
-S_new_slab(pTHX_ size_t sz)
+S_new_slab(pTHX_ OPSLAB *head, size_t sz)
{
+ OPSLAB *slab;
+
+ /* opslot_offset is only U16 */
+ assert(sz < U16_MAX);
+
#ifdef PERL_DEBUG_READONLY_OPS
- OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+ slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
PROT_READ|PROT_WRITE,
MAP_ANON|MAP_PRIVATE, -1, 0);
DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
perror("mmap failed");
abort();
}
- slab->opslab_size = (U16)sz;
#else
- OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+ slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
+ slab->opslab_size = (U16)sz;
+
#ifndef WIN32
/* The context is unused in non-Windows */
PERL_UNUSED_CONTEXT;
#endif
- slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
+ slab->opslab_head = head ? head : slab;
+ DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
+ (unsigned int)slab->opslab_size, (void*)slab,
+ (void*)(slab->opslab_head)));
return slab;
}
-/* requires double parens and aTHX_ */
-#define DEBUG_S_warn(args) \
- DEBUG_S( \
- 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.
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
- OPSLAB *slab;
+ OPSLAB *head_slab; /* first slab in the chain */
OPSLAB *slab2;
OPSLOT *slot;
OP *o;
- size_t opsz, space;
+ size_t opsz;
/* We only allocate ops from the slab during subroutine compilation.
We find the slab via PL_compcv, hence that must be non-NULL. It could
details. */
if (!CvSTART(PL_compcv)) {
CvSTART(PL_compcv) =
- (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
+ (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
CvSLABBED_on(PL_compcv);
- slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
+ head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
}
- else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
+ else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
opsz = SIZE_TO_PSIZE(sz);
sz = opsz + OPSLOT_HEADER_P;
/* The slabs maintain a free list of OPs. In particular, constant folding
will free up OPs, so it makes sense to re-use them where possible. A
freed up slot is used in preference to a new allocation. */
- if (slab->opslab_freed) {
- OP **too = &slab->opslab_freed;
+ if (head_slab->opslab_freed) {
+ OP **too = &head_slab->opslab_freed;
o = *too;
- 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_ "found free op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)head_slab));
+
+ while (o && OpSLOT(o)->opslot_size < 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", (void*)o)); }
}
if (o) {
+ DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)head_slab));
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
}
}
-#define INIT_OPSLOT \
- slot->opslot_slab = slab; \
- slot->opslot_next = slab2->opslab_first; \
- slab2->opslab_first = slot; \
+#define INIT_OPSLOT(s) \
+ slot->opslot_offset = DIFF(slab2, slot) ; \
+ slot->opslot_size = s; \
+ slab2->opslab_free_space -= s; \
o = &slot->opslot_op; \
o->op_slabbed = 1
/* The partially-filled slab is next in the chain. */
- slab2 = slab->opslab_next ? slab->opslab_next : slab;
- if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
+ slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
+ if (slab2->opslab_free_space < sz) {
/* Remaining space is too small. */
-
/* If we can fit a BASEOP, add it to the free chain, so as not
to waste it. */
- if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+ if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
slot = &slab2->opslab_slots;
- INIT_OPSLOT;
+ INIT_OPSLOT(slab2->opslab_free_space);
o->op_type = OP_FREED;
- o->op_next = slab->opslab_freed;
- slab->opslab_freed = o;
+ o->op_next = head_slab->opslab_freed;
+ head_slab->opslab_freed = o;
}
/* Create a new slab. Make this one twice as big. */
- slot = slab2->opslab_first;
- while (slot->opslot_next) slot = slot->opslot_next;
- slab2 = S_new_slab(aTHX_
- (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
- ? PERL_MAX_SLAB_SIZE
- : (DIFF(slab2, slot)+1)*2);
- slab2->opslab_next = slab->opslab_next;
- slab->opslab_next = slab2;
+ slab2 = S_new_slab(aTHX_ head_slab,
+ slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
+ ? PERL_MAX_SLAB_SIZE
+ : slab2->opslab_size * 2);
+ slab2->opslab_next = head_slab->opslab_next;
+ head_slab->opslab_next = slab2;
}
- assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
+ assert(slab2->opslab_size >= sz);
/* Create a new op slot */
- slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
+ slot = (OPSLOT *)
+ ((I32 **)&slab2->opslab_slots
+ + slab2->opslab_free_space - sz);
assert(slot >= &slab2->opslab_slots);
- if (DIFF(&slab2->opslab_slots, slot)
- < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
- slot = &slab2->opslab_slots;
- INIT_OPSLOT;
- DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
+ INIT_OPSLOT(sz);
+ DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
+ (void*)o, (void*)slab2, (void*)head_slab));
gotit:
/* moresib == 0, op_sibling == 0 implies a solitary unattached op */
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", (void*)o, (void*)slab));
+ DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
+ (void*)o,
+ (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
+ (void*)slab));
OpslabREFCNT_dec_padok(slab);
}
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
- OPSLOT *slot;
- for (slot = slab2->opslab_first;
- slot->opslot_next;
- slot = slot->opslot_next) {
+ OPSLOT *slot = (OPSLOT*)
+ ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
+ OPSLOT *end = (OPSLOT*)
+ ((I32**)slab2 + slab2->opslab_size);
+ for (; slot < end;
+ slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
+ {
if (slot->opslot_op.op_type != OP_FREED
&& !(slot->opslot_op.op_savefree
#ifdef DEBUGGING
yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
return o;
}
-
+
STATIC OP *
S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
{
{
SV * const namesv = cv_name((CV *)gv, NULL, 0);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
-
+
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
(int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
}
&& isIDFIRST_utf8_safe((U8 *)name+1, name + len))
|| (name[1] == '_' && len > 2)))
{
+ const char * const type =
+ PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
+ PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
+
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& isASCII(name[1])
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
- /* diag_listed_as: Can't use global %s in "%s" */
- yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
- name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
- PL_parser->in_my == KEY_state ? "state" : "my"));
+ /* diag_listed_as: Can't use global %s in %s */
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
+ name[0], toCTRL(name[1]),
+ (int)(len - 2), name + 2,
+ type));
} else {
- yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
- PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
+ yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
+ (int) len, name,
+ type), flags & SVf_UTF8);
}
}
/** Bug #15654
Even if op_clear does a pad_free for the target of the op,
pad_free doesn't actually remove the sv that exists in the pad;
- instead it lives on. This results in that it could be reused as
+ instead it lives on. This results in that it could be reused as
a target later on when the pad was reallocated.
**/
if(o->op_targ) {
}
}
}
- if (PL_curpm == o)
+ if (PL_curpm == o)
PL_curpm = NULL;
}
+
STATIC void
S_find_and_forget_pmops(pTHX_ OP *o)
{
+ OP* top_op = o;
+
PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
- if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
- while (kid) {
- switch (kid->op_type) {
- case OP_SUBST:
- case OP_SPLIT:
- case OP_MATCH:
- case OP_QR:
- forget_pmop((PMOP*)kid);
- }
- find_and_forget_pmops(kid);
- kid = OpSIBLING(kid);
- }
+ while (1) {
+ switch (o->op_type) {
+ case OP_SUBST:
+ case OP_SPLIT:
+ case OP_MATCH:
+ case OP_QR:
+ forget_pmop((PMOP*)o);
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ o = cUNOPo->op_first;
+ continue;
+ }
+
+ while (1) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ o = o->op_sibparent; /* process next sibling */
+ break;
+ }
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
}
}
+
/*
=for apidoc op_null
=cut
*/
+
OP *
Perl_op_linklist(pTHX_ OP *o)
{
- OP *first;
+
+ OP **prevp;
+ OP *kid;
+ OP * top_op = o;
PERL_ARGS_ASSERT_OP_LINKLIST;
- if (o->op_next)
- return o->op_next;
+ while (1) {
+ /* Descend down the tree looking for any unprocessed subtrees to
+ * do first */
+ if (!o->op_next) {
+ if (o->op_flags & OPf_KIDS) {
+ o = cUNOPo->op_first;
+ continue;
+ }
+ o->op_next = o; /* leaf node; link to self initially */
+ }
+
+ /* if we're at the top level, there either weren't any children
+ * to process, or we've worked our way back to the top. */
+ if (o == top_op)
+ return o->op_next;
- /* establish postfix order */
- first = cUNOPo->op_first;
- if (first) {
- OP *kid;
- o->op_next = LINKLIST(first);
- kid = first;
- for (;;) {
- OP *sibl = OpSIBLING(kid);
- if (sibl) {
- kid->op_next = LINKLIST(sibl);
- kid = sibl;
- } else {
- kid->op_next = o;
- break;
- }
- }
- }
- else
- o->op_next = o;
+ /* o is now processed. Next, process any sibling subtrees */
- return o->op_next;
+ if (OpHAS_SIBLING(o)) {
+ o = OpSIBLING(o);
+ continue;
+ }
+
+ /* Done all the subtrees at this level. Go back up a level and
+ * link the parent in with all its (processed) children.
+ */
+
+ o = o->op_sibparent;
+ assert(!o->op_next);
+ prevp = &(o->op_next);
+ kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
+ while (kid) {
+ *prevp = kid->op_next;
+ prevp = &(kid->op_next);
+ kid = OpSIBLING(kid);
+ }
+ *prevp = o;
+ }
}
+
static OP *
S_scalarkids(pTHX_ OP *o)
{
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)
{
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)
{
&& (SvPOK(sv) || SvIOK(sv))
&& (!SvGMAGICAL(sv))
) {
+ if (argop->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(argop);
argp++->p = sv;
utf8 |= cBOOL(SvUTF8(sv));
nconst++;
sv_utf8_upgrade_nomg(sv);
argp->p = SvPV_nomg(sv, argp->len);
total_len += argp->len;
-
+
/* see if any strings would grow if converted to utf8 */
if (!utf8) {
variant += variant_under_utf8_count((U8 *) argp->p,
lastkidop = pmop;
}
- /* Optimise
+ /* Optimise
* target = A.B.C...
* target .= A.B.C...
*/
} while (( o = traverse_op_tree(top, o)) != NULL);
}
-/*
-=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
-would do the modifying, although C<local()> is represented by C<OP_NULL>,
-because it has no op type of its own (it is signalled by a flag on
-the lvalue op).
-
-This function detects things that can't be modified, such as C<$x+1>, and
-generates errors for them. For example, C<$x+1 = 2> would cause it to be
-called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
-
-It also flags things that need to behave specially in an lvalue context,
-such as C<$$x = 5> which might have to vivify a reference in C<$x>.
-
-=cut
-*/
-
static void
S_mark_padname_lvalue(pTHX_ PADNAME *pn)
{
return 0;
}
+
+/* apply lvalue reference (aliasing) context to the optree o.
+ * E.g. in
+ * \($x,$y) = (...)
+ * o would be the list ($x,$y) and type would be OP_AASSIGN.
+ * It may descend and apply this to children too, for example in
+ * \( $cond ? $x, $y) = (...)
+ */
+
static void
S_lvref(pTHX_ OP *o, I32 type)
{
dVAR;
OP *kid;
- switch (o->op_type) {
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid;
- kid = OpSIBLING(kid))
- S_lvref(aTHX_ kid, type);
- /* FALLTHROUGH */
- case OP_PUSHMARK:
- return;
- case OP_RV2AV:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- if (o->op_flags & OPf_PARENS) {
- if (o->op_private & OPpLVAL_INTRO) {
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "localized parenthesized array in list assignment"));
- return;
- }
- slurpy:
- OpTYPE_set(o, OP_LVAVREF);
- o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
- o->op_flags |= OPf_MOD|OPf_REF;
- return;
- }
- o->op_private |= OPpLVREF_AV;
- goto checkgv;
- case OP_RV2CV:
- kid = cUNOPo->op_first;
- if (kid->op_type == OP_NULL)
- kid = cUNOPx(OpSIBLING(kUNOP->op_first))
- ->op_first;
- o->op_private = OPpLVREF_CV;
- if (kid->op_type == OP_GV)
- o->op_flags |= OPf_STACKED;
- else if (kid->op_type == OP_PADCV) {
- o->op_targ = kid->op_targ;
- kid->op_targ = 0;
- op_free(cUNOPo->op_first);
- cUNOPo->op_first = NULL;
- o->op_flags &=~ OPf_KIDS;
- }
- else goto badref;
- break;
- case OP_RV2HV:
- if (o->op_flags & OPf_PARENS) {
- parenhash:
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "parenthesized hash in list assignment"));
- return;
- }
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_RV2SV:
- checkgv:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- break;
- case OP_PADHV:
- if (o->op_flags & OPf_PARENS) goto parenhash;
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_PADSV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- break;
- case OP_PADAV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- if (o->op_flags & OPf_PARENS) goto slurpy;
- o->op_private |= OPpLVREF_AV;
- break;
- case OP_AELEM:
- case OP_HELEM:
- o->op_private |= OPpLVREF_ELEM;
- o->op_flags |= OPf_STACKED;
- break;
- case OP_ASLICE:
- case OP_HSLICE:
- OpTYPE_set(o, OP_LVREFSLICE);
- o->op_private &= OPpLVAL_INTRO;
- return;
- case OP_NULL:
- if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
- goto badref;
- else if (!(o->op_flags & OPf_KIDS))
- return;
- if (o->op_targ != OP_LIST) {
- S_lvref(aTHX_ cBINOPo->op_first, type);
- return;
- }
- /* FALLTHROUGH */
- case OP_LIST:
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
- assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
- S_lvref(aTHX_ kid, type);
- }
- return;
- case OP_STUB:
- if (o->op_flags & OPf_PARENS)
- return;
- /* FALLTHROUGH */
- default:
- badref:
- /* diag_listed_as: Can't modify reference to %s in %s assignment */
- yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
- o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
- ? "do block"
- : OP_DESC(o),
- PL_op_desc[type]));
- return;
- }
- OpTYPE_set(o, OP_LVREF);
- o->op_private &=
- OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
- if (type == OP_ENTERLOOP)
- o->op_private |= OPpLVREF_ITER;
+ OP * top_op = o;
+
+ while (1) {
+ switch (o->op_type) {
+ case OP_COND_EXPR:
+ o = OpSIBLING(cUNOPo->op_first);
+ continue;
+
+ case OP_PUSHMARK:
+ goto do_next;
+
+ case OP_RV2AV:
+ if (cUNOPo->op_first->op_type != OP_GV) goto badref;
+ o->op_flags |= OPf_STACKED;
+ if (o->op_flags & OPf_PARENS) {
+ if (o->op_private & OPpLVAL_INTRO) {
+ yyerror(Perl_form(aTHX_ "Can't modify reference to "
+ "localized parenthesized array in list assignment"));
+ goto do_next;
+ }
+ slurpy:
+ OpTYPE_set(o, OP_LVAVREF);
+ o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
+ o->op_flags |= OPf_MOD|OPf_REF;
+ goto do_next;
+ }
+ o->op_private |= OPpLVREF_AV;
+ goto checkgv;
+
+ case OP_RV2CV:
+ kid = cUNOPo->op_first;
+ if (kid->op_type == OP_NULL)
+ kid = cUNOPx(OpSIBLING(kUNOP->op_first))
+ ->op_first;
+ o->op_private = OPpLVREF_CV;
+ if (kid->op_type == OP_GV)
+ o->op_flags |= OPf_STACKED;
+ else if (kid->op_type == OP_PADCV) {
+ o->op_targ = kid->op_targ;
+ kid->op_targ = 0;
+ op_free(cUNOPo->op_first);
+ cUNOPo->op_first = NULL;
+ o->op_flags &=~ OPf_KIDS;
+ }
+ else goto badref;
+ break;
+
+ case OP_RV2HV:
+ if (o->op_flags & OPf_PARENS) {
+ parenhash:
+ yyerror(Perl_form(aTHX_ "Can't modify reference to "
+ "parenthesized hash in list assignment"));
+ goto do_next;
+ }
+ o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
+ case OP_RV2SV:
+ checkgv:
+ if (cUNOPo->op_first->op_type != OP_GV) goto badref;
+ o->op_flags |= OPf_STACKED;
+ break;
+
+ case OP_PADHV:
+ if (o->op_flags & OPf_PARENS) goto parenhash;
+ o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
+ case OP_PADSV:
+ PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
+ break;
+
+ case OP_PADAV:
+ PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
+ if (o->op_flags & OPf_PARENS) goto slurpy;
+ o->op_private |= OPpLVREF_AV;
+ break;
+
+ case OP_AELEM:
+ case OP_HELEM:
+ o->op_private |= OPpLVREF_ELEM;
+ o->op_flags |= OPf_STACKED;
+ break;
+
+ case OP_ASLICE:
+ case OP_HSLICE:
+ OpTYPE_set(o, OP_LVREFSLICE);
+ o->op_private &= OPpLVAL_INTRO;
+ goto do_next;
+
+ case OP_NULL:
+ if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
+ goto badref;
+ else if (!(o->op_flags & OPf_KIDS))
+ goto do_next;
+
+ /* the code formerly only recursed into the first child of
+ * a non ex-list OP_NULL. if we ever encounter such a null op with
+ * more than one child, need to decide whether its ok to process
+ * *all* its kids or not */
+ assert(o->op_targ == OP_LIST
+ || !(OpHAS_SIBLING(cBINOPo->op_first)));
+ /* FALLTHROUGH */
+ case OP_LIST:
+ o = cLISTOPo->op_first;
+ continue;
+
+ case OP_STUB:
+ if (o->op_flags & OPf_PARENS)
+ goto do_next;
+ /* FALLTHROUGH */
+ default:
+ badref:
+ /* diag_listed_as: Can't modify reference to %s in %s assignment */
+ yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
+ o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
+ ? "do block"
+ : OP_DESC(o),
+ PL_op_desc[type]));
+ goto do_next;
+ }
+
+ OpTYPE_set(o, OP_LVREF);
+ o->op_private &=
+ OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
+ if (type == OP_ENTERLOOP)
+ o->op_private |= OPpLVREF_ITER;
+
+ do_next:
+ while (1) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ o = o->op_sibparent;
+ break;
+ }
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
+ } /* while */
}
+
PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)
{
|| type == OP_REFGEN || type == OP_LEAVESUBLV;
}
+
+/*
+=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
+would do the modifying, although C<local()> is represented by C<OP_NULL>,
+because it has no op type of its own (it is signalled by a flag on
+the lvalue op).
+
+This function detects things that can't be modified, such as C<$x+1>, and
+generates errors for them. For example, C<$x+1 = 2> would cause it to be
+called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
+
+It also flags things that need to behave specially in an lvalue context,
+such as C<$$x = 5> which might have to vivify a reference in C<$x>.
+
+=cut
+
+Perl_op_lvalue_flags() is a non-API lower-level interface to
+op_lvalue(). The flags param has these bits:
+ OP_LVALUE_NO_CROAK: return rather than croaking on error
+
+*/
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
- OP *kid;
- /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
- int localize = -1;
+ OP *top_op = o;
if (!o || (PL_parser && PL_parser->error_count))
return o;
+ while (1) {
+ OP *kid;
+ /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
+ int localize = -1;
+ OP *next_kid = NULL;
+
if ((o->op_private & OPpTARGET_MY)
&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
{
- return o;
+ goto do_next;
}
- assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+ /* elements of a list might be in void context because the list is
+ in scalar context or because they are attribute sub calls */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
+ goto do_next;
if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
switch (o->op_type) {
case OP_UNDEF:
PL_modcount++;
- return o;
+ goto do_next;
+
case OP_STUB:
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)) {
"subroutine call of &%" SVf " in %s",
SVfARG(namesv), PL_op_desc[type]),
SvUTF8(namesv));
- return o;
+ goto do_next;
}
}
/* FALLTHROUGH */
? "do block"
: OP_DESC(o)),
type ? PL_op_desc[type] : "local"));
- return o;
+ goto do_next;
case OP_PREINC:
case OP_PREDEC:
goto nomod;
else {
const I32 mods = PL_modcount;
+ /* we recurse rather than iterate here because we need to
+ * calculate and use the delta applied to PL_modcount by the
+ * first child. So in something like
+ * ($x, ($y) x 3) = split;
+ * split knows that 4 elements are wanted
+ */
modkids(cBINOPo->op_first, type);
if (type != OP_AASSIGN)
goto nomod;
case OP_COND_EXPR:
localize = 1;
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- op_lvalue(kid, type);
+ next_kid = OpSIBLING(cUNOPo->op_first);
break;
case OP_RV2AV:
/* Treat \(@foo) like ordinary list, but still mark it as modi-
fiable since some contexts need to know. */
o->op_flags |= OPf_MOD;
- return o;
+ goto do_next;
}
/* FALLTHROUGH */
case OP_RV2GV:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
+
case OP_KVHSLICE:
case OP_KVASLICE:
case OP_AKEYS:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
+
case OP_AVHVSWITCH:
if (type == OP_LEAVESUBLV
&& (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
+
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
PL_modcount++;
break;
+
case OP_RV2SV:
ref(cUNOPo->op_first, o->op_type);
localize = 1;
/* Treat \(@foo) like ordinary list, but still mark it as modi-
fiable since some contexts need to know. */
o->op_flags |= OPf_MOD;
- return o;
+ goto do_next;
}
if (scalar_mod_type(o, type))
goto nomod;
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
+ /* we recurse rather than iterate here because the child
+ * needs to be processed with a different 'type' parameter */
+
/* substr and vec */
/* If this op is in merely potential (non-fatal) modifiable
context, then apply OP_ENTERSUB context to
case OP_LINESEQ:
localize = 0;
if (o->op_flags & OPf_KIDS)
- op_lvalue(cLISTOPo->op_last, type);
+ next_kid = cLISTOPo->op_last;
break;
case OP_NULL:
/* this should trigger a "Can't modify transliteration" err */
op_lvalue(sib, type);
}
- op_lvalue(cBINOPo->op_first, type);
+ next_kid = cBINOPo->op_first;
+ /* we assume OP_NULLs which aren't ex-list have no more than 2
+ * children. If this assumption is wrong, increase the scan
+ * limit below */
+ assert( !OpHAS_SIBLING(next_kid)
+ || !OpHAS_SIBLING(OpSIBLING(next_kid)));
break;
}
/* FALLTHROUGH */
case OP_LIST:
localize = 0;
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(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 )
- op_lvalue(kid, type);
+ next_kid = cLISTOPo->op_first;
break;
case OP_COREARGS:
- return o;
+ goto do_next;
case OP_AND:
case OP_OR:
if (type == OP_LEAVESUBLV
|| !S_vivifies(cLOGOPo->op_first->op_type))
- op_lvalue(cLOGOPo->op_first, type);
- if (type == OP_LEAVESUBLV
+ next_kid = cLOGOPo->op_first;
+ else if (type == OP_LEAVESUBLV
|| !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
- op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
+ next_kid = OpSIBLING(cLOGOPo->op_first);
goto nomod;
case OP_SREFGEN:
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
"Declaring references is experimental");
- op_lvalue(cUNOPo->op_first, OP_NULL);
- return o;
+ next_kid = cUNOPo->op_first;
+ goto do_next;
}
if (type != OP_AASSIGN && type != OP_SASSIGN
&& type != OP_ENTERLOOP)
if (o->op_type == OP_REFGEN)
op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
op_null(o);
- return o;
+ goto do_next;
case OP_SPLIT:
if ((o->op_private & OPpSPLIT_ASSIGN)) {
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
- return o;
+ goto do_next;
if (type != OP_LEAVESUBLV)
o->op_flags |= OPf_MOD;
else if (type != OP_GREPSTART && type != OP_ENTERSUB
&& type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
- return o;
+
+ 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;
+ if (!OpHAS_SIBLING(next_kid)) {
+ /* a few node types don't recurse into their second child */
+ OP *parent = next_kid->op_sibparent;
+ I32 ptype = parent->op_type;
+ if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
+ || ( (ptype == OP_AND || ptype == OP_OR)
+ && (type != OP_LEAVESUBLV
+ && S_vivifies(next_kid->op_type))
+ )
+ ) {
+ /*try parent's next sibling */
+ o = parent;
+ next_kid = NULL;
+ }
+ }
+ }
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
+
+ }
+ o = next_kid;
+
+ } /* while */
+
}
+
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
return o;
}
+
+/* Apply reference (autovivification) context to the subtree at o.
+ * For example in
+ * push @{expression}, ....;
+ * o will be the head of 'expression' and type will be OP_RV2AV.
+ * It marks the op o (or a suitable child) as autovivifying, e.g. by
+ * setting OPf_MOD.
+ * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
+ * set_op_ref is true.
+ *
+ * Also calls scalar(o).
+ */
+
OP *
Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
dVAR;
- OP *kid;
+ OP * top_op = o;
PERL_ARGS_ASSERT_DOREF;
if (PL_parser && PL_parser->error_count)
return o;
- switch (o->op_type) {
- case OP_ENTERSUB:
- if ((type == OP_EXISTS || type == OP_DEFINED) &&
- !(o->op_flags & OPf_STACKED)) {
- OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
- assert(cUNOPo->op_first->op_type == OP_NULL);
- op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
- o->op_flags |= OPf_SPECIAL;
- }
- else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
+ while (1) {
+ switch (o->op_type) {
+ case OP_ENTERSUB:
+ if ((type == OP_EXISTS || type == OP_DEFINED) &&
+ !(o->op_flags & OPf_STACKED)) {
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ /* disable pushmark */
+ op_null(((LISTOP*)cUNOPo->op_first)->op_first);
+ o->op_flags |= OPf_SPECIAL;
+ }
+ else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+
+ break;
+
+ case OP_COND_EXPR:
+ o = OpSIBLING(cUNOPo->op_first);
+ continue;
+
+ case OP_RV2SV:
+ if (type == OP_DEFINED)
+ o->op_flags |= OPf_SPECIAL; /* don't create GV */
+ /* FALLTHROUGH */
+ case OP_PADSV:
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+ if (o->op_flags & OPf_KIDS) {
+ type = o->op_type;
+ o = cUNOPo->op_first;
+ continue;
+ }
+ break;
- break;
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
+ /* FALLTHROUGH */
+ case OP_RV2GV:
+ if (type == OP_DEFINED)
+ o->op_flags |= OPf_SPECIAL; /* don't create GV */
+ type = o->op_type;
+ o = cUNOPo->op_first;
+ continue;
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(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);
- /* FALLTHROUGH */
- case OP_PADSV:
- if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
- break;
+ case OP_PADAV:
+ case OP_PADHV:
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
+ break;
- case OP_RV2AV:
- case OP_RV2HV:
- if (set_op_ref)
- o->op_flags |= OPf_REF;
- /* FALLTHROUGH */
- case OP_RV2GV:
- if (type == OP_DEFINED)
- o->op_flags |= OPf_SPECIAL; /* don't create GV */
- doref(cUNOPo->op_first, o->op_type, set_op_ref);
- break;
+ case OP_SCALAR:
+ case OP_NULL:
+ if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
+ break;
+ o = cBINOPo->op_first;
+ continue;
- case OP_PADAV:
- case OP_PADHV:
- if (set_op_ref)
- o->op_flags |= OPf_REF;
- break;
+ case OP_AELEM:
+ case OP_HELEM:
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+ type = o->op_type;
+ o = cBINOPo->op_first;
+ continue;;
- case OP_SCALAR:
- case OP_NULL:
- if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
- break;
- doref(cBINOPo->op_first, type, set_op_ref);
- break;
- case OP_AELEM:
- case OP_HELEM:
- doref(cBINOPo->op_first, o->op_type, set_op_ref);
- if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
- break;
+ case OP_SCOPE:
+ case OP_LEAVE:
+ set_op_ref = FALSE;
+ /* FALLTHROUGH */
+ case OP_ENTER:
+ case OP_LIST:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ o = cLISTOPo->op_last;
+ continue;
- case OP_SCOPE:
- case OP_LEAVE:
- set_op_ref = FALSE;
- /* FALLTHROUGH */
- case OP_ENTER:
- case OP_LIST:
- if (!(o->op_flags & OPf_KIDS))
- break;
- doref(cLISTOPo->op_last, type, set_op_ref);
- break;
- default:
- break;
- }
- return scalar(o);
+ default:
+ break;
+ } /* switch */
+ while (1) {
+ if (o == top_op)
+ return scalar(top_op); /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ o = o->op_sibparent;
+ /* Normally skip all siblings and go straight to the parent;
+ * the only op that requires two children to be processed
+ * is OP_COND_EXPR */
+ if (!OpHAS_SIBLING(o)
+ && o->op_sibparent->op_type == OP_COND_EXPR)
+ break;
+ continue;
+ }
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
+ } /* while */
}
+
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
/* The listop in rops might have a pushmark at the beginning,
which will mess up list assignment. */
LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
- if (rops->op_type == OP_LIST &&
+ if (rops->op_type == OP_LIST &&
lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
{
OP * const pushmark = lrops->op_first;
dVAR;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
- o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
+ o = op_prepend_elem(OP_LINESEQ,
+ newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
OpTYPE_set(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
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;
}
/*
while (t < tend) {
cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
- /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
- if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
+ /* the toker converts X-Y into (X, RANGE_INDICATOR, Y) */
+ if (t < tend && *t == RANGE_INDICATOR) {
t++;
cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
/* Create a utf8 string containing the complement of the
* codepoint ranges. For example if cp[] contains [A,B], [C,D],
* then transv will contain the equivalent of:
- * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
- * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
- * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
- * A range of a single char skips the ILLEGAL_UTF8_BYTE and
+ * join '', map chr, 0, RANGE_INDICATOR, A - 1,
+ * B + 1, RANGE_INDICATOR, C - 1,
+ * D + 1, RANGE_INDICATOR, 0x7fffffff;
+ * A range of a single char skips the RANGE_INDICATOR and
* end cp.
*/
for (j = 0; j < i; j++) {
t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
if (diff > 1) {
- U8 range_mark = ILLEGAL_UTF8_BYTE;
+ U8 range_mark = RANGE_INDICATOR;
t = uvchr_to_utf8(tmpbuf, val - 1);
sv_catpvn(transv, (char *)&range_mark, 1);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
{
- U8 range_mark = ILLEGAL_UTF8_BYTE;
+ U8 range_mark = RANGE_INDICATOR;
sv_catpvn(transv, (char *)&range_mark, 1);
}
t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
if (tfirst > tlast) {
tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
- if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
+ if (t < tend && *t == RANGE_INDICATOR) { /* illegal utf8 val indicates range */
t++;
tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
if (r < rend) {
rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
- if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
+ if (r < rend && *r == RANGE_INDICATOR) { /* illegal utf8 val indicates range */
r++;
rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
goto warnins;
}
- /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
- * table. Entries with the value -1 indicate chars not to be
- * translated, while -2 indicates a search char without a
- * corresponding replacement char under /d.
- *
- * Normally, the table has 256 slots. However, in the presence of
- * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
- * added, and if there are enough replacement chars to start pairing
- * with the \x{100},... search chars, then a larger (> 256) table
- * is allocated.
- *
- * In addition, regardless of whether under /c, an extra slot at the
- * end is used to store the final repeating char, or -3 under an empty
- * replacement list, or -2 under /d; which makes the runtime code
- * easier.
- *
- * The toker will have already expanded char ranges in t and r.
- */
+ /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
+ * table. Entries with the value TR_UNMAPPED indicate chars not to be
+ * translated, while TR_DELETE indicates a search char without a
+ * corresponding replacement char under /d.
+ *
+ * Normally, the table has 256 slots. However, in the presence of
+ * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
+ * added, and if there are enough replacement chars to start pairing
+ * with the \x{100},... search chars, then a larger (> 256) table
+ * is allocated.
+ *
+ * In addition, regardless of whether under /c, an extra slot at the
+ * end is used to store the final repeating char, or TR_R_EMPTY under an
+ * empty replacement list, or TR_DELETE under /d; which makes the
+ * runtime code easier.
+ *
+ * The toker will have already expanded char ranges in t and r.
+ */
- /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
- * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
- * The OPtrans_map struct already contains one slot; hence the -1.
- */
- struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
- tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
- tbl->size = 256;
- cPVOPo->op_pv = (char*)tbl;
+ /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
+ * plus final slot for repeat/TR_DELETE/TR_R_EMPTY. Later we realloc if
+ * excess > * 0. The OPtrans_map struct already contains one slot;
+ * hence the -1.
+ */
+ struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
+ tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
+ tbl->size = 256;
+ cPVOPo->op_pv = (char*)tbl;
- if (complement) {
- Size_t excess;
+ if (complement) {
+ Size_t excess;
- /* in this branch, j is a count of 'consumed' (i.e. paired off
- * with a search char) replacement chars (so j <= rlen always)
- */
- for (i = 0; i < tlen; i++)
- tbl->map[t[i]] = -1;
-
- for (i = 0, j = 0; i < 256; i++) {
- if (!tbl->map[i]) {
- if (j == rlen) {
- if (del)
- tbl->map[i] = -2;
- else if (rlen)
- tbl->map[i] = r[j-1];
- else
- tbl->map[i] = (short)i;
- }
- else {
- tbl->map[i] = r[j++];
- }
- if ( tbl->map[i] >= 0
- && UVCHR_IS_INVARIANT((UV)i)
- && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
- )
- grows = TRUE;
- }
- }
+ /* in this branch, j is a count of 'consumed' (i.e. paired off
+ * with a search char) replacement chars (so j <= rlen always)
+ */
+ for (i = 0; i < tlen; i++)
+ tbl->map[t[i]] = (short) TR_UNMAPPED;
+
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl->map[i]) {
+ if (j == rlen) {
+ if (del)
+ tbl->map[i] = (short) TR_DELETE;
+ else if (rlen)
+ tbl->map[i] = r[j-1];
+ else
+ tbl->map[i] = (short)i;
+ }
+ else {
+ tbl->map[i] = r[j++];
+ }
+ if ( tbl->map[i] >= 0
+ && UVCHR_IS_INVARIANT((UV)i)
+ && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
+ )
+ grows = TRUE;
+ }
+ }
- ASSUME(j <= rlen);
- excess = rlen - j;
+ ASSUME(j <= rlen);
+ excess = rlen - j;
- if (excess) {
- /* More replacement chars than search chars:
- * store excess replacement chars at end of main table.
- */
+ if (excess) {
+ /* More replacement chars than search chars:
+ * store excess replacement chars at end of main table.
+ */
- struct_size += excess;
- tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
- struct_size + excess * sizeof(short));
- tbl->size += excess;
- cPVOPo->op_pv = (char*)tbl;
+ struct_size += excess;
+ tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
+ struct_size + excess * sizeof(short));
+ tbl->size += excess;
+ cPVOPo->op_pv = (char*)tbl;
+
+ for (i = 0; i < excess; i++)
+ tbl->map[i + 256] = r[j+i];
+ }
+ else {
+ /* no more replacement chars than search chars */
+ if (!rlen && !del && !squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
- for (i = 0; i < excess; i++)
- tbl->map[i + 256] = r[j+i];
+ tbl->map[tbl->size] = del
+ ? (short) TR_DELETE
+ : rlen
+ ? r[rlen - 1]
+ : (short) TR_R_EMPTY;
}
else {
- /* no more replacement chars than search chars */
- if (!rlen && !del && !squash)
+ if (!rlen && !del) {
+ r = t; rlen = tlen;
+ if (!squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
+ else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
o->op_private |= OPpTRANS_IDENTICAL;
- }
-
- tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
- }
- else {
- if (!rlen && !del) {
- r = t; rlen = tlen;
- if (!squash)
- o->op_private |= OPpTRANS_IDENTICAL;
- }
- else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
- o->op_private |= OPpTRANS_IDENTICAL;
- }
+ }
- for (i = 0; i < 256; i++)
- tbl->map[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
- if (del) {
- if (tbl->map[t[i]] == -1)
- tbl->map[t[i]] = -2;
- continue;
- }
- --j;
- }
- if (tbl->map[t[i]] == -1) {
- if ( UVCHR_IS_INVARIANT(t[i])
- && ! UVCHR_IS_INVARIANT(r[j]))
- grows = TRUE;
- tbl->map[t[i]] = r[j];
- }
- }
- tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
- }
+ for (i = 0; i < 256; i++)
+ tbl->map[i] = (short) TR_UNMAPPED;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (del) {
+ if (tbl->map[t[i]] == (short) TR_UNMAPPED)
+ tbl->map[t[i]] = (short) TR_DELETE;
+ continue;
+ }
+ --j;
+ }
+ if (tbl->map[t[i]] == (short) TR_UNMAPPED) {
+ if ( UVCHR_IS_INVARIANT(t[i])
+ && ! UVCHR_IS_INVARIANT(r[j]))
+ grows = TRUE;
+ tbl->map[t[i]] = r[j];
+ }
+ }
+ tbl->map[tbl->size] = del
+ ? (short) TR_UNMAPPED
+ : rlen
+ ? (short) TR_UNMAPPED
+ : (short) TR_R_EMPTY;
+ }
/* both non-utf8 and utf8 code paths end up here */
warnins:
if(del && rlen == tlen) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
}
*
* Flags currently has 2 bits of meaning:
* 1: isreg indicates that the pattern is part of a regex construct, eg
- * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
- * split "pattern", which aren't. In the former case, expr will be a list
- * if the pattern contains more than one term (eg /a$b/).
+ * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
+ * split "pattern", which aren't. In the former case, expr will be a list
+ * if the pattern contains more than one term (eg /a$b/).
* 2: The pattern is for a split.
*
* When the pattern has been compiled within a new anon CV (for
* qr/(?{...})/ ), then floor indicates the savestack level just before
* the new sub was created
+ *
+ * tr/// is also handled.
*/
OP *
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;
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 my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
loop->op_private = (U8)iterpflags;
+
+ /* upgrade loop from a LISTOP to a LOOPOP;
+ * keep it in-place if there's space */
if (loop->op_slabbed
- && DIFF(loop, OpSLOT(loop)->opslot_next)
- < SIZE_TO_PSIZE(sizeof(LOOP)))
+ && OpSLOT(loop)->opslot_size
+ < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
{
+ /* no space; allocate new op */
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
}
else if (!loop->op_slabbed)
{
+ /* loop was malloc()ed */
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
OpLASTSIB_set(loop->op_last, (OP*)loop);
}
SvPV_nolen_const(((SVOP*)label)->op_sv)));
}
}
-
+
/* If we have already created an op, we do not need the label. */
if (o)
op_free(label);
return o;
}
-/* Does this look like a boolean operation? For these purposes
+
+/* For the purposes of 'when(implied_smartmatch)'
+ * versus 'when(boolean_expression)',
+ * does this look like a boolean operation? For these purposes
a boolean operation is:
- a subroutine call [*]
- a logical connective
- a filetest operator, with the exception of -s -M -A -C
- defined(), exists() or eof()
- /$re/ or $foo =~ /$re/
-
+
[*] possibly surprising
*/
STATIC bool
case OP_SEQ: case OP_SNE: case OP_SLT:
case OP_SGT: case OP_SLE: case OP_SGE:
-
+
case OP_SMARTMATCH:
-
+
case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
case OP_FTTEXT: case OP_FTBINARY:
-
+
case OP_DEFINED: case OP_EXISTS:
case OP_MATCH: case OP_EOF:
if (o->op_private & OPpTRUEBOOL)
return TRUE;
return FALSE;
-
+
case OP_CONST:
/* Detect comparisons that have been optimized away */
if (cSVOPo->op_sv == &PL_sv_yes
|| cSVOPo->op_sv == &PL_sv_no)
-
+
return TRUE;
else
return FALSE;
}
}
+
/*
=for apidoc newGIVENOP
newDEFSVOP(),
scalar(ref_array_or_hash(cond)));
}
-
+
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
the package sub. So check PadnameOUTER(name) too.
*/
- if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
assert(!CvWEAKOUTSIDE(compcv));
SvREFCNT_dec(CvOUTSIDE(compcv));
CvWEAKOUTSIDE_on(compcv);
cv = NULL;
}
}
-
+
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
{
SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
- OP * anoncode =
+ OP * anoncode =
newSVOP(OP_ANONCODE, 0,
cv);
if (CvANONCONST(cv))
if ((PL_hints & HINT_LOCALIZE_HH) != 0
&& !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* 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))));
+ HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
+ OP *hhop;
+ STOREFEATUREBITSHH(hh);
+ hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
/* append hhop to only child */
op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
PL_op_desc[type]);
if (kid->op_type == OP_CONST
- && ( !SvROK(cSVOPx_sv(kid))
+ && ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
bad_type_pv(numargs, "array", o, kid);
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
OP *second = OpSIBLING(first);
-
+
/* Implicitly take a reference to an array or hash */
/* remove the original two siblings, then add back the
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 && !(first->op_flags & OPf_STACKED)) {
OpTYPE_set(first, OP_QR);
OpTYPE_set(second, OP_QR);
}
}
-
+
return o;
}
HEK *hek;
if (was_readonly) {
- SvREADONLY_off(sv);
- }
+ SvREADONLY_off(sv);
+ }
+
if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
s = SvPVX(sv);
}
return ck_fun(o);
}
-
+
OP *
Perl_ck_join(pTHX_ OP *o)
{
yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
}
-
+
op_free(entersubop);
switch(cvflags >> 16) {
case 'F': return newSVOP(OP_CONST, 0,
parent = aop;
aop = cUNOPx(aop)->op_first;
}
-
+
first = prev = aop;
aop = OpSIBLING(aop);
/* find last sibling */
if (cvflags == (OP_ENTEREVAL | (1<<16)))
flags |= OPpEVAL_BYTES <<8;
-
+
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
-/*
+/*
---------------------------------------------------------
-
+
Common vars in list assignment
There now follows some enums and static functions for detecting
----
First some random observations:
-
+
* If a lexical var is an alias of something else, e.g.
for my $x ($lex, $pkg, $a[0]) {...}
then the act of aliasing will increase the reference count of the SV
-
+
* If a package var is an alias of something else, it may still have a
reference count of 1, depending on how the alias was created, e.g.
in *a = *b, $a may have a refcount of 1 since the GP is shared
with a single GvSV pointer to the SV. So If it's an alias of another
package var, then RC may be 1; if it's an alias of another scalar, e.g.
a lexical var or an array element, then it will have RC > 1.
-
+
* There are many ways to create a package alias; ultimately, XS code
may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
run-time tracing mechanisms are unlikely to be able to catch all cases.
-
+
* When the LHS is all my declarations, the same vars can't appear directly
on the RHS, but they can indirectly via closures, aliasing and lvalue
subs. But those techniques all involve an increase in the lexical
scalar's ref count.
-
+
* When the LHS is all lexical vars (but not necessarily my declarations),
it is possible for the same lexicals to appear directly on the RHS, and
without an increased ref count, since the stack isn't refcounted.
This case can be detected at compile time by scanning for common lex
vars with PL_generation.
-
+
* lvalue subs defeat common var detection, but they do at least
return vars with a temporary ref count increment. Also, you can't
tell at compile time whether a sub call is lvalue.
-
-
+
+
So...
-
+
A: There are a few circumstances where there definitely can't be any
commonality:
-
+
LHS empty: () = (...);
RHS empty: (....) = ();
RHS contains only constants or other 'can't possibly be shared'
RHS contains a single element with no aggregate on LHS: e.g.
($a,$b,$c) = ($x); again, once $a has been modified, its value
won't be used again.
-
+
B: If LHS are all 'my' lexical var declarations (or safe ops, which
we can ignore):
-
+
my ($a, $b, @c) = ...;
-
+
Due to closure and goto tricks, these vars may already have content.
For the same reason, an element on the RHS may be a lexical or package
alias of one of the vars on the left, or share common elements, for
example:
-
+
my ($x,$y) = f(); # $x and $y on both sides
sub f : lvalue { ($x,$y) = (1,2); $y, $x }
-
+
and
-
+
my $ra = f();
my @a = @$ra; # elements of @a on both sides
sub f { @a = 1..4; \@a }
-
-
+
+
First, just consider scalar vars on LHS:
-
+
RHS is safe only if (A), or in addition,
* contains only lexical *scalar* vars, where neither side's
- lexicals have been flagged as aliases
-
+ lexicals have been flagged as aliases
+
If RHS is not safe, then it's always legal to check LHS vars for
RC==1, since the only RHS aliases will always be associated
with an RC bump.
-
+
Note that in particular, RHS is not safe if:
-
+
* it contains package scalar vars; e.g.:
-
+
f();
my ($x, $y) = (2, $x_alias);
sub f { $x = 1; *x_alias = \$x; }
-
+
* It contains other general elements, such as flattened or
* spliced or single array or hash elements, e.g.
-
+
f();
- my ($x,$y) = @a; # or $a[0] or @a{@b} etc
-
+ my ($x,$y) = @a; # or $a[0] or @a{@b} etc
+
sub f {
($x, $y) = (1,2);
use feature 'refaliasing';
\($a[0], $a[1]) = \($y,$x);
}
-
+
It doesn't matter if the array/hash is lexical or package.
-
+
* it contains a function call that happens to be an lvalue
sub which returns one or more of the above, e.g.
-
+
f();
my ($x,$y) = f();
-
+
sub f : lvalue {
($x, $y) = (1,2);
*x1 = \$x;
$y, $x1;
}
-
+
(so a sub call on the RHS should be treated the same
as having a package var on the RHS).
-
+
* any other "dangerous" thing, such an op or built-in that
returns one of the above, e.g. pp_preinc
-
-
+
+
If RHS is not safe, what we can do however is at compile time flag
that the LHS are all my declarations, and at run time check whether
all the LHS have RC == 1, and if so skip the full scan.
-
+
Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
-
+
Here the issue is whether there can be elements of @a on the RHS
which will get prematurely freed when @a is cleared prior to
assignment. This is only a problem if the aliasing mechanism
is one which doesn't increase the refcount - only if RC == 1
will the RHS element be prematurely freed.
-
+
Because the array/hash is being INTROed, it or its elements
can't directly appear on the RHS:
-
+
my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
-
+
but can indirectly, e.g.:
-
+
my $r = f();
my (@a) = @$r;
sub f { @a = 1..3; \@a }
-
+
So if the RHS isn't safe as defined by (A), we must always
mortalise and bump the ref count of any remaining RHS elements
when assigning to a non-empty LHS aggregate.
-
+
Lexical scalars on the RHS aren't safe if they've been involved in
aliasing, e.g.
-
+
use feature 'refaliasing';
-
+
f();
\(my $lex) = \$pkg;
my @a = ($lex,3); # equivalent to ($a[0],3)
-
+
sub f {
@a = (1,2);
\$pkg = \$a[0];
}
-
+
Similarly with lexical arrays and hashes on the RHS:
-
+
f();
my @b;
my @a = (@b);
-
+
sub f {
@a = (1,2);
\$b[0] = \$a[1];
\$b[1] = \$a[0];
}
-
-
-
+
+
+
C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
my $a; ($a, my $b) = (....);
-
+
The difference between (B) and (C) is that it is now physically
possible for the LHS vars to appear on the RHS too, where they
are not reference counted; but in this case, the compile-time
PL_generation sweep will detect such common vars.
-
+
So the rules for (C) differ from (B) in that if common vars are
detected, the runtime "test RC==1" optimisation can no longer be used,
and a full mark and sweep is required
-
+
D: As (C), but in addition the LHS may contain package vars.
-
+
Since package vars can be aliased without a corresponding refcount
increase, all bets are off. It's only safe if (A). E.g.
-
+
my ($x, $y) = (1,2);
-
+
for $x_alias ($x) {
($x_alias, $y) = (3, $x); # whoops
}
-
+
Ditto for LHS aggregate package vars.
-
+
E: Any other dangerous ops on LHS, e.g.
(f(), $a[0], @$r) = (...);
-
+
this is similar to (E) in that all bets are off. In addition, it's
impossible to determine at compile time whether the LHS
contains a scalar or an aggregate, e.g.
-
+
sub f : lvalue { @a }
(f()) = 1..3;
'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
set PL_generation on lexical vars; if the latter, we see if
PL_generation matches.
- 'top' indicates whether we're recursing or at the top level.
'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
This fn will increment it by the number seen. It's not intended to
be an accurate count (especially as many ops can push a variable
*/
static int
-S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
+S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
{
+ OP *top_op = o;
+ OP *effective_top_op = o;
+ int all_flags = 0;
+
+ while (1) {
+ bool top = o == effective_top_op;
int flags = 0;
- bool kid_top = FALSE;
+ OP* next_kid = NULL;
/* first, look for a solitary @_ on the RHS */
if ( rhs
&& kid->op_type == OP_GV
&& cGVOPx_gv(kid) == PL_defgv
)
- flags |= AAS_DEFAV;
+ flags = AAS_DEFAV;
}
switch (o->op_type) {
case OP_GVSV:
(*scalars_p)++;
- return AAS_PKG_SCALAR;
+ all_flags |= AAS_PKG_SCALAR;
+ goto do_next;
case OP_PADAV:
case OP_PADHV:
(*scalars_p) += 2;
/* if !top, could be e.g. @a[0,1] */
- if (top && (o->op_flags & OPf_REF))
- return (o->op_private & OPpLVAL_INTRO)
- ? AAS_MY_AGG : AAS_LEX_AGG;
- return AAS_DANGEROUS;
+ all_flags |= (top && (o->op_flags & OPf_REF))
+ ? ((o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG)
+ : AAS_DANGEROUS;
+ goto do_next;
case OP_PADSV:
{
int comm = S_aassign_padcheck(aTHX_ o, rhs)
? AAS_LEX_SCALAR_COMM : 0;
(*scalars_p)++;
- return (o->op_private & OPpLVAL_INTRO)
+ all_flags |= (o->op_private & OPpLVAL_INTRO)
? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
+ goto do_next;
+
}
case OP_RV2AV:
case OP_RV2HV:
(*scalars_p) += 2;
if (cUNOPx(o)->op_first->op_type != OP_GV)
- return AAS_DANGEROUS; /* @{expr}, %{expr} */
+ all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
/* @pkg, %pkg */
/* if !top, could be e.g. @a[0,1] */
- if (top && (o->op_flags & OPf_REF))
- return AAS_PKG_AGG;
- return AAS_DANGEROUS;
+ else if (top && (o->op_flags & OPf_REF))
+ all_flags |= AAS_PKG_AGG;
+ else
+ all_flags |= AAS_DANGEROUS;
+ goto do_next;
case OP_RV2SV:
(*scalars_p)++;
if (cUNOPx(o)->op_first->op_type != OP_GV) {
(*scalars_p) += 2;
- return AAS_DANGEROUS; /* ${expr} */
+ all_flags |= AAS_DANGEROUS; /* ${expr} */
}
- return AAS_PKG_SCALAR; /* $pkg */
+ else
+ all_flags |= AAS_PKG_SCALAR; /* $pkg */
+ goto do_next;
case OP_SPLIT:
if (o->op_private & OPpSPLIT_ASSIGN) {
* ... = @a;
*/
- if (o->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED) {
/* @{expr} = split() - the array expression is tacked
* on as an extra child to split - process kid */
- return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
- top, scalars_p);
+ next_kid = cLISTOPo->op_last;
+ goto do_next;
+ }
/* ... else array is directly attached to split op */
(*scalars_p) += 2;
- if (PL_op->op_private & OPpSPLIT_LEX)
- return (o->op_private & OPpLVAL_INTRO)
- ? AAS_MY_AGG : AAS_LEX_AGG;
- else
- return AAS_PKG_AGG;
+ all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
+ ? ((o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG)
+ : AAS_PKG_AGG;
+ goto do_next;
}
(*scalars_p)++;
/* other args of split can't be returned */
- return AAS_SAFE_SCALAR;
+ all_flags |= AAS_SAFE_SCALAR;
+ goto do_next;
case OP_UNDEF:
/* undef counts as a scalar on the RHS:
/* these are all no-ops; they don't push a potentially common SV
* onto the stack, so they are neither AAS_DANGEROUS nor
* AAS_SAFE_SCALAR */
- return 0;
+ goto do_next;
case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
break;
case OP_NULL:
case OP_LIST:
- /* these do nothing but may have children; but their children
- * should also be treated as top-level */
- kid_top = top;
+ /* these do nothing, but may have children */
break;
default:
&& (o->op_private & OPpTARGET_MY))
{
(*scalars_p)++;
- return S_aassign_padcheck(aTHX_ o, rhs)
- ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
+ all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
+ ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
+ goto do_next;
}
/* if its an unrecognised, non-dangerous op, assume that it
break;
}
- /* XXX this assumes that all other ops are "transparent" - i.e. that
+ all_flags |= flags;
+
+ /* by default, process all kids next
+ * XXX this assumes that all other ops are "transparent" - i.e. that
* they can return some of their children. While this true for e.g.
* sort and grep, it's not true for e.g. map. We really need a
* 'transparent' flag added to regen/opcodes
*/
if (o->op_flags & OPf_KIDS) {
- OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
+ next_kid = cUNOPo->op_first;
+ /* these ops do nothing but may have children; but their
+ * children should also be treated as top-level */
+ if ( o == effective_top_op
+ && (o->op_type == OP_NULL || o->op_type == OP_LIST)
+ )
+ effective_top_op = next_kid;
+ }
+
+
+ /* 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 all_flags; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ next_kid = o->op_sibparent;
+ if (o == effective_top_op)
+ effective_top_op = next_kid;
+ }
+ else
+ if (o == effective_top_op)
+ effective_top_op = o->op_sibparent;
+ o = o->op_sibparent; /* try parent's next sibling */
+
}
- return flags;
+ o = next_kid;
+ } /* while */
+
}
this optimisation if the first NEXTSTATE has a label. */
if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
OP *nextop = o->op_next;
- while (nextop && nextop->op_type == OP_NULL)
- nextop = nextop->op_next;
+ while (nextop) {
+ switch (nextop->op_type) {
+ case OP_NULL:
+ case OP_SCALAR:
+ case OP_LINESEQ:
+ case OP_SCOPE:
+ nextop = nextop->op_next;
+ continue;
+ }
+ break;
+ }
if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
op_null(o);
}
break;
-
+
case OP_NOT:
break;
DEFER(cLOGOP->op_other);
o->op_opt = 1;
break;
-
+
case OP_GREPWHILE:
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
iter = enter->op_next;
if (!iter || iter->op_type != OP_ITER)
break;
-
+
expushmark = enter->op_first;
if (!expushmark || expushmark->op_type != OP_NULL
|| expushmark->op_targ != OP_PUSHMARK)
PL_generation++;
/* scan LHS */
lscalars = 0;
- l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
+ l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
/* scan RHS */
rscalars = 0;
- r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
+ r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
lr = (l|r);
break;
case OP_CUSTOM: {
- Perl_cpeep_t cpeep =
+ Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
if (cpeep)
cpeep(aTHX_ o, oldop);
break;
}
-
+
}
/* did we just null the current op? If so, re-process it to handle
* eliding "empty" ops from the chain */
/*
=head1 Custom Operators
-=for apidoc custom_op_xop
+=for apidoc Perl_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
https://perl5.git.perl.org / perl5.git / blobdiff