From 84615ddc63ad2a350fb7c2e4583313bbbdf219a9 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Tue, 30 Jan 2001 18:48:32 +0000 Subject: integrate changes#8243,8254,8255,8313,8314,8363,8383,8390,8416, 8417,8418,8419,8424,8427,8430,8441,8563 from mainline (TODO: b.t now fails one test) Subject: [PATCH] lvalue AUTOLOAD. No, really. Subject: [PATCH] Interesting syntax idea Make opens + bareword assigns do typeglob assigns. Tests for #8254. Subject: [PATCH @8269] Continue blocks and B::Deparse Make the peephole optimizer to bypass more null ops and and rewrite the deparse handling of continue blocks. Subject: Re: [PATCH @8269] Continue blocks and B::Deparse Doc tweak on #8313. Subject: [PATCH @8344] Fix spurious GVSV OPpOUR_INTRO Subject: [PATCH @8382] Remove FileHandle/IO dependence in t/io/openpid.t Subject: [PATCH perl@8269] Opcode.XS, fix memory leak Subject: RE: [PATCH] [ID 20001223.002] lvalues in list context Replace 10000 with RETVAL_MAX, and compute RETVAL_MAX according to the platform. Subject: [PATCH @8404] Consolidated lvalue sub changes Subject: Re: [PATCH] [ID 20001223.002] lvalues in list context Rename RETVAL_MAX to RETURN_UNLIMITED_NUMBER. Subject: B::Concise -- an improved replacement for B::Terse The B::Terse drop-in replacement wasn't quite drop-in. The LVRET macro needed an aTHX. Use the /^Perl_/-less form of is_lvalue_sub(). Subject: [PATCH @8545] [ID 20000808.005] OP_REFGEN as an lvalue p4raw-link: @8314 on //depot/perl: 646bba827d867c3a9ec63754025d124b158b6337 p4raw-link: @8313 on //depot/perl: 58cccf98a8ed478d6cf084cb2de62268c379cbc6 p4raw-link: @8255 on //depot/perl: 26191e783d73bf5f223253769d4bfbf74617dc91 p4raw-link: @8254 on //depot/perl: d38a0a1467f89c02cbd16ebdc31b41c6b552f379 p4raw-link: @8243 on //depot/perl: d32f2495b04e916e41d6514e2a6126c7223b49c9 p4raw-id: //depot/maint-5.6/perl@8620 p4raw-integrated: from //depot/perl@8616 'copy in' ext/B/B/Lint.pm (@4545..) t/io/openpid.t (@6903..) pod/perlsub.pod (@8228..) ext/B/B/Terse.pm (@8424..) 'edit in' pp.h (@8430..) op.c (@8442..) 'merge in' ext/B/B.pm (@8072..) pod/perldiag.pod (@8244..) ext/B/B/Deparse.pm (@8313..) doop.c (@8385..) p4raw-branched: from //depot/perl@8424 'branch in' ext/B/B/Concise.pm p4raw-integrated: from //depot/perl@8424 'merge in' MANIFEST (@8267..) p4raw-integrated: from //depot/perl@8418 'copy in' t/pragma/sub_lval.t (@8417..) p4raw-integrated: from //depot/perl@8417 'copy in' opcode.h pp.sym pp_proto.h (@7123..) 'edit in' op.h (@8313..) pp.c (@8415..) 'merge in' opcode.pl (@8282..) pp_ctl.c (@8328..) embed.h embed.pl proto.h (@8378..) pp_hot.c (@8382..) toke.c (@8413..) p4raw-integrated: from //depot/perl@8390 'merge in' ext/Opcode/Opcode.xs (@8127..) p4raw-integrated: from //depot/perl@8363 'merge in' dump.c (@8289..) p4raw-integrated: from //depot/perl@8014 'ignore' t/lib/b.t (@7721..) --- MANIFEST | 1 + doop.c | 4 +- dump.c | 1 + embed.h | 8 + embed.pl | 1 + ext/B/B.pm | 9 +- ext/B/B/Concise.pm | 812 +++++++++++++++++++++++++++++++++++++++++++++++++++ ext/B/B/Deparse.pm | 280 +++++++++++------- ext/B/B/Lint.pm | 6 +- ext/B/B/Terse.pm | 2 +- ext/Opcode/Opcode.xs | 1 + op.c | 124 ++++---- op.h | 7 +- opcode.h | 4 +- opcode.pl | 4 +- pod/perldiag.pod | 8 + pod/perlsub.pod | 4 - pp.c | 37 ++- pp.h | 7 + pp.sym | 1 + pp_ctl.c | 14 + pp_hot.c | 44 ++- pp_proto.h | 1 + proto.h | 1 + t/io/openpid.t | 13 +- t/lib/b.t | 30 +- t/pragma/sub_lval.t | 152 ++++++++-- toke.c | 18 +- 28 files changed, 1359 insertions(+), 235 deletions(-) create mode 100644 ext/B/B/Concise.pm diff --git a/MANIFEST b/MANIFEST index a6d81d4991..3db0284e3d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -172,6 +172,7 @@ ext/B/B/Bblock.pm Compiler basic block analysis support ext/B/B/Bytecode.pm Compiler Bytecode backend ext/B/B/C.pm Compiler C backend ext/B/B/CC.pm Compiler CC backend +ext/B/B/Concise.pm Compiler Concise backend ext/B/B/Debug.pm Compiler Debug backend ext/B/B/Deparse.pm Compiler Deparse backend ext/B/B/Disassembler.pm Compiler Disassembler backend diff --git a/doop.c b/doop.c index a47d6f38c5..f07a69aa3d 100644 --- a/doop.c +++ b/doop.c @@ -1207,7 +1207,7 @@ Perl_do_kv(pTHX) dokeys = dovalues = TRUE; if (!hv) { - if (PL_op->op_flags & OPf_MOD) { /* lvalue */ + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ dTARGET; /* make sure to clear its target here */ if (SvTYPE(TARG) == SVt_PVLV) LvTARG(TARG) = Nullsv; @@ -1226,7 +1226,7 @@ Perl_do_kv(pTHX) IV i; dTARGET; - if (PL_op->op_flags & OPf_MOD) { /* lvalue */ + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'k', Nullch, 0); diff --git a/dump.c b/dump.c index 3fefd1a715..49efb600c6 100644 --- a/dump.c +++ b/dump.c @@ -453,6 +453,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } else if (o->op_type == OP_ENTERSUB || o->op_type == OP_RV2SV || + o->op_type == OP_GVSV || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_RV2GV || diff --git a/embed.h b/embed.h index c7729e7c49..ca816346e5 100644 --- a/embed.h +++ b/embed.h @@ -273,6 +273,7 @@ #define io_close Perl_io_close #define invert Perl_invert #define is_gv_magical Perl_is_gv_magical +#define is_lvalue_sub Perl_is_lvalue_sub #define is_uni_alnum Perl_is_uni_alnum #define is_uni_alnumc Perl_is_uni_alnumc #define is_uni_idfirst Perl_is_uni_idfirst @@ -1172,6 +1173,7 @@ #define ck_open Perl_ck_open #define ck_repeat Perl_ck_repeat #define ck_require Perl_ck_require +#define ck_return Perl_ck_return #define ck_rfun Perl_ck_rfun #define ck_rvconst Perl_ck_rvconst #define ck_sassign Perl_ck_sassign @@ -1742,6 +1744,7 @@ #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define invert(a) Perl_invert(aTHX_ a) #define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c) +#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) @@ -2629,6 +2632,7 @@ #define ck_open(a) Perl_ck_open(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) +#define ck_return(a) Perl_ck_return(aTHX_ a) #define ck_rfun(a) Perl_ck_rfun(aTHX_ a) #define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a) #define ck_sassign(a) Perl_ck_sassign(aTHX_ a) @@ -3413,6 +3417,8 @@ #define invert Perl_invert #define Perl_is_gv_magical CPerlObj::Perl_is_gv_magical #define is_gv_magical Perl_is_gv_magical +#define Perl_is_lvalue_sub CPerlObj::Perl_is_lvalue_sub +#define is_lvalue_sub Perl_is_lvalue_sub #define Perl_is_uni_alnum CPerlObj::Perl_is_uni_alnum #define is_uni_alnum Perl_is_uni_alnum #define Perl_is_uni_alnumc CPerlObj::Perl_is_uni_alnumc @@ -5100,6 +5106,8 @@ #define ck_repeat Perl_ck_repeat #define Perl_ck_require CPerlObj::Perl_ck_require #define ck_require Perl_ck_require +#define Perl_ck_return CPerlObj::Perl_ck_return +#define ck_return Perl_ck_return #define Perl_ck_rfun CPerlObj::Perl_ck_rfun #define ck_rfun Perl_ck_rfun #define Perl_ck_rvconst CPerlObj::Perl_ck_rvconst diff --git a/embed.pl b/embed.pl index 4f6a9691e0..fec38f3a3d 100755 --- a/embed.pl +++ b/embed.pl @@ -1592,6 +1592,7 @@ Ap |char* |instr |const char* big|const char* little p |bool |io_close |IO* io|bool not_implicit p |OP* |invert |OP* cmd dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags +p |I32 |is_lvalue_sub Ap |bool |is_uni_alnum |U32 c Ap |bool |is_uni_alnumc |U32 c Ap |bool |is_uni_idfirst |U32 c diff --git a/ext/B/B.pm b/ext/B/B.pm index dc4c4f7417..5f2cc9b819 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,12 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs @EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber amagic_generation - walkoptree walkoptree_slow walkoptree_exec walksymtable + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm new file mode 100644 index 0000000000..9f539554e1 --- /dev/null +++ b/ext/B/B/Concise.pm @@ -0,0 +1,812 @@ +package B::Concise; +# Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved. +# This program is free software; you can redistribute and/or modify it +# under the same terms as Perl itself. + +our $VERSION = "0.50"; +use strict; +use B qw(class ppname main_start main_root main_cv cstring svref_2object + SVf_IOK SVf_NOK SVf_POK OPf_KIDS); + +my %style = + ("terse" => + ["(?(#label =>\n)?)(*( )*)#class (#addr) pp_#name " + . "(?([#targ])?) #svclass~(?((#svaddr))?)~#svval\n", + "(*( )*)goto #class (#addr)\n", + "#class pp_#name"], + "concise" => + ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", + " (*( )*) goto #seq\n", + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], + "linenoise" => + ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", + "gt_#seq ", + "(?(#seq)?)#noise#arg(?([#targarg])?)"], + "debug" => + ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" + . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" + . "(?(\top_sv\t\t#svaddr\n)?)", + " GOTO #addr\n", + "#addr"], + "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, + $ENV{B_CONCISE_TREE_FORMAT}], + ); + +my($format, $gotofmt, $treefmt); +my $curcv; +my($seq_base, $cop_seq_base); + +sub concise_cv { + my ($order, $cvref) = @_; + my $cv = svref_2object($cvref); + $curcv = $cv; + if ($order eq "exec") { + walk_exec($cv->START); + } elsif ($order eq "basic") { + walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); + } else { + print tree($cv->ROOT, 0) + } +} + +my $start_sym = "\e(0"; # "\cN" sometimes also works +my $end_sym = "\e(B"; # "\cO" respectively + +my @tree_decorations = + ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], + [" ", "-", "+", "+", "|", "`", "", 0], + [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], + [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], + ); +my $tree_style = 0; + +my $base = 36; +my $big_endian = 1; + +my $order = "basic"; + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + my $do_main = 0; + ($format, $gotofmt, $treefmt) = @{$style{"concise"}}; + for my $o (@options) { + if ($o eq "-basic") { + $order = "basic"; + } elsif ($o eq "-exec") { + $order = "exec"; + } elsif ($o eq "-tree") { + $order = "tree"; + } elsif ($o eq "-compact") { + $tree_style |= 1; + } elsif ($o eq "-loose") { + $tree_style &= ~1; + } elsif ($o eq "-vt") { + $tree_style |= 2; + } elsif ($o eq "-ascii") { + $tree_style &= ~2; + } elsif ($o eq "-main") { + $do_main = 1; + } elsif ($o =~ /^-base(\d+)$/) { + $base = $1; + } elsif ($o eq "-bigendian") { + $big_endian = 1; + } elsif ($o eq "-littleendian") { + $big_endian = 0; + } elsif (exists $style{substr($o, 1)}) { + ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}}; + } else { + warn "Option $o unrecognized"; + } + } + if (@args) { + return sub { + for my $objname (@args) { + $objname = "main::" . $objname unless $objname =~ /::/; + eval "concise_cv(\$order, \\&$objname)"; + die "concise_cv($order, \\&$objname) failed: $@" if $@; + } + } + } + if (!@args or $do_main) { + if ($order eq "exec") { + return sub { return if class(main_start) eq "NULL"; + $curcv = main_cv; + walk_exec(main_start) } + } elsif ($order eq "tree") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + print tree(main_root, 0) } + } elsif ($order eq "basic") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + walk_topdown(main_root, + sub { $_[0]->concise($_[1]) }, 0); } + } + } +} + +my %labels; +my $lastnext; + +my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", + 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", + 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";"); + +my @linenoise = + qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl + ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I + -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< + > i> <= i, >= i. == i= != i! s, s. s= s! s? b& b^ b| -0 -i + ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy + uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ + a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} + v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o + ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v + ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r + -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd + co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 + g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e + e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn + Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>'; + +my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; + +sub op_flags { + my($x) = @_; + my(@v); + push @v, "v" if ($x & 3) == 1; + push @v, "s" if ($x & 3) == 2; + push @v, "l" if ($x & 3) == 3; + push @v, "K" if $x & 4; + push @v, "P" if $x & 8; + push @v, "R" if $x & 16; + push @v, "M" if $x & 32; + push @v, "S" if $x & 64; + push @v, "*" if $x & 128; + return join("", @v); +} + +sub base_n { + my $x = shift; + return "-" . base_n(-$x) if $x < 0; + my $str = ""; + do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); + $str = reverse $str if $big_endian; + return $str; +} + +sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" } + +sub walk_topdown { + my($op, $sub, $level) = @_; + $sub->($op, $level); + if ($op->flags & OPf_KIDS) { + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + walk_topdown($kid, $sub, $level + 1); + } + } + if (class($op) eq "PMOP" and $ {$op->pmreplroot}) { + walk_topdown($op->pmreplroot, $sub, $level + 1); + } +} + +sub walklines { + my($ar, $level) = @_; + for my $l (@$ar) { + if (ref($l) eq "ARRAY") { + walklines($l, $level + 1); + } else { + $l->concise($level); + } + } +} + +sub walk_exec { + my($top, $level) = @_; + my %opsseen; + my @lines; + my @todo = ([$top, \@lines]); + while (@todo and my($op, $targ) = @{shift @todo}) { + for (; $$op; $op = $op->next) { + last if $opsseen{$$op}++; + push @$targ, $op; + my $name = $op->name; + if ($name + =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->other, $ar]; + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->pmreplstart, $ar]; + } elsif ($name =~ /^enter(loop|iter)$/) { + $labels{$op->nextop->seq} = "NEXT"; + $labels{$op->lastop->seq} = "LAST"; + $labels{$op->redoop->seq} = "REDO"; + } + } + } + walklines(\@lines, 0); +} + +sub fmt_line { + my($hr, $fmt, $level) = @_; + my $text = $fmt; + $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ + $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; + $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; + $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; + $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; + $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; + $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg; + $text =~ s/[ \t]*~+[ \t]*/ /g; + return $text; +} + +my %priv; +$priv{$_}{128} = "LVINTRO" + for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", + "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", + "padav", "padhv"); +$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); +$priv{"aassign"}{64} = "COMMON"; +$priv{"aassign"}{32} = "PHASH"; +$priv{"sassign"}{64} = "BKWARD"; +$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont"); +@{$priv{"trans"}}{1,2,4,8,16,64} = ("UTF", "IDENT", "SQUASH", "DEL", + "COMPL", "GROWS"); +$priv{"repeat"}{64} = "DOLIST"; +$priv{"leaveloop"}{64} = "CONT"; +@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") + for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem"); +$priv{"entersub"}{16} = "DBG"; +$priv{"entersub"}{32} = "TARG"; +@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); +$priv{"gv"}{32} = "EARLYCV"; +$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; +$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv"); +$priv{$_}{16} = "TARGMY" + for (map(($_,"s$_"),"chop", "chomp"), + map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", + "add", "subtract", "negate"), "pow", "concat", "stringify", + "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", + "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", + "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", + "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", + "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", + "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", + "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", + "setpriority", "time", "sleep"); +@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN"); +$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; +$priv{"list"}{64} = "GUESSED"; +$priv{"delete"}{64} = "SLICE"; +$priv{"exists"}{64} = "SUB"; +$priv{$_}{64} = "LOCALE" + for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", + "scmp", "lc", "uc", "lcfirst", "ucfirst"); +@{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV"); +$priv{"threadsv"}{64} = "SVREFd"; +$priv{$_}{16} = "INBIN" for ("open", "backtick"); +$priv{$_}{32} = "INCR" for ("open", "backtick"); +$priv{$_}{64} = "OUTBIN" for ("open", "backtick"); +$priv{$_}{128} = "OUTCR" for ("open", "backtick"); +$priv{"exit"}{128} = "VMS"; + +sub private_flags { + my($name, $x) = @_; + my @s; + for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { + if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { + $x -= $flag; + push @s, $priv{$name}{$flag}; + } + } + push @s, $x if $x; + return join(",", @s); +} + +sub concise_op { + my ($op, $level, $format) = @_; + my %h; + $h{exname} = $h{name} = $op->name; + $h{NAME} = uc $h{name}; + $h{class} = class($op); + $h{extarg} = $h{targ} = $op->targ; + $h{extarg} = "" unless $h{extarg}; + if ($h{name} eq "null" and $h{targ}) { + $h{exname} = "ex-" . substr(ppname($h{targ}), 3); + $h{extarg} = ""; + } elsif ($h{targ}) { + my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; + if (defined $padname and class($padname) ne "SPECIAL") { + $h{targarg} = $padname->PV; + my $intro = $padname->NVX - $cop_seq_base; + my $finish = int($padname->IVX) - $cop_seq_base; + $finish = "end" if $finish == 999999999 - $cop_seq_base; + $h{targarglife} = "$h{targarg}:$intro,$finish"; + } else { + $h{targarglife} = $h{targarg} = "t" . $h{targ}; + } + } + $h{arg} = ""; + $h{svclass} = $h{svaddr} = $h{svval} = ""; + if ($h{class} eq "PMOP") { + my $precomp = $op->precomp; + $precomp = defined($precomp) ? "/$precomp/" : ""; + my $pmreplstart; + if ($ {$op->pmreplstart}) { + undef $lastnext; + $pmreplstart = "replstart->" . seq($op->pmreplstart); + $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; + } else { + $h{arg} = "($precomp)"; + } + } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { + $h{arg} = '("' . $op->pv . '")'; + $h{svval} = '"' . $op->pv . '"'; + } elsif ($h{class} eq "COP") { + my $label = $op->label; + $label = $label ? "$label: " : ""; + my $loc = $op->file; + $loc =~ s[.*/][]; + $loc .= ":" . $op->line; + my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); + my $arybase = $op->arybase; + $arybase = $arybase ? ' $[=' . $arybase : ""; + $h{arg} = "($label$stash $cseq $loc$arybase)"; + } elsif ($h{class} eq "LOOP") { + $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) + . " redo->" . seq($op->redoop) . ")"; + } elsif ($h{class} eq "LOGOP") { + undef $lastnext; + $h{arg} = "(other->" . seq($op->other) . ")"; + } elsif ($h{class} eq "SVOP") { + my $sv = $op->sv; + $h{svclass} = class($sv); + $h{svaddr} = sprintf("%#x", $$sv); + if ($h{svclass} eq "GV") { + my $gv = $sv; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + $h{arg} = "(*$stash" . $gv->NAME . ")"; + $h{svval} = "*$stash" . $gv->NAME; + } else { + while (class($sv) eq "RV") { + $h{svval} .= "\\"; + $sv = $sv->RV; + } + if (class($sv) eq "SPECIAL") { + $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + } elsif ($sv->FLAGS & SVf_NOK) { + $h{svval} = $sv->NV; + } elsif ($sv->FLAGS & SVf_IOK) { + $h{svval} = $sv->IV; + } elsif ($sv->FLAGS & SVf_POK) { + $h{svval} = cstring($sv->PV); + } + $h{arg} = "($h{svclass} $h{svval})"; + } + } + $h{seq} = $h{hyphseq} = seq($op); + $h{seq} = "" if $h{seq} eq "-"; + $h{seqnum} = $op->seq; + $h{next} = $op->next; + $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); + $h{nextaddr} = sprintf("%#x", $ {$op->next}); + $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); + $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); + $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); + + $h{classsym} = $opclass{$h{class}}; + $h{flagval} = $op->flags; + $h{flags} = op_flags($op->flags); + $h{privval} = $op->private; + $h{private} = private_flags($h{name}, $op->private); + $h{addr} = sprintf("%#x", $$op); + $h{label} = $labels{$op->seq}; + $h{typenum} = $op->type; + $h{noise} = $linenoise[$op->type]; + return fmt_line(\%h, $format, $level); +} + +sub B::OP::concise { + my($op, $level) = @_; + if ($order eq "exec" and $lastnext and $$lastnext != $$op) { + my $h = {"seq" => seq($lastnext), "class" => class($lastnext), + "addr" => sprintf("%#x", $$lastnext)}; + print fmt_line($h, $gotofmt, $level+1); + } + $lastnext = $op->next; + print concise_op($op, $level, $format); +} + +sub tree { + my $op = shift; + my $level = shift; + my $style = $tree_decorations[$tree_style]; + my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; + my $name = concise_op($op, $level, $treefmt); + if (not $op->flags & OPf_KIDS) { + return $name . "\n"; + } + my @lines; + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + push @lines, tree($kid, $level+1); + } + my $i; + for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { + $lines[$i] = $space . $lines[$i]; + } + if ($i > 0) { + $lines[$i] = $last . $lines[$i]; + while ($i-- > 1) { + if (substr($lines[$i], 0, 1) eq " ") { + $lines[$i] = $nokid . $lines[$i]; + } else { + $lines[$i] = $kid . $lines[$i]; + } + } + $lines[$i] = $kids . $lines[$i]; + } else { + $lines[0] = $single . $lines[0]; + } + return("$name$lead" . shift @lines, + map(" " x (length($name)+$size) . $_, @lines)); +} + +# This is a bit of a hack; the 2 and 15 were determined empirically. +# These need to stay the last things in the module. +$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2; +$seq_base = svref_2object(eval 'sub{}')->START->seq + 15; + +1; + +__END__ + +=head1 NAME + +B::Concise - Walk Perl syntax tree, printing concise info about ops + +=head1 SYNOPSIS + + perl -MO=Concise[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend prints the internal OPs of a Perl program's syntax +tree in one of several space-efficient text formats suitable for debugging +the inner workings of perl or other compiler backends. It can print OPs in +the order they appear in the OP tree, in the order they will execute, or +in a text approximation to their tree structure, and the format of the +information displyed is customizable. Its function is similar to that of +perl's B<-Dx> debugging flag or the B module, but it is more +sophisticated and flexible. + +=head1 OPTIONS + +Arguments that don't start with a hyphen are taken to be the names of +subroutines to print the OPs of; if no such functions are specified, the +main body of the program (outside any subroutines, and not including use'd +or require'd files) is printed. + +=over 4 + +=item B<-basic> + +Print OPs in the order they appear in the OP tree (a preorder +traversal, starting at the root). The indentation of each OP shows its +level in the tree. This mode is the default, so the flag is included +simply for completeness. + +=item B<-exec> + +Print OPs in the order they would normally execute (for the majority +of constructs this is a postorder traversal of the tree, ending at the +root). In most cases the OP that usually follows a given OP will +appear directly below it; alternate paths are shown by indentation. In +cases like loops when control jumps out of a linear path, a 'goto' +line is generated. + +=item B<-tree> + +Print OPs in a text approximation of a tree, with the root of the tree +at the left and 'left-to-right' order of children transformed into +'top-to-bottom'. Because this mode grows both to the right and down, +it isn't suitable for large programs (unless you have a very wide +terminal). + +=item B<-compact> + +Use a tree format in which the minimum amount of space is used for the +lines connecting nodes (one character in most cases). This squeezes out +a few precious columns of screen real estate. + +=item B<-loose> + +Use a tree format that uses longer edges to separate OP nodes. This format +tends to look better than the compact one, especially in ASCII, and is +the default. + +=item B<-vt> + +Use tree connecting characters drawn from the VT100 line-drawing set. +This looks better if your terminal supports it. + +=item B<-ascii> + +Draw the tree with standard ASCII characters like C<+> and C<|>. These don't +look as clean as the VT100 characters, but they'll work with almost any +terminal (or the horizontal scrolling mode of less(1)) and are suitable +for text documentation or email. This is the default. + +=item B<-main> + +Include the main program in the output, even if subroutines were also +specified. + +=item B<-base>I + +Print OP sequence numbers in base I. If I is greater than 10, the +digit for 11 will be 'a', and so on. If I is greater than 36, the digit +for 37 will be 'A', and so on until 62. Values greater than 62 are not +currently supported. The default is 36. + +=item B<-bigendian> + +Print sequence numbers with the most significant digit first. This is the +usual convention for Arabic numerals, and the default. + +=item B<-littleendian> + +Print seqence numbers with the least significant digit first. + +=item B<-concise> + +Use the author's favorite set of formatting conventions. This is the +default, of course. + +=item B<-terse> + +Use formatting conventions that emulate the ouput of B. The +basic mode is almost indistinguishable from the real B, and the +exec mode looks very similar, but is in a more logical order and lacks +curly brackets. B doesn't have a tree mode, so the tree mode +is only vaguely reminiscient of B. + +=item B<-linenoise> + +Use formatting conventions in which the name of each OP, rather than being +written out in full, is represented by a one- or two-character abbreviation. +This is mainly a joke. + +=item B<-debug> + +Use formatting conventions reminiscient of B; these aren't +very concise at all. + +=item B<-env> + +Use formatting conventions read from the environment variables +C, C, and C. + +=back + +=head1 FORMATTING SPECIFICATIONS + +For each general style ('concise', 'terse', 'linenoise', etc.) there are +three specifications: one of how OPs should appear in the basic or exec +modes, one of how 'goto' lines should appear (these occur in the exec +mode only), and one of how nodes should appear in tree mode. Each has the +same format, described below. Any text that doesn't match a special +pattern is copied verbatim. + +=over 4 + +=item B<(x(>IB<;>IB<)x)> + +Generates I in exec mode, or I in basic mode. + +=item B<(*(>IB<)*)> + +Generates one copy of I for each indentation level. + +=item B<(*(>IB<;>IB<)*)> + +Generates one fewer copies of I than the indentation level, followed +by one copy of I if the indentation level is more than 0. + +=item B<(?(>IB<#>IIB<)?)> + +If the value of I is true (not empty or zero), generates the +value of I surrounded by I and I, otherwise +nothing. + +=item B<#>I + +Generates the value of the variable I. + +=item B<#>II + +Generates the value of I, left jutified to fill I spaces. + +=item B<~> + +Any number of tildes and surrounding whitespace will be collapsed to +a single space. + +=back + +The following variables are recognized: + +=over 4 + +=item B<#addr> + +The address of the OP, in hexidecimal. + +=item B<#arg> + +The OP-specific information of the OP (such as the SV for an SVOP, the +non-local exit pointers for a LOOP, etc.) enclosed in paretheses. + +=item B<#class> + +The B-determined class of the OP, in all caps. + +=item B<#classym> + +A single symbol abbreviating the class of the OP. + +=item B<#exname> + +The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. + +=item B<#extarg> + +The target of the OP, or nothing for a nulled OP. + +=item B<#firstaddr> + +The address of the OP's first child, in hexidecimal. + +=item B<#flags> + +The OP's flags, abbreviated as a series of symbols. + +=item B<#flagval> + +The numeric value of the OP's flags. + +=item B<#hyphenseq> + +The sequence number of the OP, or a hyphen if it doesn't have one. + +=item B<#label> + +'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec +mode, or empty otherwise. + +=item B<#lastaddr> + +The address of the OP's last child, in hexidecimal. + +=item B<#name> + +The OP's name. + +=item B<#NAME> + +The OP's name, in all caps. + +=item B<#next> + +The sequence number of the OP's next OP. + +=item B<#nextaddr> + +The address of the OP's next OP, in hexidecimal. + +=item B<#noise> + +The two-character abbreviation for the OP's name. + +=item B<#private> + +The OP's private flags, rendered with abbreviated names if possible. + +=item B<#privval> + +The numeric value of the OP's private flags. + +=item B<#seq> + +The sequence number of the OP. + +=item B<#seqnum> + +The real sequence number of the OP, as a regular number and not adjusted +to be relative to the start of the real program. (This will generally be +a fairly large number because all of B is compiled before +your program is). + +=item B<#sibaddr> + +The address of the OP's next youngest sibling, in hexidecimal. + +=item B<#svaddr> + +The address of the OP's SV, if it has an SV, in hexidecimal. + +=item B<#svclass> + +The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). + +=item B<#svval> + +The value of the OP's SV, if it has one, in a short human-readable format. + +=item B<#targ> + +The numeric value of the OP's targ. + +=item B<#targarg> + +The name of the variable the OP's targ refers to, if any, otherwise the +letter t followed by the OP's targ in decimal. + +=item B<#targarglife> + +Same as B<#targarg>, but followed by the COP sequence numbers that delimit +the variable's lifetime (or 'end' for a variable in an open scope) for a +variable. + +=item B<#typenum> + +The numeric value of the OP's type, in decimal. + +=back + +=head1 ABBREVIATIONS + +=head2 OP flags abbreviations + + v OPf_WANT_VOID Want nothing (void context) + s OPf_WANT_SCALAR Want single value (scalar context) + l OPf_WANT_LIST Want list of any length (list context) + K OPf_KIDS There is a firstborn child. + P OPf_PARENS This operator was parenthesized. + (Or block needs explicit scope entry.) + R OPf_REF Certified reference. + (Return container, not containee). + M OPf_MOD Will modify (lvalue). + S OPf_STACKED Some arg is arriving on the stack. + * OPf_SPECIAL Do something weird for this op (see op.h) + +=head2 OP class abbreviations + + 0 OP (aka BASEOP) An OP with no children + 1 UNOP An OP with one child + 2 BINOP An OP with two children + | LOGOP A control branch OP + @ LISTOP An OP that could have lots of children + / PMOP An OP with a regular expression + $ SVOP An OP with an SV + " PVOP An OP with a string + { LOOP An OP that holds pointers for a loop + ; COP An OP that marks the start of a statement + +=head1 AUTHOR + +Stephen McCamant, C + +=cut diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 5c5c5eb9cb..4762832951 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.591; +$VERSION = 0.60; use strict; # Changes between 0.50 and 0.51: @@ -83,6 +83,12 @@ use strict; # - added support for Chip's OP_METHOD_NAMED # - added support for Ilya's OPpTARGET_MY optimization # - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures # Todo: # - finish tr/// changes @@ -93,8 +99,8 @@ use strict; # - left/right context # - recognize `use utf8', `use integer', etc # - treat top-level block specially for incremental output -# - interpret in high bit chars in string as utf8 \x{...} (when?) -# - copy comments (look at real text with $^P?) +# - interpret high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) @@ -108,7 +114,6 @@ use strict; # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - auto-apply `-u'? -# - while{} with one-statement continue => for(; XXX; XXX) {}? # - -uPackage:: descend recursively? # - here-docs? # - ? @@ -357,6 +362,8 @@ sub new { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; } } return $self; @@ -393,6 +400,7 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; +# cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); @@ -679,70 +687,69 @@ sub pp_entertry { # see also leavetry return "XXX"; } -# leave and scope/lineseq should probably share code -sub pp_leave { +sub lineseq { my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - local($self->{'curstash'}) = $self->{'curstash'}; - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - for (; !null($kid); $kid = $kid->sibling) { + my(@ops) = @_; + my($expr, @exprs); + for (my $i = 0; $i < @ops; $i++) { $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + last if $i > $#ops; } - $expr .= $self->deparse($kid, 0); + if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and + $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) + { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } - if ($cx > 0) { # inside an expression - return "do { " . join(";\n", @exprs) . " }"; - } else { - return join(";\n", @exprs) . ";"; - } + return join(";\n", @exprs); } -sub pp_scope { - my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { - $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + local($self->{'curstash'}) = $self->{'curstash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; } - $expr .= $self->deparse($kid, 0); - push @exprs, $expr if length $expr; + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . join(";\n", @exprs) . " }"; + return "do { " . $self->lineseq(@kids) . " }"; } else { - return join(";\n", @exprs) . ";"; + return $self->lineseq(@kids) . ";"; } } -sub pp_lineseq { pp_scope(@_) } +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. @@ -1380,11 +1387,14 @@ sub logop { my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + if ($cx == 0 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + } elsif ($cx == 0 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; @@ -1675,7 +1685,8 @@ sub pp_cond_expr { my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false))) { + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); @@ -1704,20 +1715,24 @@ sub pp_cond_expr { return $head . join($cuddle, "", @elsifs) . $false; } -sub pp_leaveloop { +sub loop_common { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; + my $body; + my $cond = undef; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) + $cond = ""; } else { $bare = 1; } + $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; @@ -1749,62 +1764,60 @@ sub pp_leaveloop { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; - $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"} - ->{$kid->name}; - $head = "$name (" . $self->deparse($kid->first, 1) . ") "; - $kid = $kid->first->sibling; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } - # The third-to-last kid is the continue block if the pointer used - # by `next BLOCK' points to its first OP, which happens to be the - # the op_next of the head of the _previous_ statement. - # Unless it's a bare loop, in which case it's last, since there's - # no unstack or extra nextstate. - # Except if the previous head isn't null but the first kid is - # (because it's a nulled out nextstate in a scope), in which - # case the head's next is advanced past the null but the nextop's - # isn't, so we need to try nextop->next. - my $precont; - my $cont = $kid->first; - if ($bare) { - while (!null($cont->sibling)) { - $precont = $cont; - $cont = $cont->sibling; - } - } else { - while (!null($cont->sibling->sibling->sibling)) { - $precont = $cont; - $cont = $cont->sibling; + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's penultimate child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the third-to-last child in the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(@states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; } - } - if ($precont and $ {$precont->next} == $ {$enter->nextop} - || $ {$precont->next} == $ {$enter->nextop->next} ) - { - my $state = $kid->first; - my $cuddle = $self->{'cuddle'}; - my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { - $expr = ""; - if (is_state $state) { - $expr = $self->deparse($state, 0); - $state = $state->sibling; - last if null $state; - } - $expr .= $self->deparse($state, 0); - push @exprs, $expr if $expr; - } - $kid = join(";\n", @exprs); - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; } else { $cont = "\cK"; - $kid = $self->deparse($kid, 0); + $body = $self->deparse($body, 0); } - return $head . "{\n\t" . $kid . "\n\b}" . $cont; + return $head . "{\n\t" . $body . "\n\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling, $cx, $init); } sub pp_leavetry { @@ -2851,8 +2864,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B B<-MO=Deparse>[B<,-u>I][B<,-p>][B<,-q>][B<,-l>][B<,-s>I] - I +B B<-MO=Deparse>[B<,-u>I][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I][B<,-x>I] I =head1 DESCRIPTION @@ -2997,6 +3010,55 @@ file is compiled as a main program. =back +=item B<-x>I + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I should be a digit, with higher values +meaning more expansion. As with B<-q>, this actually involves turning off +special cases in B::Deparse's normal operations. + +If I is at least 3, for loops will be translated into equivalent +while loops with continue blocks; for instance + + for ($i = 0; $i < 10; ++$i) { + print $i; + } + +turns into + + $i = 0; + while ($i < 10) { + print $i; + } continue { + ++$i + } + +Note that in a few cases this translation can't be perfectly carried back +into the source code -- if the loop's initializer declares a my variable, +for instance, it won't have the correct scope outside of the loop. + +If I is at least 7, if statements will be translated into equivalent +expressions using C<&&>, C and C; for instance + + print 'hi' if $nice; + if ($nice) { + print 'hi'; + } + if ($nice) { + print 'hi'; + } else { + print 'bye'; + } + +turns into + + $nice and print 'hi'; + $nice and do { print 'hi' }; + $nice ? do { print 'hi' } : do { print 'bye' }; + +Long sequences of elsifs will turn into nested ternary operators, which +B::Deparse doesn't know how to indent nicely. + =back =head1 USING B::Deparse AS A MODULE @@ -3043,7 +3105,7 @@ See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant , based on an earlier +Stephen McCamant , based on an earlier version by Malcolm Beattie , with contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index ed0d07dfcb..094b3cf8fd 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents +use B qw(walkoptree main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY ); @@ -277,12 +277,12 @@ sub B::GV::lintcv { return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; + walkoptree($root, "lint") if $$root; } sub do_lint { my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; + walkoptree(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 66b5cfc2f2..a7a071e937 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,6 +1,6 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow main_start main_root cstring svref_2object); use B::Asmdata qw(@specialsv_name); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index e191ec7c9c..63c24e192b 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -265,6 +265,7 @@ PPCODE: /* %INC must be clean for use/require in compartment */ save_hash(PL_incgv); + sv_free((SV*)GvHV(PL_incgv)); /* get rid of what save_hash gave us*/ GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); PUSHMARK(SP); diff --git a/op.c b/op.c index 3d2404c6ce..1bc27b28dc 100644 --- a/op.c +++ b/op.c @@ -55,6 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* S_gv_ename(pTHX_ GV *gv) @@ -1350,6 +1351,31 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: + if (o->op_private & (OPpCONST_BARE) && + !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) { + SV *sv = ((SVOP*)o)->op_sv; + GV *gv; + + /* Could be a filehandle */ + if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) { + OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv)); + op_free(o); + o = gvio; + } else { + /* OK, it's a sub */ + OP* enter; + gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); + + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv) + )); + enter->op_private |= OPpLVAL_INTRO; + op_free(o); + o = enter; + } + break; + } if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { @@ -1380,6 +1406,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; @@ -1514,7 +1541,7 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!type && cUNOPo->op_first->op_type != OP_GV) Perl_croak(aTHX_ "Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ @@ -1523,14 +1550,16 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_AASSIGN: case OP_ASLICE: case OP_HSLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALL THROUGH */ + case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: - case OP_REFGEN: case OP_CHOMP: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) @@ -1549,11 +1578,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADAV: case OP_PADHV: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_REFGEN && o->op_flags & OPf_PARENS) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: PL_modcount++; @@ -1581,6 +1612,8 @@ Perl_mod(pTHX_ OP *o, I32 type) /* FALL THROUGH */ case OP_POS: case OP_VEC: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; lvalue_func: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); @@ -1595,12 +1628,15 @@ Perl_mod(pTHX_ OP *o, I32 type) if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; PL_modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + case OP_LINESEQ: if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; @@ -1619,8 +1655,14 @@ Perl_mod(pTHX_ OP *o, I32 type) for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; + + case OP_RETURN: + if (type != OP_LEAVESUBLV) + goto nomod; + break; /* mod()ing was handled by ck_return() */ } - o->op_flags |= OPf_MOD; + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; @@ -1629,7 +1671,8 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_flags &= ~OPf_SPECIAL; PL_hints |= HINT_BLOCK_SCOPE; } - else if (type != OP_GREPSTART && type != OP_ENTERSUB) + else if (type != OP_GREPSTART && type != OP_ENTERSUB + && type != OP_LEAVESUBLV) o->op_flags |= OPf_REF; return o; } @@ -3462,7 +3505,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } else { - if (PL_modcount < 10000 && + if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -3890,7 +3933,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { OP *unstack = newOP(OP_UNSTACK, 0); @@ -4581,7 +4623,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); if (CvLVALUE(cv)) { - CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, + mod(scalarseq(block), OP_LEAVESUBLV)); } else { CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); @@ -5365,6 +5408,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5973,6 +6017,17 @@ Perl_ck_require(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_return(pTHX_ OP *o) +{ + OP *kid; + if (CvLVALUE(PL_compcv)) { + for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_LEAVESUBLV); + } + return o; +} + #if 0 OP * Perl_ck_retarget(pTHX_ OP *o) @@ -6452,7 +6507,6 @@ Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6471,7 +6525,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ o->op_seq = PL_op_seqmax++; - last_composite = Nullop; break; case OP_CONST: @@ -6562,7 +6615,7 @@ Perl_peep(pTHX_ register OP *o) (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) <= 255 && i >= 0) @@ -6611,8 +6664,14 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: o->op_seq = PL_op_seqmax++; + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; @@ -6620,6 +6679,9 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; + while (cPMOP->op_pmreplstart && + cPMOP->op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); break; @@ -6752,42 +6814,6 @@ Perl_peep(pTHX_ register OP *o) break; } - case OP_RV2AV: - case OP_RV2HV: - if (!(o->op_flags & OPf_WANT) - || (o->op_flags & OPf_WANT) == OPf_WANT_LIST) - { - last_composite = o; - } - o->op_seq = PL_op_seqmax++; - break; - - case OP_RETURN: - if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) { - o->op_seq = PL_op_seqmax++; - break; - } - /* FALL THROUGH */ - - case OP_LEAVESUBLV: - if (last_composite) { - OP *r = last_composite; - - while (r->op_sibling) - r = r->op_sibling; - if (r->op_next == o - || (r->op_next->op_type == OP_LIST - && r->op_next->op_next == o)) - { - if (last_composite->op_type == OP_RV2AV) - yyerror("Lvalue subs returning arrays not implemented yet"); - else - yyerror("Lvalue subs returning hashes not implemented yet"); - ; - } - } - /* FALL THROUGH */ - default: o->op_seq = PL_op_seqmax++; break; diff --git a/op.h b/op.h index 55b85a5494..97b057af9d 100644 --- a/op.h +++ b/op.h @@ -139,9 +139,6 @@ Deprecated. Use C instead. /* Private for OP_REPEAT */ #define OPpREPEAT_DOLIST 64 /* List replication. */ -/* Private for OP_LEAVELOOP */ -#define OPpLOOP_CONTINUE 64 /* a continue block is present */ - /* Private for OP_RV2?V, OP_?ELEM */ #define OPpDEREF (32|64) /* Want ref to something: */ #define OPpDEREF_AV 32 /* Want ref to AV. */ @@ -159,7 +156,9 @@ Deprecated. Use C instead. /* OP_?ELEM only */ #define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ /* OP_RV2?V, OP_GVSV only */ -#define OPpOUR_INTRO 16 /* Defer creation of array/hash elem */ +#define OPpOUR_INTRO 16 /* Variable was in an our() */ + /* OP_RV2[AH]V, OP_PAD[AH]V, OP_[AH]ELEM */ +#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */ /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */ /* Private for OPs with TARGLEX */ diff --git a/opcode.h b/opcode.h index 8dc8b7ae6b..542ec60c8b 100644 --- a/opcode.h +++ b/opcode.h @@ -541,7 +541,7 @@ EXT char *PL_op_desc[] = { "method lookup", "subroutine entry", "subroutine exit", - "lvalue subroutine exit", + "lvalue subroutine return", "caller", "warn", "die", @@ -1278,7 +1278,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* iter */ MEMBER_TO_FPTR(Perl_ck_null), /* enterloop */ MEMBER_TO_FPTR(Perl_ck_null), /* leaveloop */ - MEMBER_TO_FPTR(Perl_ck_null), /* return */ + MEMBER_TO_FPTR(Perl_ck_return), /* return */ MEMBER_TO_FPTR(Perl_ck_null), /* last */ MEMBER_TO_FPTR(Perl_ck_null), /* next */ MEMBER_TO_FPTR(Perl_ck_null), /* redo */ diff --git a/opcode.pl b/opcode.pl index 43d98ae8af..beca4a1fc6 100755 --- a/opcode.pl +++ b/opcode.pl @@ -596,7 +596,7 @@ orassign logical or assignment (||=) ck_null s| method method lookup ck_method d1 entersub subroutine entry ck_subr dmt1 L leavesub subroutine exit ck_null 1 -leavesublv lvalue subroutine exit ck_null 1 +leavesublv lvalue subroutine return ck_null 1 caller caller ck_fun t% S? warn warn ck_fun imst@ L die die ck_fun dimst@ L @@ -613,7 +613,7 @@ enteriter foreach loop entry ck_null d{ iter foreach loop iterator ck_null 0 enterloop loop entry ck_null d{ leaveloop loop exit ck_null 2 -return return ck_null dm@ L +return return ck_return dm@ L last last ck_null ds} next next ck_null ds} redo redo ck_null ds} diff --git a/pod/perldiag.pod b/pod/perldiag.pod index b68068712f..5ea1083009 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -899,6 +899,14 @@ suidperl. temporary or readonly values) from a subroutine used as an lvalue. This is not allowed. +=item Can't return %s to lvalue scalar context + +(F) You tried to return a complete array or hash from an lvalue subroutine, +but you called the subroutine in a way that made Perl think you meant +to return only one value. You probably meant to write parentheses around +the call to the subroutine, which tell Perl that the call should be in +list context. + =item Can't return outside a subroutine (F) The return statement was executed in mainline code, that is, where diff --git a/pod/perlsub.pod b/pod/perlsub.pod index cef8050731..b440cd1d93 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -645,10 +645,6 @@ and in: all the subroutines are called in a list context. -The current implementation does not allow arrays and hashes to be -returned from lvalue subroutines directly. You may return a -reference instead. This restriction may be lifted in future. - =head2 Passing Symbol Table Entries (typeglobs) B: The mechanism described in this section was originally diff --git a/pp.c b/pp.c index a8bdb613d4..3df975d785 100644 --- a/pp.c +++ b/pp.c @@ -114,6 +114,11 @@ PP(pp_padav) if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; + } else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + PUSHs(TARG); + RETURN; } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; @@ -149,6 +154,11 @@ PP(pp_padhv) SAVECLEARSV(PL_curpad[PL_op->op_targ]); if (PL_op->op_flags & OPf_REF) RETURN; + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + RETURN; + } gimme = GIMME_V; if (gimme == G_ARRAY) { RETURNOP(do_kv()); @@ -340,7 +350,7 @@ PP(pp_pos) { djSP; dTARGET; dPOPss; - if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_flags & OPf_MOD || LVRET) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, '.', Nullch, 0); @@ -384,8 +394,12 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + if ((PL_op->op_private & OPpLVAL_INTRO)) { + if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) + cv = GvCV(gv); + if (!CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } } else cv = (CV*)&PL_sv_undef; @@ -2009,16 +2023,17 @@ PP(pp_substr) I32 pos; I32 rem; I32 fail; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; char *tmps; I32 arybase = PL_curcop->cop_arybase; char *repl = 0; STRLEN repl_len; + int num_args = PL_op->op_private & 7; SvTAINTED_off(TARG); /* decontaminate */ SvUTF8_off(TARG); /* decontaminate */ - if (MAXARG > 2) { - if (MAXARG > 3) { + if (num_args > 2) { + if (num_args > 3) { sv = POPs; repl = SvPV(sv, repl_len); } @@ -2042,7 +2057,7 @@ PP(pp_substr) pos -= arybase; rem = curlen-pos; fail = rem; - if (MAXARG > 2) { + if (num_args > 2) { if (len < 0) { rem += len; if (rem < 0) @@ -2054,7 +2069,7 @@ PP(pp_substr) } else { pos += curlen; - if (MAXARG < 3) + if (num_args < 3) rem = curlen; else if (len >= 0) { rem = pos+len; @@ -2130,7 +2145,7 @@ PP(pp_vec) register IV size = POPi; register IV offset = POPi; register SV *src = POPs; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ @@ -2625,7 +2640,7 @@ PP(pp_aslice) djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 arybase = PL_curcop->cop_arybase; I32 elem; @@ -2812,7 +2827,7 @@ PP(pp_hslice) { djSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) diff --git a/pp.h b/pp.h index 2226c20a6a..0ab91cd86a 100644 --- a/pp.h +++ b/pp.h @@ -373,3 +373,10 @@ See C. SvREFCNT_dec(tmpRef); \ SvRV(rv)=AMG_CALLun(rv,copy); \ } } STMT_END + +/* +=for apidoc mU||LVRET +True if this op will be the return value of an lvalue subroutine + +=cut */ +#define LVRET ((PL_op->op_private & OPpMAYBE_LVSUB) && is_lvalue_sub()) diff --git a/pp.sym b/pp.sym index 42b29f6967..2bd3922153 100644 --- a/pp.sym +++ b/pp.sym @@ -30,6 +30,7 @@ Perl_ck_null Perl_ck_open Perl_ck_repeat Perl_ck_require +Perl_ck_return Perl_ck_rfun Perl_ck_rvconst Perl_ck_sassign diff --git a/pp_ctl.c b/pp_ctl.c index a76a241c5f..06d16e7bf1 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1197,6 +1197,20 @@ Perl_block_gimme(pTHX) } } +I32 +Perl_is_lvalue_sub(pTHX) +{ + I32 cxix; + + cxix = dopoptosub(cxstack_ix); + assert(cxix >= 0); /* We should only be called from inside subs */ + + if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) + return cxstack[cxix].blk_sub.lval; + else + return 0; +} + STATIC I32 S_dopoptosub(pTHX_ I32 startingblock) { diff --git a/pp_hot.c b/pp_hot.c index bfd06dd83b..de15c95c9c 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -447,6 +447,12 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + SETs((SV*)av); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVAV) { @@ -455,6 +461,13 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } else { GV *gv; @@ -508,6 +521,13 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } } @@ -551,6 +571,12 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + SETs((SV*)hv); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { @@ -559,6 +585,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } else { GV *gv; @@ -612,6 +645,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } } @@ -1507,7 +1547,7 @@ PP(pp_helem) SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; @@ -2745,7 +2785,7 @@ PP(pp_aelem) SV** svp; IV elem = POPi; AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); SV *sv; diff --git a/pp_proto.h b/pp_proto.h index c249ecbdd7..c3b24e864b 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -29,6 +29,7 @@ PERL_CKDEF(Perl_ck_null) PERL_CKDEF(Perl_ck_open) PERL_CKDEF(Perl_ck_repeat) PERL_CKDEF(Perl_ck_require) +PERL_CKDEF(Perl_ck_return) PERL_CKDEF(Perl_ck_rfun) PERL_CKDEF(Perl_ck_rvconst) PERL_CKDEF(Perl_ck_sassign) diff --git a/proto.h b/proto.h index c8914eba0b..8710ec3320 100644 --- a/proto.h +++ b/proto.h @@ -331,6 +331,7 @@ PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little); PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit); PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd); PERL_CALLCONV bool Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags); +PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX); PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ U32 c); diff --git a/t/io/openpid.t b/t/io/openpid.t index 3871e0b4e4..7c04a29fe8 100755 --- a/t/io/openpid.t +++ b/t/io/openpid.t @@ -16,10 +16,8 @@ BEGIN { } } - -use FileHandle; use Config; -autoflush STDOUT 1; +$| = 1; $SIG{PIPE} = 'IGNORE'; print "1..10\n"; @@ -33,10 +31,8 @@ $perl = qq[$^X "-I../lib"]; # the other reader reads one line, waits a few seconds and then # exits to test the waitpid function. # -$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[first process\\n]; sleep 30;"/; -$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[second process\\n]; sleep 30;"/; +$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; +$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; $cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN $cmd4 = qq/$perl -e "print scalar <>;"/; @@ -76,7 +72,8 @@ print "not " unless $kill_cnt == 2; print "ok 8\n"; # send one expected line of text to child process and then wait for it -autoflush FH4 1; +select(FH4); $| = 1; select(STDOUT); + print FH4 "ok 9\n"; print "# waiting for process $pid4 to exit\n"; $reap_pid = waitpid $pid4, 0; diff --git a/t/lib/b.t b/t/lib/b.t index 2be4d10bf8..f119ae1461 100755 --- a/t/lib/b.t +++ b/t/lib/b.t @@ -10,7 +10,7 @@ use warnings; use strict; use Config; -print "1..13\n"; +print "1..15\n"; my $test = 1; @@ -34,21 +34,21 @@ ok; my $a = <<'EOF'; { $test = sub : lvalue { - 1; + my $x; } ; } EOF chomp $a; -print "not " if $deparse->coderef2text(sub{$test = sub : lvalue { 1 }}) ne $a; +print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a; ok; $a =~ s/lvalue/method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method { 1 }}) ne $a; +print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a; ok; $a =~ s/method/locked method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }}) +print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}}) ne $a; ok; } @@ -62,10 +62,7 @@ $b = <<'EOF'; LINE: while (defined($_ = )) { chomp $_; @F = split(/\s+/, $_, 0); - '???' -} -continue { - '???' + '???'; } EOF @@ -81,7 +78,7 @@ ok; #7 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`; print "not " unless $a =~ -/\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s; +/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; ok; $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`; @@ -119,7 +116,7 @@ $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; $a =~ s/-uCwd,// if $^O eq 'cygwin'; if ($Config{static_ext} eq ' ') { $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; + . '-umain,-ustrict,-uwarnings'; print "# [$a] vs [$b]\nnot " if $a ne $b; ok; } else { @@ -133,3 +130,14 @@ if ($is_thread) { print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; } ok; + +# Bug 20001204.07 +{ +my $foo = $deparse->coderef2text(sub { { 234; }}); +# Constants don't get optimised here. +print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; +ok; +$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); +print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; +ok; +} diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t index 3ab8766892..03a2fa0a9a 100755 --- a/t/pragma/sub_lval.t +++ b/t/pragma/sub_lval.t @@ -1,12 +1,12 @@ -print "1..46\n"; +print "1..64\n"; BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } -sub a : lvalue { my $a = 34; bless \$a } # Return a temporary -sub b : lvalue { shift } +sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary +sub b : lvalue { ${\shift} } my $out = a(b()); # Check that temporaries are allowed. print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. @@ -34,9 +34,9 @@ print "ok 3\n"; sub get_lex : lvalue { $in } sub get_st : lvalue { $blah } -sub id : lvalue { shift } +sub id : lvalue { ${\shift} } sub id1 : lvalue { $_[0] } -sub inc : lvalue { ++$_[0] } +sub inc : lvalue { ${\++$_[0]} } $in = 5; $blah = 3; @@ -288,40 +288,41 @@ print "# '$_'.\nnot " print "ok 34\n"; $x = '1234567'; -sub lv1t : lvalue { index $x, 2 } $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1t : lvalue { index $x, 2 } lv1t = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify index in lvalue subroutine return/; print "ok 35\n"; $_ = undef; eval <<'EOE' or $_ = $@; - (lv1t) = (2,3); + sub lv2t : lvalue { shift } + (lv2t) = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify shift in lvalue subroutine return/; print "ok 36\n"; $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue -sub lv1tmp : lvalue { xxx } # is it a TEMP? $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmp : lvalue { xxx } # is it a TEMP? lv1tmp = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; print "ok 37\n"; $_ = undef; @@ -334,17 +335,17 @@ print "# '$_'.\nnot " unless /Can\'t return a temporary from lvalue subroutine/; print "ok 38\n"; -sub xxx () { 'xxx' } # Not lvalue -sub lv1tmpr : lvalue { xxx } # is it a TEMP? +sub yyy () { 'yyy' } # Const, not lvalue $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmpr : lvalue { yyy } # is it read-only? lv1tmpr = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a readonly value from lvalue subroutine/; + unless /Can\'t modify constant item in lvalue subroutine return/; print "ok 39\n"; $_ = undef; @@ -357,8 +358,6 @@ print "# '$_'.\nnot " unless /Can\'t return a readonly value from lvalue subroutine/; print "ok 40\n"; -=for disabled constructs - sub lva : lvalue {@a} $_ = undef; @@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -print "# '$_'.\nnot " - unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 41\n"; $_ = undef; @@ -397,10 +395,6 @@ EOE print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 43\n"; -=cut - -print "ok $_\n" for 41..43; - sub lv1n : lvalue { $newvar } $_ = undef; @@ -427,3 +421,117 @@ $a = \&lv1nn; $a->() = 8; print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; print "ok 46\n"; + +# This must happen at run time +eval { + sub AUTOLOAD : lvalue { $newvar }; +}; +foobar() = 12; +print "# '$newvar'.\nnot " unless $newvar eq "12"; +print "ok 47\n"; + +# Testing DWIM of foo = bar; +sub foo : lvalue { + $a; +} +$a = "not ok 48\n"; +foo = "ok 48\n"; +print $a; + +open bar, ">nothing" or die $!; +bar = *STDOUT; +print bar "ok 49\n"; +unlink "nothing"; + +{ +my %hash; my @array; +sub alv : lvalue { $array[1] } +sub alv2 : lvalue { $array[$_[0]] } +sub hlv : lvalue { $hash{"foo"} } +sub hlv2 : lvalue { $hash{$_[0]} } +$array[1] = "not ok 51\n"; +alv() = "ok 50\n"; +print alv(); + +alv2(20) = "ok 51\n"; +print $array[20]; + +$hash{"foo"} = "not ok 52\n"; +hlv() = "ok 52\n"; +print $hash{foo}; + +$hash{bar} = "not ok 53\n"; +hlv("bar") = "ok 53\n"; +print hlv("bar"); + +sub array : lvalue { @array } +sub array2 : lvalue { @array2 } # This is a global. +sub hash : lvalue { %hash } +sub hash2 : lvalue { %hash2 } # So's this. +@array2 = qw(foo bar); +%hash2 = qw(foo bar); + +(array()) = qw(ok 54); +print "not " unless "@array" eq "ok 54"; +print "ok 54\n"; + +(array2()) = qw(ok 55); +print "not " unless "@array2" eq "ok 55"; +print "ok 55\n"; + +(hash()) = qw(ok 56); +print "not " unless $hash{ok} == 56; +print "ok 56\n"; + +(hash2()) = qw(ok 57); +print "not " unless $hash2{ok} == 57; +print "ok 57\n"; + +@array = qw(a b c d); +sub aslice1 : lvalue { @array[0,2] }; +(aslice1()) = ("ok", "already"); +print "# @array\nnot " unless "@array" eq "ok b already d"; +print "ok 58\n"; + +@array2 = qw(a B c d); +sub aslice2 : lvalue { @array2[0,2] }; +(aslice2()) = ("ok", "already"); +print "not " unless "@array2" eq "ok B already d"; +print "ok 59\n"; + +%hash = qw(a Alpha b Beta c Gamma); +sub hslice : lvalue { @hash{"c", "b"} } +(hslice()) = ("CISC", "BogoMIPS"); +print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; +print "ok 60\n"; +} + +$str = "Hello, world!"; +sub sstr : lvalue { substr($str, 1, 4) } +sstr() = "i"; +print "not " unless $str eq "Hi, world!"; +print "ok 61\n"; + +$str = "Made w/ JavaScript"; +sub veclv : lvalue { vec($str, 2, 32) } +veclv() = 0x5065726C; +print "# $str\nnot " unless $str eq "Made w/ PerlScript"; +print "ok 62\n"; + +sub position : lvalue { pos } +@p = (); +$_ = "fee fi fo fum"; +while (/f/g) { + push @p, position; + position() += 6; +} +print "# @p\nnot " unless "@p" eq "1 8"; +print "ok 63\n"; + +# Bug 20001223.002: split thought that the list had only one element +@ary = qw(4 5 6); +sub lval1 : lvalue { $ary[0]; } +sub lval2 : lvalue { $ary[1]; } +(lval1(), lval2()) = split ' ', "1 2 3 4"; +print "not " unless join(':', @ary) eq "1:2:6"; +print "ok 64\n"; diff --git a/toke.c b/toke.c index 7d04588efe..d47c418074 100644 --- a/toke.c +++ b/toke.c @@ -3018,9 +3018,21 @@ Perl_yylex(pTHX) PL_lex_stuff = Nullsv; } else { - attrs = append_elem(OP_LIST, attrs, - newSVOP(OP_CONST, 0, - newSVpvn(s, len))); + if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + CvLVALUE_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) + CvLOCKED_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) + CvMETHOD_on(PL_compcv); + /* After we've set the flags, it could be argued that + we don't need to do the attributes.pm-based setting + process, and shouldn't bother appending recognized + flags. To experiment with that, uncomment the + following "else": */ + /* else */ + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(s, len))); } s = skipspace(d); if (*s == ':' && s[1] != ':') -- cgit v1.2.1