#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* Used to avoid recursion through the op tree in scalarvoid() and
+ op_free()
+*/
+
+#define DEFERRED_OP_STEP 100
+#define DEFER_OP(o) \
+ STMT_START { \
+ if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
+ defer_stack_alloc += DEFERRED_OP_STEP; \
+ assert(defer_stack_alloc > 0); \
+ Renew(defer_stack, defer_stack_alloc, OP *); \
+ } \
+ defer_stack[++defer_ix] = o; \
+ } STMT_END
+
+#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
+
/* remove any leading "empty" ops from the op_next chain whose first
* node's address is stored in op_p. Store the updated address of the
* first node in op_p.
{
dVAR;
OPCODE type;
+ SSize_t defer_ix = -1;
+ SSize_t defer_stack_alloc = 0;
+ OP **defer_stack = NULL;
- /* Though ops may be freed twice, freeing the op after its slab is a
- big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
- /* During the forced freeing of ops after compilation failure, kidops
- may be freed before their parents. */
- if (!o || o->op_type == OP_FREED)
- return;
+ do {
- type = o->op_type;
+ /* Though ops may be freed twice, freeing the op after its slab is a
+ big no-no. */
+ assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ /* During the forced freeing of ops after compilation failure, kidops
+ may be freed before their parents. */
+ if (!o || o->op_type == OP_FREED)
+ continue;
- /* 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 */
- if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
- assert(!(o->op_private & ~PL_op_private_valid[type]));
- }
+ type = o->op_type;
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- if (refcnt) {
- /* Need to find and remove any pattern match ops from the list
- we maintain for reset(). */
- find_and_forget_pmops(o);
- return;
- }
- }
- break;
- default:
- break;
- }
- }
+ /* 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 */
+ if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
- /* Call the op_free hook if it has been set. Do it now so that it's called
- * at the right time for refcounted ops, but still before all of the kids
- * are freed. */
- CALL_OPFREEHOOK(o);
+ if (o->op_private & OPpREFCOUNTED) {
+ switch (type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
+ continue;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
- op_free(kid);
- }
- }
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid, *nextkid;
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
+ nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
+ if (!kid || kid->op_type == OP_FREED)
+ /* During the forced freeing of ops after
+ compilation failure, kidops may be freed before
+ their parents. */
+ continue;
+ if (!(kid->op_flags & OPf_KIDS))
+ /* If it has no kids, just free it now */
+ op_free(kid);
+ else
+ DEFER_OP(kid);
+ }
+ }
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
- if (o->op_slabbed)
- Slab_to_rw(OpSLAB(o));
+ if (o->op_slabbed)
+ Slab_to_rw(OpSLAB(o));
- /* COP* is not cleared by op_clear() so that we may track line
- * numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
- cop_free((COP*)o);
- }
+ /* COP* is not cleared by op_clear() so that we may track line
+ * numbers etc even after null() */
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+ cop_free((COP*)o);
+ }
- op_clear(o);
- FreeOp(o);
+ op_clear(o);
+ FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
- if (PL_op == o)
- PL_op = NULL;
+ if (PL_op == o)
+ PL_op = NULL;
#endif
+ } while ( (o = POP_DEFERRED_OP()) );
+
+ Safefree(defer_stack);
}
void
return;
op_clear(o);
o->op_targ = o->op_type;
- o->op_type = OP_NULL;
- o->op_ppaddr = PL_ppaddr[OP_NULL];
+ CHANGE_TYPE(o, OP_NULL);
}
void
LOGOP *
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
+ dVAR;
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = (OPCODE)type;
+ CHANGE_TYPE(logop, type);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
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 (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
+ op_null(cLISTOPx(cUNOPo->op_first)->op_first);
+ o->op_private &=~ OPpREPEAT_DOLIST;
+ }
+ }
break;
case OP_OR:
case OP_AND:
}
OP *
-Perl_scalarvoid(pTHX_ OP *o)
+Perl_scalarvoid(pTHX_ OP *arg)
{
dVAR;
OP *kid;
- SV *useless_sv = NULL;
- const char* useless = NULL;
SV* sv;
U8 want;
+ SSize_t defer_stack_alloc = 0;
+ SSize_t defer_ix = -1;
+ OP **defer_stack = NULL;
+ OP *o = arg;
PERL_ARGS_ASSERT_SCALARVOID;
- if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_DBSTATE
- || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE)))
- PL_curcop = (COP*)o; /* for warning below */
+ do {
+ SV *useless_sv = NULL;
+ const char* useless = NULL;
+
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE)))
+ PL_curcop = (COP*)o; /* for warning below */
+
+ /* assumes no premature commitment */
+ want = o->op_flags & OPf_WANT;
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
+ {
+ continue;
+ }
- /* assumes no premature commitment */
- want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
- {
- return o;
- }
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ /* newASSIGNOP has already applied scalar context, which we
+ leave, as if this op is inside SASSIGN. */
+ continue;
+ }
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return scalar(o); /* As if inside SASSIGN */
- }
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ switch (o->op_type) {
+ default:
+ if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALLTHROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALLTHROUGH */
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_SMARTMATCH:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_KVASLICE:
+ case OP_KVHSLICE:
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ case OP_PROTOTYPE:
+ case OP_RUNCV:
+ func_ops:
+ useless = OP_DESC(o);
+ break;
- switch (o->op_type) {
- default:
- if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
- break;
- /* FALLTHROUGH */
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED)
- break;
- goto func_ops;
- case OP_SUBSTR:
- if (o->op_private == 4)
- break;
- /* FALLTHROUGH */
- case OP_GVSV:
- case OP_WANTARRAY:
- case OP_GV:
- case OP_SMARTMATCH:
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- case OP_PADANY:
- case OP_AV2ARYLEN:
- case OP_REF:
- case OP_REFGEN:
- case OP_SREFGEN:
- case OP_DEFINED:
- case OP_HEX:
- case OP_OCT:
- case OP_LENGTH:
- case OP_VEC:
- case OP_INDEX:
- case OP_RINDEX:
- case OP_SPRINTF:
- case OP_AELEM:
- case OP_AELEMFAST:
- case OP_AELEMFAST_LEX:
- case OP_ASLICE:
- case OP_KVASLICE:
- case OP_HELEM:
- case OP_HSLICE:
- case OP_KVHSLICE:
- case OP_UNPACK:
- case OP_PACK:
- case OP_JOIN:
- case OP_LSLICE:
- case OP_ANONLIST:
- case OP_ANONHASH:
- case OP_SORT:
- case OP_REVERSE:
- case OP_RANGE:
- case OP_FLIP:
- case OP_FLOP:
- case OP_CALLER:
- case OP_FILENO:
- case OP_EOF:
- case OP_TELL:
- case OP_GETSOCKNAME:
- case OP_GETPEERNAME:
- case OP_READLINK:
- case OP_TELLDIR:
- case OP_GETPPID:
- case OP_GETPGRP:
- case OP_GETPRIORITY:
- case OP_TIME:
- case OP_TMS:
- case OP_LOCALTIME:
- case OP_GMTIME:
- case OP_GHBYNAME:
- case OP_GHBYADDR:
- case OP_GHOSTENT:
- case OP_GNBYNAME:
- case OP_GNBYADDR:
- case OP_GNETENT:
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GETLOGIN:
- case OP_PROTOTYPE:
- case OP_RUNCV:
- func_ops:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- /* Otherwise it's "Useless use of grep iterator" */
- useless = OP_DESC(o);
- break;
+ case OP_GVSV:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
+ case OP_ASLICE:
+ case OP_HELEM:
+ case OP_HSLICE:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
+ useless = OP_DESC(o);
+ break;
- case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
+ 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)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
#endif
- useless = OP_DESC(o);
- break;
+ )
+ useless = OP_DESC(o);
+ break;
- case OP_NOT:
- kid = cUNOPo->op_first;
- if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
- goto func_ops;
- }
- useless = "negative pattern binding (!~)";
- break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "non-destructive substitution (s///r)";
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "non-destructive substitution (s///r)";
+ break;
- case OP_TRANSR:
- useless = "non-destructive transliteration (tr///r)";
- break;
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
+ break;
- case OP_RV2GV:
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
- useless = "a variable";
- break;
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
+ (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
- case OP_CONST:
- sv = cSVOPo_sv;
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
- else {
- if (ckWARN(WARN_VOID)) {
- NV nv;
- /* don't warn on optimised away booleans, eg
- * use constant Foo, 5; Foo || print; */
- if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = NULL;
- /* the constants 0 and 1 are permitted as they are
- conventionally used as dummies in constructs like
- 1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
- useless = NULL;
- else if (SvPOK(sv)) {
- SV * const dsv = newSVpvs("");
- useless_sv
- = Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, SvPVX_const(sv),
- SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP
- | PERL_PV_ESCAPE_NOCLEAR
- | PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec_NN(dsv);
- }
- else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
- }
- else
- useless = "a constant (undef)";
- }
- }
- op_null(o); /* don't execute or even remember it */
- break;
+ case OP_CONST:
+ sv = cSVOPo_sv;
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ else {
+ if (ckWARN(WARN_VOID)) {
+ NV nv;
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = NULL;
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
+ else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
+ useless = NULL;
+ else if (SvPOK(sv)) {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
+ }
+ else
+ useless = "a constant (undef)";
+ }
+ }
+ op_null(o); /* don't execute or even remember it */
+ break;
- case OP_POSTINC:
- o->op_type = OP_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREINC];
- break;
+ case OP_POSTINC:
+ CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ break;
- case OP_POSTDEC:
- o->op_type = OP_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREDEC];
- break;
+ case OP_POSTDEC:
+ CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_I_POSTINC:
- o->op_type = OP_I_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
- break;
+ case OP_I_POSTINC:
+ CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ break;
- case OP_I_POSTDEC:
- o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
- break;
+ case OP_I_POSTDEC:
+ CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
- refgen = (UNOP *)((BINOP *)o)->op_first;
+ refgen = (UNOP *)((BINOP *)o)->op_first;
- if (!refgen || (refgen->op_type != OP_REFGEN
- && refgen->op_type != OP_SREFGEN))
- break;
+ if (!refgen || (refgen->op_type != OP_REFGEN
+ && refgen->op_type != OP_SREFGEN))
+ break;
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
- if (exlist->op_first->op_type != OP_PUSHMARK
- && exlist->op_first != exlist->op_last)
- break;
+ if (exlist->op_first->op_type != OP_PUSHMARK
+ && exlist->op_first != exlist->op_last)
+ break;
- rv2cv = (UNOP*)exlist->op_last;
+ rv2cv = (UNOP*)exlist->op_last;
- if (rv2cv->op_type != OP_RV2CV)
- break;
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
- break;
- }
+ break;
+ }
- case OP_AASSIGN: {
- inplace_aassign(o);
- break;
- }
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
- case OP_OR:
- case OP_AND:
- kid = cLOGOPo->op_first;
- if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)) {
- if (o->op_type == OP_AND) {
- o->op_type = OP_OR;
- o->op_ppaddr = PL_ppaddr[OP_OR];
- } else {
- o->op_type = OP_AND;
- o->op_ppaddr = PL_ppaddr[OP_AND];
- }
- op_null(kid);
- }
- /* FALLTHROUGH */
+ case OP_OR:
+ case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)) {
+ if (o->op_type == OP_AND) {
+ CHANGE_TYPE(o, OP_OR);
+ } else {
+ CHANGE_TYPE(o, OP_AND);
+ }
+ op_null(kid);
+ }
+ /* FALLTHROUGH */
+
+ case OP_DOR:
+ case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
- case OP_DOR:
- case OP_COND_EXPR:
- case OP_ENTERGIVEN:
- case OP_ENTERWHEN:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
+ case OP_NULL:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALLTHROUGH */
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALLTHROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
+ kids:
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
+ case OP_LIST:
+ /* If the first kid after pushmark is something that the padrange
+ optimisation would reject, then null the list and the pushmark.
+ */
+ if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
+ && ( !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO
+ || !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO)
+ ) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ goto kids;
+ case OP_ENTEREVAL:
+ scalarkids(o);
+ break;
+ case OP_SCALAR:
+ scalar(o);
+ break;
+ }
- case OP_NULL:
- if (o->op_flags & OPf_STACKED)
- break;
- /* FALLTHROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- case OP_ENTERTRY:
- case OP_ENTER:
- if (!(o->op_flags & OPf_KIDS))
- break;
- /* FALLTHROUGH */
- case OP_SCOPE:
- case OP_LEAVE:
- case OP_LEAVETRY:
- case OP_LEAVELOOP:
- case OP_LINESEQ:
- case OP_LEAVEGIVEN:
- case OP_LEAVEWHEN:
- kids:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
- case OP_LIST:
- /* If the first kid after pushmark is something that the padrange
- optimisation would reject, then null the list and the pushmark.
- */
- if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
- && ( !(kid = OP_SIBLING(kid))
- || ( kid->op_type != OP_PADSV
- && kid->op_type != OP_PADAV
- && kid->op_type != OP_PADHV)
- || kid->op_private & ~OPpLVAL_INTRO
- || !(kid = OP_SIBLING(kid))
- || ( kid->op_type != OP_PADSV
- && kid->op_type != OP_PADAV
- && kid->op_type != OP_PADHV)
- || kid->op_private & ~OPpLVAL_INTRO)
- ) {
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
- }
- goto kids;
- case OP_ENTEREVAL:
- scalarkids(o);
- break;
- case OP_SCALAR:
- return scalar(o);
- }
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ SVfARG(sv_2mortal(useless_sv)));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
+ } while ( (o = POP_DEFERRED_OP()) );
- if (useless_sv) {
- /* mortalise it, in case warnings are fatal. */
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %"SVf" in void context",
- SVfARG(sv_2mortal(useless_sv)));
- }
- else if (useless) {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %s in void context",
- useless);
- }
- return o;
+ Safefree(defer_stack);
+
+ return arg;
}
static OP *
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
return;
}
slurpy:
- o->op_type = OP_LVAVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
+ CHANGE_TYPE(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
break;
case OP_ASLICE:
case OP_HSLICE:
- o->op_type = OP_LVREFSLICE;
- o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
+ CHANGE_TYPE(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
PL_op_desc[type]));
return;
}
- o->op_type = OP_LVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVREF];
+ CHANGE_TYPE(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
PL_modcount++;
break;
}
- if (type != OP_AASSIGN || !(o->op_private & OPpREPEAT_DOLIST))
+ if (!(o->op_private & OPpREPEAT_DOLIST))
goto nomod;
else {
const I32 mods = PL_modcount;
- modkids(cBINOPo->op_first, OP_AASSIGN);
+ modkids(cBINOPo->op_first, type);
+ if (type != OP_AASSIGN)
+ goto nomod;
kid = cBINOPo->op_last;
if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
const IV iv = SvIV(kSVOP_sv);
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(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;
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
- if (!(right->op_flags & OPf_STACKED) && ismatchop) {
- OP *newleft;
-
- right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+ if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+ if (left->op_type == OP_PADSV
+ && !(left->op_private & OPpLVAL_INTRO))
+ {
+ right->op_targ = left->op_targ;
+ op_free(left);
+ o = right;
+ }
+ else {
+ right->op_flags |= OPf_STACKED;
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
(cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
- newleft = op_lvalue(left, rtype);
- else
- newleft = left;
- if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
- else
- o = op_prepend_elem(rtype, scalar(newleft), right);
+ left = op_lvalue(left, rtype);
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = op_prepend_elem(rtype, scalar(left), right);
+ }
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
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_type = OP_LEAVE;
- o->op_ppaddr = PL_ppaddr[OP_LEAVE];
+ CHANGE_TYPE(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ CHANGE_TYPE(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
/*
=for apidoc Am|int|block_start|int full
-Handles compile-time scope entry. Arranges for hints to be restored on block
+Handles compile-time scope entry.
+Arranges for hints to be restored on block
exit and also handles pad sequence numbers to make lexical variables scope
-right. Returns a savestack index for use with C<block_end>.
+right. Returns a savestack index for use with C<block_end>.
=cut
*/
{
const int retval = PL_savestack_ix;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ SAVEI32(PL_compiling.cop_seq);
+ PL_compiling.cop_seq = 0;
CALL_BLOCK_HOOKS(bhk_start, full);
/*
=for apidoc Am|OP *|block_end|I32 floor|OP *seq
-Handles compile-time scope exit. I<floor> is the savestack index returned by
+Handles compile-time scope exit. I<floor>
+is the savestack index returned by
C<block_start>, and I<seq> is the body of the block. Returns the block,
possibly modified.
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
it needs one, and folding constants.
A list-type op is usually constructed one kid at a time via C<newLISTOP>,
-C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
+C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
C<op_convert> to make it the right type.
=cut
}
}
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(o, type);
o->op_flags |= flags;
o = CHECKOP(type, o);
NewOp(1101, listop, 1, LISTOP);
- listop->op_type = (OPCODE)type;
- listop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)type;
- unop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(unop, type);
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
Constructs, checks, and returns an op of method type with a method name
-evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
+evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
and, shifted up eight bits, the eight bits of C<op_private>, except that
-the bit with value 1 is automatically set. I<dynamic_meth> supplies an
+the bit with value 1 is automatically set. I<dynamic_meth> supplies an
op which evaluates method name; it is consumed by this function and
become part of the constructed op tree.
Supported optypes: OP_METHOD.
methop->op_next = (OP*)methop;
}
- methop->op_type = (OPCODE)type;
- methop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(methop, type);
methop = (METHOP*) CHECKOP(type, methop);
if (methop->op_next) return (OP*)methop;
=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
Constructs, checks, and returns an op of method type with a constant
-method name. I<type> is the opcode. I<flags> gives the eight bits of
+method name. I<type> is the opcode. I<flags> gives the eight bits of
C<op_flags>, and, shifted up eight bits, the eight bits of
-C<op_private>. I<const_meth> supplies a constant method name;
+C<op_private>. I<const_meth> supplies a constant method name;
it must be a shared COW string.
Supported optypes: OP_METHOD_NAMED.
if (!first)
first = newOP(OP_NULL, 0);
- binop->op_type = (OPCODE)type;
- binop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
UV tfirst = 1;
UV tlast = 0;
IV tdiff;
+ STRLEN tcount = 0;
UV rfirst = 1;
UV rlast = 0;
IV rdiff;
+ STRLEN rcount = 0;
IV diff;
I32 none = 0;
U32 max = 0;
/* now see which range will peter our first, if either. */
tdiff = tlast - tfirst;
rdiff = rlast - rfirst;
+ tcount += tdiff + 1;
+ rcount += rdiff + 1;
if (tdiff <= rdiff)
diff = tdiff;
(void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
- if (grows)
- o->op_private |= OPpTRANS_GROWS;
-
Safefree(tsave);
Safefree(rsave);
- op_free(expr);
- op_free(repl);
- return o;
+ tlen = tcount;
+ rlen = rcount;
+ if (r < rend)
+ rlen++;
+ else if (rlast == 0xffffffff)
+ rlen = 0;
+
+ goto warnins;
}
tbl = (short*)PerlMemShared_calloc(
}
}
+ warnins:
if(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
NewOp(1101, pmop, 1, PMOP);
- pmop->op_type = (OPCODE)type;
- pmop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
}
rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
- rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
}
else {
rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
- rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
rcop->op_private = 1;
/* establish postfix order */
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, svop, 1, SVOP);
- svop->op_type = (OPCODE)type;
- svop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, padop, 1, PADOP);
- padop->op_type = (OPCODE)type;
- padop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- pvop->op_type = (OPCODE)type;
- pvop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_cop_seqmax++; /* Purely for B::*'s benefit */
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
-
+ COP_SEQMAX_INC; /* Purely for B::*'s benefit */
}
/*
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- cop->op_type = OP_DBSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
+ CHANGE_TYPE(cop, OP_DBSTATE);
}
else {
- cop->op_type = OP_NEXTSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
+ CHANGE_TYPE(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
-#ifdef NATIVE_HINTS
- cop->op_private |= NATIVE_HINTS;
-#endif
#ifdef VMS
if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
#endif
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
- logop->op_ppaddr = PL_ppaddr[type];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
return live;
}
logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
- logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
- range->op_ppaddr = PL_ppaddr[OP_RANGE];
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
left->op_next = flip;
right->op_next = flop;
- range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);
+ range->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
- flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;
+ flip->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
SvPADTMP_on(PAD_SV(flip->op_targ));
if (!loop) {
NewOp(1101,loop,1,LOOP);
- loop->op_type = OP_ENTERLOOP;
- loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
+ CHANGE_TYPE(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- sv->op_type = OP_RV2GV;
- sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+ CHANGE_TYPE(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
PERL_ARGS_ASSERT_NEWGIVWHENOP;
enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
- enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
enterop->op_private = 0;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
*
* examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
sv = newSV(0);
SAVEFREESV(sv);
}
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
PERL_ARGS_ASSERT_NEWMYSUB;
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
+ PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
CvFLAGS(compcv) | preserved_flags;
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
- CvPADLIST(cv) = CvPADLIST(compcv);
+ CvPADLIST_set(cv, CvPADLIST(compcv));
CvOUTSIDE(compcv) = temp_cv;
- CvPADLIST(compcv) = temp_padl;
+ CvPADLIST_set(compcv, temp_padl);
CvSTART(cv) = CvSTART(compcv);
CvSTART(compcv) = cvstart;
CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
itself has a refcount. */
CvSLABBED_off(cv);
OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
+#endif
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (slab)
+ Slab_to_ro(slab);
+#endif
if (o) op_free(o);
return cv;
}
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
+ PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
| CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST_set(cv,CvPADLIST(PL_compcv));
CvOUTSIDE(PL_compcv) = temp_cv;
- CvPADLIST(PL_compcv) = temp_av;
+ CvPADLIST_set(PL_compcv, temp_av);
CvSTART(cv) = CvSTART(PL_compcv);
CvSTART(PL_compcv) = cvstart;
CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (!special) Slab_to_ro(slab);
+ if (!special && slab)
+ Slab_to_ro(slab);
#endif
return cv;
}
return cv;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+ PERL_ARGS_ASSERT_NEWXS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
+}
+
CV *
Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *const filename, const char *const proto,
}
CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+ PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ );
+}
+
+CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
const char *const proto, SV **const_svp,
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+ if (!subaddr)
+ Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+ name, filename ? filename : PL_xsubfilename);
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
name ? len : PL_curstash ? sizeof("__ANON__") - 1:
sizeof("__ANON__::__ANON__") - 1,
GV_ADDMULTI | flags, SVt_PVCV);
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
+
if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
gv_method_changed(gv); /* newXS */
}
}
- if (!name)
- CvANON_on(cv);
+
CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if(filename) {
+ (void)gv_fetchfile(filename);
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvDYNFILE_on(cv);
+ CvFILE(cv) = savepv(filename);
+ } else {
+ /* NOTE: not copied, as it is expected to be an external constant string */
+ CvFILE(cv) = (char *)filename;
+ }
+ } else {
+ assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+ CvFILE(cv) = (char*)PL_xsubfilename;
+ }
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
-
+#ifndef PERL_IMPLICIT_CONTEXT
+ CvHSCXT(cv) = &PL_stack_sp;
+#else
+ PoisonPADLIST(cv);
+#endif
+
if (name)
process_special_blocks(0, name, gv, cv);
- }
+ else
+ CvANON_on(cv);
+ } /* <- not a conditional branch */
+
- if (flags & XS_DYNAMIC_FILENAME) {
- CvFILE(cv) = savepv(filename);
- CvDYNFILE_on(cv);
- }
sv_setpv(MUTABLE_SV(cv), proto);
if (interleave) LEAVE;
return cv;
return cv;
}
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
- PERL_ARGS_ASSERT_NEWXS;
- return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
- );
-}
-
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- o->op_type = OP_RV2HV;
- o->op_ppaddr = PL_ppaddr[OP_RV2HV];
+ CHANGE_TYPE(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- o->op_type = OP_PADCV;
- o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ CHANGE_TYPE(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADSV;
- o->op_ppaddr = PL_ppaddr[OP_PADSV];
+ CHANGE_TYPE(o, OP_PADSV);
return o;
}
return newUNOP(OP_RV2SV, 0, scalar(o));
op_free(o);
enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
- enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
/* establish postfix order */
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- o->op_type = OP_LEAVETRY;
- o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
+ CHANGE_TYPE(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- kid->op_type = OP_GV;
+ CHANGE_TYPE(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
kid->op_private = 0;
- kid->op_ppaddr = PL_ppaddr[OP_GV];
/* FAKE globs in the symbol table cause weird bugs (#77810) */
SvFAKE_off(gv);
}
PERL_ARGS_ASSERT_CK_GREP;
- o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
kid = kUNOP->op_first;
gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
- gwop->op_ppaddr = PL_ppaddr[type];
kid->op_next = (OP*)gwop;
offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- first->op_type = OP_QR;
- first->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- second->op_type = OP_QR;
- second->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(second, OP_QR);
}
}
}
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
{
dVAR;
OP * const kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_SASSIGN;
-
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
- && !(kkid->op_private & OPpLVAL_INTRO))
+ && (!(kkid->op_private & OPpLVAL_INTRO)
+ || kkid->op_private & OPpPAD_STATE))
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN.
- * first replace the PADSV with OP_SIBLING(o), then
- * detach kid and OP_SIBLING(o) from o */
- op_sibling_splice(o, kid, 1, OP_SIBLING(o));
- op_sibling_splice(o, NULL, -1, NULL);
+ * Detach kid and free the rest. */
+ op_sibling_splice(o, NULL, 1, NULL);
op_free(o);
- op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ dVAR;
+ OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
if (OP_HAS_SIBLING(kid)) {
OP *kkid = OP_SIBLING(kid);
- /* For state variable assignment, kkid is a list op whose op_last
- is a padsv. */
+ /* For state variable assignment with attributes, kkid is a list op
+ whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
(OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
- && (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+ && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == (OPpLVAL_INTRO|OPpPAD_STATE)) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
- OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const nullop =
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
OP *const condop = first->op_next;
- condop->op_type = OP_ONCE;
- condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ CHANGE_TYPE(condop, OP_ONCE);
other->op_targ = target;
/* Store the initializedness of state vars in a separate
return nullop;
}
}
- return o;
+ return S_maybe_targlex(aTHX_ o);
}
OP *
{
OP * const right = cLISTOPo->op_first;
OP * const left = OP_SIBLING(right);
- OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
+ OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
bool stacked = 0;
PERL_ARGS_ASSERT_CK_REFASSIGN;
assert (left);
assert (left->op_type == OP_SREFGEN);
+ o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
+
switch (varop->op_type) {
case OP_PADAV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto settarg;
case OP_PADHV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_PADSV:
settarg:
o->op_targ = varop->op_targ;
PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
break;
case OP_RV2AV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto checkgv;
case OP_RV2HV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_RV2SV:
checkgv:
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
- goto null_and_stack;
+ detach_and_stack:
+ /* Point varop to its GV kid, detached. */
+ varop = op_sibling_splice(varop, NULL, -1, NULL);
+ stacked = TRUE;
+ break;
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;
+ OP * const kidparent =
+ cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OP * const kid = cUNOPx(kidparent)->op_first;
+ o->op_private |= OPpLVREF_CV;
+ if (kid->op_type == OP_GV) {
+ varop = kidparent;
+ goto detach_and_stack;
+ }
if (kid->op_type != OP_PADCV) goto bad;
o->op_targ = kid->op_targ;
kid->op_targ = 0;
}
case OP_AELEM:
case OP_HELEM:
- o->op_private = OPpLVREF_ELEM;
- null_and_stack:
+ o->op_private |= OPpLVREF_ELEM;
op_null(varop);
- op_null(left);
stacked = TRUE;
+ /* Detach varop. */
+ op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
break;
default:
bad:
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__REFALIASING),
"Aliasing via reference is experimental");
- o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
- if (stacked) o->op_flags |= OPf_STACKED;
+ if (stacked) {
+ o->op_flags |= OPf_STACKED;
+ op_sibling_splice(o, right, 1, varop);
+ }
else {
o->op_flags &=~ OPf_STACKED;
op_sibling_splice(o, right, 1, NULL);
- op_free(left);
}
+ op_free(left);
return o;
}
if (o->op_flags & OPf_KIDS) {
kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && OP_HAS_SIBLING(kid)) {
- o->op_type = OP_SSELECT;
- o->op_ppaddr = PL_ppaddr[OP_SSELECT];
+ CHANGE_TYPE(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
-
- kid->op_type = OP_PUSHRE;
- kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
+ CHANGE_TYPE(kid, OP_PUSHRE);
scalar(kid);
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
{
OP * const kid = OP_SIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN) {
+ if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ {
assert(!OP_HAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
- && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ ||OP_TYPE_IS(sibling->op_next->op_next,
+ OP_LEAVESUBLV))
&& cUNOPx(sibling)->op_first == next
&& OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
&& next->op_next
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
assert(sizeof(OP) <= sizeof(BINOP));
- o->op_type = OP_STUB;
- o->op_ppaddr = PL_ppaddr[OP_STUB];
+ CHANGE_TYPE(o, OP_STUB);
o->op_private = 0;
break;
}
* *always* formerly a pushmark */
assert(o->op_type == OP_PUSHMARK);
o->op_next = followop;
- o->op_type = OP_PADRANGE;
- o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
+ CHANGE_TYPE(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- o->op_type = OP_GVSV;
- o->op_ppaddr = PL_ppaddr[OP_GVSV];
+ CHANGE_TYPE(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- o->op_type = OP_RCATLINE;
+ CHANGE_TYPE(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
- o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
op_null(o->op_next->op_next);
op_null(o->op_next);
}
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- o->op_type = OP_CONST;
- o->op_ppaddr = PL_ppaddr[OP_CONST];
+ CHANGE_TYPE(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
break;
case OP_SASSIGN:
- if (OP_GIMME(o,0) == G_VOID) {
+ if (OP_GIMME(o,0) == G_VOID
+ || ( o->op_next->op_type == OP_LINESEQ
+ && ( o->op_next->op_next->op_type == OP_LEAVESUB
+ || ( o->op_next->op_next->op_type == OP_RETURN
+ && !CvLVALUE(PL_compcv)))))
+ {
OP *right = cBINOP->op_first;
if (right) {
/* sassign
/* 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. */
+ /* There can’t be common vars if the lhs is a stub. */
+ if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ == cLISTOPx(cBINOPo->op_last)->op_last
+ && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+ {
+ o->op_private &=~ OPpASSIGN_COMMON;
+ break;
+ }
if (o->op_private & OPpASSIGN_COMMON) {
/* See the comment before S_aassign_common_vars concerning
PL_generation sorcery. */