useless = OP_DESC(o);
break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
+
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
return o;
}
+/* XXX kept for BINCOMPAT only */
void
Perl_save_hints(pTHX)
{
- SAVEI32(PL_hints);
- SAVESPTR(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
- SAVEFREESV(GvHV(PL_hintgv));
+ Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
}
int
op_free(right);
return Nullop;
}
+ /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
+ if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
+ && right->op_type == OP_STUB
+ && (left->op_private & OPpLVAL_INTRO))
+ {
+ op_free(right);
+ left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
+ return left;
+ }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
no_bareword_allowed(first);
else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
- if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ 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 = Nullop;
- other->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
op_free(other);
*otherp = Nullop;
- first->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (first->op_type == OP_CONST)
+ first->op_private |= OPpCONST_SHORTCIRCUIT;
return first;
}
}
char *name;
char *aname;
GV *gv;
- char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
+ char *ps;
register CV *cv=0;
SV *const_sv;
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
+ }
+ else
+ ps = Nullch;
+
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
op_free(o);
o = newop;
+ return o;
}
else {
if ((PL_hints & HINT_FILETEST_ACCESS) &&
OP* k;
o = ck_sort(o);
kid = cLISTOPo->op_first->op_sibling;
- for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
+ for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
kid->op_next = (OP*)gwop;
return kid;
}
}
+ /* optimise C<my $x = undef> to C<my $x> */
+ if (kid->op_type == OP_UNDEF) {
+ OP *kkid = kid->op_sibling;
+ if (kkid && kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO))
+ {
+ cLISTOPo->op_first = NULL;
+ kid->op_sibling = NULL;
+ op_free(o);
+ op_free(kid);
+ return kkid;
+ }
+ }
return o;
}
{
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
- int reversed;
+ int descending;
GV *gv;
if (!(o->op_flags & OPf_STACKED))
return;
if (GvSTASH(gv) != PL_curstash)
return;
if (strEQ(GvNAME(gv), "a"))
- reversed = 0;
+ descending = 0;
else if (strEQ(GvNAME(gv), "b"))
- reversed = 1;
+ descending = 1;
else
return;
+
kid = k; /* back to cmp */
if (kBINOP->op_last->op_type != OP_RV2SV)
return;
kid = kUNOP->op_first; /* get past rv2sv */
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash
- || ( reversed
+ || ( descending
? strNE(GvNAME(gv), "a")
: strNE(GvNAME(gv), "b")))
return;
o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
- if (reversed)
- o->op_private |= OPpSORT_REVERSE;
+ if (descending)
+ o->op_private |= OPpSORT_DESCEND;
if (k->op_type == OP_NCMP)
o->op_private |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
}
case OP_SORT: {
- /* make @a = sort @a act in-place */
-
/* will point to RV2AV or PADAV op on LHS/RHS of assign */
OP *oleft, *oright;
OP *o2;
- o->op_opt = 1;
-
/* check that RHS of sort is a single plain array */
oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
+
+ /* reverse sort ... can be optimised. */
+ if (!cUNOPo->op_sibling) {
+ /* Nothing follows us on the list. */
+ OP *reverse = o->op_next;
+
+ if (reverse->op_type == OP_REVERSE &&
+ (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
+ OP *pushmark = cUNOPx(reverse)->op_first;
+ if (pushmark && (pushmark->op_type == OP_PUSHMARK)
+ && (cUNOPx(pushmark)->op_sibling == o)) {
+ /* reverse -> pushmark -> sort */
+ o->op_private |= OPpSORT_REVERSE;
+ op_null(reverse);
+ pushmark->op_next = oright->op_next;
+ op_null(oright);
+ }
+ }
+ }
+
+ /* make @a = sort @a act in-place */
+
+ o->op_opt = 1;
+
oright = cUNOPx(oright)->op_sibling;
if (!oright)
break;
|| (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ if (o2->op_sibling != o)
+ break;
+
/* check the array is the same on both sides */
if (oleft->op_type == OP_RV2AV) {
if (oright->op_type != OP_RV2AV
break;
}
-
+ case OP_REVERSE: {
+ OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
+ OP *gvop = NULL;
+ LISTOP *enter, *exlist;
+ o->op_opt = 1;
+
+ enter = (LISTOP *) o->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_NULL) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ /* for $a (...) will have OP_GV then OP_RV2GV here.
+ for (...) just has an OP_GV. */
+ if (enter->op_type == OP_GV) {
+ gvop = (OP *) enter;
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_RV2GV) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ }
+
+ if (enter->op_type != OP_ENTERITER)
+ break;
+
+ iter = enter->op_next;
+ if (!iter || iter->op_type != OP_ITER)
+ break;
+
+ expushmark = enter->op_first;
+ if (!expushmark || expushmark->op_type != OP_NULL
+ || expushmark->op_targ != OP_PUSHMARK)
+ break;
+
+ exlist = (LISTOP *) expushmark->op_sibling;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_last != o) {
+ /* Mmm. Was expecting to point back to this op. */
+ break;
+ }
+ theirmark = exlist->op_first;
+ if (!theirmark || theirmark->op_type != OP_PUSHMARK)
+ break;
+
+ if (theirmark->op_sibling != o) {
+ /* There's something between the mark and the reverse, eg
+ for (1, reverse (...))
+ so no go. */
+ break;
+ }
+
+ ourmark = ((LISTOP *)o)->op_first;
+ if (!ourmark || ourmark->op_type != OP_PUSHMARK)
+ break;
+
+ ourlast = ((LISTOP *)o)->op_last;
+ if (!ourlast || ourlast->op_next != o)
+ break;
+
+ rv2av = ourmark->op_sibling;
+ if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
+ && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
+ /* We're just reversing a single array. */
+ rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
+ enter->op_flags |= OPf_STACKED;
+ }
+ /* We don't have control over who points to theirmark, so sacrifice
+ ours. */
+ theirmark->op_next = ourmark->op_next;
+ theirmark->op_flags = ourmark->op_flags;
+ ourlast->op_next = gvop ? gvop : (OP *) enter;
+ op_null(ourmark);
+ op_null(o);
+ enter->op_private |= OPpITER_REVERSED;
+ iter->op_private |= OPpITER_REVERSED;
+
+ break;
+ }
+
default:
o->op_opt = 1;
break;
projects / p5sagit/p5-mst-13.2.git / blobdiff