From: Robin Houston Date: Sun, 6 May 2001 14:36:56 +0000 (+0100) Subject: scoping X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ce4e655dc29e27029ad1ce2f03223f9feef69025;p=p5sagit%2Fp5-mst-13.2.git scoping Message-ID: <20010506143656.A4006@penderel> p4raw-id: //depot/perl@10007 --- diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 6e42a48..2f01389 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -11,11 +11,11 @@ use Carp 'cluck', 'croak'; use B qw(class main_root main_start main_cv svref_2object opnumber cstring OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL - OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE + OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpSORT_REVERSE - SVf_IOK SVf_NOK SVf_ROK SVf_POK + SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); @@ -210,7 +210,7 @@ use warnings (); # if present, the fourth parameter is passed on by deparse. # # If present and true, it means that the op exists directly as -# part of a lineseq. Currently it's only used by pp_scope to +# part of a lineseq. Currently it's only used by scopeop to # decide whether its results need to be enclosed in a do {} block. # Nonprinting characters with special meaning: @@ -654,8 +654,8 @@ sub deparse { Carp::confess("Null op in deparse") if !defined($op) || class($op) eq "NULL"; my $meth = "pp_" . $op->name; - if ($meth eq "pp_scope") { - return $self->pp_scope($op, $cx, $flags); + if (is_scope($op)) { + return $self->$meth($op, $cx, $flags); } return $self->$meth($op, $cx); } @@ -692,6 +692,7 @@ sub deparse_sub { my $self = shift; my $cv = shift; my $proto = ""; +Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); local $self->{'curcop'} = $self->{'curcop'}; if ($cv->FLAGS & SVf_POK) { @@ -708,18 +709,35 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); local($self->{'curcvlex'}); local(@$self{qw'curstash warnings hints'}) = @$self{qw'curstash warnings hints'}; + my $body; if (not null $cv->ROOT) { - # skip leavesub - return $proto . "{\n\t" . - $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; + my $lineseq = $cv->ROOT->first; + if ($lineseq->name eq "lineseq") { + my @ops; + for(my$o=$lineseq->first; $$o; $o=$o->sibling) { + push @ops, $o; + } + $body = $self->lineseq(undef, @ops).";"; + my $scope_en = $self->find_scope_en($lineseq); + if (defined $scope_en) { + my $subs = join"", $self->seq_subs($scope_en); + $body .= ";\n$subs" if length($subs); + } + } + else { + $body = $self->deparse($cv->ROOT->first, 0); + } } - my $sv = $cv->const_sv; - if ($$sv) { - # uh-oh. inlinable sub... format it differently - return $proto . "{ " . const($sv) . " }\n"; - } else { # XSUB? (or just a declaration) - return "$proto;\n"; + else { + my $sv = $cv->const_sv; + if ($$sv) { + # uh-oh. inlinable sub... format it differently + return $proto . "{ " . const($sv) . " }\n"; + } else { # XSUB? (or just a declaration) + return "$proto;\n"; + } } + return $proto ."{\n\t$body\n\b}" ."\n"; } sub deparse_format { @@ -839,11 +857,14 @@ sub maybe_parens_func { sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; - if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; + if ($op->private & (OPpLVAL_INTRO|$our_intro) + and not $self->{'avoid_local'}{$$op}) { + my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; if (want_scalar($op)) { - return "local $text"; + return "$our_local $text"; } else { - return $self->maybe_parens_func("local", $text, $cx, 16); + return $self->maybe_parens_func("$our_local", $text, $cx, 16); } } else { return $text; @@ -967,10 +988,27 @@ sub pp_entertry { # see also leavetry return "XXX"; } +# $root should be the op which represents the root of whatever +# we're sequencing here. If it's undefined, then we don't append +# any subroutine declarations to the deparsed ops, otherwise we +# append appropriate declarations. sub lineseq { - my $self = shift; - my(@ops) = @_; + my($self, $root, @ops) = @_; my($expr, @exprs); + + my $out_cop = $self->{'curcop'}; + my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; + my $limit_seq; + if (defined $root) { + $limit_seq = $out_seq; + my $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; + $limit_seq = $nseq if !defined($limit_seq) + or defined($nseq) && $nseq < $limit_seq; + } + $limit_seq = $self->{'limit_seq'} + if defined($self->{'limit_seq'}) + && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); + local $self->{'limit_seq'} = $limit_seq; for (my $i = 0; $i < @ops; $i++) { $expr = ""; if (is_state $ops[$i]) { @@ -997,11 +1035,16 @@ sub lineseq { $expr =~ s/;\n?\z//; push @exprs, $expr; } - return join(";\n", grep {length} @exprs); + my $body = join(";\n", grep {length} @exprs); + my $subs = ""; + if (defined $root && defined $limit_seq) { + $subs = join "\n", $self->seq_subs($limit_seq); + } + return join(";\n", grep {length} $body, $subs); } sub scopeop { - my($real_block, $self, $op, $cx) = @_; + my($real_block, $self, $op, $cx, $flags) = @_; my $kid; my @kids; @@ -1031,20 +1074,15 @@ sub scopeop { for (; !null($kid); $kid = $kid->sibling) { push @kids, $kid; } - if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . $self->lineseq(@kids) . " }"; + if ($flags || $cx > 0) { # inside an expression, (a do {} while for lineseq) + return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}"; } else { - my $lineseq = $self->lineseq(@kids); + my $lineseq = $self->lineseq($op, @kids); return (length ($lineseq) ? "$lineseq;" : ""); } } -sub pp_scope { - my ($self, $op, $cx, $flags) = @_; - my $body = scopeop(0, @_); - return $body if $cx > 0 || !defined $flags || !$flags; - return "do {\n\t$body\n\b};"; -} +sub pp_scope { scopeop(0, @_); } sub pp_lineseq { scopeop(0, @_); } sub pp_leave { scopeop(1, @_); } @@ -1107,12 +1145,13 @@ sub lex_in_scope { sub populate_curcvlex { my $self = shift; - for (my $cv = $self->{'curcv'}; $$cv; $cv = $cv->OUTSIDE) { + for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { my @padlist = $cv->PADLIST->ARRAY; my @ns = $padlist[0]->ARRAY; for (my $i=0; $i<@ns; ++$i) { next if class($ns[$i]) eq "SPECIAL"; + next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars if (class($ns[$i]) eq "PV") { # Probably that pesky lexical @_ next; @@ -1126,17 +1165,34 @@ sub populate_curcvlex { } } -# Recurses down the tree, looking for a COP -sub find_cop { - my ($self, $op) = @_; - if ($op->flags & OPf_KIDS) { - for (my $o=$op->first; $$o; $o=$o->sibling) { - return $o if is_state($o); - my $r = $self->find_cop($o); - return $r if defined $r; +sub find_scope_st { ((find_scope(@_))[0]); } +sub find_scope_en { ((find_scope(@_))[1]); } + +# Recurses down the tree, looking for pad variable introductions and COPs +sub find_scope { + my ($self, $op, $scope_st, $scope_en) = @_; +Carp::cluck() if !defined $op; + return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; + + for (my $o=$op->first; $$o; $o=$o->sibling) { + if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { + my $s = int($self->padname_sv($o->targ)->NVX); + my $e = $self->padname_sv($o->targ)->IVX; + $scope_st = $s if !defined($scope_st) || $s < $scope_st; + $scope_en = $e if !defined($scope_en) || $e > $scope_en; + } + elsif (is_state($o)) { + my $c = $o->cop_seq; + $scope_st = $c if !defined($scope_st) || $c < $scope_st; + $scope_en = $c if !defined($scope_en) || $c > $scope_en; + } + elsif ($o->flags & OPf_KIDS) { + ($scope_st, $scope_en) = + $self->find_scope($o, $scope_st, $scope_en) } } - return undef; + + return ($scope_st, $scope_en); } # Returns a list of subs which should be inserted before the COP @@ -1146,8 +1202,8 @@ sub cop_subs { # If we have nephews, then our sequence number indicates # the cop_seq of the end of some sort of scope. if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS - and my $ncop = $self->find_cop($op->sibling)) { - $seq = $ncop->cop_seq; + and my $nseq = $self->find_scope_st($op->sibling) ) { + $seq = $nseq; } $seq = $out_seq if defined($out_seq) && $out_seq < $seq; return $self->seq_subs($seq); @@ -1158,6 +1214,7 @@ sub seq_subs { my @text; #push @text, "# ($seq)\n"; + return "" if !defined $seq; while (scalar(@{$self->{'subs_todo'}}) and $seq > $self->{'subs_todo'}[0][0]) { push @text, $self->next_todo; @@ -1172,7 +1229,6 @@ sub pp_nextstate { my($op, $cx) = @_; $self->{'curcop'} = $op; my @text; -#push @text, "# ", $op->cop_seq, "\n"; push @text, $self->cop_subs($op); push @text, $op->label . ": " if $op->label; my $stash = $op->stashpv; @@ -2144,21 +2200,26 @@ sub pp_list { my($expr, @exprs); my $kid = $op->first->sibling; # skip pushmark my $lop; - my $local = "either"; # could be local(...) or my(...) + my $local = "either"; # could be local(...), my(...) or our(...) for ($lop = $kid; !null($lop); $lop = $lop->sibling) { # This assumes that no other private flags equal 128, and that # OPs that store things other than flags in their op_private, # like OP_AELEMFAST, won't be immediate children of a list. - unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef") + unless ($lop->private & OPpLVAL_INTRO + or $lop->name eq "undef") { $local = ""; # or not last; } if ($lop->name =~ /^pad[ash]v$/) { # my() - ($local = "", last) if $local eq "local"; + ($local = "", last) if $local eq "local" || $local eq "our"; $local = "my"; + } elsif ($op->name =~ /^(gv|rv2)[ash]v$/ + && $op->private & OPpOUR_INTRO) { # our() + ($local = "", last) if $local eq "my" || $local eq "local"; + $local = "our"; } elsif ($lop->name ne "undef") { # local() - ($local = "", last) if $local eq "my"; + ($local = "", last) if $local eq "my" || $local eq "our"; $local = "local"; } } @@ -2242,7 +2303,6 @@ sub loop_common { my $bare = 0; my $body; my $cond = undef; - my $out_seq = $self->{'curcop'}->cop_seq;; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "while (1) "; # Can't use for(;;) if there's a continue @@ -2314,7 +2374,7 @@ sub loop_common { for (; $$state != $$cont; $state = $state->sibling) { push @states, $state; } - $body = $self->lineseq(@states); + $body = $self->lineseq(undef, @states); if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; $cont = "\cK"; @@ -2330,11 +2390,7 @@ sub loop_common { $cont = "\cK"; $body = $self->deparse($body, 0); } - $body =~ s/;?$/;/; - $body .= "\n"; - # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside - # the loop. So we insert any subs which are due here. - $body .= join"", $self->seq_subs($out_seq); + $body =~ s/;?$/;\n/; return $head . "{\n\t" . $body . "\b}" . $cont; } @@ -2452,7 +2508,11 @@ sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); - return "\$" . $self->gv_name($gv) . "[" . + my $name = $self->gv_name($gv); + $name = $self->{'curstash'}."::$name" + if $name !~ /::/ && $self->lex_in_scope('@'.$name); + + return "\$" . $name . "[" . ($op->private + $self->{'arybase'}) . "]"; } @@ -2526,6 +2586,13 @@ sub elem { $array = $self->padany($array); } elsif (is_scope($array)) { # ${expr}[0] $array = "{" . $self->deparse($array, 0) . "}"; + } elsif ($array->name eq "gv") { + $array = $self->gv_name($self->gv_or_padgv($array)); + if ($array !~ /::/) { + my $prefix = ($left eq '[' ? '@' : '%'); + $array = $self->{curstash}.'::'.$array + if $self->lex_in_scope($prefix . $array); + } } elsif (is_scalar $array) { # $x[0], $$x[0], ... $array = $self->deparse($array, 24); } else { @@ -2839,7 +2906,7 @@ sub pp_entersub { return "$kid(" . $args . ")"; } elsif (defined $proto and $proto eq "") { return $kid; - } elsif (defined $proto and $proto eq "\$") { + } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) { return $self->maybe_parens_func($kid, $args, $cx, 16); } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); @@ -3386,7 +3453,7 @@ sub pp_split { my($kid, @exprs, $ary, $expr); $kid = $op->first; if ($ {$kid->pmreplroot}) { - $ary = '@' . $self->gv_name($kid->pmreplroot); + $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot)); } for (; !null($kid); $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index da6566b..df64ab3 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -13,7 +13,7 @@ foreach my $const (qw( GVf_IMPORTED_AV GVf_IMPORTED_HV GVf_IMPORTED_SV GVf_IMPORTED_CV CVf_METHOD CVf_LOCKED CVf_LVALUE - SVf_IOK SVf_IVisUV SVf_NOK SVf_POK + SVpad_OUR SVf_IOK SVf_IVisUV SVf_NOK SVf_POK SVf_ROK SVp_IOK SVp_POK SVp_NOK )) { diff --git a/t/lib/b-deparse.t b/t/lib/b-deparse.t index 59f8cbf..048ce31 100644 --- a/t/lib/b-deparse.t +++ b/t/lib/b-deparse.t @@ -15,7 +15,7 @@ use warnings; use strict; use Config; -print "1..12\n"; +print "1..14\n"; use B::Deparse; my $deparse = B::Deparse->new() or print "not "; @@ -166,3 +166,11 @@ $test /= 2 if ++$test; continue { 123; } +#### +# 9 +my $x; +print $main::x; +#### +# 10 +my @x; +print $main::x[1];