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 { \
} \
defer_stack[++defer_ix] = o; \
} STMT_END
+#define DEFER_REVERSE(count) \
+ STMT_START { \
+ UV cnt = (count); \
+ if (cnt > 1) { \
+ OP **top = defer_stack + defer_ix; \
+ /* top - (cnt) + 1 isn't safe here */ \
+ OP **bottom = top - (cnt - 1); \
+ OP *tmp; \
+ assert(bottom >= defer_stack); \
+ while (top > bottom) { \
+ tmp = *top; \
+ *top-- = *bottom; \
+ *bottom++ = tmp; \
+ } \
+ } \
+ } STMT_END;
#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
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);
OpMAYBESIB_set(start, insert, NULL);
}
else {
- if (!parent)
- goto no_parent;
+ assert(parent);
cLISTOPx(parent)->op_first = insert;
if (insert)
parent->op_flags |= OPf_KIDS;
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.
*
OpTYPE_set(logop, type);
logop->op_first = first;
logop->op_other = other;
- logop->op_flags = OPf_KIDS;
+ if (first)
+ logop->op_flags = OPf_KIDS;
while (kid && OpHAS_SIBLING(kid))
kid = OpSIBLING(kid);
if (kid)
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;
}
STATIC void
S_maybe_multiconcat(pTHX_ OP *o)
{
+ dVAR;
OP *lastkidop; /* the right-most of any kids unshifted onto o */
OP *topop; /* the top-most op in the concat tree (often equals o,
unless there are assign/stringify ops above it */
SSize_t nargs = 0;
SSize_t nconst = 0;
+ SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
STRLEN variant;
bool utf8 = FALSE;
bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
U8 private_flags = 0; /* ... op_private of the multiconcat op */
bool is_sprintf = FALSE; /* we're optimising an sprintf */
bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
+ bool prev_was_const = FALSE; /* previous arg was a const */
/* -----------------------------------------------------------------
* Phase 1:
}
else if ( topop->op_type == OP_CONCAT
&& (topop->op_flags & OPf_STACKED)
- && (cUNOPo->op_first->op_flags & OPf_MOD)
&& (!(topop->op_private & OPpCONCAT_NESTED))
)
{
last = TRUE;
}
- if ( nargs > PERL_MULTICONCAT_MAXARG - 2
+ if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
|| (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
{
/* At least two spare slots are needed to decompose both
argp++->p = sv;
utf8 |= cBOOL(SvUTF8(sv));
nconst++;
+ if (prev_was_const)
+ /* this const may be demoted back to a plain arg later;
+ * make sure we have enough arg slots left */
+ nadjconst++;
+ prev_was_const = !prev_was_const;
}
else {
argp++->p = NULL;
nargs++;
+ prev_was_const = FALSE;
}
if (last)
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;
- 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;
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
- case OP_CONCAT:
- case OP_SASSIGN:
- case OP_STRINGIFY:
- case OP_SPRINTF:
- S_maybe_multiconcat(aTHX_ o);
- break;
+ case OP_CONCAT:
+ case OP_SASSIGN:
+ case OP_STRINGIFY:
+ case OP_SPRINTF:
+ S_maybe_multiconcat(aTHX_ o);
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
- default:
- break;
- }
+ default:
+ break;
+ }
- if (!(o->op_flags & OPf_KIDS))
- return;
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ IV child_count = 0;
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ DEFER_OP(kid);
+ ++child_count;
+ }
+ DEFER_REVERSE(child_count);
+ }
+ } 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(pTHX_ 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;
return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
+/* Helper function for S_pmtrans(): comparison function to sort an array
+ * of codepoint range pairs. Sorts by start point, or if equal, by end
+ * point */
+
static int uvcompare(const void *a, const void *b)
__attribute__nonnull__(1)
__attribute__nonnull__(2)
return 0;
}
+/* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
+ * containing the search and replacement strings, assemble into
+ * a translation table attached as o->op_pv.
+ * Free expr and repl.
+ * It expects the toker to have already set the
+ * OPpTRANS_COMPLEMENT
+ * OPpTRANS_SQUASH
+ * OPpTRANS_DELETE
+ * flags as appropriate; this function may add
+ * OPpTRANS_FROM_UTF
+ * OPpTRANS_TO_UTF
+ * OPpTRANS_IDENTICAL
+ * OPpTRANS_GROWS
+ * flags
+ */
+
static OP *
S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
SV * const tstr = ((SVOP*)expr)->op_sv;
- SV * const rstr =
- ((SVOP*)repl)->op_sv;
+ SV * const rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
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;
- short *tbl;
-
- const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
- const I32 squash = o->op_private & OPpTRANS_SQUASH;
- I32 del = o->op_private & OPpTRANS_DELETE;
+ Size_t i, j;
+ bool grows = FALSE;
+ OPtrans_map *tbl;
+ SSize_t struct_size; /* malloced size of table struct */
+
+ 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;
o->op_private |= OPpTRANS_TO_UTF;
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+
+ /* for utf8 translations, op_sv will be set to point to a swash
+ * containing codepoint ranges. This is done by first assembling
+ * a textual representation of the ranges in listsv then compiling
+ * it using swash_init(). For more details of the textual format,
+ * see L<perlunicode.pod/"User-Defined Character Properties"> .
+ */
+
SV* const listsv = newSVpvs("# comment\n");
SV* transv = NULL;
const U8* tend = t + tlen;
* odd. */
if (complement) {
+ /* utf8 and /c:
+ * replace t/tlen/tend with a version that has the ranges
+ * complemented
+ */
U8 tmpbuf[UTF8_MAXBYTES+1];
UV *cp;
UV nextmin = 0;
Newx(cp, 2*tlen, UV);
i = 0;
transv = newSVpvs("");
+
+ /* convert search string into array of (start,end) range
+ * codepoint pairs stored in cp[]. Most "ranges" will start
+ * and end at the same char */
while (t < tend) {
cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
+ /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
t++;
cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
}
i++;
}
+
+ /* sort the ranges */
qsort(cp, i, 2*sizeof(UV), uvcompare);
+
+ /* Create a utf8 string containing the complement of the
+ * codepoint ranges. For example if cp[] contains [A,B], [C,D],
+ * then transv will contain the equivalent of:
+ * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
+ * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
+ * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
+ * A range of a single char skips the ILLEGAL_UTF8_BYTE and
+ * end cp.
+ */
for (j = 0; j < i; j++) {
UV val = cp[2*j];
diff = val - nextmin;
if (val >= nextmin)
nextmin = val + 1;
}
+
t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
{
else if (!rlen && !del) {
r = t; rlen = tlen; rend = tend;
}
+
if (!squash) {
if ((!rlen && !del) || t == r ||
(tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
}
}
+ /* extract char ranges from t and r and append them to listsv */
+
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
tfirst += diff + 1;
}
+ /* compile listsv into a swash and attach to o */
+
none = ++max;
if (del)
- del = ++max;
+ ++max;
if (max > 0xffff)
bits = 32;
goto warnins;
}
- tbl = (short*)PerlMemShared_calloc(
- (o->op_private & OPpTRANS_COMPLEMENT) &&
- !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
- sizeof(short));
+ /* 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.
+ *
+ * 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.
+ */
+
+ /* 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) {
- for (i = 0; i < (I32)tlen; i++)
- tbl[t[i]] = -1;
+ 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 < tlen; i++)
+ tbl->map[t[i]] = -1;
+
for (i = 0, j = 0; i < 256; i++) {
- if (!tbl[i]) {
- if (j >= (I32)rlen) {
+ if (!tbl->map[i]) {
+ if (j == rlen) {
if (del)
- tbl[i] = -2;
+ tbl->map[i] = -2;
else if (rlen)
- tbl[i] = r[j-1];
+ tbl->map[i] = r[j-1];
else
- tbl[i] = (short)i;
+ tbl->map[i] = (short)i;
}
else {
- if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
- grows = 1;
- tbl[i] = r[j++];
+ tbl->map[i] = r[j++];
}
+ if ( tbl->map[i] >= 0
+ && UVCHR_IS_INVARIANT((UV)i)
+ && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
+ )
+ grows = TRUE;
}
}
- if (!del) {
- if (!rlen) {
- j = rlen;
- if (!squash)
- o->op_private |= OPpTRANS_IDENTICAL;
- }
- else if (j >= (I32)rlen)
- j = rlen - 1;
- else {
- tbl =
- (short *)
- PerlMemShared_realloc(tbl,
- (0x101+rlen-j) * sizeof(short));
- cPVOPo->op_pv = (char*)tbl;
- }
- tbl[0x100] = (short)(rlen - j);
- for (i=0; i < (I32)rlen - j; i++)
- tbl[0x101+i] = r[j+i];
- }
+
+ ASSUME(j <= rlen);
+ excess = rlen - j;
+
+ 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;
+
+ 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;
+ }
+
+ 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[i] = -1;
- for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
- if (j >= (I32)rlen) {
+ tbl->map[i] = -1;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
if (del) {
- if (tbl[t[i]] == -1)
- tbl[t[i]] = -2;
+ if (tbl->map[t[i]] == -1)
+ tbl->map[t[i]] = -2;
continue;
}
--j;
}
- if (tbl[t[i]] == -1) {
+ if (tbl->map[t[i]] == -1) {
if ( UVCHR_IS_INVARIANT(t[i])
&& ! UVCHR_IS_INVARIANT(r[j]))
- grows = 1;
- tbl[t[i]] = r[j];
+ 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 */
+
warnins:
if(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
return o;
}
+
/*
=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
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 */
static OP *
S_newONCEOP(pTHX_ OP *initop, OP *padop)
{
+ dVAR;
const PADOFFSET target = padop->op_targ;
OP *const other = newOP(OP_PADSV,
padop->op_flags
&& 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;
o->op_private = (U8)(PL_hints & HINT_INTEGER);
- if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
- || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
- || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
- || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
- "The bitwise feature is experimental");
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& OP_IS_INFIX_BIT(o->op_type))
{
|| 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