X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=77a213ed5f39588f2e65ae9966675dd2127198b8;hb=53273a086103cdbbf7ebdd5f1a18b2c0777cbc1b;hp=4f819c3d08b8c042c3f8107ffb96be380c4ba86b;hpb=471178c043790ed006373ae69f9589278aca3fbf;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 4f819c3..77a213e 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,62 @@ * either way, as the saying is, if you follow me." --the Gaffer */ +/* This file contains the functions that create, manipulate and optimize + * the OP structures that hold a compiled perl program. + * + * A Perl program is compiled into a tree of OPs. Each op contains + * structural pointers (eg to its siblings and the next op in the + * execution sequence), a pointer to the function that would execute the + * op, plus any data specific to that op. For example, an OP_CONST op + * points to the pp_const() function and to an SV containing the constant + * value. When pp_const() is executed, its job is to push that SV onto the + * stack. + * + * OPs are mainly created by the newFOO() functions, which are mainly + * called from the parser (in perly.y) as the code is parsed. For example + * the Perl code $a + $b * $c would cause the equivalent of the following + * to be called (oversimplifying a bit): + * + * newBINOP(OP_ADD, flags, + * newSVREF($a), + * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) + * ) + * + * Note that during the build of miniperl, a temporary copy of this file + * is made, called opmini.c. + */ + +/* +Perl's compiler is essentially a 3-pass compiler with interleaved phases: + + A bottom-up pass + A top-down pass + An execution-order pass + +The bottom-up pass is represented by all the "newOP" routines and +the ck_ routines. The bottom-upness is actually driven by yacc. +So at the point that a ck_ routine fires, we have no idea what the +context is, either upward in the syntax tree, or either forward or +backward in the execution order. (The bottom-up parser builds that +part of the execution order it knows about, but if you follow the "next" +links around, you'll find it's actually a closed loop through the +top level node. + +Whenever the bottom-up parser gets to a node that supplies context to +its components, it invokes that portion of the top-down pass that applies +to that part of the subtree (and marks the top node as processed, so +if a node further up supplies context, it doesn't have to take the +plunge again). As a particular subcase of this, as the new node is +built, it takes all the closed execution loops of its subcomponents +and links them into a new closed loop for the higher level node. But +it's still not the real execution order. + +The actual execution order is not known till we get a grammar reduction +to a top-level unit like a subroutine or file that will be called by +"name" rather than via a "next" pointer. At that point, we can call +into peep() to do that code's portion of the 3rd pass. It has to be +recursive, but it's recursive on basic blocks, not on tree nodes. +*/ #include "EXTERN.h" #define PERL_IN_OP_C @@ -200,7 +256,8 @@ Perl_allocmy(pTHX_ char *name) off = pad_add_name(name, PL_in_my_stash, (PL_in_my == KEY_our - ? (PL_curstash ? PL_curstash : PL_defstash) + /* $_ is always in main::, even with our */ + ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : Nullhv ), 0 /* not fake */ @@ -215,6 +272,7 @@ Perl_op_free(pTHX_ OP *o) { register OP *kid, *nextkid; OPCODE type; + PADOFFSET refcnt; if (!o || o->op_static) return; @@ -228,11 +286,10 @@ Perl_op_free(pTHX_ OP *o) case OP_SCOPE: case OP_LEAVEWRITE: OP_REFCNT_LOCK; - if (OpREFCNT_dec(o)) { - OP_REFCNT_UNLOCK; - return; - } + refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; + if (refcnt) + return; break; default: break; @@ -418,6 +475,18 @@ Perl_op_null(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_NULL]; } +void +Perl_op_refcnt_lock(pTHX) +{ + OP_REFCNT_LOCK; +} + +void +Perl_op_refcnt_unlock(pTHX) +{ + OP_REFCNT_UNLOCK; +} + /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) @@ -1737,7 +1806,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) } else return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, Nullop)); + pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * @@ -2354,7 +2423,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) */ if (complement) { - U8 tmpbuf[UTF8_MAXLEN+1]; + U8 tmpbuf[UTF8_MAXBYTES+1]; UV *cp; UV nextmin = 0; New(1109, cp, 2*tlen, UV); @@ -2636,15 +2705,56 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) return CHECKOP(type, pmop); } +/* Given some sort of match op o, and an expression expr containing a + * pattern, either compile expr into a regex and attach it to o (if it's + * constant), or convert expr into a runtime regcomp op sequence (if it's + * not) + * + * isreg indicates that the pattern is part of a regex construct, eg + * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or + * split "pattern", which aren't. In the former case, expr will be a list + * if the pattern contains more than one term (eg /a$b/) or if it contains + * a replacement, ie s/// or tr///. + */ + OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) +Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) { PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; + OP* repl = Nullop; + bool reglist; - if (o->op_type == OP_TRANS) + if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { + /* last element in list is the replacement; pop it */ + OP* kid; + repl = cLISTOPx(expr)->op_last; + kid = cLISTOPx(expr)->op_first; + while (kid->op_sibling != repl) + kid = kid->op_sibling; + kid->op_sibling = Nullop; + cLISTOPx(expr)->op_last = kid; + } + + if (isreg && expr->op_type == OP_LIST && + cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) + { + /* convert single element list to element */ + OP* oe = expr; + expr = cLISTOPx(oe)->op_first->op_sibling; + cLISTOPx(oe)->op_first->op_sibling = Nullop; + cLISTOPx(oe)->op_last = Nullop; + op_free(oe); + } + + if (o->op_type == OP_TRANS) { return pmtrans(o, expr, repl); + } + + reglist = isreg && expr->op_type == OP_LIST; + if (reglist) + op_null(expr); PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; @@ -2653,7 +2763,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; char *p = SvPV(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { + if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { sv_setpvn(pat, "\\s+", 3); p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; @@ -2675,11 +2785,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) rcop->op_type = OP_REGCOMP; rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; rcop->op_first = scalar(expr); - rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) - ? (OPf_SPECIAL | OPf_KIDS) - : OPf_KIDS); + rcop->op_flags |= OPf_KIDS + | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); rcop->op_private = 1; rcop->op_other = o; + if (reglist) + rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); + /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ PL_cv_has_eval = 1; @@ -3932,7 +4045,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); else - Perl_sv_catpvf(aTHX_ msg, ": none"); + Perl_sv_catpv(aTHX_ msg, ": none"); sv_catpv(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); @@ -4091,10 +4204,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } else aname = Nullch; - gv = gv_fetchpv(name ? name : (aname ? aname : - (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + gv = name ? gv_fetchsv(cSVOPo->op_sv, + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV) + : gv_fetchpv(aname ? aname + : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); if (o) SAVEFREEOP(o); @@ -4562,15 +4678,13 @@ void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { register CV *cv; - char *name; GV *gv; - STRLEN n_a; if (o) - name = SvPVx(cSVOPo->op_sv, n_a); + gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM); else - name = "STDOUT"; - gv = gv_fetchpv(name,TRUE, SVt_PVFM); + gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM); + #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); @@ -4582,7 +4696,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + o ? "Format %"SVf" redefined" + : "Format STDOUT redefined" ,cSVOPo->op_sv); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -4750,7 +4866,8 @@ Perl_newSVREF(pTHX_ OP *o) return newUNOP(OP_RV2SV, 0, scalar(o)); } -/* Check routines. */ +/* Check routines. See the comments at the top of this file for details + * on when these are called */ OP * Perl_ck_anoncode(pTHX_ OP *o) @@ -4995,11 +5112,9 @@ Perl_ck_rvconst(pTHX_ register OP *o) o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - char *name; int iscv; GV *gv; SV *kidsv = kid->op_sv; - STRLEN n_a; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { @@ -5029,7 +5144,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } - name = SvPV(kidsv, n_a); if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; switch (o->op_type) { @@ -5045,8 +5159,8 @@ Perl_ck_rvconst(pTHX_ register OP *o) } if (badthing) Perl_croak(aTHX_ - "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", - name, badthing); + "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + kidsv, badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -5058,7 +5172,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) */ iscv = (o->op_type == OP_RV2CV) * 2; do { - gv = gv_fetchpv(name, + gv = gv_fetchsv(kidsv, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -5101,9 +5215,8 @@ Perl_ck_ftst(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - STRLEN n_a; OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); + gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO)); op_free(o); o = newop; return o; @@ -5145,7 +5258,6 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - STRLEN n_a; tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || @@ -5188,13 +5300,12 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVAV) )); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Array @%s missing the @ in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -5208,13 +5319,12 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVHV) )); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) )); if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Hash %%%s missing the %% in argument %"IVdf" of %s()", - name, (IV)numargs, PL_op_desc[type]); + "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", + ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -5241,8 +5351,7 @@ Perl_ck_fun(pTHX_ OP *o) (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, - SVt_PVIO) ); + gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) ); if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) cLISTOPo->op_last = newop; @@ -5915,6 +6024,7 @@ S_simplify_sort(pTHX_ OP *o) OP *k; int descending; GV *gv; + const char *gvname; if (!(o->op_flags & OPf_STACKED)) return; GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); @@ -5941,9 +6051,10 @@ S_simplify_sort(pTHX_ OP *o) gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; - if (strEQ(GvNAME(gv), "a")) + gvname = GvNAME(gv); + if (*gvname == 'a' && gvname[1] == '\0') descending = 0; - else if (strEQ(GvNAME(gv), "b")) + else if (*gvname == 'b' && gvname[1] == '\0') descending = 1; else return; @@ -5956,10 +6067,12 @@ S_simplify_sort(pTHX_ OP *o) return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; - if (GvSTASH(gv) != PL_curstash - || ( descending - ? strNE(GvNAME(gv), "a") - : strNE(GvNAME(gv), "b"))) + if (GvSTASH(gv) != PL_curstash) + return; + gvname = GvNAME(gv); + if ( descending + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (descending) @@ -5995,7 +6108,7 @@ Perl_ck_split(pTHX_ OP *o) if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); if (cLISTOPo->op_first == cLISTOPo->op_last) cLISTOPo->op_last = kid; cLISTOPo->op_first = kid; @@ -6159,9 +6272,7 @@ Perl_ck_subr(pTHX_ OP *o) OP *sibling = o2->op_sibling; SV *n = newSVpvn("",0); op_free(o2); - gv_fullname3(n, gv, ""); - if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6)) - sv_chop(n, SvPVX(n)+6); + gv_fullname4(n, gv, "", FALSE); o2 = newSVOP(OP_CONST, 0, n); prev->op_sibling = o2; o2->op_sibling = sibling; @@ -6335,7 +6446,9 @@ Perl_ck_substr(pTHX_ OP *o) return o; } -/* A peephole optimizer. We visit the ops in the order they're to execute. */ +/* A peephole optimizer. We visit the ops in the order they're to execute. + * See the comments at the top of this file for more details about when + * peep() is called */ void Perl_peep(pTHX_ register OP *o) @@ -6576,7 +6689,9 @@ Perl_peep(pTHX_ register OP *o) break; case OP_HELEM: { + UNOP *rop; SV *lexname; + GV **fields; SV **svp, *sv; char *key = NULL; STRLEN keylen; @@ -6596,9 +6711,88 @@ Perl_peep(pTHX_ register OP *o) SvREFCNT_dec(sv); *svp = lexname; } + + if ((o->op_private & (OPpLVAL_INTRO))) + break; + + rop = (UNOP*)((BINOP*)o)->op_first; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); + if (!(SvFLAGS(lexname) & SVpad_TYPED)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + key = SvPV(*svp, keylen); + if (!hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + { + Perl_croak(aTHX_ "No such class field \"%s\" " + "in variable %s of type %s", + key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + } + break; } + case OP_HSLICE: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp; + char *key; + STRLEN keylen; + SVOP *first_key_op, *key_op; + + if ((o->op_private & (OPpLVAL_INTRO)) + /* I bet there's always a pushmark... */ + || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) + /* hmmm, no optimization if list contains only one key. */ + break; + rop = (UNOP*)((LISTOP*)o)->op_last; + if (rop->op_type != OP_RV2HV) + break; + if (rop->op_first->op_type == OP_PADSV) + /* @$hash{qw(keys here)} */ + rop = (UNOP*)rop->op_first; + else { + /* @{$hash}{qw(keys here)} */ + if (rop->op_first->op_type == OP_SCOPE + && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) + { + rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; + } + else + break; + } + + lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); + if (!(SvFLAGS(lexname) & SVpad_TYPED)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + /* Again guessing that the pushmark can be jumped over.... */ + first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) + ->op_first->op_sibling; + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) { + if (key_op->op_type != OP_CONST) + continue; + svp = cSVOPx_svp(key_op); + key = SvPV(*svp, keylen); + if (!hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + { + Perl_croak(aTHX_ "No such class field \"%s\" " + "in variable %s of type %s", + key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + } + } + break; + } + case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ OP *oleft, *oright; @@ -6717,6 +6911,96 @@ Perl_peep(pTHX_ register OP *o) 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;