Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
OPSLAB *slab2;
- OPSLOT *slot;
#ifdef DEBUGGING
size_t savestack_count = 0;
#endif
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
+ OPSLOT *slot;
for (slot = slab2->opslab_first;
slot->opslot_next;
slot = slot->opslot_next) {
/* FALLTHROUGH */
case OP_TRANS:
case OP_TRANSR:
- if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+ if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
+ && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
+ {
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
dVAR;
OP *kid;
SV* sv;
- U8 want;
SSize_t defer_stack_alloc = 0;
SSize_t defer_ix = -1;
OP **defer_stack = NULL;
PERL_ARGS_ASSERT_SCALARVOID;
do {
+ U8 want;
SV *useless_sv = NULL;
const char* useless = NULL;
}
+/* do all the final processing on an optree (e.g. running the peephole
+ * optimiser on it), then attach it to cv (if cv is non-null)
+ */
+
+static void
+S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
+{
+ OP **startp;
+
+ /* XXX for some reason, evals, require and main optrees are
+ * never attached to their CV; instead they just hang off
+ * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
+ * and get manually freed when appropriate */
+ if (cv)
+ startp = &CvSTART(cv);
+ else
+ startp = PL_in_eval? &PL_eval_start : &PL_main_start;
+
+ *startp = start;
+ optree->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(optree, 1);
+ CALL_PEEP(*startp);
+ finalize_optree(optree);
+ S_prune_chain_head(startp);
+
+ if (cv) {
+ /* now that optimizer has done its work, adjust pad values */
+ pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
+ : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
+}
+
+
/*
=for apidoc finalize_optree
void
Perl_newPROG(pTHX_ OP *o)
{
+ OP *start;
+
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
else
scalar(PL_eval_root);
- PL_eval_start = op_linklist(PL_eval_root);
- PL_eval_root->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(PL_eval_root, 1);
+ start = op_linklist(PL_eval_root);
PL_eval_root->op_next = 0;
i = PL_savestack_ix;
SAVEFREEOP(o);
ENTER;
- CALL_PEEP(PL_eval_start);
- finalize_optree(PL_eval_root);
- S_prune_chain_head(&PL_eval_start);
+ S_process_optree(aTHX_ NULL, PL_eval_root, start);
LEAVE;
PL_savestack_ix = i;
}
}
PL_main_root = op_scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
- PL_main_start = LINKLIST(PL_main_root);
- PL_main_root->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(PL_main_root, 1);
+ start = LINKLIST(PL_main_root);
PL_main_root->op_next = 0;
- CALL_PEEP(PL_main_start);
- finalize_optree(PL_main_root);
- S_prune_chain_head(&PL_main_start);
+ S_process_optree(aTHX_ NULL, PL_main_root, start);
cv_forget_slab(PL_compcv);
PL_compcv = 0;
S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
- OP *curop;
- const SSize_t oldtmps_floor = PL_tmps_floor;
+ OP *curop, *old_next;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
+ COP *old_curcop;
+ U8 oldwarn = PL_dowarn;
SV **svp;
AV *av;
+ I32 old_cxix;
+ COP not_compiling;
+ int ret = 0;
+ dJMPENV;
+ bool op_was_null;
list(o);
if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
+ op_was_null = o->op_type == OP_NULL;
+ if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
+ o->op_type = OP_CUSTOM;
CALL_PEEP(curop);
+ if (op_was_null)
+ o->op_type = OP_NULL;
S_prune_chain_head(&curop);
PL_op = curop;
- Perl_pp_pushmark(aTHX);
- CALLRUNOPS(aTHX);
- PL_op = curop;
- assert (!(curop->op_flags & OPf_SPECIAL));
- assert(curop->op_type == OP_RANGE);
- Perl_pp_anonlist(aTHX);
- PL_tmps_floor = oldtmps_floor;
+
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, G_FAKINGEVAL);
+
+ old_curcop = PL_curcop;
+ StructCopy(old_curcop, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ current COP, but that IN_PERL_RUNTIME is true. */
+ assert(IN_PERL_RUNTIME);
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ PL_diehook = NULL;
+ JMPENV_PUSH(ret);
+
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
+ switch (ret) {
+ case 0:
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
+#endif
+ Perl_pp_pushmark(aTHX);
+ CALLRUNOPS(aTHX);
+ PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
+ Perl_pp_anonlist(aTHX);
+ break;
+ case 3:
+ CLEAR_ERRSV();
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
+ ret);
+ }
+
+ JMPENV_POP;
+ PL_dowarn = oldwarn;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ PL_curcop = old_curcop;
+
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ delete_eval_scope();
+ }
+ if (ret)
+ return o;
OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
rx_flags |= RXf_SPLIT;
}
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
&& !(o2->op_private & OPpPAD_STATE))
{
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional");
+ "Deprecated use of my() in false conditional. "
+ "This will be a fatal error in Perl 5.30");
}
*otherp = NULL;
PL_breakable_sub_gen++;
CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
itself has a refcount. */
CvSLABBED_off(cv);
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
-
- /* now that optimizer has done its work, adjust pad values */
-
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ S_process_optree(aTHX_ cv, block, start);
}
attrs:
PL_breakable_sub_gen++;
CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
itself has a refcount. */
CvSLABBED_off(cv);
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
-
- /* now that optimizer has done its work, adjust pad values */
-
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ S_process_optree(aTHX_ cv, block, start);
}
attrs:
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
CV *cv;
-
GV *gv;
+ OP *root;
+ OP *start;
if (PL_parser && PL_parser->error_count) {
op_free(block);
CvFILE_set_from_cop(cv, PL_curcop);
- pad_tidy(padtidy_FORMAT);
- CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
+ CvROOT(cv) = root;
+ start = LINKLIST(root);
+ root->op_next = 0;
+ S_process_optree(aTHX_ cv, root, start);
cv_forget_slab(cv);
finish:
case OP_HELEM:
break;
case OP_KVASLICE:
- Perl_croak(aTHX_ "delete argument is index/value array slice,"
- " use array slice");
+ o->op_flags |= OPf_SPECIAL;
+ /* FALLTHROUGH */
case OP_KVHSLICE:
- Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
- " hash slice");
+ o->op_private |= OPpKVSLICE;
+ break;
default:
Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
"element or slice");
op_sibling_splice(o, NULL, 0, first);
/* Implicitly take a reference to a regular expression */
- if (first->op_type == OP_MATCH) {
+ if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
OpTYPE_set(first, OP_QR);
}
- if (second->op_type == OP_MATCH) {
+ if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
OpTYPE_set(second, OP_QR);
}
}
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
- HEK *hek;
U32 hash;
char *s;
STRLEN len;
if (kid->op_private & OPpCONST_BARE) {
dVAR;
const char *end;
+ HEK *hek;
if (was_readonly) {
SvREADONLY_off(sv);
}
else {
dVAR;
+ HEK *hek;
if (was_readonly) SvREADONLY_off(sv);
PERL_HASH(hash, s, len);
hek = share_hek(s,
PERL_ARGS_ASSERT_CK_RETURN;
kid = OpSIBLING(cLISTOPo->op_first);
- if (CvLVALUE(PL_compcv)) {
+ if (PL_compcv && CvLVALUE(PL_compcv)) {
for (; kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
case OP_GV:
/* it may be a package var index */
- ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
- if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
+ if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
|| o->op_private != 0
)
break;
&& ( (o->op_private & OPpDEREF) == OPpDEREF_AV
|| (o->op_private & OPpDEREF) == OPpDEREF_HV);
+ /* This doesn't make much sense but is legal:
+ * @{ local $x[0][0] } = 1
+ * Since scope exit will undo the autovivification,
+ * don't bother in the first place. The OP_LEAVE
+ * assertion is in case there are other cases of both
+ * OPpLVAL_INTRO and OPpDEREF which don't include a scope
+ * exit that would undo the local - in which case this
+ * block of code would need rethinking.
+ */
+ if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
+#ifdef DEBUGGING
+ OP *n = o->op_next;
+ while (n && ( n->op_type == OP_NULL
+ || n->op_type == OP_LIST))
+ n = n->op_next;
+ assert(n && n->op_type == OP_LEAVE);
+#endif
+ o->op_private &= ~OPpDEREF;
+ is_deref = FALSE;
+ }
+
if (is_deref) {
ASSUME(!(o->op_flags &
~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
*/
static void
-S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag)
+S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag)
{
OP *lop;
case OP_PADHV:
/* see if %h is used in boolean context */
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
- S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
if (o->op_type != OP_PADHV)
break;
/* FALLTHROUGH */
&& ( kid->op_targ == OP_NEXTSTATE
|| kid->op_targ == OP_DBSTATE ))
|| kid->op_type == OP_STUB
- || kid->op_type == OP_ENTER);
- nullop->op_next = kLISTOP->op_next;
+ || kid->op_type == OP_ENTER
+ || (PL_parser && PL_parser->error_count));
+ nullop->op_next = kid->op_next;
DEFER(nullop->op_next);
}
break;
}
+ case OP_REF:
+ /* see if ref() is used in boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
https://perl5.git.perl.org / perl5.git / blobdiff