diff options
author | Father Chrysostomos <sprout@cpan.org> | 2014-11-13 22:32:26 -0800 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2014-11-29 18:19:43 -0800 |
commit | d4f1bfe749f8acb00b6450570f232326bab855a1 (patch) | |
tree | 057ff54b0b35d4795dd7426f6f691fda745182ef /lib | |
parent | 9e7973fa06e83f9e8592f277685d066e2ff6abef (diff) | |
download | perl-d4f1bfe749f8acb00b6450570f232326bab855a1.tar.gz |
Deparse lexical subs
We currently have a problem with the hints to allow lexical subs to
begin with not necessarily being in scope at the point of the declara-
tion. So the fix for that (which is a bit of a kludge) is to emit
‘use feature 'lexical_subs'’ and the equivalent of turning off the
corresponding warnings category, which may result in a surfeit of
^WARNING_BITS gibberish. But at least it works. :-)
Also, package subs are not yet disambiguated with package name pre-
fixes if they fall in the same scope as lexical subs of the same name.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/B/Deparse-core.t | 2 | ||||
-rw-r--r-- | lib/B/Deparse.pm | 132 | ||||
-rw-r--r-- | lib/B/Deparse.t | 26 |
3 files changed, 144 insertions, 16 deletions
diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t index 6662baaada..7c1bd2a411 100644 --- a/lib/B/Deparse-core.t +++ b/lib/B/Deparse-core.t @@ -102,7 +102,7 @@ sub testit { my $got_text = $deparse->coderef2text($code_ref); - unless ($got_text =~ /^\{ + unless ($got_text =~ / package (?:lexsub)?test; BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"} use strict 'refs', 'subs'; diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 9fb73400a3..e6aed4c5b1 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -236,7 +236,8 @@ BEGIN { # # subs_todo: # array of [cop_seq, CV, is_format?] for subs and formats we still -# want to deparse +# want to deparse. Lexical subs have one more element, giving the pad +# name thingy, and CV may be undef, indicating a stub declaration. # # protos_todo: # as above, but [name, prototype] for subs that never got a GV @@ -459,6 +460,72 @@ sub next_todo { my $self = shift; my $ent = shift @{$self->{'subs_todo'}}; my $cv = $ent->[1]; + if ($ent->[3]) { # lexical sub + my @text; + + # At this point, we may not yet have deparsed the hints that allow + # lexical subroutines to be recognized. So adjust the current + # hints and deparse them. + # When lex subs cease being experimental, we should be able to + # remove this code. + { + local $^H = $self->{'hints'}; + local %^H = %{ $self->{'hinthash'} || {} }; + local ${^WARNING_BITS} = $self->{'warnings'}; + feature->import("lexical_subs"); + warnings->unimport("experimental::lexical_subs"); + # Here we depend on the fact that individual features + # will always set the feature bundle to ‘custom’ + # (== $feature::hint_mask). If we had another specific bundle + # enabled previously, normalise it. + if (($self->{'hints'} & $feature::hint_mask) + != $feature::hint_mask) + { + if ($self->{'hinthash'}) { + delete $self->{'hinthash'}{$_} + for grep /^feature_/, keys %{$self->{'hinthash'}}; + } + else { $self->{'hinthash'} = {} } + $self->{'hinthash'} + = _features_from_bundle(@$self{'hints','hinthash'}); + } + push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H, + $self->{indent_size}, $^H); + push @text, $self->declare_warnings($self->{'warnings'}, + ${^WARNING_BITS}) + unless ($self->{'warnings'} // 'u') + eq (${^WARNING_BITS } // 'u'); + $self->{'warnings'} = ${^WARNING_BITS}; + $self->{'hints'} = $^H; + $self->{'hinthash'} = {%^H}; + } + + # Now emit the sub itself. + my $padname = $ent->[3]; + my $flags = $padname->FLAGS; + push @text, + !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW + ? $self->keyword($flags & SVpad_OUR + ? "our" + : $flags & SVpad_STATE + ? "state" + : "my") . " " + : ""; + # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’ + # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e., + # we have a core bug here. + push @text, "sub " . substr $padname->PVX, 1; + if ($cv) { + # my sub foo { } + push @text, " " . $self->deparse_sub($cv); + $text[-1] =~ s/ ;$/;/; + } + else { + # my sub foo; + push @text, ";\n"; + } + return join "", @text; + } my $gv = $cv->GV; my $name = $self->gv_name($gv); if ($ent->[2]) { @@ -813,6 +880,7 @@ sub compile { my $root = main_root; local $B::overlay = {}; unless (null $root) { + $self->pad_subs($self->{'curcv'}); $self->pessimise($root, main_start); print $self->indent($self->deparse_root($root)), "\n"; } @@ -1015,6 +1083,45 @@ sub indent { return join("\n", @lines); } +sub pad_subs { + my ($self, $cv) = @_; + my $padlist = $cv->PADLIST; + my @names = $padlist->ARRAYelt(0)->ARRAY; + my @values = $padlist->ARRAYelt(1)->ARRAY; + my @todo; + for my $ix (0.. $#names) { for $_ ($names[$ix]) { + next if class($_) eq "SPECIAL"; + my $name = $_->PVX; + if ($name =~ /^&./) { + my $low = $_->COP_SEQ_RANGE_LOW; + my $flags = $_->FLAGS; + if ($flags & SVpad_OUR) { + push @todo, [$low, undef, 0, $_]; + # [seq, no cv, not format, padname] + next; + } + my $protocv = $flags & SVpad_STATE + ? $values[$ix] + # XXX temporary future-compatibility; B::PADNAME will + # have a PROTOCV method and no MAGIC method + : $_->can("MAGIC") ? $_->MAGIC->OBJ : $_->PROTOCV; + my $outseq = $protocv->OUTSIDE_SEQ; + if ($outseq <= $low) { + # defined before its name is visible, so it’s gotta be + # declared and defined at once: my sub foo { ... } + push @todo, [$low, $protocv, 0, $_]; + } + else { + # declared and defined separately: my sub f; sub f { ... } + push @todo, [$low, undef, 0, $_], + [$outseq, $protocv, 0, $_]; + } + } + }} + @{$self->{'subs_todo'}} = + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo +} + sub deparse_sub { my $self = shift; my $cv = shift; @@ -1040,6 +1147,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); my $root = $cv->ROOT; local $B::overlay = {}; if (not null $root) { + $self->pad_subs($cv); $self->pessimise($root, $cv->START); my $lineseq = $root->first; if ($lineseq->name eq "lineseq") { @@ -1664,8 +1772,14 @@ sub seq_subs { while (scalar(@{$self->{'subs_todo'}}) and $seq > $self->{'subs_todo'}[0][0]) { my $cv = $self->{'subs_todo'}[0][1]; - my $outside = $cv && $cv->OUTSIDE; - if ($cv and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) { + # Skip the OUTSIDE check for lexical subs. We may be deparsing a + # cloned anon sub with lexical subs declared in it, in which case + # the OUTSIDE pointer points to the anon protosub. + my $lexical = !!$self->{'subs_todo'}[0][3]; + my $outside = !$lexical && $cv && $cv->OUTSIDE; + if (!$lexical and $cv + and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) + { push @pending, shift @{$self->{'subs_todo'}}; next; } @@ -5183,6 +5297,10 @@ sub is_lexical_subs { return 1; } +# Pretend these two ops do not exist. The perl parser adds them to the +# beginning of any block containing my-sub declarations, whereas we handle +# the subs in pad_subs and next_todo. +*pp_clonecv = *pp_introcv; sub pp_introcv { my $self = shift; my($op, $cx) = @_; @@ -5191,14 +5309,6 @@ sub pp_introcv { return ''; } -sub pp_clonecv { - my $self = shift; - my($op, $cx) = @_; - my $sv = $self->padname_sv($op->targ); - my $name = substr $sv->PVX, 1; # skip &/$/@/%, like $self->padany - return "my sub $name"; -} - sub pp_padcv { my $self = shift; my($op, $cx) = @_; diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index bbdd5a5e51..808f1583a5 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -306,13 +306,13 @@ EOCODI # CORE::no $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`; -like($a, qr/my sub no;\n\(\);\nCORE::no less;/, +like($a, qr/my sub no;\nCORE::no less;/, 'CORE::no after my sub no'); # CORE::use $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`; -like($a, qr/my sub use;\n\(\);\nCORE::use less;/, +like($a, qr/my sub use;\nCORE::use less;/, 'CORE::use after my sub use'); # CORE::__DATA__ @@ -1631,20 +1631,38 @@ $a x= $b; my($a, $b, $c) = @_; #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" -# TODO unimplemented in B::Deparse; RT #116553 # lexical subroutine use feature 'lexical_subs'; no warnings "experimental::lexical_subs"; my sub f {} print f(); +>>>> +use feature 'lexical_subs'; +BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"} +my sub f { + BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"} + +} +BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"} +print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" -# TODO unimplemented in B::Deparse; RT #116553 # lexical "state" subroutine use feature 'state', 'lexical_subs'; no warnings 'experimental::lexical_subs'; state sub f {} print f(); +>>>> +use feature 'lexical_subs'; +BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"} +CORE::state sub f { + BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"} + use feature 'state'; + +} +BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"} +use feature 'state'; +print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" # TODO unimplemented in B::Deparse; RT #116553 |