recursive, but it's recursive on basic blocks, not on tree nodes.
*/
+/* To implement user lexical pragmas, there needs to be a way at run time to
+ get the compile time state of %^H for that block. Storing %^H in every
+ block (or even COP) would be very expensive, so a different approach is
+ taken. The (running) state of %^H is serialised into a tree of HE-like
+ structs. Stores into %^H are chained onto the current leaf as a struct
+ refcounted_he * with the key and the value. Deletes from %^H are saved
+ with a value of PL_sv_placeholder. The state of %^H at any point can be
+ turned back into a regular HV by walking back up the tree from that point's
+ leaf, ignoring any key you've already seen (placeholder or not), storing
+ the rest into the HV structure, then removing the placeholders. Hence
+ memory is only used to store the %^H deltas from the enclosing COP, rather
+ than the entire %^H on each COP.
+
+ To cause actions on %^H to write out the serialisation records, it has
+ magic type 'H'. This magic (itself) does nothing, but its presence causes
+ the values to gain magic type 'h', which has entries for set and clear.
+ C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ saves the current C<PL_compiling.cop_hints> on the save stack, so that it
+ will be correctly restored when any inner compiling scope is exited.
+*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
STATIC void
S_no_bareword_allowed(pTHX_ const OP *o)
{
+ 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",
cSVOPo_sv));
{
dVAR;
+#ifdef PERL_MAD
+ /* if (o->op_madprop && o->op_madprop->mad_next)
+ abort(); */
+ /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
+ "modification of a read only value" for a reason I can't fathom why.
+ It's the "" stringification of $_, where $_ was set to '' in a foreach
+ loop, but it defies simplification into a small test case.
+ However, commenting them out has caused ext/List/Util/t/weak.t to fail
+ the last test. */
+ /*
+ 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 = o->op_targ;
+ o->op_targ = 0;
+ goto retry;
+ }
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
+ PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
/*EMPTY*/
SvREFCNT_dec(cop->cop_io);
#endif
}
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints);
}
void
dVAR;
if (o->op_type == OP_NULL)
return;
- op_clear(o);
+ if (!PL_madskills)
+ op_clear(o);
o->op_targ = o->op_type;
o->op_type = OP_NULL;
o->op_ppaddr = PL_ppaddr[OP_NULL];
SV* sv;
U8 want;
+ /* 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_SETSTATE
|| o->op_type == OP_DBSTATE
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ if (o->op_private & OPpCONST_ARYBASE)
+ useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = 0;
+ useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
- useless = 0;
+ useless = NULL;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
(before the invention of POD) was based on a
if (strnEQ(maybe_macro, "di", 2) ||
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
- useless = 0;
+ useless = NULL;
}
}
}
PL_modcount++;
return o;
case OP_CONST:
- if (!(o->op_private & (OPpCONST_ARYBASE)))
+ if (!(o->op_private & OPpCONST_ARYBASE))
goto nomod;
localize = 0;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
+ CopARYBASE_set(&PL_compiling,
+ (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
PL_eval_start = 0;
}
else if (!type) {
- SAVEI32(PL_compiling.cop_arybase);
- PL_compiling.cop_arybase = 0;
+ SAVECOPARYBASE(&PL_compiling);
+ CopARYBASE_set(&PL_compiling, 0);
}
else if (type == OP_REFGEN)
goto nomod;
Perl_croak(aTHX_ "That use of $[ is unsupported");
break;
case OP_STUB:
- if (o->op_flags & OPf_PARENS)
+ if (o->op_flags & OPf_PARENS || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
*/
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;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
- } else if (type == OP_UNDEF) {
+ } else if (type == OP_UNDEF
+#ifdef PERL_MAD
+ || type == OP_STUB
+#endif
+ ) {
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
Perl_invert(pTHX_ OP *o)
{
if (!o)
- return o;
- /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return NULL;
return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVESPTR(PL_compiling.cop_warnings);
- if (! specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
- }
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
SAVESPTR(PL_compiling.cop_io);
if (! specialCopIO(PL_compiling.cop_io)) {
PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
{
if (o->op_type == OP_LIST) {
OP * const o2
- = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
- SVt_PV)));
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
{
dVAR;
register OP *curop;
+ OP *newop;
I32 type = o->op_type;
- SV *sv;
+ SV *sv = NULL;
+ int ret = 0;
+ I32 oldscope;
+ OP *old_next;
+ dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
}
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
PL_op = curop;
- CALLRUNOPS(aTHX);
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- SvREFCNT_inc_simple_void(sv);
- SvTEMP_off(sv);
+
+ oldscope = PL_scopestack_ix;
+ create_eval_scope(G_FAKINGEVAL);
+
+ JMPENV_PUSH(ret);
+
+ switch (ret) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ, FALSE);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ SvREFCNT_inc_simple_void(sv);
+ SvTEMP_off(sv);
+ }
+ break;
+ case 3:
+ /* Something tried to die. Abandon constant folding. */
+ /* Pretend the error never happened. */
+ sv_setpvn(ERRSV,"",0);
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
+
+ JMPENV_POP;
+
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
+
+ if (ret)
+ goto nope;
+
+#ifndef PERL_MAD
op_free(o);
+#endif
+ assert(sv);
if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, (GV*)sv);
- return newSVOP(OP_CONST, 0, sv);
+ newop = newGVOP(OP_GV, 0, (GV*)sv);
+ else
+ newop = newSVOP(OP_CONST, 0, sv);
+ op_getmad(o,newop,'f');
+ return newop;
- nope:
+ nope:
return o;
}
o->op_opt = 0; /* needs to be revisited in peep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
+#ifdef PERL_MAD
+ op_getmad(curop,o,'O');
+#else
op_free(curop);
+#endif
linklist(o);
return list(o);
}
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
+#ifdef PERL_MAD
+ if (last->op_first && first->op_madprop) {
+ MADPROP *mp = last->op_first->op_madprop;
+ if (mp) {
+ while (mp->mad_next)
+ mp = mp->mad_next;
+ mp->mad_next = first->op_madprop;
+ }
+ else {
+ last->op_first->op_madprop = first->op_madprop;
+ }
+ }
+ first->op_madprop = last->op_madprop;
+ last->op_madprop = 0;
+#endif
+
FreeOp(last);
return (OP*)first;
/* 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)
+{
+ 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;
+ 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)
+{
+ return newMADPROP(key, MAD_SV, sv, 0);
+}
+
+MADPROP *
+Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+{
+ MADPROP *mp;
+ Newxz(mp, 1, 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_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((char*)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((SV*)mp->mad_val);
+ break;
+ default:
+ PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
+ break;
+ }
+ Safefree(mp);
+}
+
+#endif
+
OP *
Perl_newNULLLIST(pTHX)
{
const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
+ const U32 flags = UTF8_ALLOW_DEFAULT;
if (!from_utf) {
STRLEN len = tlen;
i = 0;
transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
}
else {
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
}
else
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;
}
PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
+#ifdef PERL_MAD
+ op_getmad(expr,(OP*)pm,'e');
+#else
op_free(expr);
+#endif
}
else {
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
return CHECKOP(type, pvop);
}
+#ifdef PERL_MAD
+OP*
+#else
void
+#endif
Perl_package(pTHX_ OP *o)
{
dVAR;
const char *name;
STRLEN len;
+#ifdef PERL_MAD
+ OP *pegop;
+#endif
save_hptr(&PL_curstash);
save_item(PL_curstname);
name = SvPV_const(cSVOPo->op_sv, len);
PL_curstash = gv_stashpvn(name, len, TRUE);
sv_setpvn(PL_curstname, name, len);
- op_free(o);
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_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
}
+#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 = newOP(OP_NULL,0);
+#endif
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 (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)) {
imop = NULL; /* use 5.0; */
if (!aver)
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));
PL_copline = NOLINE;
PL_expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
+
+#ifdef PERL_MAD
+ if (!PL_madskills) {
+ /* FIXME - don't allocate pegop if !PL_madskills */
+ op_free(pegop);
+ return NULL;
+ }
+ return pegop;
+#endif
}
/*
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+ newGVOP(OP_GV, 0, gv))))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
if (PL_eval_start)
PL_eval_start = 0;
else if (left->op_type == OP_CONST) {
+ /* FIXME for MAD */
/* Result of assignment is always 1 (or we'd be dead already) */
return newSVOP(OP_CONST, 0, newSViv(1));
}
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = NULL; /* don't free split */
right->op_next = tmpop->op_next; /* fix starting loc */
+#ifdef PERL_MAD
+ op_getmad(o,right,'R'); /* blow off assign */
+#else
op_free(o); /* blow off assign */
+#endif
right->op_flags &= ~OPf_WANT;
/* "I don't know and I don't care." */
return right;
if (PL_eval_start)
PL_eval_start = 0;
else {
- o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
+ /* FIXME for MAD */
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
+ o->op_private |= OPpCONST_ARYBASE;
}
}
return o;
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = (U8)flags;
- cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(cop, PL_hints);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- PL_compiling.op_private = cop->op_private;
+ CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
if (label) {
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
- cop->cop_arybase = PL_curcop->cop_arybase;
- if (specialWARN(PL_curcop->cop_warnings))
- cop->cop_warnings = PL_curcop->cop_warnings ;
- else
- cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
if (specialCopIO(PL_curcop->cop_io))
cop->cop_io = PL_curcop->cop_io;
else
cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+ cop->cop_hints = PL_curcop->cop_hints;
+ if (cop->cop_hints) {
+ HINTS_REFCNT_LOCK;
+ cop->cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
if (PL_copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
scalarboolean(first);
/* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
- if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
+ if (first->op_type == OP_NOT
+ && (first->op_flags & OPf_SPECIAL)
+ && (first->op_flags & OPf_KIDS)) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
if (o->op_next)
first->op_next = o->op_next;
cUNOPo->op_first = NULL;
+#ifdef PERL_MAD
+ op_getmad(o,first,'O');
+#else
op_free(o);
+#endif
}
}
if (first->op_type == OP_CONST) {
if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
- op_free(first);
*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);
return other;
}
else {
"Deprecated use of my() in false conditional");
}
- op_free(other);
*otherp = NULL;
if (first->op_type == OP_CONST)
first->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);
return first;
}
}
no_bareword_allowed(first);
}
if (SvTRUE(((SVOP*)first)->op_sv)) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ trueop = newUNOP(OP_NULL, 0, trueop);
+ op_getmad(first,trueop,'C');
+ op_getmad(falseop,trueop,'e');
+ }
+ /* FIXME for MAD - should there be an ELSE here? */
+#else
op_free(first);
op_free(falseop);
+#endif
return trueop;
}
else {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ falseop = newUNOP(OP_NULL, 0, falseop);
+ op_getmad(first,falseop,'C');
+ op_getmad(trueop,falseop,'t');
+ }
+ /* FIXME for MAD - should there be an ELSE here? */
+#else
op_free(first);
op_free(trueop);
+#endif
return falseop;
}
}
break;
case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
+ if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
break;
case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
+ if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
PADOFFSET padoff = 0;
I32 iterflags = 0;
I32 iterpflags = 0;
+ OP *madsv = NULL;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
padoff = sv->op_targ;
- sv->op_targ = 0;
- op_free(sv);
+ if (PL_madskills)
+ madsv = sv;
+ else {
+ sv->op_targ = 0;
+ op_free(sv);
+ }
sv = NULL;
}
else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
padoff = sv->op_targ;
- sv->op_targ = 0;
- iterflags |= OPf_SPECIAL;
- op_free(sv);
+ if (PL_madskills)
+ madsv = sv;
+ else {
+ sv->op_targ = 0;
+ iterflags |= OPf_SPECIAL;
+ op_free(sv);
+ }
sv = NULL;
}
else
* set the STACKED flag to indicate that these values are to be
* treated as min/max values by 'pp_iterinit'.
*/
- UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
OP* const right = left->op_sibling;
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 = tmp;
}
#else
- Renew(loop, 1, LOOP);
+ loop = PerlMemShared_realloc(loop, sizeof(LOOP));
#endif
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
+ if (madsv)
+ op_getmad(madsv, (OP*)loop, 'v');
PL_copline = forline;
return newSTATEOP(0, label, wop);
}
? SvPVx_nolen_const(((SVOP*)label)->op_sv)
: ""));
}
+#ifdef PERL_MAD
+ op_getmad(label,o,'L');
+#else
op_free(label);
+#endif
}
else {
/* Check whether it's going to be a goto &function */
*/
STATIC
bool
-S_looks_like_bool(pTHX_ OP *o)
+S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
switch(o->op_type) {
OP *
Perl_newWHENOP(pTHX_ OP *cond, OP *block)
{
- bool cond_llb = (!cond || looks_like_bool(cond));
+ const bool cond_llb = (!cond || looks_like_bool(cond));
OP *cond_op;
if (cond_llb)
return sv;
}
+#ifdef PERL_MAD
+OP *
+#else
void
+#endif
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
+#if 0
+ /* This would be the return value, but the return cannot be reached. */
+ OP* pegop = newOP(OP_NULL, 0);
+#endif
+
PERL_UNUSED_ARG(floor);
if (o)
if (block)
SAVEFREEOP(block);
Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+#ifdef PERL_MAD
+ NORETURN_FUNCTION_END;
+#endif
}
CV *
full GV and CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
- = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
+ = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
: (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
gv_fetch_flags, SVt_PVCV);
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
+ if (!PL_madskills) {
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ }
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
}
#endif
- if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
+ 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, NULL);
cv_ckproto(cv, gv, ps);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- if (!block && !attrs) {
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )&& !attrs) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
SAVEFREESV(PL_compcv);
goto done;
}
- if (block) {
+ if (block
+#ifdef PERL_MAD
+ && block->op_type != OP_NULL
+#endif
+ ) {
if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
: "Subroutine %s redefined", name);
CopLINE_set(PL_curcop, oldline);
}
- SvREFCNT_dec(cv);
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
cv = NULL;
}
}
}
if (const_sv) {
- SvREFCNT_inc_void_NN(const_sv);
+ SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
GvCV(gv) = NULL;
cv = newCONSTSUB(NULL, name, const_sv);
}
+ PL_sub_generation++;
+ if (PL_madskills)
+ goto install_block;
op_free(block);
SvREFCNT_dec(PL_compcv);
PL_compcv = NULL;
- PL_sub_generation++;
goto done;
}
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
* before we clobber PL_compcv.
*/
- if (cv && !block) {
+ if (cv && (!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
rcv = (SV*)cv;
/* Might have had built-in attributes applied -- propagate them. */
CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
- if (!block) {
+ if (
+#ifdef PERL_MAD
+ (
+#endif
+ !block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL) && !PL_madskills
+#endif
+ ) {
/* got here with just attrs -- work done, so bug out */
SAVEFREESV(PL_compcv);
goto done;
cv = PL_compcv;
if (name) {
GvCV(gv) = cv;
+ if (PL_madskills) {
+ if (strEQ(name, "import")) {
+ PL_formfeed = (SV*)cv;
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+ }
+ }
GvCVGEN(gv) = 0;
PL_sub_generation++;
}
}
}
}
+ install_block:
if (!block)
goto done;
else {
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
+ OP* newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+ op_getmad(block,newblock,'B');
+#else
op_free(block);
- block = newSTATEOP(0, NULL, 0);
+#endif
+ block = newblock;
}
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
return cv;
}
+#ifdef PERL_MAD
+OP *
+#else
void
+#endif
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
dVAR;
register CV *cv;
+#ifdef PERL_MAD
+ OP* pegop = newOP(OP_NULL, 0);
+#endif
GV * const gv = o
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
+#ifdef PERL_MAD
+ op_getmad(o,pegop,'n');
+ op_getmad_weak(block, pegop, 'b');
+#else
op_free(o);
+#endif
PL_copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_MAD
+ return pegop;
+#endif
}
OP *
Perl_ck_anoncode(pTHX_ OP *o)
{
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
- cSVOPo->op_sv = NULL;
+ if (!PL_madskills)
+ cSVOPo->op_sv = NULL;
return o;
}
return o;
}
+#ifdef PERL_MAD
+ op_getmad(kUNOP->op_first,newop,'K');
+#else
op_free(kUNOP->op_first);
+#endif
kUNOP->op_first = newop;
}
o->op_ppaddr = PL_ppaddr[++o->op_type];
Perl_ck_eof(pTHX_ OP *o)
{
dVAR;
- const I32 type = o->op_type;
if (o->op_flags & OPf_KIDS) {
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);
- o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+#endif
+ o = newop;
}
return ck_fun(o);
}
}
else 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 {
+#ifdef PERL_MAD
+ OP* const oldo = o;
+#else
op_free(o);
+#endif
o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up */
- OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+ OP *hhop = newSVOP(OP_CONST, 0,
+ (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
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);
- o = newop;
- return o;
+#endif
+ return newop;
}
- else {
- if ((PL_hints & HINT_FILETEST_ACCESS) &&
- OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
- }
if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
&& kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
o->op_private |= OPpFT_STACKED;
}
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;
}
while (oa && kid) {
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? */
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
((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;
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
((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;
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(o,OP_DESC(o));
+ o->op_private |= numargs;
+#else
+ /* FIXME - should the numargs move as for the PERL_MAD case? */
o->op_private |= numargs;
if (kid)
return too_many_arguments(o,OP_DESC(o));
+#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) {
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop;
+ LOGOP *gwop = NULL;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
I32 offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
- NewOp(1101, gwop, 1, LOGOP);
+ /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
if (o->op_flags & OPf_STACKED) {
OP* k;
for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
+ NewOp(1101, gwop, 1, LOGOP);
kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
Perl_croak(aTHX_ "panic: ck_grep");
kid = kUNOP->op_first;
+ if (!gwop)
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
gwop->op_first = listkids(o);
/* Now we do not need PADSV and SASSIGN. */
kid->op_sibling = o->op_sibling; /* NULL */
cLISTOPo->op_first = NULL;
+#ifdef PERL_MAD
+ op_getmad(o,kid,'O');
+ op_getmad(kkid,kid,'M');
+#else
op_free(o);
op_free(kkid);
+#endif
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
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;
}
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
OP * const kid = cUNOPo->op_first;
+ OP * newop;
+
cUNOPo->op_first = 0;
+#ifndef PERL_MAD
op_free(o);
- return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
+#endif
+ newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, kid,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0,
+ gv))))));
+ op_getmad(o,newop,'O');
+ return newop;
}
return ck_fun(o);
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+ /* FIXME - this can be refactored to reduce code in #ifdefs */
+#ifdef PERL_MAD
+ OP * const oldo = o;
+#else
op_free(o);
+#endif
argop = newUNOP(OP_RV2AV, 0,
scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
+#ifdef PERL_MAD
+ o = newUNOP(type, 0, scalar(argop));
+ op_getmad(oldo,o,'O');
+ return o;
+#else
return newUNOP(type, 0, scalar(argop));
+#endif
}
return scalar(modkids(ck_fun(o), type));
}
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 *
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
+ OP* o3;
+ if (PL_madskills && o2->op_type == OP_NULL)
+ o3 = ((UNOP*)o2)->op_first;
+ else
+ o3 = o2;
if (proto) {
switch (*proto) {
case '\0':
case '&':
proto++;
arg++;
- if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
+ if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
bad_type(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o2);
+ gv_ename(namegv), o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
proto++;
arg++;
- if (o2->op_type == OP_RV2GV)
+ if (o3->op_type == OP_RV2GV)
goto wrapref; /* autoconvert GLOB -> GLOBref */
- else if (o2->op_type == OP_CONST)
- o2->op_private &= ~OPpCONST_STRICT;
- else if (o2->op_type == OP_ENTERSUB) {
+ else if (o3->op_type == OP_CONST)
+ o3->op_private &= ~OPpCONST_STRICT;
+ else if (o3->op_type == OP_ENTERSUB) {
/* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o2)->op_first;
+ OP *gvop = ((UNOP*)o3)->op_first;
if (gvop && gvop->op_type == OP_NULL) {
gvop = ((UNOP*)gvop)->op_first;
if (gvop) {
GV * const gv = cGVOPx_gv(gvop);
OP * const sibling = o2->op_sibling;
SV * const n = newSVpvs("");
+#ifdef PERL_MAD
+ OP * const oldo2 = o2;
+#else
op_free(o2);
+#endif
gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
+ op_getmad(oldo2,o2,'O');
prev->op_sibling = o2;
o2->op_sibling = sibling;
}
*p = '\0';
while (*--p != '[');
bad_type(arg, Perl_form(aTHX_ "one of %s", p),
- gv_ename(namegv), o2);
+ gv_ename(namegv), o3);
*proto = s;
} else
goto oops;
break;
case '*':
- if (o2->op_type == OP_RV2GV)
+ if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o2);
+ bad_type(arg, "symbol", gv_ename(namegv), o3);
break;
case '&':
- if (o2->op_type == OP_ENTERSUB)
+ if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+ bad_type(arg, "subroutine entry", gv_ename(namegv),
+ o3);
break;
case '$':
- if (o2->op_type == OP_RV2SV ||
- o2->op_type == OP_PADSV ||
- o2->op_type == OP_HELEM ||
- o2->op_type == OP_AELEM ||
- o2->op_type == OP_THREADSV)
+ if (o3->op_type == OP_RV2SV ||
+ o3->op_type == OP_PADSV ||
+ o3->op_type == OP_HELEM ||
+ o3->op_type == OP_AELEM ||
+ o3->op_type == OP_THREADSV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "scalar", gv_ename(namegv), o2);
+ bad_type(arg, "scalar", gv_ename(namegv), o3);
break;
case '@':
- if (o2->op_type == OP_RV2AV ||
- o2->op_type == OP_PADAV)
+ if (o3->op_type == OP_RV2AV ||
+ o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o2);
+ bad_type(arg, "array", gv_ename(namegv), o3);
break;
case '%':
- if (o2->op_type == OP_RV2HV ||
- o2->op_type == OP_PADHV)
+ if (o3->op_type == OP_RV2HV ||
+ o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o2);
+ bad_type(arg, "hash", gv_ename(namegv), o3);
break;
wrapref:
{
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
+#ifdef PERL_MAD
+ OP * const oldo = o;
+#else
op_free(o);
+#endif
o=newSVOP(OP_CONST, 0, newSViv(0));
+ op_getmad(oldo,o,'O');
}
return o;
}
Perl_ck_substr(pTHX_ OP *o)
{
o = ck_fun(o);
- if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
+ if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
if (kid->op_type == OP_NULL)
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) - PL_curcop->cop_arybase)
+ (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
<= 255 &&
i >= 0)
{
https://perl5.git.perl.org / perl5.git / blobdiff