#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* 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.
+ */
+
+STATIC void
+S_prune_chain_head(pTHX_ OP** op_p)
+{
+ while (*op_p
+ && ( (*op_p)->op_type == OP_NULL
+ || (*op_p)->op_type == OP_SCOPE
+ || (*op_p)->op_type == OP_SCALAR
+ || (*op_p)->op_type == OP_LINESEQ)
+ )
+ *op_p = (*op_p)->op_next;
+}
+
+
/* See the explanatory comments above struct opslab in op.h. */
#ifdef PERL_DEBUG_READONLY_OPS
/* Destructor */
+/*
+=for apidoc Am|void|op_free|OP *o
+
+Free an op. Only use this when an op is no longer linked to from any
+optree.
+
+=cut
+*/
+
void
Perl_op_free(pTHX_ OP *o)
{
o->op_targ = 0;
goto retry;
}
+ /* FALLTHROUGH */
case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
if (!(o->op_flags & OPf_REF)
|| (PL_check[o->op_type] != Perl_ck_ftst))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
case OP_REDO:
if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_TRANS:
case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
#else
SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_MATCH:
case OP_QR:
clear_pmop:
}
}
+/*
+=for apidoc Am|void|op_null|OP *o
+
+Neutralizes an op when it is no longer needed, but is still linked to from
+other ops.
+
+=cut
+*/
+
void
Perl_op_null(pTHX_ OP *o)
{
=head1 Optree Manipulation Functions
=for apidoc Am|OP*|op_linklist|OP *o
-This function is the implementation of the L</LINKLIST> macro. It should
+This function is the implementation of the L</LINKLIST> macro. It should
not be called directly.
=cut
case OP_RVALUES:
return;
}
+
+ /* Don't warn if we have a nulled list either. */
+ if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
+ return;
+
assert(kid->op_sibling);
name = S_op_varname(aTHX_ kid->op_sibling);
if (!name) /* XS module fiddling with the op tree */
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalar(kid);
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SPLIT:
case OP_MATCH:
case OP_QR:
default:
if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
case OP_SUBSTR:
if (o->op_private == 4)
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
/* 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_eq_nowarn(SvNV(sv), 0.0) ||
- NV_eq_nowarn(SvNV(sv), 1.0)))
+ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = NULL;
else if (SvPOK(sv)) {
SV * const dsv = newSVpvs("");
}
op_null(kid);
}
+ /* FALLTHROUGH */
case OP_DOR:
case OP_COND_EXPR:
case OP_NULL:
if (o->op_flags & OPf_STACKED)
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
case OP_ENTERTRY:
case OP_ENTER:
if (!(o->op_flags & OPf_KIDS))
break;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
/*
=for apidoc finalize_optree
-This function finalizes the optree. Should be called directly after
-the complete optree is built. It does some additional
+This function finalizes the optree. Should be called directly after
+the complete optree is built. It does some additional
checking which can't be done in the normal ck_xxx functions and makes
the tree thread-safe.
case OP_HSLICE:
S_scalar_slice_warning(aTHX_ o);
+ /* FALLTHROUGH */
+ case OP_KVHSLICE:
+ kid = cLISTOPo->op_first->op_sibling;
if (/* I bet there's always a pushmark... */
- (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
- && kid->op_type != OP_CONST)
+ OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
+ && OP_TYPE_ISNT_NN(kid, OP_CONST))
+ {
break;
+ }
key_op = (SVOP*)(kid->op_type == OP_CONST
? kid
}
lexname = NULL; /* just to silence compiler warnings */
+ fields = NULL; /* just to silence compiler warnings */
+
check_fields =
rop
&& (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
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
+generates errors for them. For example, C<$x+1 = 2> would cause it to be
called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
It also flags things that need to behave specially in an lvalue context,
=cut
*/
+static bool
+S_vivifies(const OPCODE type)
+{
+ switch(type) {
+ case OP_RV2AV: case OP_ASLICE:
+ case OP_RV2HV: case OP_KVASLICE:
+ case OP_RV2SV: case OP_HSLICE:
+ case OP_AELEMFAST: case OP_KVHSLICE:
+ case OP_HELEM:
+ case OP_AELEM:
+ return 1;
+ }
+ return 0;
+}
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
break;
}
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
nomod:
if (flags & OP_LVALUE_NO_CROAK) return NULL;
PL_modcount = RETURN_UNLIMITED_NUMBER;
return o; /* Treat \(@foo) like ordinary list. */
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_RV2GV:
if (scalar_mod_type(o, type))
goto nomod;
ref(cUNOPo->op_first, o->op_type);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_ASLICE:
case OP_HSLICE:
localize = 1;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_AASSIGN:
/* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
if (type == OP_LEAVESUBLV && (
|| (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
))
o->op_private |= OPpMAYBE_LVSUB;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
case OP_RV2SV:
ref(cUNOPo->op_first, o->op_type);
localize = 1;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_GV:
PL_hints |= HINT_BLOCK_SCOPE;
+ /* FALLTHROUGH */
case OP_SASSIGN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
&& type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
case OP_SUBSTR:
if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
goto nomod;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_POS:
case OP_VEC:
lvalue_func:
case OP_LEAVE:
case OP_LEAVELOOP:
o->op_private |= OPpLVALUE;
+ /* FALLTHROUGH */
case OP_SCOPE:
case OP_ENTER:
case OP_LINESEQ:
op_lvalue(cBINOPo->op_first, type);
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_LIST:
localize = 0;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
case OP_AND:
case OP_OR:
- op_lvalue(cLOGOPo->op_first, type);
- op_lvalue(cLOGOPo->op_first->op_sibling, type);
+ if (type == OP_LEAVESUBLV
+ || !S_vivifies(cLOGOPo->op_first->op_type))
+ op_lvalue(cLOGOPo->op_first, type);
+ if (type == OP_LEAVESUBLV
+ || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
+ op_lvalue(cLOGOPo->op_first->op_sibling, type);
goto nomod;
}
case OP_SASSIGN:
if (o && o->op_type == OP_RV2GV)
return FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PREINC:
case OP_PREDEC:
case OP_POSTINC:
case OP_SOCKPAIR:
if (numargs == 2)
return TRUE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SYSOPEN:
case OP_OPEN:
case OP_SELECT: /* XXX c.f. SelectSaver.pm */
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
doref(cUNOPo->op_first, o->op_type, set_op_ref);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
case OP_RV2HV:
if (set_op_ref)
o->op_flags |= OPf_REF;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
case OP_SCOPE:
case OP_LEAVE:
set_op_ref = FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_ENTER:
case OP_LIST:
if (!(o->op_flags & OPf_KIDS))
PERL_ARGS_ASSERT_APPLY_ATTRS;
/* fake up C<use attributes $pkg,$rv,@attrs> */
- ENTER; /* need to protect against side-effects of 'use' */
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
newSVOP(OP_CONST, 0,
newRV(target)),
dup_attrlist(attrs))));
- LEAVE;
}
STATIC void
target->op_type == OP_PADAV);
/* Ensure that attributes.pm is loaded. */
- ENTER; /* need to protect against side-effects of 'use' */
/* Don't force the C<use> if we don't need it. */
svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs(ATTRSMODULE), NULL);
- LEAVE;
/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
}
}
+static void
+S_cant_declare(pTHX_ OP *o)
+{
+ if (o->op_type == OP_NULL
+ && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
+ o = cUNOPo->op_first;
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
+ o->op_type == OP_NULL
+ && o->op_flags & OPf_SPECIAL
+ ? "do block"
+ : OP_DESC(o),
+ PL_parser->in_my == KEY_our ? "our" :
+ PL_parser->in_my == KEY_state ? "state" :
+ "my"));
+}
+
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
- OP_DESC(o),
- PL_parser->in_my == KEY_our
- ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
+ S_cant_declare(aTHX_ o);
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
+ assert(PL_parser);
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
type != OP_PADHV &&
type != OP_PUSHMARK)
{
- yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
- OP_DESC(o),
- PL_parser->in_my == KEY_our
- ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
+ S_cant_declare(aTHX_ o);
return o;
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
+ assert(PL_parser);
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
/* !~ doesn't make sense with /r, so error on it for now */
if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
type == OP_NOT)
+ /* diag_listed_as: Using !~ with %s doesn't make sense */
yyerror("Using !~ with s///r doesn't make sense");
if (rtype == OP_TRANSR && type == OP_NOT)
+ /* diag_listed_as: Using !~ with %s doesn't make sense */
yyerror("Using !~ with tr///r doesn't make sense");
ismatchop = (rtype == OP_MATCH ||
=for apidoc Aox||blockhook_register
Register a set of hooks to be called when the Perl lexical scope changes
-at compile time. See L<perlguts/"Compile-time scope hooks">.
+at compile time.
See L<perlguts/"Compile-time scope hooks">.
=cut
*/
ENTER;
CALL_PEEP(PL_eval_start);
finalize_optree(PL_eval_root);
+ S_prune_chain_head(aTHX_ &PL_eval_start);
LEAVE;
PL_savestack_ix = i;
}
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
finalize_optree(PL_main_root);
+ S_prune_chain_head(aTHX_ &PL_main_start);
cv_forget_slab(PL_compcv);
PL_compcv = 0;
#endif
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
- else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
+ else if (!SvIMMORTAL(sv)) {
+ SvPADTMP_on(sv);
+ SvREADONLY_on(sv);
+ }
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
- PL_op = curop = LINKLIST(o);
+ curop = LINKLIST(o);
o->op_next = 0;
CALL_PEEP(curop);
+ S_prune_chain_head(aTHX_ &curop);
+ PL_op = curop;
Perl_pp_pushmark(aTHX);
CALLRUNOPS(aTHX);
PL_op = curop;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
if (AvFILLp(av) != -1)
for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
+ {
SvPADTMP_on(*svp);
+ SvREADONLY_on(*svp);
+ }
#ifdef PERL_MAD
op_getmad(curop,o,'O');
#else
dVAR;
BINOP *binop;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
+ ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
|| type == OP_SASSIGN || type == OP_NULL );
NewOp(1101, binop, 1, BINOP);
} else {
SV * const repointer = &PL_sv_undef;
av_push(PL_regex_padav, repointer);
- pmop->op_pmoffset = av_len(PL_regex_padav);
+ pmop->op_pmoffset = av_tindex(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
/* have to peep the DOs individually as we've removed it from
* the op_next chain */
CALL_PEEP(o);
+ S_prune_chain_head(aTHX_ &(o->op_next));
if (is_compiletime)
/* runtime finalizes as part of finalizing whole tree */
finalize_optree(o);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
- SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
padop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified and not NULL, provides version semantics
+(or 0 for no flags). ver, if specified
+and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
* that it has a PL_parser to play with while doing that, and also
* that it doesn't mess with any existing parser, by creating a tmp
* new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work. */
+ * since pp_require() will create another parser for the real work.
+ * The ENTER/LEAVE pair protect callers from any side effects of use. */
ENTER;
SAVEVPTR(PL_curcop);
LEAVE;
}
+PERL_STATIC_INLINE OP *
+S_new_entersubop(pTHX_ GV *gv, OP *arg)
+{
+ return newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newLISTOP(OP_LIST, 0, arg,
+ newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv))));
+}
+
OP *
Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
PERL_ARGS_ASSERT_DOFILE;
if (!force_builtin && (gv = gv_override("do", 2))) {
- doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, term,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)))));
+ doop = S_new_entersubop(aTHX_ gv, term);
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
- if ((left->op_type == OP_LIST
- || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+ if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
{
OP* lop = ((LISTOP*)left)->op_first;
maybe_common_vars = FALSE;
(state $a, my $b, our $c, $d, undef) = ... */
}
} else if (lop->op_type == OP_UNDEF ||
- lop->op_type == OP_PUSHMARK) {
+ OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
/* undef may be interesting in
(state $a, undef, state $c) */
} else {
OP* listop;
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
- (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
+ block->op_type == OP_NULL;
PERL_UNUSED_ARG(debuggable);
if (expr) {
- if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+ if (once && (
+ (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+ || ( expr->op_type == OP_NOT
+ && cUNOPx(expr)->op_first->op_type == OP_CONST
+ && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
+ )
+ ))
+ /* Return the block now, so that S_new_logop does not try to
+ fold it away. */
return block; /* do {} while 0 does once */
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
o = new_logop(OP_AND, 0, &expr, &listop);
+ if (once) {
+ ASSUME(listop);
+ }
+
if (listop)
((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
if (once && o != listop)
+ {
+ assert(cUNOPo->op_first->op_type == OP_AND
+ || cUNOPo->op_first->op_type == OP_OR);
o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
+ }
if (o == listop)
o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
else
return FALSE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
return FALSE;
}
=for apidoc cv_const_sv
-If C<cv> is a constant sub eligible for inlining. returns the constant
+If C<cv> is a constant sub eligible for inlining, returns the constant
value returned by the sub. Otherwise, returns NULL.
Constant subs can be created with C<newCONSTSUB> or as described in
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !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.
*/
SV *
-Perl_op_const_sv(pTHX_ const OP *o)
+Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
{
dVAR;
SV *sv = NULL;
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_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 {
+ if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ sv = &PL_sv_undef; /* an arbitrary non-null value */
+ }
+ }
else {
return NULL;
}
#endif
{
/* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
+ SAVEFREESV(cv);
}
return TRUE;
}
)
const_sv = NULL;
else
- const_sv = op_const_sv(block);
+ const_sv = op_const_sv(block, NULL);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
/* already defined? */
if (exists) {
- if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+ if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
cv = NULL;
else {
if (attrs) goto attrs;
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(aTHX_ &CvSTART(cv));
/* now that optimizer has done its work, adjust pad values */
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>. */
return cv;
}
+/* _x = extended */
CV *
-Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
-{
- return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
-}
-
-CV *
-Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
- OP *block, U32 flags)
+Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, bool o_is_gv)
{
dVAR;
GV *gv;
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
- const bool o_is_gv = flags & 1;
const char * const name =
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
)
const_sv = NULL;
else
- const_sv = op_const_sv(block);
+ const_sv = op_const_sv(block, NULL);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(aTHX_ &CvSTART(cv));
/* now that optimizer has done its work, adjust pad values */
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 (*name == 'B') {
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
+ dSP;
if (floor) LEAVE_SCOPE(floor);
ENTER;
+ PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
SAVEVPTR(PL_curcop);
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
+ POPSTACK;
LEAVE;
}
else
U32 flags)
{
CV *cv;
+ bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
),
cv, const_svp);
}
- SvREFCNT_dec_NN(cv);
+ interleave = TRUE;
+ ENTER;
+ SAVEFREESV(cv);
cv = NULL;
}
}
CvDYNFILE_on(cv);
}
sv_setpv(MUTABLE_SV(cv), proto);
+ if (interleave) LEAVE;
return cv;
}
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(aTHX_ &CvSTART(cv));
cv_forget_slab(cv);
finish:
static void
S_io_hints(pTHX_ OP *o)
{
+#if O_BINARY != 0 || O_TEXT != 0
HV * const table =
PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
if (table) {
STRLEN len = 0;
const char *d = SvPV_const(*svp, len);
const I32 mode = mode_from_discipline(d, len);
+ /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
+# if O_BINARY != 0
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
- else if (mode & O_TEXT)
+# endif
+# if O_TEXT != 0
+ if (mode & O_TEXT)
o->op_private |= OPpOPEN_IN_CRLF;
+# endif
}
svp = hv_fetchs(table, "open_OUT", FALSE);
STRLEN len = 0;
const char *d = SvPV_const(*svp, len);
const I32 mode = mode_from_discipline(d, len);
+ /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
+# if O_BINARY != 0
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
- else if (mode & O_TEXT)
+# endif
+# if O_TEXT != 0
+ if (mode & O_TEXT)
o->op_private |= OPpOPEN_OUT_CRLF;
+# endif
}
}
+#else
+ PERL_UNUSED_ARG(o);
+#endif
}
OP *
/* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
&& (gv = gv_override("readpipe",8))) {
- newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- cUNOPo->op_first->op_sibling,
- newCVREF(0, newGVOP(OP_GV, 0, gv))
- ));
+ newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
cUNOPo->op_first->op_sibling = NULL;
}
else if (!(o->op_flags & OPf_KIDS))
switch (kid->op_type) {
case OP_ASLICE:
o->op_flags |= OPf_SPECIAL;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_HSLICE:
o->op_private |= OPpSLICE;
break;
case OP_AELEM:
o->op_flags |= OPf_SPECIAL;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_HELEM:
break;
case OP_KVASLICE:
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
- else scalar(kid);
+ else {
+ scalar(kid);
+ /* diag_listed_as: push on reference is experimental */
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
+ "%s on reference is experimental",
+ PL_op_desc[type]);
+ }
break;
case OA_HVREF:
if (kid->op_type == OP_CONST &&
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- o = newLISTOP(OP_LIST, 0, o, NULL);
- o = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, o,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)))));
+ o = S_new_entersubop(aTHX_ gv, o);
o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
/* For state variable assignment, kkid is a list op whose op_last
is a padsv. */
if ((kkid->op_type == OP_PADSV ||
- (kkid->op_type == OP_LIST &&
+ (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
#ifndef PERL_MAD
op_free(o);
#endif
- newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv)))));
+ newop = S_new_entersubop(aTHX_ gv, kid);
op_getmad(o,newop,'O');
return newop;
}
if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+
if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
+ /* if the first arg is a code block, process it and mark sort as
+ * OPf_SPECIAL */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
LINKLIST(kid);
if (kid->op_type == OP_LEAVE)
return o;
}
+/* for sort { X } ..., where X is one of
+ * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
+ * elide the second child of the sort (the one containing X),
+ * and set these flags as appropriate
+ OPpSORT_NUMERIC;
+ OPpSORT_INTEGER;
+ OPpSORT_DESCEND;
+ * Also, check and warn on lexical $a, $b.
+ */
+
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
op_append_elem(OP_SPLIT, o, newDEFSVOP());
kid = kid->op_sibling;
+ assert(kid);
scalar(kid);
if (!kid->op_sibling)
/* _ must be at the end */
if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
+ /* FALLTHROUGH */
case '$':
proto++;
arg++;
)
);
}
- assert(0);
+ NOT_REACHED;
}
else {
OP *prev, *cvop;
at compile time as I<cv>.
The C-level function pointer is supplied in I<ckfun>, and an SV argument
-for it is supplied in I<ckobj>. The function is intended to be called
-in this manner:
+for it is supplied in I<ckobj>. The function should be defined like this:
+
+ STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
+
+It is intended to be called in this manner:
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
MAGIC *callmg;
sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
+ assert(callmg);
if (callmg->mg_flags & MGf_REFCOUNTED) {
SvREFCNT_dec(callmg->mg_obj);
callmg->mg_flags &= ~MGf_REFCOUNTED;
if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
SvIsCOW_on(sv);
CowREFCNT(sv) = 0;
+# ifdef PERL_DEBUG_READONLY_COW
+ sv_buf_to_ro(sv);
+# endif
}
#endif
SvREADONLY_on(sv);
}
}
/* if treating as a reference, defer additional checks to runtime */
- return o->op_type == ref_type ? o : ck_fun(o);
+ if (o->op_type == ref_type) {
+ /* diag_listed_as: keys on reference is experimental */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
+ "%s is experimental", PL_op_desc[ref_type]);
+ return o;
+ }
+ return ck_fun(o);
}
OP *
op_null(oleft);
}
+
+
+/* mechanism for deferring recursion in rpeep() */
+
#define MAX_DEFERRED 4
#define DEFER(o) \
STMT_START { \
if (defer_ix == (MAX_DEFERRED-1)) { \
- CALL_RPEEP(defer_queue[defer_base]); \
+ OP **defer = defer_queue[defer_base]; \
+ CALL_RPEEP(*defer); \
+ S_prune_chain_head(aTHX_ defer); \
defer_base = (defer_base + 1) % MAX_DEFERRED; \
defer_ix--; \
} \
- defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
} STMT_END
+#define IS_AND_OP(o) (o->op_type == OP_AND)
+#define IS_OR_OP(o) (o->op_type == OP_OR)
+
+
+STATIC void
+S_null_listop_in_list_context(pTHX_ OP *o)
+{
+ OP *kid;
+
+ PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
+
+ /* This is an OP_LIST in list context. That means we
+ * can ditch the OP_LIST and the OP_PUSHMARK within. */
+
+ kid = cLISTOPo->op_first;
+ /* Find the end of the chain of OPs executed within the OP_LIST. */
+ while (kid->op_next != o)
+ kid = kid->op_next;
+
+ kid->op_next = o->op_next; /* patch list out of exec chain */
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+}
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
dVAR;
OP* oldop = NULL;
OP* oldoldop = NULL;
- OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+ OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
if (o && o->op_opt)
o = NULL;
if (!o) {
- while (defer_ix >= 0)
- CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
+ while (defer_ix >= 0) {
+ OP **defer =
+ defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
+ CALL_RPEEP(*defer);
+ S_prune_chain_head(aTHX_ defer);
+ }
break;
}
clear this again. */
o->op_opt = 1;
PL_op = o;
+
+
+ /* The following will have the OP_LIST and OP_PUSHMARK
+ * patched out later IF the OP_LIST is in list context.
+ * So in that case, we can set the this OP's op_next
+ * to skip to after the OP_PUSHMARK:
+ * a THIS -> b
+ * d list -> e
+ * b pushmark -> c
+ * c whatever -> d
+ * e whatever
+ * will eventually become:
+ * a THIS -> c
+ * - ex-list -> -
+ * - ex-pushmark -> -
+ * c whatever -> e
+ * e whatever
+ */
+ {
+ OP *sibling;
+ OP *other_pushmark;
+ if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
+ && (sibling = o->op_sibling)
+ && sibling->op_type == OP_LIST
+ /* This KIDS check is likely superfluous since OP_LIST
+ * would otherwise be an OP_STUB. */
+ && sibling->op_flags & OPf_KIDS
+ && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
+ && (other_pushmark = cLISTOPx(sibling)->op_first)
+ /* Pointer equality also effectively checks that it's a
+ * pushmark. */
+ && other_pushmark == o->op_next)
+ {
+ o->op_next = other_pushmark->op_next;
+ null_listop_in_list_context(sibling);
+ }
+ }
+
switch (o->op_type) {
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
case OP_NEXTSTATE:
PL_curcop = ((COP*)o); /* for warnings */
+ /* Optimise a "return ..." at the end of a sub to just be "...".
+ * This saves 2 ops. Before:
+ * 1 <;> nextstate(main 1 -e:1) v ->2
+ * 4 <@> return K ->5
+ * 2 <0> pushmark s ->3
+ * - <1> ex-rv2sv sK/1 ->4
+ * 3 <#> gvsv[*cat] s ->4
+ *
+ * After:
+ * - <@> return K ->-
+ * - <0> pushmark s ->2
+ * - <1> ex-rv2sv sK/1 ->-
+ * 2 <$> gvsv(*cat) s ->3
+ */
+ {
+ OP *next = o->op_next;
+ OP *sibling = o->op_sibling;
+ 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)
+ && cUNOPx(sibling)->op_first == next
+ && next->op_sibling && next->op_sibling->op_next
+ && next->op_next
+ ) {
+ /* Look through the PUSHMARK's siblings for one that
+ * points to the RETURN */
+ OP *top = next->op_sibling;
+ while (top && top->op_next) {
+ if (top->op_next == sibling) {
+ top->op_next = sibling->op_next;
+ o->op_next = next->op_next;
+ break;
+ }
+ top = top->op_sibling;
+ }
+ }
+ }
+
+ /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
+ *
+ * This latter form is then suitable for conversion into padrange
+ * later on. Convert:
+ *
+ * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
+ *
+ * into:
+ *
+ * nextstate1 -> listop -> nextstate3
+ * / \
+ * pushmark -> padop1 -> padop2
+ */
+ if (o->op_next && (
+ o->op_next->op_type == OP_PADSV
+ || o->op_next->op_type == OP_PADAV
+ || o->op_next->op_type == OP_PADHV
+ )
+ && !(o->op_next->op_private & ~OPpLVAL_INTRO)
+ && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
+ && o->op_next->op_next->op_next && (
+ o->op_next->op_next->op_next->op_type == OP_PADSV
+ || o->op_next->op_next->op_next->op_type == OP_PADAV
+ || o->op_next->op_next->op_next->op_type == OP_PADHV
+ )
+ && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
+ && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
+ && (!CopLABEL((COP*)o)) /* Don't mess with labels */
+ && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
+ ) {
+ OP *first;
+ OP *last;
+ OP *newop;
+
+ first = o->op_next;
+ last = o->op_next->op_next->op_next;
+
+ newop = newLISTOP(OP_LIST, 0, first, last);
+ newop->op_flags |= OPf_PARENS;
+ newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ /* Kill nextstate2 between padop1/padop2 */
+ op_free(first->op_next);
+
+ first->op_next = last; /* padop2 */
+ first->op_sibling = last; /* ... */
+ o->op_next = cUNOPx(newop)->op_first; /* pushmark */
+ o->op_next->op_next = first; /* padop1 */
+ o->op_next->op_sibling = first; /* ... */
+ newop->op_next = last->op_next; /* nextstate3 */
+ newop->op_sibling = last->op_sibling;
+ last->op_next = newop; /* listop */
+ last->op_sibling = NULL;
+ o->op_sibling = newop; /* ... */
+
+ newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ /* Ensure pushmark has this flag if padops do */
+ if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
+ o->op_next->op_flags |= OPf_MOD;
+ }
+
+ break;
+ }
+
/* Two NEXTSTATEs in a row serve no purpose. Except if they happen
to carry two labels. For now, take the easier option, and skip
this optimisation if the first NEXTSTATE has a label. */
though (See 20010220.007). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
nothin:
- if (oldop && o->op_next) {
+ if (oldop) {
oldop->op_next = o->op_next;
o->op_opt = 0;
continue;
)
break;
- /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ /* let $a[N] potentially be optimised into AELEMFAST_LEX
* instead */
if ( p->op_type == OP_PADAV
&& p->op_next
*/
assert(followop);
if (gimme == OPf_WANT_VOID) {
- if (followop->op_type == OP_LIST
+ if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
&& gimme == (followop->op_flags & OPf_WANT)
&& ( followop->op_next->op_type == OP_NEXTSTATE
|| followop->op_next->op_type == OP_DBSTATE))
|| p->op_type == OP_PADHV)
&& (p->op_flags & OPf_WANT) == OPf_WANT_VOID
&& (p->op_private & OPpLVAL_INTRO) == intro
+ && !(p->op_private & ~OPpLVAL_INTRO)
&& p->op_next
&& ( p->op_next->op_type == OP_NEXTSTATE
|| p->op_next->op_type == OP_DBSTATE)
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
+ (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
{
GV *gv;
if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
while (o->op_next && ( o->op_type == o->op_next->op_type
|| o->op_next->op_type == OP_NULL))
o->op_next = o->op_next->op_next;
+
+ /* if we're an OR and our next is a AND in void context, we'll
+ follow it's op_other on short circuit, same for reverse.
+ We can't do this with OP_DOR since if it's true, its return
+ value is the underlying value which must be evaluated
+ by the next op */
+ if (o->op_next &&
+ (
+ (IS_AND_OP(o) && IS_OR_OP(o->op_next))
+ || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
+ )
+ && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
+ ) {
+ o->op_next = ((LOGOP*)o->op_next)->op_other;
+ }
DEFER(cLOGOP->op_other);
o->op_opt = 1;
DEFER(cLOOP->op_lastop);
break;
+ case OP_ENTERTRY:
+ assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
+ DEFER(cLOGOPo->op_other);
+ break;
+
case OP_SUBST:
assert(!(cPMOP->op_pmflags & PMf_ONCE));
while (cPMOP->op_pmstashstartu.op_pmreplstart &&
case OP_SORT: {
OP *oright;
- if (o->op_flags & OPf_STACKED) {
- OP * const kid =
- cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
- if (kid->op_type == OP_SCOPE
- || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
- DEFER(kLISTOP->op_first);
+ if (o->op_flags & OPf_SPECIAL) {
+ /* first arg is a code block */
+ OP * const nullop = cLISTOP->op_first->op_sibling;
+ OP * kid = cUNOPx(nullop)->op_first;
+
+ assert(nullop->op_type == OP_NULL);
+ assert(kid->op_type == OP_SCOPE
+ || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
+ /* since OP_SORT doesn't have a handy op_other-style
+ * field that can point directly to the start of the code
+ * block, store it in the otherwise-unused op_next field
+ * of the top-level OP_NULL. This will be quicker at
+ * run-time, and it will also allow us to remove leading
+ * OP_NULLs by just messing with op_nexts without
+ * 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_STUB
+ || kid->op_type == OP_ENTER);
+ nullop->op_next = kLISTOP->op_next;
+ DEFER(nullop->op_next);
}
/* check that RHS of sort is a single plain array */
if (OP_GIMME(o,0) == G_VOID) {
OP *right = cBINOP->op_first;
if (right) {
+ /* sassign
+ * RIGHT
+ * substr
+ * pushmark
+ * arg1
+ * arg2
+ * ...
+ * becomes
+ *
+ * ex-sassign
+ * substr
+ * pushmark
+ * RIGHT
+ * arg1
+ * arg2
+ * ...
+ */
OP *left = right->op_sibling;
if (left->op_type == OP_SUBSTR
&& (left->op_private & 7) < 4) {
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
- XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+ XopENTRYCUSTOM(o, xop_peep);
if (cpeep)
cpeep(aTHX_ o, oldop);
break;
}
}
- oldoldop = oldop;
- oldop = o;
+ /* did we just null the current op? If so, re-process it to handle
+ * eliding "empty" ops from the chain */
+ if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
+ o->op_opt = 0;
+ o = oldop;
+ }
+ else {
+ oldoldop = oldop;
+ oldop = o;
+ }
}
LEAVE;
}
=head1 Custom Operators
=for apidoc Ao||custom_op_xop
-Return the XOP structure for a given custom op. This function should be
+Return the XOP structure for a given custom op. This macro should be
considered internal to OP_NAME and the other access macros: use them instead.
+This macro does call a function. Prior
+to 5.19.6, this was implemented as a
+function.
=cut
*/
-const XOP *
-Perl_custom_op_xop(pTHX_ const OP *o)
+XOPRETANY
+Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
{
SV *keysv;
HE *he = NULL;
static const XOP xop_null = { 0, 0, 0, 0, 0 };
- PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+ PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
assert(o->op_type == OP_CUSTOM);
/* This is wrong. It assumes a function pointer can be cast to IV,
XopENTRY_set(xop, xop_desc, savepvn(pv, l));
}
Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
- return xop;
}
-
- if (!he) return &xop_null;
-
- xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
- return xop;
+ else {
+ if (!he)
+ xop = (XOP *)&xop_null;
+ else
+ xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+ }
+ {
+ XOPRETANY any;
+ if(field == XOPe_xop_ptr) {
+ any.xop_ptr = xop;
+ } else {
+ const U32 flags = XopFLAGS(xop);
+ if(flags & field) {
+ switch(field) {
+ case XOPe_xop_name:
+ any.xop_name = xop->xop_name;
+ break;
+ case XOPe_xop_desc:
+ any.xop_desc = xop->xop_desc;
+ break;
+ case XOPe_xop_class:
+ any.xop_class = xop->xop_class;
+ break;
+ case XOPe_xop_peep:
+ any.xop_peep = xop->xop_peep;
+ break;
+ default:
+ NOT_REACHED;
+ break;
+ }
+ } else {
+ switch(field) {
+ case XOPe_xop_name:
+ any.xop_name = XOPd_xop_name;
+ break;
+ case XOPe_xop_desc:
+ any.xop_desc = XOPd_xop_desc;
+ break;
+ case XOPe_xop_class:
+ any.xop_class = XOPd_xop_class;
+ break;
+ case XOPe_xop_peep:
+ any.xop_peep = XOPd_xop_peep;
+ break;
+ default:
+ NOT_REACHED;
+ break;
+ }
+ }
+ }
+ return any;
+ }
}
/*
=for apidoc Ao||custom_op_register
-Register a custom op. See L<perlguts/"Custom Operators">.
+Register a custom op.
See L<perlguts/"Custom Operators">.
=cut
*/
OP_SSELECT),
coresub_op(coreargssv, 0, OP_SELECT)
);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_BASEOP:
I<new_pointer> is written into the L</PL_check> array, while the value
previously stored there is written to I<*old_checker_p>.
+The function should be defined like this:
+
+ static OP *new_checker(pTHX_ OP *op) { ... }
+
+It is intended to be called in this manner:
+
+ new_checker(aTHX_ op)
+
+I<old_checker_p> should be defined like this:
+
+ static Perl_check_t old_checker_p;
+
L</PL_check> is global to an entire process, and a module wishing to
hook op checking may find itself invoked more than once per process,
typically in different threads. To handle that situation, this function
Perl_croak(aTHX_ "Magical list constants are not supported");
if (GIMME_V != G_ARRAY) {
EXTEND(SP, 1);
- ST(0) = newSViv((IV)AvFILLp(av)+1);
+ ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
XSRETURN(1);
}
EXTEND(SP, AvFILLp(av)+1);
https://perl5.git.perl.org / perl5.git / blobdiff