#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(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
#else
OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
+#ifndef WIN32
+ /* The context is unused in non-Windows */
+ PERL_UNUSED_CONTEXT;
+#endif
slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
return slab;
}
if (slab->opslab_freed) {
OP **too = &slab->opslab_freed;
o = *too;
- DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
+ DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
DEBUG_S_warn((aTHX_ "Alas! too small"));
o = *(too = &o->op_next);
- if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
+ if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
}
if (o) {
*too = o->op_next;
< SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
slot = &slab2->opslab_slots;
INIT_OPSLOT;
- DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
+ DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
return (void *)o;
}
o->op_type = OP_FREED;
o->op_next = slab->opslab_freed;
slab->opslab_freed = o;
- DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
+ DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
OpslabREFCNT_dec_padok(slab);
}
dVAR;
OPSLAB *slab2;
PERL_ARGS_ASSERT_OPSLAB_FREE;
- DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
+ DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
assert(slab->opslab_refcnt == 1);
for (; slab; slab = slab2) {
slab2 = slab->opslab_next;
#endif
#ifdef PERL_DEBUG_READONLY_OPS
DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
- slab));
+ (void*)slab));
if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
perror("munmap failed");
abort();
S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
- yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
SvUTF8(namesv) | flags);
return o;
}
{
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
- if (PL_madskills)
- return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
}
/*
+=head1 Optree Manipulation Functions
+
=for apidoc alloccopstash
Available only under threaded builds, this function allocates an entry in
/* 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)
{
PERL_ARGS_ASSERT_OP_CLEAR;
-#ifdef PERL_MAD
- mad_free(o->op_madprop);
- o->op_madprop = 0;
-#endif
-
- retry:
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
- if (PL_madskills && o->op_targ != OP_NULL) {
- o->op_type = (Optype)o->op_targ;
- 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)
{
if (o->op_type == OP_NULL)
return;
- if (!PL_madskills)
- op_clear(o);
+ op_clear(o);
o->op_targ = o->op_type;
o->op_type = OP_NULL;
o->op_ppaddr = PL_ppaddr[OP_NULL];
default:
Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
(long) context);
- return 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 */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value @%"SVf"%c%"SVf"%c better written as $%"
SVf"%c%"SVf"%c",
- SVfARG(name), lbrack, keysv, rbrack,
- SVfARG(name), lbrack, keysv, rbrack);
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
OP *
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:
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%%%"SVf"%c%"SVf"%c in scalar context better "
"written as $%"SVf"%c%"SVf"%c",
- SVfARG(name), lbrack, keysv, rbrack,
- SVfARG(name), lbrack, keysv, rbrack);
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
}
return o;
PERL_ARGS_ASSERT_SCALARVOID;
- /* trailing mad null ops don't count as "there" for void processing */
- if (PL_madskills &&
- o->op_type != OP_NULL &&
- o->op_sibling &&
- o->op_sibling->op_type == OP_NULL)
- {
- OP *sib;
- for (sib = o->op_sibling;
- sib && sib->op_type == OP_NULL;
- sib = sib->op_sibling) ;
-
- if (!sib)
- return o;
- }
-
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
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:
SvREFCNT_dec_NN(dsv);
}
else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
}
else
useless = "a constant (undef)";
case OP_AND:
kid = cLOGOPo->op_first;
if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)
- && !PL_madskills) {
+ && (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
o->op_type = OP_OR;
o->op_ppaddr = PL_ppaddr[OP_OR];
}
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:
/* mortalise it, in case warnings are fatal. */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Useless use of %"SVf" in void context",
- sv_2mortal(useless_sv));
+ SVfARG(sv_2mortal(useless_sv)));
}
else if (useless) {
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
/*
=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.
{
PERL_ARGS_ASSERT_FINALIZE_OP;
-#if defined(PERL_MAD) && defined(USE_ITHREADS)
- {
- /* Make sure mad ops are also thread-safe */
- MADPROP *mp = o->op_madprop;
- while (mp) {
- if (mp->mad_type == MAD_OP && mp->mad_vlen) {
- OP *prop_op = (OP *) mp->mad_val;
- /* We only need "Relocate sv to the pad for thread safety.", but this
- easiest way to make sure it traverses everything */
- if (prop_op->op_type == OP_CONST)
- cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
- finalize_op(prop_op);
- }
- mp = mp->mad_next;
- }
- }
-#endif
switch (o->op_type) {
case OP_NEXTSTATE:
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
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)
{
PL_modcount++;
return o;
case OP_STUB:
- if ((o->op_flags & OPf_PARENS) || PL_madskills)
+ if ((o->op_flags & OPf_PARENS))
break;
goto nomod;
case OP_ENTERSUB:
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))
*/
if (o->op_type == OP_CONST)
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
-#ifdef PERL_MAD
- else if (o->op_type == OP_NULL)
- rop = NULL;
-#endif
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
rop = NULL;
return o;
type = o->op_type;
- if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
- (void)my_kid(cUNOPo->op_first, attrs, imopsp);
- return o;
- }
if (type == OP_LIST) {
OP *kid;
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),
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
+ assert(PL_parser);
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %"SVf" will act on scalar(%"SVf")",
- desc, name, name);
+ desc, SVfARG(name), SVfARG(name));
else {
const char * const sample = (isary
? "@array" : "%hash");
=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(&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(&PL_main_start);
cv_forget_slab(PL_compcv);
PL_compcv = 0;
case OP_UC:
case OP_LC:
case OP_FC:
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_COMPILETIME(LC_CTYPE))
+ goto nope;
+#endif
+ break;
case OP_SLT:
case OP_SGT:
case OP_SLE:
case OP_SGE:
case OP_SCMP:
+#ifdef USE_LOCALE_COLLATE
+ if (IN_LC_COMPILETIME(LC_COLLATE))
+ goto nope;
+#endif
+ break;
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (IN_LOCALE_COMPILETIME)
+#ifdef USE_LOCALE_NUMERIC
+ if (IN_LC_COMPILETIME(LC_NUMERIC))
goto nope;
+#endif
break;
case OP_PACK:
if (!cLISTOPo->op_first->op_sibling
CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
-#ifdef PERL_MAD
- /* Can't simply swipe the SV from the pad, because that relies on
- the op being freed "real soon now". Under MAD, this doesn't
- happen (see the #ifdef below). */
- sv = newSVsv(sv);
-#else
pad_swipe(o->op_targ, FALSE);
-#endif
}
else if (SvTEMP(sv)) { /* grab mortal temp? */
SvREFCNT_inc_simple_void(sv);
if (ret)
goto nope;
-#ifndef PERL_MAD
op_free(o);
-#endif
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
else if (!SvIMMORTAL(sv)) {
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
if (type != OP_STRINGIFY) newop->op_folded = 1;
}
- op_getmad(o,newop,'f');
return newop;
nope:
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(&curop);
+ PL_op = curop;
Perl_pp_pushmark(aTHX);
CALLRUNOPS(aTHX);
PL_op = curop;
SvPADTMP_on(*svp);
SvREADONLY_on(*svp);
}
-#ifdef PERL_MAD
- op_getmad(curop,o,'O');
-#else
op_free(curop);
-#endif
LINKLIST(o);
return list(o);
}
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
-#ifdef PERL_MAD
- if (((LISTOP*)last)->op_first && first->op_madprop) {
- MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
- if (mp) {
- while (mp->mad_next)
- mp = mp->mad_next;
- mp->mad_next = first->op_madprop;
- }
- else {
- ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
- }
- }
- first->op_madprop = last->op_madprop;
- last->op_madprop = 0;
-#endif
S_op_destroy(aTHX_ last);
/* Constructors */
-#ifdef PERL_MAD
-
-TOKEN *
-Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
-{
- TOKEN *tk;
- Newxz(tk, 1, TOKEN);
- tk->tk_type = (OPCODE)optype;
- tk->tk_type = 12345;
- tk->tk_lval = lval;
- tk->tk_mad = madprop;
- return tk;
-}
-
-void
-Perl_token_free(pTHX_ TOKEN* tk)
-{
- PERL_ARGS_ASSERT_TOKEN_FREE;
-
- if (tk->tk_type != 12345)
- return;
- mad_free(tk->tk_mad);
- Safefree(tk);
-}
-
-void
-Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
-{
- MADPROP* mp;
- MADPROP* tm;
-
- PERL_ARGS_ASSERT_TOKEN_GETMAD;
-
- if (tk->tk_type != 12345) {
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Invalid TOKEN object ignored");
- return;
- }
- tm = tk->tk_mad;
- if (!tm)
- return;
-
- /* faked up qw list? */
- if (slot == '(' &&
- tm->mad_type == MAD_SV &&
- SvPVX((SV *)tm->mad_val)[0] == 'q')
- slot = 'x';
-
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- token_getmad(tk,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
- mp = mp->mad_next;
- }
- else {
- o->op_madprop = tm;
- mp = o->op_madprop;
- }
- if (mp->mad_key == 'X')
- mp->mad_key = slot; /* just change the first one */
-
- tk->tk_mad = 0;
- }
- else
- mad_free(tm);
- Safefree(tk);
-}
-
-void
-Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
-{
- MADPROP* mp;
- if (!from)
- return;
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- op_getmad(from,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
- }
- else {
- o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
- }
- }
-}
-
-void
-Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
-{
- MADPROP* mp;
- if (!from)
- return;
- if (o) {
- mp = o->op_madprop;
- if (mp) {
- for (;;) {
- /* pretend constant fold didn't happen? */
- if (mp->mad_key == 'f' &&
- (o->op_type == OP_CONST ||
- o->op_type == OP_GV) )
- {
- op_getmad(from,(OP*)mp->mad_val,slot);
- return;
- }
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
- }
- else {
- o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
- }
- }
- else {
- PerlIO_printf(PerlIO_stderr(),
- "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
- op_free(from);
- }
-}
-
-void
-Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
-{
- MADPROP* tm;
- if (!mp || !o)
- return;
- if (slot)
- mp->mad_key = slot;
- tm = o->op_madprop;
- o->op_madprop = mp;
- for (;;) {
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
-}
-
-void
-Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
-{
- if (!o)
- return;
- addmad(tm, &(o->op_madprop), slot);
-}
-
-void
-Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
-{
- MADPROP* mp;
- if (!tm || !root)
- return;
- if (slot)
- tm->mad_key = slot;
- mp = *root;
- if (!mp) {
- *root = tm;
- return;
- }
- for (;;) {
- if (!mp->mad_next)
- break;
- mp = mp->mad_next;
- }
- mp->mad_next = tm;
-}
-
-MADPROP *
-Perl_newMADsv(pTHX_ char key, SV* sv)
-{
- PERL_ARGS_ASSERT_NEWMADSV;
-
- return newMADPROP(key, MAD_SV, sv, 0);
-}
-
-MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
-{
- MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
- mp->mad_next = 0;
- mp->mad_key = key;
- mp->mad_vlen = vlen;
- mp->mad_type = type;
- mp->mad_val = val;
-/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
- return mp;
-}
-
-void
-Perl_mad_free(pTHX_ MADPROP* mp)
-{
-/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
- if (!mp)
- return;
- if (mp->mad_next)
- mad_free(mp->mad_next);
-/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
- PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
- switch (mp->mad_type) {
- case MAD_NULL:
- break;
- case MAD_PV:
- Safefree(mp->mad_val);
- break;
- case MAD_OP:
- if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
- op_free((OP*)mp->mad_val);
- break;
- case MAD_SV:
- sv_free(MUTABLE_SV(mp->mad_val));
- break;
- default:
- PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
- break;
- }
- PerlMemShared_free(mp);
-}
-
-#endif
/*
=head1 Optree construction
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);
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
SV * const rstr =
-#ifdef PERL_MAD
- (repl->op_type == OP_NULL)
- ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
-#endif
((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
rend = r + len;
}
-/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
+/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
* encoded chars in native encoding which makes ranges in the EBCDIC 0..255
* odd. */
Safefree(tsave);
Safefree(rsave);
-#ifdef PERL_MAD
- op_getmad(expr,o,'e');
- op_getmad(repl,o,'r');
-#else
op_free(expr);
op_free(repl);
-#endif
return o;
}
if (grows)
o->op_private |= OPpTRANS_GROWS;
-#ifdef PERL_MAD
- op_getmad(expr,o,'e');
- op_getmad(repl,o,'r');
-#else
op_free(expr);
op_free(repl);
-#endif
return o;
}
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
- if (IN_LOCALE_COMPILETIME) {
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_COMPILETIME(LC_CTYPE)) {
set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
- else if ((! (PL_hints & HINT_BYTES))
- /* Both UNI_8_BIT and locale :not_characters imply Unicode */
- && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
- {
+ else
+#endif
+ if (IN_UNI_8_BIT) {
set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
} 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(&(o->op_next));
if (is_compiletime)
/* runtime finalizes as part of finalizing whole tree */
finalize_optree(o);
: Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
rx_flags, pm->op_pmflags)
);
-#ifdef PERL_MAD
- op_getmad(expr,(OP*)pm,'e');
-#else
op_free(expr);
-#endif
}
else {
/* compile-time pattern that includes literal code blocks */
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)
return CHECKOP(type, pvop);
}
-#ifdef PERL_MAD
-OP*
-#else
void
-#endif
Perl_package(pTHX_ OP *o)
{
dVAR;
SV *const sv = cSVOPo->op_sv;
-#ifdef PERL_MAD
- OP *pegop;
-#endif
PERL_ARGS_ASSERT_PACKAGE;
PL_parser->copline = NOLINE;
PL_parser->expect = XSTATE;
-#ifndef PERL_MAD
op_free(o);
-#else
- if (!PL_madskills) {
- op_free(o);
- return NULL;
- }
-
- pegop = newOP(OP_NULL,0);
- op_getmad(o,pegop,'P');
- return pegop;
-#endif
}
void
op_free(v);
}
-#ifdef PERL_MAD
-OP*
-#else
void
-#endif
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
dVAR;
OP *pack;
OP *imop;
OP *veop;
-#ifdef PERL_MAD
- OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
-#endif
SV *use_version = NULL;
PERL_ARGS_ASSERT_UTILIZE;
if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
- if (PL_madskills)
- op_getmad(idop,pegop,'U');
-
veop = NULL;
if (version) {
SV * const vesv = ((SVOP*)version)->op_sv;
- if (PL_madskills)
- op_getmad(version,pegop,'V');
if (!arg && !SvNIOKp(vesv)) {
arg = version;
}
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB) {
- if (PL_madskills)
- op_getmad(arg,pegop,'S');
imop = arg; /* no import on explicit () */
}
else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
else {
SV *meth;
- if (PL_madskills)
- op_getmad(arg,pegop,'A');
-
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
PL_cop_seqmax++;
-#ifdef PERL_MAD
- return pegop;
-#endif
}
/*
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
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 {
LINKLIST(o);
}
- if (right && right->op_type == OP_SPLIT && !PL_madskills) {
+ if (right && right->op_type == OP_SPLIT) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
&& (first->op_flags & OPf_KIDS)
&& ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
|| (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
- && !PL_madskills) {
+ ) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
- if (PL_madskills) {
- OP *newop = newUNOP(OP_NULL, 0, other);
- op_getmad(first, newop, '1');
- newop->op_targ = type; /* set "was" field */
- return newop;
- }
op_free(first);
if (other->op_type == OP_LEAVE)
other = newUNOP(OP_NULL, OPf_SPECIAL, other);
*otherp = NULL;
if (cstop->op_type == OP_CONST)
cstop->op_private |= OPpCONST_SHORTCIRCUIT;
- if (PL_madskills) {
- first = newUNOP(OP_NULL, 0, first);
- op_getmad(other, first, '2');
- first->op_targ = type; /* set "was" field */
- }
- else
- op_free(other);
+ op_free(other);
return first;
}
}
cstop->op_private & OPpCONST_STRICT) {
no_bareword_allowed(cstop);
}
- if (PL_madskills) {
- /* This is all dead code when PERL_MAD is not defined. */
- live = newUNOP(OP_NULL, 0, live);
- op_getmad(first, live, 'C');
- op_getmad(dead, live, left ? 'e' : 't');
- } else {
- op_free(first);
- op_free(dead);
- }
+ op_free(first);
+ op_free(dead);
if (live->op_type == OP_LEAVE)
live = newUNOP(OP_NULL, OPf_SPECIAL, live);
else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
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 */
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
- OP *madsv = NULL;
PERL_ARGS_ASSERT_NEWFOROP;
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
padoff = sv->op_targ;
- if (PL_madskills)
- madsv = sv;
- else {
- sv->op_targ = 0;
- op_free(sv);
- }
+ sv->op_targ = 0;
+ op_free(sv);
sv = NULL;
}
else
right->op_next = (OP*)listop;
listop->op_next = listop->op_first;
-#ifdef PERL_MAD
- op_getmad(expr,(OP*)listop,'O');
-#else
op_free(expr);
-#endif
expr = (OP*)(listop);
op_null(expr);
iterflags |= OPf_STACKED;
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
- if (madsv)
- op_getmad(madsv, (OP*)loop, 'v');
return wop;
}
/* If we have already created an op, we do not need the label. */
if (o)
-#ifdef PERL_MAD
- op_getmad(label,o,'L');
-#else
op_free(label);
-#endif
else o = newUNOP(type, OPf_STACKED, label);
PL_hints |= HINT_BLOCK_SCOPE;
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;
- if (PL_madskills)
- return NULL;
-
if (!o)
return 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;
}
assert (o || name);
assert (const_svp);
if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
SvREFCNT_inc_simple_void_NN(PL_compcv);
CopLINE_set(PL_curcop, oldline);
}
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SAVEFREESV(cv);
- }
+ SAVEFREESV(cv);
return TRUE;
}
else
ps = NULL;
- if (!PL_madskills) {
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- }
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
if (PL_parser && PL_parser->error_count) {
op_free(block);
if (!block || !ps || *ps || attrs
|| (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)
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);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
- if (PL_madskills)
- goto install_block;
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
) {
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- install_block:
if (!block)
goto attrs;
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
-#ifdef PERL_MAD
- op_getmad(block,newblock,'B');
-#else
op_free(block);
-#endif
block = newblock;
}
CvROOT(cv) = CvLVALUE(cv)
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&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;
store it. */
const I32 gv_fetch_flags
= ec ? GV_NOADD_NOINIT :
- (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
- || PL_madskills)
+ (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
? 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;
else
ps = NULL;
- if (!PL_madskills) {
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- }
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
if (ec) {
op_free(block);
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
)
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);
const_sv
);
}
- if (PL_madskills)
- goto install_block;
op_free(block);
SvREFCNT_dec(PL_compcv);
PL_compcv = NULL;
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- install_block:
if (!block)
goto attrs;
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
-#ifdef PERL_MAD
- op_getmad(block,newblock,'B');
-#else
op_free(block);
-#endif
block = newblock;
}
CvROOT(cv) = CvLVALUE(cv)
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&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>. */
);
}
-#ifdef PERL_MAD
-OP *
-#else
void
-#endif
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
dVAR;
CV *cv;
-#ifdef PERL_MAD
- OP* pegop = newOP(OP_NULL, 0);
-#endif
GV *gv;
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
cv_forget_slab(cv);
finish:
-#ifdef PERL_MAD
- op_getmad(o,pegop,'n');
- op_getmad_weak(block, pegop, 'b');
-#else
op_free(o);
-#endif
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
-#ifdef PERL_MAD
- return pegop;
-#endif
}
OP *
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Using an array as a reference is deprecated");
+ Perl_croak(aTHX_ "Can't use an array as a reference");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
}
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Using a hash as a reference is deprecated");
+ Perl_croak(aTHX_ "Can't use a hash as a reference");
}
return newUNOP(OP_RV2HV, 0, scalar(o));
}
PERL_ARGS_ASSERT_CK_ANONCODE;
cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
- if (!PL_madskills)
- cSVOPo->op_sv = NULL;
+ cSVOPo->op_sv = NULL;
return o;
}
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_CONTEXT;
+ PERL_UNUSED_ARG(o);
+#endif
}
OP *
else if (!(o->op_flags & OPf_KIDS))
newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
if (newop) {
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
S_io_hints(aTHX_ o);
type == OP_RV2AV || type == OP_RV2HV)
return o;
}
-#ifdef PERL_MAD
- op_getmad(kUNOP->op_first,newop,'K');
-#else
op_free(kUNOP->op_first);
-#endif
kUNOP->op_first = newop;
}
/* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
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:
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
o = newop;
}
o = ck_fun(o);
if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
-#ifdef PERL_MAD
- OP* const oldo = o;
-#endif
cUNOPo->op_first = 0;
-#ifndef PERL_MAD
op_free(o);
-#endif
NewOp(1101, enter, 1, LOGOP);
enter->op_type = OP_ENTERTRY;
o->op_type = OP_LEAVETRY;
o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
enter->op_other = o;
- op_getmad(oldo,o,'O');
return o;
}
else {
}
else {
const U8 priv = o->op_private;
-#ifdef PERL_MAD
- OP* const oldo = o;
-#else
op_free(o);
-#endif
o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
- op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
&& !kid->op_folded) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
}
}
else {
-#ifdef PERL_MAD
- OP* const oldo = o;
-#else
op_free(o);
-#endif
if (type == OP_FTTTY)
o = newGVOP(type, OPf_REF, PL_stdingv);
else
o = newUNOP(type, 0, newDEFSVOP());
- op_getmad(oldo,o,'O');
}
return o;
}
numargs++;
sibl = kid->op_sibling;
-#ifdef PERL_MAD
- if (!sibl && kid->op_type == OP_STUB) {
- numargs--;
- break;
- }
-#endif
switch (oa & 7) {
case OA_SCALAR:
/* list seen where single (scalar) arg expected? */
"Useless use of %s with no values",
PL_op_desc[type]);
- if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- OP * const newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
- op_free(kid);
-#endif
- kid = newop;
- kid->op_sibling = sibl;
- *tokid = kid;
- }
- else if (kid->op_type == OP_CONST
+ if (kid->op_type == OP_CONST
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
/* 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 &&
- (kid->op_private & OPpCONST_BARE))
- {
- OP * const newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
- op_free(kid);
-#endif
- kid = newop;
- kid->op_sibling = sibl;
- *tokid = kid;
- }
- else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
+ if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
op_lvalue(kid, type);
break;
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
-#ifdef PERL_MAD
- op_getmad(kid,newop,'K');
-#else
op_free(kid);
-#endif
kid = newop;
}
else if (kid->op_type == OP_READLINE) {
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
-#ifdef PERL_MAD
- if (kid && kid->op_type != OP_STUB)
- return too_many_arguments_pv(o,OP_DESC(o), 0);
- o->op_private |= numargs;
-#else
- /* FIXME - should the numargs move as for the PERL_MAD case? */
+ /* FIXME - should the numargs or-ing move after the too many
+ * arguments check? */
o->op_private |= numargs;
if (kid)
return too_many_arguments_pv(o,OP_DESC(o), 0);
-#endif
listkids(o);
}
else if (PL_opargs[type] & OA_DEFGV) {
-#ifdef PERL_MAD
- OP *newop = newUNOP(type, 0, newDEFSVOP());
- op_getmad(o,newop,'O');
- return newop;
-#else
/* Ordering of these two is important to keep f_map.t passing. */
op_free(o);
return newUNOP(type, 0, newDEFSVOP());
-#endif
}
if (oa) {
else {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
op_free(o);
-#endif
return newop;
}
return o;
&& !(kid->op_flags & OPf_STACKED)
/* Cannot steal the second time! */
&& !(kid->op_private & OPpTARGET_MY)
- /* Keep the full thing for madskills */
- && !PL_madskills
)
{
OP * const kkid = kid->op_sibling;
/* 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
)
)
kSVOP->op_sv = NULL;
}
cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
-#ifdef PERL_MAD
- op_getmad(o,cmop,'O');
-#else
op_free(o);
-#endif
return cmop;
}
}
else {
kid = newDEFSVOP();
}
-#ifndef PERL_MAD
op_free(o);
-#endif
newop = S_new_entersubop(aTHX_ gv, kid);
- op_getmad(o,newop,'O');
return newop;
}
}
argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
-#ifdef PERL_MAD
- {
- OP * const oldo = o;
- o = newUNOP(type, 0, scalar(argop));
- op_getmad(oldo,o,'O');
- return o;
- }
-#else
op_free(o);
return newUNOP(type, 0, scalar(argop));
-#endif
}
return scalar(ck_fun(o));
}
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)
{
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
kid = cLISTOPo->op_first->op_sibling;
cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
-#ifdef PERL_MAD
- op_getmad(kid,o,'S'); /* then delete it */
-#else
op_free(kid); /* then delete it */
-#endif
}
OP *
op_append_elem(OP_SPLIT, o, newDEFSVOP());
kid = kid->op_sibling;
+ assert(kid);
scalar(kid);
if (!kid->op_sibling)
} break;
default: {
return NULL;
- } break;
+ } NOT_REACHED; /* NOTREACHED */
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
if (!aop->op_sibling)
aop = cUNOPx(aop)->op_first;
for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
- if (!(PL_madskills && aop->op_type == OP_STUB)) {
- list(aop);
- op_lvalue(aop, OP_ENTERSUB);
- }
+ list(aop);
+ op_lvalue(aop, OP_ENTERSUB);
}
return entersubop;
}
aop = aop->op_sibling;
for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
while (aop != cvop) {
- OP* o3;
- if (PL_madskills && aop->op_type == OP_STUB) {
- aop = aop->op_sibling;
- continue;
- }
- if (PL_madskills && aop->op_type == OP_NULL)
- o3 = ((UNOP*)aop)->op_first;
- else
- o3 = aop;
+ OP* o3 = aop;
if (proto >= proto_end)
return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
/* _ must be at the end */
if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
+ /* FALLTHROUGH */
case '$':
proto++;
arg++;
GV * const gv = cGVOPx_gv(gvop);
OP * const sibling = aop->op_sibling;
SV * const n = newSVpvs("");
-#ifdef PERL_MAD
- OP * const oldaop = aop;
-#else
op_free(aop);
-#endif
gv_fullname4(n, gv, "", FALSE);
aop = newSVOP(OP_CONST, 0, n);
- op_getmad(oldaop,aop,'O');
prev->op_sibling = aop;
aop->op_sibling = sibling;
}
break;
case '[': case ']':
goto oops;
- break;
+
case '\\':
proto++;
arg++;
else
goto oops;
goto again;
- break;
+
case ']':
if (contextclass) {
const char *p = proto;
aop = cUNOPx(aop)->op_first;
aop = aop->op_sibling;
for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
- if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
- aop = aop->op_sibling;
- }
if (aop != cvop)
(void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
)
);
}
- assert(0);
+ NOT_REACHED;
}
else {
OP *prev, *cvop;
U32 flags;
-#ifdef PERL_MAD
- bool seenarg = FALSE;
-#endif
if (!aop->op_sibling)
aop = cUNOPx(aop)->op_first;
for (cvop = aop;
cvop->op_sibling;
prev=cvop, cvop = cvop->op_sibling)
-#ifdef PERL_MAD
- if (PL_madskills && cvop->op_sibling
- && cvop->op_type != OP_STUB) seenarg = TRUE
-#endif
;
prev->op_sibling = NULL;
flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
-#ifdef PERL_MAD
- if (!PL_madskills || seenarg)
-#endif
(void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
op_free(aop);
}
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 *
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"length() used on %"SVf" (did you mean \"scalar(%s%"SVf
")\"?)",
- name, hash ? "keys " : "", name
+ SVfARG(name), hash ? "keys " : "", SVfARG(name)
);
else if (hash)
/* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
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(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;
+ OP *fop;
+ OP *sop;
if (!o || o->op_opt)
return;
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(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 */
&& 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_sibling->op_next == sibling
- && next->op_next && sibling->op_next)
- {
- next->op_sibling->op_next = sibling->op_next;
- o->op_next = next->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
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)
break;
- {
- OP *fop;
- OP *sop;
-
#define HV_OR_SCALARHV(op) \
( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
? (op) \
if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
fop->op_private |= OPpTRUEBOOL;
#undef HV_OR_SCALARHV
- /* GERONIMO! */
- }
+ /* GERONIMO! */ /* FALLTHROUGH */
case OP_MAPWHILE:
case OP_GREPWHILE:
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) {
}
}
- 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 macro 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.7, this was implemented as a
+This macro does call a function. Prior
+to 5.19.6, this was implemented as a
function.
=cut
/*
=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
*/
}
/*
-=head1 Functions in file op.c
=for apidoc core_prototype
+
This function assigns the prototype of the named core function to C<sv>, or
to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
NULL if the core function has no prototype. C<code> is a code as returned
OP_SSELECT),
coresub_op(coreargssv, 0, OP_SELECT)
);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_BASEOP:
is_const
? "Constant subroutine %"SVf" redefined"
: "Subroutine %"SVf" redefined",
- name);
+ SVfARG(name));
}
/*
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
{
dVAR;
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
if (*old_checker_p) return;
OP_CHECK_MUTEX_LOCK;
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