#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)); }
}
}
-#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
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
} 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;
+ break;
- 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_COND_EXPR:
+ o = OpSIBLING(cUNOPo->op_first);
+ continue;
- 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_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;
- 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 */
+ type = o->op_type;
+ o = cUNOPo->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_PADAV:
+ case OP_PADHV:
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
+ 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;
- doref(cLISTOPo->op_last, type, set_op_ref);
- break;
- default:
- break;
- }
- return scalar(o);
+ case OP_SCALAR:
+ case OP_NULL:
+ if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
+ break;
+ o = cBINOPo->op_first;
+ continue;
+
+ 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_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;
+
+ 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)
{
/* 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);
}
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
}
}
+
/*
=for apidoc newGIVENOP
/*
=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