In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b17645516d4569fdfc26a2ed61c6e8704ced92cf?hp=62c2e3c53c95143112488f21098f7907a4e338ab>
- Log ----------------------------------------------------------------- commit b17645516d4569fdfc26a2ed61c6e8704ced92cf Author: Father Chrysostomos <[email protected]> Date: Sat Oct 25 16:38:31 2014 -0700 toke.c: Report the proper type for assign ops For combined assignment operators like *= and +=, the lexer passes an ASSIGNOP token to the parser, but the -DT output said MULOP or ADDOP; i.e., it was reporting the type *before* the check for a following â=â, instead of after it. M toke.c commit c57eecc5887375ee1e30559792e11dc9776a6b01 Author: Father Chrysostomos <[email protected]> Date: Mon Oct 20 23:29:01 2014 -0700 Optimise ($foo)x1 and ($foo)x0 in list cx If the repeat count is 1, then we simply remove the repetition operator and have the ops of the lhs evaluated, regardless of what they are. If the repeat count is 0, then we only optimise if the lhs is a simple scalar or constant. We optimise the whole thing down to the empty list. This only happens currently for integer constants on the right- hand side. In the 0 case it could be extended to multiple scalars/constants, but that would be more work. M op.c commit 6a861075fb6ed781f0d345cf3ff86fcef333c8f5 Author: Father Chrysostomos <[email protected]> Date: Sat Oct 25 14:41:52 2014 -0700 Deparse list repetition assignment properly This only applies to the almost useless case of nothing but a repetition on the lhs of list assignment: ((undef)x3) = foo(); Other cases where the repetition is part of a larger list already deparsed correctly. Checking whether the lhs begins with a parenthesis is not sufficient to determine whether the lhs is parenthesized. I believe repetition is the only binary op other than the comma that is allowed on the lhs, so we can just check for that in the op tree. M lib/B/Deparse.pm M lib/B/Deparse.t commit 5e462669b0360f3f3233454ec8036d9c6290ceec Author: Father Chrysostomos <[email protected]> Date: Sat Oct 25 13:58:56 2014 -0700 Make repeat op tree more consistent Formerly, ck_repeat would sometimes make the right-hand argument of list repetition accessible via cBINOPo->op_last and sometimes via cLISTOPx(cBINOP->op_first)->op_last. In the case of ($x)x1, repeat rv2sv gv const would become repeat ex-list pushmark rv2sv gv const while in the case of ($x,$y)x1, repeat list pushmark rv2sv gv rv2sv gv const would just have the list changed to an ex-list. Having the right-hand argument accessible from two different places makes things more complicated elsewhere in op.c, so keep the second kid where it was. The old approach was to detach all kids, and then wrap them in a list op if the first kid was not a list already. Instead, just detach the first kid. M ext/B/t/concise-xs.t M lib/B/Deparse.pm M op.c ----------------------------------------------------------------------- Summary of changes: ext/B/t/concise-xs.t | 1 + lib/B/Deparse.pm | 19 +++++++++++-- lib/B/Deparse.t | 3 ++ op.c | 77 ++++++++++++++++++++++++++++++++++++++++++---------- toke.c | 16 +++++------ 5 files changed, 91 insertions(+), 25 deletions(-) diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index 865a164..096b8f2 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -168,6 +168,7 @@ my $testpkgs = { OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH + OPpREPEAT_DOLIST PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_EXTENDED_MORE PMf_FOLD PMf_GLOBAL PMf_KEEP PMf_NONDESTRUCT diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index e327256..ade6a78 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -14,7 +14,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY - OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER + OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST OPpSORT_REVERSE SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG SVpad_TYPED @@ -2542,9 +2542,17 @@ sub binop { if ($flags & SWAP_CHILDREN) { ($left, $right) = ($right, $left); } + my $leftop = $left; $left = $self->deparse_binop_left($op, $left, $prec); $left = "($left)" if $flags & LIST_CONTEXT - && $left !~ /^(my|our|local|)[\@\(]/; + and $left !~ /^(my|our|local|)[\@\(]/ + || do { + # Parenthesize if the left argument is a + # lone repeat op. + my $left = $leftop->first->sibling; + $left->name eq 'repeat' + && null($left->sibling); + }; $right = $self->deparse_binop_right($op, $right, $prec); return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); } @@ -2636,6 +2644,7 @@ sub pp_repeat { $prec = 7; } if (null($right)) { # list repeat; count is inside left-side ex-list + # in 5.21.5 and earlier my $kid = $left->first->sibling; # skip pushmark my @exprs; for (; !null($kid->sibling); $kid = $kid->sibling) { @@ -2644,7 +2653,11 @@ sub pp_repeat { $right = $kid; $left = "(" . join(", ", @exprs). ")"; } else { - $left = $self->deparse_binop_left($op, $left, $prec); + my $dolist = $op->private & OPpREPEAT_DOLIST; + $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec); + if ($dolist) { + $left = "($left)"; + } } $right = $self->deparse_binop_right($op, $right, $prec); return $self->maybe_parens("$left x$eq $right", $cx, $prec); diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 98a19c8..a206529 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -358,6 +358,9 @@ $test /= 2 if ++$test; # list x -((1, 2) x 2); #### +# Assignment to list x +((undef) x 3) = undef; +#### # lvalue sub { my $test = sub : lvalue { diff --git a/op.c b/op.c index 1d5a861..f032885 100644 --- a/op.c +++ b/op.c @@ -1959,9 +1959,24 @@ Perl_list(pTHX_ OP *o) switch (o->op_type) { case OP_FLOP: - case OP_REPEAT: list(cBINOPo->op_first); break; + case OP_REPEAT: + if (o->op_private & OPpREPEAT_DOLIST + && !(o->op_flags & OPf_STACKED)) + { + list(cBINOPo->op_first); + kid = cBINOPo->op_last; + if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv) + && SvIVX(kSVOP_sv) == 1) + { + op_null(o); /* repeat */ + op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */ + /* const (rhs): */ + op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL)); + } + } + break; case OP_OR: case OP_AND: case OP_COND_EXPR: @@ -2626,16 +2641,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; else { const I32 mods = PL_modcount; - if (cBINOPo->op_last) { - modkids(cBINOPo->op_first, OP_AASSIGN); - kid = cBINOPo->op_last; - } - else { - kid = OP_SIBLING(cUNOPx(cBINOPo->op_first)->op_first); - for (; OP_HAS_SIBLING(kid); kid = OP_SIBLING(kid)) - op_lvalue(kid, OP_AASSIGN); - assert(kid == cLISTOPx(cBINOPo->op_first)->op_last); - } + modkids(cBINOPo->op_first, OP_AASSIGN); + kid = cBINOPo->op_last; if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) { const IV iv = SvIV(kSVOP_sv); if (PL_modcount != RETURN_UNLIMITED_NUMBER) @@ -10286,10 +10293,9 @@ Perl_ck_repeat(pTHX_ OP *o) if (cBINOPo->op_first->op_flags & OPf_PARENS) { OP* kids; o->op_private |= OPpREPEAT_DOLIST; - kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */ - kids = force_list(kids, 1); /* promote them to a list */ + kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */ + kids = force_list(kids, 1); /* promote it to a list */ op_sibling_splice(o, NULL, 0, kids); /* and add back */ - if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL; } else scalar(o); @@ -11968,6 +11974,49 @@ Perl_rpeep(pTHX_ OP *o) case OP_PUSHMARK: + /* Given + 5 repeat/DOLIST + 3 ex-list + 1 pushmark + 2 scalar or const + 4 const[0] + convert repeat into a stub with no kids. + */ + if (o->op_next->op_type == OP_CONST + || ( o->op_next->op_type == OP_PADSV + && !(o->op_next->op_private & OPpLVAL_INTRO)) + || ( o->op_next->op_type == OP_GV + && o->op_next->op_next->op_type == OP_RV2SV + && !(o->op_next->op_next->op_private + & (OPpLVAL_INTRO|OPpOUR_INTRO)))) + { + const OP *kid = o->op_next->op_next; + if (o->op_next->op_type == OP_GV) + kid = kid->op_next; + /* kid is now the ex-list. */ + if (kid->op_type == OP_NULL + && (kid = kid->op_next)->op_type == OP_CONST + /* kid is now the repeat count. */ + && kid->op_next->op_type == OP_REPEAT + && kid->op_next->op_private & OPpREPEAT_DOLIST + && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST + && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0) + { + o = kid->op_next; /* repeat */ + assert(oldop); + oldop->op_next = o; + op_free(cBINOPo->op_first); + op_free(cBINOPo->op_last ); + o->op_flags &=~ OPf_KIDS; + /* stub is a baseop; repeat is a binop */ + assert(sizeof(OP) <= sizeof(BINOP)); + o->op_type = OP_STUB; + o->op_ppaddr = PL_ppaddr[OP_STUB]; + o->op_private = 0; + break; + } + } + /* Convert a series of PAD ops for my vars plus support into a * single padrange op. Basically * diff --git a/toke.c b/toke.c index d866ef2..f4e8258 100644 --- a/toke.c +++ b/toke.c @@ -206,7 +206,7 @@ static const char* const lex_state_names[] = { #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval)) #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval)) -#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval))) +#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval)) #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval)) #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) @@ -220,14 +220,14 @@ static const char* const lex_state_names[] = { #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP)) #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) -#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) -#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) -#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) -#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) +#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP)) +#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP)) +#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP)) +#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP)) #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) -#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) +#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP)) #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP)) -#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) +#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP)) #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) @@ -486,7 +486,7 @@ S_ao(pTHX_ int toketype) pl_yylval.ival = OP_DORASSIGN; toketype = ASSIGNOP; } - return toketype; + return REPORT(toketype); } /* -- Perl5 Master Repository
