Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
(UV)flags);
- /* Until we're using the length for real, cross check that we're being
- told the truth. */
- assert(strlen(name) == len);
-
/* complain about "my $<special_var>" etc etc */
if (len &&
!(is_our ||
((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
- /* name[2] is true if strlen(name) > 2 */
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
- ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
+ ? (PL_curstash && !memEQs(name,len,"$_")
+ ? PL_curstash
+ : PL_defstash)
: NULL
)
);
/* an op should only ever acquire op_private flags that we know about.
* If this fails, you may need to fix something in regen/op_private */
- assert(!(o->op_private & ~PL_op_private_valid[type]));
+ if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
case OP_SPLIT:
kid = cLISTOPo->op_first;
if (kid && kid->op_type == OP_PUSHRE
+ && !kid->op_targ
+ && !(o->op_flags & OPf_STACKED)
#ifdef USE_ITHREADS
&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
#else
refgen = (UNOP *)((BINOP *)o)->op_first;
- if (!refgen || refgen->op_type != OP_REFGEN)
+ if (!refgen || (refgen->op_type != OP_REFGEN
+ && refgen->op_type != OP_SREFGEN))
break;
exlist = (LISTOP *)refgen->op_first;
|| exlist->op_targ != OP_LIST)
break;
- if (exlist->op_first->op_type != OP_PUSHMARK)
+ if (exlist->op_first->op_type != OP_PUSHMARK
+ && exlist->op_first != exlist->op_last)
break;
rv2cv = (UNOP*)exlist->op_last;
return 0;
}
+static void
+S_lvref(pTHX_ OP *o, I32 type)
+{
+ OP *kid;
+ switch (o->op_type) {
+ case OP_COND_EXPR:
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid;
+ kid = OP_SIBLING(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) {
+ /* diag_listed_as: Can't modify %s in %s */
+ yyerror(Perl_form(aTHX_ "Can't modify reference to "
+ "localized parenthesized array in list assignment"));
+ return;
+ }
+ slurpy:
+ o->op_type = OP_LVAVREF;
+ o->op_ppaddr = PL_ppaddr[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(kUNOP->op_first->op_sibling)
+ ->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:
+ /* diag_listed_as: Can't modify %s in %s */
+ 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:
+ o->op_type = OP_LVREFSLICE;
+ o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
+ o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
+ 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 = OP_SIBLING(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 %s in %s */
+ 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;
+ }
+ o->op_type = OP_LVREF;
+ o->op_ppaddr = PL_ppaddr[OP_LVREF];
+ o->op_private &=
+ OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
+ if (type == OP_ENTERLOOP)
+ o->op_private |= OPpLVREF_ITER;
+}
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
break;
}
else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO
- |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
+ o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV) {
/* Potential lvalue context: */
o->op_private |= OPpENTERSUB_INARGS;
break;
op_lvalue(kid, type);
break;
- case OP_RETURN:
- if (type != OP_LEAVESUBLV)
- goto nomod;
- break; /* op_lvalue()ing was handled by ck_return() */
-
case OP_COREARGS:
return o;
|| !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
goto nomod;
+
+ case OP_SREFGEN:
+ if (type != OP_AASSIGN && type != OP_SASSIGN
+ && type != OP_ENTERLOOP)
+ goto nomod;
+ /* Don’t bother applying lvalue context to the ex-list. */
+ kid = cUNOPx(cUNOPo->op_first)->op_first;
+ assert (!OP_HAS_SIBLING(kid));
+ goto kid_2lvref;
+ case OP_REFGEN:
+ if (type != OP_AASSIGN) goto nomod;
+ kid = cUNOPo->op_first;
+ kid_2lvref:
+ {
+ const U8 ec = PL_parser ? PL_parser->error_count : 0;
+ S_lvref(aTHX_ kid, type);
+ if (!PL_parser || PL_parser->error_count == ec) {
+ if (!FEATURE_LVREF_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental lvalue references not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
+ "Lvalue references are experimental");
+ }
+ }
+ if (o->op_type == OP_REFGEN)
+ op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
+ op_null(o);
+ return o;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
+ bool folded;
SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
if (ret)
goto nope;
+ folded = cBOOL(o->op_folded);
op_free(o);
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
else
{
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
- if (type != OP_STRINGIFY) newop->op_folded = 1;
+ /* OP_STRINGIFY and constant folding are used to implement qq.
+ Here the constant folding is an implementation detail that we
+ want to hide. If the stringify op is itself already marked
+ folded, however, then it is actually a folded join. */
+ if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
}
return newop;
last->op_sibling = (OP*)binop;
#endif
- binop = (BINOP*)CHECKOP(type, binop);
- if (binop->op_next || binop->op_type != (OPCODE)type)
- return (OP*)binop;
-
binop->op_last = OP_SIBLING(binop->op_first);
#ifdef PERL_OP_PARENT
if (binop->op_last)
binop->op_last->op_sibling = (OP*)binop;
#endif
+ binop = (BINOP*)CHECKOP(type, binop);
+ if (binop->op_next || binop->op_type != (OPCODE)type)
+ return (OP*)binop;
+
return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
list(force_list(listval, 1)) );
}
+#define ASSIGN_LIST 1
+#define ASSIGN_REF 2
+
STATIC I32
-S_is_list_assignment(pTHX_ const OP *o)
+S_assignment_type(pTHX_ const OP *o)
{
unsigned type;
U8 flags;
+ U8 ret;
if (!o)
return TRUE;
type = o->op_type;
if (type == OP_COND_EXPR) {
OP * const sib = OP_SIBLING(cLOGOPo->op_first);
- const I32 t = is_list_assignment(sib);
- const I32 f = is_list_assignment(OP_SIBLING(sib));
+ const I32 t = assignment_type(sib);
+ const I32 f = assignment_type(OP_SIBLING(sib));
- if (t && f)
- return TRUE;
- if (t || f)
+ if (t == ASSIGN_LIST && f == ASSIGN_LIST)
+ return ASSIGN_LIST;
+ if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
yyerror("Assignment to both a list and a scalar");
return FALSE;
}
+ if (type == OP_SREFGEN)
+ {
+ OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
+ type = kid->op_type;
+ flags |= kid->op_flags;
+ if (!(flags & OPf_PARENS)
+ && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
+ kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
+ return ASSIGN_REF;
+ ret = ASSIGN_REF;
+ }
+ else ret = 0;
+
if (type == OP_LIST &&
(flags & OPf_WANT) == OPf_WANT_SCALAR &&
o->op_private & OPpLVAL_INTRO)
- return FALSE;
+ return ret;
if (type == OP_LIST || flags & OPf_PARENS ||
type == OP_RV2AV || type == OP_RV2HV ||
type == OP_ASLICE || type == OP_HSLICE ||
- type == OP_KVASLICE || type == OP_KVHSLICE)
+ type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
return TRUE;
if (type == OP_PADAV || type == OP_PADHV)
return TRUE;
if (type == OP_RV2SV)
- return FALSE;
+ return ret;
- return FALSE;
+ return ret;
}
/*
Helper function for newASSIGNOP to detection commonality between the
- lhs and the rhs. Marks all variables with PL_generation. If it
+ lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
+ flags the op and the peephole optimizer calls this helper function
+ if the flag is set.) Marks all variables with PL_generation. If it
returns TRUE the assignment must be able to handle common variables.
+
+ PL_generation sorcery:
+ An assignment like ($a,$b) = ($c,$d) is easier than
+ ($a,$b) = ($c,$a), since there is no need for temporary vars.
+ To detect whether there are common vars, the global var
+ PL_generation is incremented for each assign op we compile.
+ Then, while compiling the assign op, we run through all the
+ variables on both sides of the assignment, setting a spare slot
+ in each of them to PL_generation. If any of them already have
+ that value, we know we've got commonality. Also, if the
+ generation number is already set to PERL_INT_MAX, then
+ the variable is involved in aliasing, so we also have
+ potential commonality in that case. We could use a
+ single bit marker, but then we'd have to make 2 passes, first
+ to clear the flag, then to test and set it. And that
+ wouldn't help with aliasing, either. To find somewhere
+ to store these values, evil chicanery is done with SvUVX().
*/
PERL_STATIC_INLINE bool
S_aassign_common_vars(pTHX_ OP* o)
OP *curop;
for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV) {
+ if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
+ || curop->op_type == OP_AELEMFAST) {
GV *gv = cGVOPx_gv(curop);
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
curop->op_type == OP_PADHV ||
curop->op_type == OP_PADANY)
{
+ padcheck:
if (PAD_COMPNAME_GEN(curop->op_targ)
- == (STRLEN)PL_generation)
+ == (STRLEN)PL_generation
+ || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
return TRUE;
PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
return TRUE;
GvASSIGN_GENERATION_set(gv, PL_generation);
}
+ else if (curop->op_targ)
+ goto padcheck;
}
+ else if (curop->op_type == OP_PADRANGE)
+ /* Ignore padrange; checking its siblings is sufficient. */
+ continue;
else
return TRUE;
}
return FALSE;
}
+/* This variant only handles lexical aliases. It is called when
+ newASSIGNOP decides that we don’t have any common vars, as lexical ali-
+ ases trump that decision. */
+PERL_STATIC_INLINE bool
+S_aassign_common_vars_aliases_only(pTHX_ OP *o)
+{
+ OP *curop;
+ for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
+ if ((curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY)
+ && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
+ return TRUE;
+
+ if (curop->op_type == OP_PUSHRE && curop->op_targ
+ && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
+ return TRUE;
+
+ if (curop->op_flags & OPf_KIDS) {
+ if (S_aassign_common_vars_aliases_only(aTHX_ curop))
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
OP *o;
+ I32 assign_type;
if (optype) {
if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
}
}
- if (is_list_assignment(left)) {
+ if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
static const char no_list_state[] = "Initialization of state variables"
" in list context currently forbidden";
OP *curop;
}
}
- /* PL_generation sorcery:
- * an assignment like ($a,$b) = ($c,$d) is easier than
- * ($a,$b) = ($c,$a), since there is no need for temporary vars.
- * To detect whether there are common vars, the global var
- * PL_generation is incremented for each assign op we compile.
- * Then, while compiling the assign op, we run through all the
- * variables on both sides of the assignment, setting a spare slot
- * in each of them to PL_generation. If any of them already have
- * that value, we know we've got commonality. We could use a
- * single bit marker, but then we'd have to make 2 passes, first
- * to clear the flag, then to test and set it. To find somewhere
- * to store these values, evil chicanery is done with SvUVX().
- */
-
if (maybe_common_vars) {
- PL_generation++;
- if (aassign_common_vars(o))
+ /* The peephole optimizer will do the full check and pos-
+ sibly turn this off. */
o->op_private |= OPpASSIGN_COMMON;
- LINKLIST(o);
}
- if (right && right->op_type == OP_SPLIT) {
+ if (right && right->op_type == OP_SPLIT
+ && !(right->op_flags & OPf_STACKED)) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
- if (left->op_type == OP_RV2AV &&
- !(left->op_private & OPpLVAL_INTRO) &&
- !(o->op_private & OPpASSIGN_COMMON) )
- {
- tmpop = ((UNOP*)left)->op_first;
- if (tmpop->op_type == OP_GV
+ if (
#ifdef USE_ITHREADS
- && !pm->op_pmreplrootu.op_pmtargetoff
+ !pm->op_pmreplrootu.op_pmtargetoff
#else
- && !pm->op_pmreplrootu.op_pmtargetgv
+ !pm->op_pmreplrootu.op_pmtargetgv
#endif
+ && !pm->op_targ
+ ) {
+ if (!(left->op_private & OPpLVAL_INTRO) &&
+ ( (left->op_type == OP_RV2AV &&
+ (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
+ || left->op_type == OP_PADAV )
) {
+ if (tmpop != (OP *)pm) {
#ifdef USE_ITHREADS
- pm->op_pmreplrootu.op_pmtargetoff
+ pm->op_pmreplrootu.op_pmtargetoff
= cPADOPx(tmpop)->op_padix;
- cPADOPx(tmpop)->op_padix = 0; /* steal it */
+ cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplrootu.op_pmtargetgv
+ pm->op_pmreplrootu.op_pmtargetgv
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
- cSVOPx(tmpop)->op_sv = NULL; /* steal it */
+ cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
+ right->op_private |=
+ left->op_private & OPpOUR_INTRO;
+ }
+ else {
+ pm->op_targ = left->op_targ;
+ left->op_targ = 0; /* filch it */
+ }
+ detach_split:
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
/* detach rest of siblings from o subtree,
* and free subtree */
op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
- right->op_next = tmpop->op_next; /* fix starting loc */
op_free(o); /* blow off assign */
right->op_flags &= ~OPf_WANT;
/* "I don't know and I don't care." */
return right;
}
- }
- else {
- if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
- ((LISTOP*)right)->op_last->op_type == OP_CONST)
+ else if (left->op_type == OP_RV2AV
+ || left->op_type == OP_PADAV)
+ {
+ /* Detach the array. */
+#ifdef DEBUGGING
+ OP * const ary =
+#endif
+ op_sibling_splice(cBINOPo->op_last,
+ cUNOPx(cBINOPo->op_last)
+ ->op_first, 1, NULL);
+ assert(ary == left);
+ /* Attach it to the split. */
+ op_sibling_splice(right, cLISTOPx(right)->op_last,
+ 0, left);
+ right->op_flags |= OPf_STACKED;
+ /* Detach split and expunge aassign as above. */
+ goto detach_split;
+ }
+ else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
+ ((LISTOP*)right)->op_last->op_type == OP_CONST)
{
SV ** const svp =
&((SVOP*)((LISTOP*)right)->op_last)->op_sv;
}
return o;
}
+ if (assign_type == ASSIGN_REF)
+ return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
if (!right)
right = newOP(OP_UNDEF, 0);
if (right->op_type == OP_READLINE) {
sv->op_targ = 0;
op_free(sv);
sv = NULL;
+ PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
}
+ else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
+ NOOP;
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
if (padoff) {
newop = OP_SIBLING(kidkid);
if (newop) {
const OPCODE type = newop->op_type;
- if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
- type == OP_PADAV || type == OP_PADHV ||
- type == OP_RV2AV || type == OP_RV2HV)
+ if (OP_HAS_SIBLING(newop))
+ return o;
+ if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS)
+ && (type == OP_RV2AV || type == OP_PADAV
+ || type == OP_RV2HV || type == OP_PADHV
+ || type == OP_RV2CV))
+ NOOP; /* OK (allow srefgen for \@a and \%h) */
+ else if (!(PL_opargs[type] & OA_RETSCALAR))
return o;
}
/* excise first sibling */
OP *const first = newOP(OP_NULL, 0);
OP *const nullop = newCONDOP(0, first, o, other);
OP *const condop = first->op_next;
- /* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(target));
condop->op_type = OP_ONCE;
condop->op_ppaddr = PL_ppaddr[OP_ONCE];
- condop->op_targ = target;
other->op_targ = target;
- /* Because we change the type of the op here, we will skip the
- assignment binop->op_last = OP_SIBLING(binop->op_first); at the
- end of Perl_newBINOP(). So need to do it here. */
- cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
- cBINOPo->op_first->op_lastsib = 0;
- cBINOPo->op_last ->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- cBINOPo->op_last->op_sibling = o;
-#endif
+ /* Store the initializedness of state vars in a separate
+ pad entry. */
+ condop->op_targ =
+ pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(condop->op_targ));
+
return nullop;
}
}
}
OP *
+Perl_ck_refassign(pTHX_ OP *o)
+{
+ OP * const right = cLISTOPo->op_first;
+ OP * const left = OP_SIBLING(right);
+ OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
+ bool stacked = 0;
+
+ PERL_ARGS_ASSERT_CK_REFASSIGN;
+ assert (left);
+ assert (left->op_type == OP_SREFGEN);
+
+ switch (varop->op_type) {
+ case OP_PADAV:
+ o->op_private = OPpLVREF_AV;
+ goto settarg;
+ case OP_PADHV:
+ o->op_private = OPpLVREF_HV;
+ case OP_PADSV:
+ settarg:
+ o->op_targ = varop->op_targ;
+ varop->op_targ = 0;
+ PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
+ break;
+ case OP_RV2AV:
+ o->op_private = OPpLVREF_AV;
+ goto checkgv;
+ case OP_RV2HV:
+ o->op_private = OPpLVREF_HV;
+ case OP_RV2SV:
+ checkgv:
+ if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
+ goto null_and_stack;
+ case OP_RV2CV: {
+ OP * const kid =
+ cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling)
+ ->op_first;
+ o->op_private = OPpLVREF_CV;
+ if (kid->op_type == OP_GV) goto null_and_stack;
+ if (kid->op_type != OP_PADCV) goto bad;
+ o->op_targ = kid->op_targ;
+ kid->op_targ = 0;
+ break;
+ }
+ case OP_AELEM:
+ case OP_HELEM:
+ o->op_private = OPpLVREF_ELEM;
+ null_and_stack:
+ op_null(varop);
+ op_null(left);
+ stacked = TRUE;
+ break;
+ default:
+ bad:
+ /* diag_listed_as: Can't modify %s in %s */
+ yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
+ "assignment",
+ OP_DESC(varop)));
+ return o;
+ }
+ if (!FEATURE_LVREF_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental lvalue references not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
+ "Lvalue references are experimental");
+ o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
+ if (stacked) o->op_flags |= OPf_STACKED;
+ else {
+ o->op_flags &=~ OPf_STACKED;
+ op_sibling_splice(o, right, 1, NULL);
+ op_free(left);
+ }
+ return o;
+}
+
+OP *
Perl_ck_repeat(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_REPEAT;
kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
kids = force_list(kids, 1); /* promote them to a list */
op_sibling_splice(o, NULL, 0, kids); /* and add back */
+ if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL;
}
else
scalar(o);
}
OP *
+Perl_ck_stringify(pTHX_ OP *o)
+{
+ OP * const kid = OP_SIBLING(cUNOPo->op_first);
+ PERL_ARGS_ASSERT_CK_STRINGIFY;
+ if (kid->op_type == OP_JOIN) {
+ assert(!OP_HAS_SIBLING(kid));
+ op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
+ op_free(o);
+ return kid;
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_join(pTHX_ OP *o)
{
- const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
+ OP * const kid = OP_SIBLING(cLISTOPo->op_first);
PERL_ARGS_ASSERT_CK_JOIN;
SVfARG(msg), SVfARG(msg));
}
}
+ if (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
+ || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
+ || (kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
+ && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))
+ {
+ const OP * const bairn = OP_SIBLING(kid); /* the list */
+ if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
+ && PL_opargs[bairn->op_type] & OA_RETSCALAR)
+ {
+ OP * const ret = convert(OP_STRINGIFY, 0,
+ op_sibling_splice(o, kid, 1, NULL));
+ op_free(o);
+ ret->op_folded = 1;
+ return ret;
+ }
+ }
+
return ck_fun(o);
}
case '&':
proto++;
arg++;
- if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
+ if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
+ && o3->op_type != OP_UNDEF)
bad_type_gv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
namegv, 0, o3);
* altering the basic op_first/op_sibling layout. */
kid = kLISTOP->op_first;
assert(
- (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+ (kid->op_type == OP_NULL
+ && ( kid->op_targ == OP_NEXTSTATE
+ || kid->op_targ == OP_DBSTATE ))
|| kid->op_type == OP_STUB
|| kid->op_type == OP_ENTER);
nullop->op_next = kLISTOP->op_next;
}
break;
+ case OP_AASSIGN:
+ /* We do the common-vars check here, rather than in newASSIGNOP
+ (as formerly), so that all lexical vars that get aliased are
+ marked as such before we do the check. */
+ if (o->op_private & OPpASSIGN_COMMON) {
+ /* See the comment before S_aassign_common_vars concerning
+ PL_generation sorcery. */
+ PL_generation++;
+ if (!aassign_common_vars(o))
+ o->op_private &=~ OPpASSIGN_COMMON;
+ }
+ else if (S_aassign_common_vars_aliases_only(aTHX_ o))
+ o->op_private |= OPpASSIGN_COMMON;
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
https://perl5.git.perl.org / perl5.git / blobdiff