op_free()
*/
+#define dDEFER_OP \
+ SSize_t defer_stack_alloc = 0; \
+ SSize_t defer_ix = -1; \
+ OP **defer_stack = NULL;
+#define DEFER_OP_CLEANUP Safefree(defer_stack)
#define DEFERRED_OP_STEP 100
#define DEFER_OP(o) \
STMT_START { \
DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
gotit:
-#ifdef PERL_OP_PARENT
/* moresib == 0, op_sibling == 0 implies a solitary unattached op */
assert(!o->op_moresib);
assert(!o->op_sibparent);
-#endif
return (void *)o;
}
{
dVAR;
OPCODE type;
- SSize_t defer_ix = -1;
- SSize_t defer_stack_alloc = 0;
- OP **defer_stack = NULL;
+ dDEFER_OP;
do {
PL_op = NULL;
} while ( (o = POP_DEFERRED_OP()) );
- Safefree(defer_stack);
+ DEFER_OP_CLEANUP;
}
/* S_op_clear_gv(): free a GV attached to an OP */
}
STATIC void
-S_forget_pmop(pTHX_ PMOP *const o
- )
+S_forget_pmop(pTHX_ PMOP *const o)
{
HV * const pmstash = PmopSTASH(o);
Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}
-
-#ifdef PERL_OP_PARENT
-
/*
=for apidoc op_parent
Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
-This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
*/
return o->op_sibparent;
}
-#endif
-
-
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
*
dVAR;
OP *kid;
SV* sv;
- SSize_t defer_stack_alloc = 0;
- SSize_t defer_ix = -1;
- OP **defer_stack = NULL;
OP *o = arg;
+ dDEFER_OP;
PERL_ARGS_ASSERT_SCALARVOID;
}
} while ( (o = POP_DEFERRED_OP()) );
- Safefree(defer_stack);
+ DEFER_OP_CLEANUP;
return arg;
}
}
else if ( topop->op_type == OP_CONCAT
&& (topop->op_flags & OPf_STACKED)
- && (cUNOPo->op_first->op_flags & OPf_MOD)
&& (!(topop->op_private & OPpCONCAT_NESTED))
)
{
OP *prev;
/* set prev to the sibling *before* the arg to be cut out,
- * e.g.:
+ * e.g. when cutting EXPR:
*
* |
- * kid= CONST
+ * kid= CONCAT
* |
- * prev= CONST -- EXPR
+ * prev= CONCAT -- EXPR
* |
*/
if (argp == args && kid->op_type != OP_CONCAT) {
- /* in e.g. '$x . = f(1)' there's no RHS concat tree
+ /* in e.g. '$x .= f(1)' there's no RHS concat tree
* so the expression to be cut isn't kid->op_last but
* kid itself */
OP *o1, *o2;
STATIC void
S_optimize_op(pTHX_ OP* o)
{
- OP *kid;
+ dDEFER_OP;
PERL_ARGS_ASSERT_OPTIMIZE_OP;
+ do {
assert(o->op_type != OP_FREED);
switch (o->op_type) {
case OP_SUBST:
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
break;
default:
break;
}
- if (!(o->op_flags & OPf_KIDS))
- return;
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
+ DEFER_OP(kid);
+ }
+ } while ( ( o = POP_DEFERRED_OP() ) );
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- optimize_op(kid);
+ DEFER_OP_CLEANUP;
}
}
#endif
+/*
+=for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
+
+Return the next op in a depth-first traversal of the op tree,
+returning NULL when the traversal is complete.
+
+The initial call must supply the root of the tree as both top and o.
+
+For now it's static, but it may be exposed to the API in the future.
+
+=cut
+*/
+
+STATIC OP*
+S_traverse_op_tree(OP *top, OP *o) {
+ OP *sib;
+
+ PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
+
+ if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
+ return cUNOPo->op_first;
+ }
+ else if ((sib = OpSIBLING(o))) {
+ return sib;
+ }
+ else {
+ OP *parent = o->op_sibparent;
+ assert(!(o->op_moresib));
+ while (parent && parent != top) {
+ OP *sib = OpSIBLING(parent);
+ if (sib)
+ return sib;
+ parent = parent->op_sibparent;
+ }
+
+ return NULL;
+ }
+}
STATIC void
S_finalize_op(pTHX_ OP* o)
{
+ OP * const top = o;
PERL_ARGS_ASSERT_FINALIZE_OP;
- assert(o->op_type != OP_FREED);
+ do {
+ assert(o->op_type != OP_FREED);
- switch (o->op_type) {
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- PL_curcop = ((COP*)o); /* for warnings */
- break;
- case OP_EXEC:
- if (OpHAS_SIBLING(o)) {
- OP *sib = OpSIBLING(o);
- if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
- && ckWARN(WARN_EXEC)
- && OpHAS_SIBLING(sib))
- {
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
+ case OP_EXEC:
+ if (OpHAS_SIBLING(o)) {
+ OP *sib = OpSIBLING(o);
+ if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
+ && ckWARN(WARN_EXEC)
+ && OpHAS_SIBLING(sib))
+ {
const OPCODE type = OpSIBLING(sib)->op_type;
if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
const line_t oldline = CopLINE(PL_curcop);
"\t(Maybe you meant system() when you said exec()?)\n");
CopLINE_set(PL_curcop, oldline);
}
- }
- }
- break;
+ }
+ }
+ break;
- case OP_GV:
- if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV * const gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
- /* XXX could check prototype here instead of just carping */
- SV * const sv = sv_newmortal();
- gv_efullname3(sv, gv, NULL);
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%" SVf "() called too early to check prototype",
- SVfARG(sv));
- }
- }
- break;
+ case OP_GV:
+ if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
+ GV * const gv = cGVOPo_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
+ /* XXX could check prototype here instead of just carping */
+ SV * const sv = sv_newmortal();
+ gv_efullname3(sv, gv, NULL);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "%" SVf "() called too early to check prototype",
+ SVfARG(sv));
+ }
+ }
+ break;
- case OP_CONST:
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
+ case OP_CONST:
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
#ifdef USE_ITHREADS
- /* FALLTHROUGH */
- case OP_HINTSEVAL:
- op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
+ /* FALLTHROUGH */
+ case OP_HINTSEVAL:
+ op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#endif
- break;
+ break;
#ifdef USE_ITHREADS
- /* Relocate all the METHOP's SVs to the pad for thread safety. */
- case OP_METHOD_NAMED:
- case OP_METHOD_SUPER:
- case OP_METHOD_REDIR:
- case OP_METHOD_REDIR_SUPER:
- op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
- break;
+ /* Relocate all the METHOP's SVs to the pad for thread safety. */
+ case OP_METHOD_NAMED:
+ case OP_METHOD_SUPER:
+ case OP_METHOD_REDIR:
+ case OP_METHOD_REDIR_SUPER:
+ op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
+ break;
#endif
- case OP_HELEM: {
- UNOP *rop;
- SVOP *key_op;
- OP *kid;
-
- if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
- break;
+ case OP_HELEM: {
+ UNOP *rop;
+ SVOP *key_op;
+ OP *kid;
- rop = (UNOP*)((BINOP*)o)->op_first;
+ if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
+ break;
- goto check_keys;
+ rop = (UNOP*)((BINOP*)o)->op_first;
- case OP_HSLICE:
- S_scalar_slice_warning(aTHX_ o);
- /* FALLTHROUGH */
+ goto check_keys;
- case OP_KVHSLICE:
- kid = OpSIBLING(cLISTOPo->op_first);
- if (/* I bet there's always a pushmark... */
- OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
- && OP_TYPE_ISNT_NN(kid, OP_CONST))
- {
- break;
- }
+ case OP_HSLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ /* FALLTHROUGH */
- key_op = (SVOP*)(kid->op_type == OP_CONST
- ? kid
- : OpSIBLING(kLISTOP->op_first));
+ case OP_KVHSLICE:
+ kid = OpSIBLING(cLISTOPo->op_first);
+ if (/* I bet there's always a pushmark... */
+ OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
+ && OP_TYPE_ISNT_NN(kid, OP_CONST))
+ {
+ break;
+ }
- rop = (UNOP*)((LISTOP*)o)->op_last;
+ key_op = (SVOP*)(kid->op_type == OP_CONST
+ ? kid
+ : OpSIBLING(kLISTOP->op_first));
- check_keys:
- if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
- rop = NULL;
- S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
- break;
- }
- case OP_NULL:
- if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
- break;
- /* FALLTHROUGH */
- case OP_ASLICE:
- S_scalar_slice_warning(aTHX_ o);
- break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
- case OP_SUBST: {
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
- break;
- }
- default:
- break;
- }
+ check_keys:
+ if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
+ rop = NULL;
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
+ break;
+ }
+ case OP_NULL:
+ if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
+ break;
+ /* FALLTHROUGH */
+ case OP_ASLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ break;
- if (o->op_flags & OPf_KIDS) {
- OP *kid;
+ case OP_SUBST: {
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
+ }
+ default:
+ break;
+ }
#ifdef DEBUGGING
- /* check that op_last points to the last sibling, and that
- * the last op_sibling/op_sibparent field points back to the
- * parent, and that the only ops with KIDS are those which are
- * entitled to them */
- U32 type = o->op_type;
- U32 family;
- bool has_last;
-
- if (type == OP_NULL) {
- type = o->op_targ;
- /* ck_glob creates a null UNOP with ex-type GLOB
- * (which is a list op. So pretend it wasn't a listop */
- if (type == OP_GLOB)
- type = OP_NULL;
- }
- family = PL_opargs[type] & OA_CLASS_MASK;
-
- has_last = ( family == OA_BINOP
- || family == OA_LISTOP
- || family == OA_PMOP
- || family == OA_LOOP
- );
- assert( has_last /* has op_first and op_last, or ...
- ... has (or may have) op_first: */
- || family == OA_UNOP
- || family == OA_UNOP_AUX
- || family == OA_LOGOP
- || family == OA_BASEOP_OR_UNOP
- || family == OA_FILESTATOP
- || family == OA_LOOPEXOP
- || family == OA_METHOP
- || type == OP_CUSTOM
- || type == OP_NULL /* new_logop does this */
- );
-
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
-# ifdef PERL_OP_PARENT
- if (!OpHAS_SIBLING(kid)) {
- if (has_last)
- assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibparent == o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+
+ /* check that op_last points to the last sibling, and that
+ * the last op_sibling/op_sibparent field points back to the
+ * parent, and that the only ops with KIDS are those which are
+ * entitled to them */
+ U32 type = o->op_type;
+ U32 family;
+ bool has_last;
+
+ if (type == OP_NULL) {
+ type = o->op_targ;
+ /* ck_glob creates a null UNOP with ex-type GLOB
+ * (which is a list op. So pretend it wasn't a listop */
+ if (type == OP_GLOB)
+ type = OP_NULL;
+ }
+ family = PL_opargs[type] & OA_CLASS_MASK;
+
+ has_last = ( family == OA_BINOP
+ || family == OA_LISTOP
+ || family == OA_PMOP
+ || family == OA_LOOP
+ );
+ assert( has_last /* has op_first and op_last, or ...
+ ... has (or may have) op_first: */
+ || family == OA_UNOP
+ || family == OA_UNOP_AUX
+ || family == OA_LOGOP
+ || family == OA_BASEOP_OR_UNOP
+ || family == OA_FILESTATOP
+ || family == OA_LOOPEXOP
+ || family == OA_METHOP
+ || type == OP_CUSTOM
+ || type == OP_NULL /* new_logop does this */
+ );
+
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ if (!OpHAS_SIBLING(kid)) {
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ assert(kid->op_sibparent == o);
+ }
}
-# else
- if (has_last && !OpHAS_SIBLING(kid))
- assert(kid == cLISTOPo->op_last);
-# endif
}
#endif
-
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- finalize_op(kid);
- }
+ } while (( o = traverse_op_tree(top, o)) != NULL);
}
/*
case OP_RV2HV:
if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
PL_modcount = RETURN_UNLIMITED_NUMBER;
- return o; /* Treat \(@foo) like ordinary list. */
+ /* Treat \(@foo) like ordinary list, but still mark it as modi-
+ fiable since some contexts need to know. */
+ o->op_flags |= OPf_MOD;
+ return o;
}
/* FALLTHROUGH */
case OP_RV2GV:
case OP_PADHV:
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
- return o; /* Treat \(@foo) like ordinary list. */
+ {
+ /* Treat \(@foo) like ordinary list, but still mark it as modi-
+ fiable since some contexts need to know. */
+ o->op_flags |= OPf_MOD;
+ return o;
+ }
if (scalar_mod_type(o, type))
goto nomod;
if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
return o;
}
+/* This function exists solely to provide a scope to limit
+ setjmp/longjmp() messing with auto variables.
+ */
+PERL_STATIC_INLINE int
+S_fold_constants_eval(pTHX) {
+ int ret = 0;
+ dJMPENV;
+
+ JMPENV_PUSH(ret);
+
+ if (ret == 0) {
+ CALLRUNOPS(aTHX);
+ }
+
+ JMPENV_POP;
+
+ return ret;
+}
+
static OP *
S_fold_constants(pTHX_ OP *const o)
{
dVAR;
- OP * volatile curop;
+ OP *curop;
OP *newop;
- volatile I32 type = o->op_type;
+ I32 type = o->op_type;
bool is_stringify;
- SV * volatile sv = NULL;
+ SV *sv = NULL;
int ret = 0;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
COP not_compiling;
U8 oldwarn = PL_dowarn;
I32 old_cxix;
- dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
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;
+ ret = S_fold_constants_eval(aTHX);
+
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);
o->op_next = old_next;
break;
default:
- JMPENV_POP;
/* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
* the stack - eg any nested evals */
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
- JMPENV_POP;
PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const U8 *r = (U8*)SvPV_const(rstr, rlen);
- I32 i;
- I32 j;
- I32 grows = 0;
+ Size_t i, j;
+ bool grows = FALSE;
OPtrans_map *tbl;
+ SSize_t struct_size; /* malloced size of table struct */
- const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
- const I32 squash = o->op_private & OPpTRANS_SQUASH;
- I32 del = o->op_private & OPpTRANS_DELETE;
+ const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
+ const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
+ const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
SV* swash;
PERL_ARGS_ASSERT_PMTRANS;
none = ++max;
if (del)
- del = ++max;
+ ++max;
if (max > 0xffff)
bits = 32;
goto warnins;
}
- /* Non-utf8 case: set o->op_pv to point to a simple 256-entry lookup
+ /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
* table. Entries with the value -1 indicate chars not to be
* translated, while -2 indicates a search char without a
* corresponding replacement char under /d.
*
- * With /c, an extra length arg is stored at the end of the table to
- * indicate the number of chars in the replacement string, plus any
- * excess replacement chars not paired with search chars. The extra
- * chars are needed for utf8 strings. For example,
- * tr/\x00-\xfd/abcd/c is logically equivalent to
- * tr/\xfe\xff\x{100}\x{101}.../abcdddd.../, so the c,d chars need to
- * be kept even though they aren't paired with any chars in the table
- * (which represents chars \x00-\xff). Even without excess chars, the
- * last replacement char needs to be kept.
+ * Normally, the table has 256 slots. However, in the presence of
+ * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
+ * added, and if there are enough replacement chars to start pairing
+ * with the \x{100},... search chars, then a larger (> 256) table
+ * is allocated.
+ *
+ * In addition, regardless of whether under /c, an extra slot at the
+ * end is used to store the final repeating char, or -3 under an empty
+ * replacement list, or -2 under /d; which makes the runtime code
+ * easier.
*
* The toker will have already expanded char ranges in t and r.
*/
- tbl = (OPtrans_map*)PerlMemShared_calloc(
- complement ? sizeof(OPtrans_map_ex) : sizeof(OPtrans_map),
- sizeof(char));
+ /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
+ * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
+ * The OPtrans_map struct already contains one slot; hence the -1.
+ */
+ struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
+ tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
+ tbl->size = 256;
cPVOPo->op_pv = (char*)tbl;
if (complement) {
+ Size_t excess;
+
/* in this branch, j is a count of 'consumed' (i.e. paired off
* with a search char) replacement chars (so j <= rlen always)
*/
- for (i = 0; i < (I32)tlen; i++)
+ for (i = 0; i < tlen; i++)
tbl->map[t[i]] = -1;
+
for (i = 0, j = 0; i < 256; i++) {
if (!tbl->map[i]) {
- if (j == (I32)rlen) {
+ if (j == rlen) {
if (del)
tbl->map[i] = -2;
else if (rlen)
tbl->map[i] = (short)i;
}
else {
- if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
- grows = 1;
tbl->map[i] = r[j++];
}
+ if ( tbl->map[i] >= 0
+ && UVCHR_IS_INVARIANT((UV)i)
+ && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
+ )
+ grows = TRUE;
}
}
- assert(j <= (I32)rlen);
-
- /* populate extended portion of table */
+ ASSUME(j <= rlen);
+ excess = rlen - j;
- {
- /* the repeat char: it may be used to fill the 0x100+
- * range. For example,
- * tr/\x00-AE-\xff/bcd/c
- * is equivalent to
- * tr/BCD\x{100}-\x{7fffffff}/bcd/
- * which is equivalent to
- * tr/BCD\x{100}-\x{7fffffff}/bcddddddddd..../
- * So remember the 'd'.
- */
- short repeat_char;
- SSize_t excess = rlen - (SSize_t)j;
- OPtrans_map_ex *extbl = (OPtrans_map_ex*)tbl;
+ if (excess) {
+ /* More replacement chars than search chars:
+ * store excess replacement chars at end of main table.
+ */
- if (excess) {
- /* More replacement chars than search chars:
- * store excess replacement chars at end of main table.
- */
+ struct_size += excess;
+ tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
+ struct_size + excess * sizeof(short));
+ tbl->size += excess;
+ cPVOPo->op_pv = (char*)tbl;
- extbl = (OPtrans_map_ex *) PerlMemShared_realloc(extbl,
- sizeof(OPtrans_map_ex) + excess * sizeof(short));
- cPVOPo->op_pv = (char*)extbl;
- for (i = 0; i < (I32)excess; i++)
- extbl->map_ex[i] = r[j+i];
- repeat_char = r[rlen-1];
- }
- else {
- /* no more replacement chars than search chars */
+ for (i = 0; i < excess; i++)
+ tbl->map[i + 256] = r[j+i];
+ }
+ else {
+ /* no more replacement chars than search chars */
+ if (!rlen && !del && !squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
- if (rlen)
- repeat_char = r[rlen - 1];
- else {
- /* empty replacement list */
- repeat_char = 0; /* this value isn't used at runtime */
- /* -1 excess count indicates empty replacement charlist */
- excess = -1;
- if (!(squash | del))
- o->op_private |= OPpTRANS_IDENTICAL;
- }
- }
- extbl->excess_len = excess; /* excess char count */
- extbl->repeat_char = (short)repeat_char; /* repeated replace char */
- }
+ tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
}
else {
if (!rlen && !del) {
else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
o->op_private |= OPpTRANS_IDENTICAL;
}
+
for (i = 0; i < 256; i++)
tbl->map[i] = -1;
- for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
- if (j >= (I32)rlen) {
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
if (del) {
if (tbl->map[t[i]] == -1)
tbl->map[t[i]] = -2;
if (tbl->map[t[i]] == -1) {
if ( UVCHR_IS_INVARIANT(t[i])
&& ! UVCHR_IS_INVARIANT(r[j]))
- grows = 1;
+ grows = TRUE;
tbl->map[t[i]] = r[j];
}
}
+ tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
}
/* both non-utf8 and utf8 code paths end up here */
op_null(scope);
}
- if (is_compiletime)
- /* runtime finalizes as part of finalizing whole tree */
- optimize_optree(o);
+ /* XXX optimize_optree() must be called on o before
+ * CALL_PEEP(), as currently S_maybe_multiconcat() can't
+ * currently cope with a peephole-optimised optree.
+ * Calling optimize_optree() here ensures that condition
+ * is met, but may mean optimize_optree() is applied
+ * to the same optree later (where hopefully it won't do any
+ * harm as it can't convert an op to multiconcat if it's
+ * already been converted */
+ optimize_optree(o);
/* have to peep the DOs individually as we've removed it from
* the op_next chain */
&& o2->op_private & OPpLVAL_INTRO
&& !(o2->op_private & OPpPAD_STATE))
{
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional. "
- "This will be a fatal error in Perl 5.30");
+ Perl_croak(aTHX_ "This use of my() in false conditional is "
+ "no longer allowed");
}
*otherp = NULL;
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
-#ifdef PERL_OP_PARENT
assert(loop->op_last->op_sibparent == (OP*)loop);
OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
-#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
else if (!loop->op_slabbed)
{
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#ifdef PERL_OP_PARENT
OpLASTSIB_set(loop->op_last, (OP*)loop);
-#endif
}
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
case OP_FLOP:
return TRUE;
+
+ case OP_INDEX:
+ case OP_RINDEX:
+ /* optimised-away (index() != -1) or similar comparison */
+ if (o->op_private & OPpTRUEBOOL)
+ return TRUE;
+ return FALSE;
case OP_CONST:
/* Detect comparisons that have been optimized away */
return TRUE;
else
return FALSE;
-
/* FALLTHROUGH */
default:
return FALSE;
Also, we may be called from load_module at run time, so
PL_curstash (which sets CvSTASH) may not point to the stash the
sub is stored in. */
+ /* XXX This optimization is currently disabled for packages other
+ than main, since there was too much CPAN breakage. */
const I32 flags =
ec ? GV_NOADD_NOINIT
: (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
+ || PL_curstash != PL_defstash
|| memchr(name, ':', namlen) || memchr(name, '\'', namlen)
? gv_fetch_flags
: GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
bad_type_pv(numargs, "array", o, kid);
+ else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
+ || kid->op_type == OP_RV2GV) {
+ bad_type_pv(1, "array", o, kid);
+ }
else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
PL_op_desc[type]), 0);
/* at this point we're looking for an OP_AELEM, OP_HELEM,
* OP_EXISTS or OP_DELETE */
- /* if something like arybase (a.k.a $[ ) is in scope,
+ /* if a custom array/hash access checker is in scope,
* abandon optimisation attempt */
if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
&& PL_check[o->op_type] != Perl_ck_null)
https://perl5.git.perl.org / perl5.git / blobdiff