Changeset 22550

Show
Ignore:
Timestamp:
10/09/08 03:23:38 (6 weeks ago)
Author:
lwall
Message:

[STD] there is no infix:<is> (was hiding missing semicolons in assign.t)
[viv] much improved typology of EXPR asts (and doesn't lose nested ops)

Location:
src/perl6
Files:
4 modified

Legend:

Unmodified
Added
Removed

  • src/perl6/Cursor.pmc

    r22534 r22550  
    779779#    delete $self->{_orig};     # needs some kind of weakening 
    780780#    delete $self->{_pos};      # EXPR blows up without this for some reason 
    781     delete $self->{_reduced}; 
     781#    delete $self->{_reduced}; 
    782782    $self; 
    783783} 

  • src/perl6/STD.pm

    r22537 r22550  
    237237            $m.deb("coercing to " ~ self) if $*DEBUG +& DEBUG::EXPR; 
    238238        } 
     239        $m<O><kind> = self.WHAT; 
    239240        return $m; 
    240241    } 
    … …  
    29962997    { <sym> } 
    29972998 
    2998 token infix:is ( --> Nonchaining) 
    2999     { <sym> } 
    3000  
    30012999token infix:but ( --> Nonchaining) 
    30023000    { <sym> } 
    … …  
    34173415                @chain = reverse @chain if @chain > 1; 
    34183416                $op<O><chain> = [@chain]; 
    3419                 push @termstack, $op; 
     3417                $op<_arity> = 'CHAIN'; 
     3418                push @termstack, $op._REDUCE('EXPR'); 
    34203419            } 
    34213420            when 'list' { 
    … …  
    34433442                @list = reverse @list if @list > 1; 
    34443443                $op<list> = [@list]; 
    3445                 push @termstack, $op; 
     3444                $op<_arity> = 'LIST'; 
     3445                push @termstack, $op._REDUCE('EXPR'); 
    34463446            } 
    34473447            when 'unary' { 
    … …  
    34563456                $op<_to> = $op<arg><_to> 
    34573457                    if $op<_to> < $op<arg><_to>; 
    3458  
    3459                 push @termstack, $op; 
     3458                $op<_arity> = 'UNARY'; 
     3459                push @termstack, $op._REDUCE('EXPR'); 
    34603460            } 
    34613461            default { 
    … …  
    34693469                $op<_from> = $op<left><_from>; 
    34703470                $op<_to> = $op<right><_to>; 
    3471  
    3472                 push @termstack, $op; 
     3471                $op<_arity> = 'BINARY'; 
     3472                push @termstack, $op._REDUCE('EXPR'); 
    34733473            } 
    34743474        } 

  • src/perl6/gimme5

    r22534 r22550  
    185185        $f =~ s/^\btemp\b//                     and $t .= qq/local/, next; 
    186186        $f =~ s/^\bchars\(//                    and $t .= qq/length(/, next; 
     187        $f =~ s/^\$\?PACKAGE//                  and $t .= qq/__PACKAGE__/, next; 
    187188 
    188189        # the following must do partial rescan of final expression 

  • src/perl6/viv

    r22527 r22550  
    1313$::ACTIONS = 'Actions'; 
    1414 
    15 if ($0 eq __FILE__) { 
    16     print "Starting...\n"; 
    17     my $r = STD->parsefile($ARGV[0]); 
    18     print Dump($r->item); 
    19 } 
    20  
    21 package Actions; 
    22  
    23 # Generic ast translation done via autoload 
    24  
    25 our $AUTOLOAD; 
    26  
    27 sub AUTOLOAD { 
    28     my $self = shift; 
    29     my $match = shift; 
    30     my $r = hoist($match); 
    31     (my $class = $AUTOLOAD) =~ s/^Actions/VAST/; 
    32     $match->{''} = bless $r, $class; 
    33 } 
    34  
    35 # propagate ->{''} nodes upward 
    36 # (untransformed STD nodes in output indicate bugs) 
    37  
    38 sub hoist { 
    39     my $node = shift; 
    40     my $text = $node->text; 
    41     my %r; 
    42     for my $k (keys %$node) { 
    43         my $v = $node->{$k}; 
    44         if ($k eq 'O') { 
    45         } 
    46         elsif ($k =~ /^[a-zA-Z]/) { 
    47             if (ref $v eq 'ARRAY') { 
    48                 my $zyg = []; 
    49                 for my $z (@$v) { 
    50                     if (ref $z) { 
    51                         if (ref $z eq 'ARRAY') { 
    52                             warn "ARRAY"; 
     15sub MAIN { 
     16    my $output = 'ast'; 
     17    while (@ARGV) { 
     18        last unless $ARGV[0] =~ /^--/; 
     19        my $switch = shift @ARGV; 
     20        if ($switch eq '--ast') { 
     21            $output = 'ast'; 
     22        } 
     23        elsif ($switch eq '--p5') { 
     24            $output = 'p5'; 
     25        } 
     26        elsif ($switch eq '--p6') { 
     27            $output = 'p6'; 
     28        } 
     29    } 
     30    my $r = STD->parsefile($ARGV[0])->item; 
     31    if ($output eq 'ast') { 
     32        print Dump($r); 
     33    } 
     34    elsif ($output eq 'p6') { 
     35        print $r->emit_p6; 
     36    } 
     37    elsif ($output eq 'p5') { 
     38        print $r->emit_p5; 
     39    } 
     40    else { 
     41        die "Unknown output mode"; 
     42    } 
     43} 
     44 
     45################################################################### 
     46 
     47{ package Actions; 
     48 
     49    # Generic ast translation done via autoload 
     50 
     51    our $AUTOLOAD; 
     52 
     53    sub AUTOLOAD { 
     54        my $self = shift; 
     55        my $match = shift; 
     56        my $r = hoist($match); 
     57        (my $class = $AUTOLOAD) =~ s/^Actions/VAST/; 
     58        gen_class($class); 
     59        bless $r, $class unless ref($r) =~ /^VAST/; 
     60        $match->{''} = $r; 
     61    } 
     62 
     63    # propagate ->{''} nodes upward 
     64    # (untransformed STD nodes in output indicate bugs) 
     65 
     66    sub hoist { 
     67        my $node = shift; 
     68        my $text = $node->text; 
     69        my %r; 
     70        for my $k (keys %$node) { 
     71            my $v = $node->{$k}; 
     72            if ($k eq 'O') { 
     73                for my $key (keys %$v) { 
     74                    $r{$key} = $$v{$key}; 
     75                } 
     76            } 
     77            elsif ($k eq '_arity') { 
     78                $r{arity} = $v; 
     79            } 
     80            elsif ($k =~ /^[a-zA-Z]/) { 
     81                if (ref $v eq 'ARRAY') { 
     82                    my $zyg = []; 
     83                    for my $z (@$v) { 
     84                        if (ref $z) { 
     85                            if (ref $z eq 'ARRAY') { 
     86                                push @$zyg, $z; 
     87                            } 
     88                            elsif (exists $z->{''}) { 
     89                                push @$zyg, $z->{''}; 
     90                            } 
     91                        } 
     92                        else { 
    5393                            push @$zyg, $z; 
    5494                        } 
    55                         elsif (exists $z->{''}) { 
    56                             push @$zyg, $z->{''}; 
    57                         } 
     95                    } 
     96                    $r{$k} = $zyg; 
     97                } 
     98                elsif (ref $v) { 
     99                    if (exists $v->{''}) { 
     100                        $r{$k} = $v->{''}; 
    58101                    } 
    59102                    else { 
    60                         push @$zyg, $z; 
     103                        $r{$k} = $v; 
    61104                    } 
    62                 } 
    63                 $r{$k} = $zyg; 
     105                    unless (ref($r{$k}) =~ /^VAST/) { 
     106                        my $class = "VAST::$k"; 
     107                        gen_class($class); 
     108                        bless $r{$k}, $class; 
     109                    } 
     110                } 
     111                else { 
     112                    $r{$k} = $v; 
     113                    $r{TEXT} = $text; 
     114                } 
    64115            } 
    65             elsif (ref $v) { 
    66                 if (exists $v->{''}) { 
    67                     $r{$k} = bless $v->{''}, "VAST::$k"; 
    68                 } 
    69                 else { 
    70                     $r{$k} = bless $v, "VAST::$k"; 
    71                 } 
     116        } 
     117        $r{TEXT} = $text unless keys %r; 
     118        \%r; 
     119    } 
     120 
     121    sub EXPR { 
     122        my $self = shift; 
     123        my $match = shift; 
     124        my $r = hoist($match); 
     125        (my $class = $r->{kind} // "STD::TERM") =~ s/^STD/VAST/; 
     126        gen_class($class); 
     127        $match->{''} = bless $r, $class; 
     128    } 
     129 
     130    sub gen_class { 
     131        my $class = shift; 
     132        no strict 'refs'; 
     133        return if @{$class . '::ISA'}; 
     134        warn "Generating $class\n"; 
     135        @{$class . '::ISA'} = 'VAST::Base'; 
     136    } 
     137 
     138} 
     139 
     140################################################################### 
     141 
     142{ package VAST::Base; 
     143    sub emit_p5 { die "Perl 5 emitter unimplemented" } 
     144 
     145    sub emit_p6 { my $self = shift; 
     146        my $text; 
     147        # XXX bogus 
     148        if (exists $self->{TEXT}) { 
     149            $text = $self->{TEXT}; 
     150        } 
     151        elsif (exists $self->{sym}) { 
     152            my $sym = $self->{sym}; 
     153            if (ref $sym eq 'ARRAY') { 
     154                $text = join '?', @$sym; 
    72155            } 
    73156            else { 
    74                 $r{$k} = $v; 
    75                 $r{TEXT} = $text; 
     157                $text = $sym; 
    76158            } 
    77159        } 
    78     } 
    79     $r{TEXT} = $text unless keys %r; 
    80     \%r; 
     160        else { 
     161            for my $key (sort keys %$self) { 
     162                my $part = $$self{$key}; 
     163                if (ref $part eq 'ARRAY') { 
     164                    my @kids = @$part; 
     165                    for my $kid (@kids) { 
     166                        $text .= $kid->emit_p6; 
     167                    } 
     168                } 
     169                elsif (ref $part) { 
     170                    $text .= $part->emit_p6; 
     171                } 
     172                else { 
     173                    $text = $key . '=' . $part; 
     174                } 
     175            } 
     176        } 
     177        $text; 
     178    } 
     179} 
     180 
     181{ package VAST::arglist; our @ISA = ('VAST::Base'); 
     182} 
     183 
     184{ package VAST::args; our @ISA = ('VAST::Base'); 
     185} 
     186 
     187{ package VAST::assertion; our @ISA = ('VAST::Base'); 
     188} 
     189 
     190{ package VAST::atom; our @ISA = ('VAST::Base'); 
     191} 
     192 
     193{ package VAST::babble; our @ISA = ('VAST::Base'); 
     194} 
     195 
     196{ package VAST::backslash; our @ISA = ('VAST::Base'); 
     197} 
     198 
     199{ package VAST::before; our @ISA = ('VAST::Base'); 
     200} 
     201 
     202{ package VAST::binding; our @ISA = ('VAST::Base'); 
     203} 
     204 
     205{ package VAST::block; our @ISA = ('VAST::Base'); 
     206} 
     207 
     208{ package VAST::cclass_elem; our @ISA = ('VAST::Base'); 
     209} 
     210 
     211{ package VAST::circumfix; our @ISA = ('VAST::Base'); 
     212} 
     213 
     214{ package VAST::codeblock; our @ISA = ('VAST::Base'); 
     215} 
     216 
     217{ package VAST::colonpair; our @ISA = ('VAST::Base'); 
     218} 
     219 
     220{ package VAST::comp_unit; our @ISA = ('VAST::Base'); 
     221} 
     222 
     223{ package VAST::declarator; our @ISA = ('VAST::Base'); 
     224} 
     225 
     226{ package VAST::default_value; our @ISA = ('VAST::Base'); 
     227} 
     228 
     229{ package VAST::deflongname; our @ISA = ('VAST::Base'); 
     230} 
     231 
     232{ package VAST::desigilname; our @ISA = ('VAST::Base'); 
     233} 
     234 
     235{ package VAST::dotty; our @ISA = ('VAST::Base'); 
     236} 
     237 
     238{ package VAST::dottyop; our @ISA = ('VAST::Base'); 
     239} 
     240 
     241{ package VAST::eat_terminator; our @ISA = ('VAST::Base'); 
     242} 
     243 
     244{ package VAST::else; our @ISA = ('VAST::Base'); 
     245} 
     246 
     247{ package VAST::escape; our @ISA = ('VAST::Base'); 
     248} 
     249 
     250{ package VAST::EXPR; our @ISA = ('VAST::Base'); 
     251} 
     252 
     253{ package VAST::extrapost; our @ISA = ('VAST::Base'); 
     254} 
     255 
     256{ package VAST::fatarrow; our @ISA = ('VAST::Base'); 
     257} 
     258 
     259{ package VAST::fulltypename; our @ISA = ('VAST::Base'); 
     260} 
     261 
     262{ package VAST::hexint; our @ISA = ('VAST::Base'); 
     263} 
     264 
     265{ package VAST::identifier; our @ISA = ('VAST::Base'); 
     266} 
     267 
     268{ package VAST::infix; our @ISA = ('VAST::Base'); 
     269} 
     270 
     271{ package VAST::infixish; our @ISA = ('VAST::Base'); 
     272} 
     273 
     274{ package VAST::infix_postfix_meta_operator; our @ISA = ('VAST::Base'); 
     275} 
     276 
     277{ package VAST::infix_prefix_meta_operator; our @ISA = ('VAST::Base'); 
     278} 
     279 
     280{ package VAST::integer; our @ISA = ('VAST::Base'); 
     281} 
     282 
     283{ package VAST::item; our @ISA = ('VAST::Base'); 
     284} 
     285 
     286{ package VAST::key; our @ISA = ('VAST::Base'); 
     287} 
     288 
     289{ package VAST::lambda; our @ISA = ('VAST::Base'); 
     290} 
     291 
     292{ package VAST::left; our @ISA = ('VAST::Base'); 
     293} 
     294 
     295{ package VAST::litchar; our @ISA = ('VAST::Base'); 
     296} 
     297 
     298{ package VAST::longname; our @ISA = ('VAST::Base'); 
     299} 
     300 
     301{ package VAST::metachar; our @ISA = ('VAST::Base'); 
     302} 
     303 
     304{ package VAST::method_def; our @ISA = ('VAST::Base'); 
     305} 
     306 
     307{ package VAST::methodop; our @ISA = ('VAST::Base'); 
     308} 
     309 
     310{ package VAST::modifier_expr; our @ISA = ('VAST::Base'); 
     311} 
     312 
     313{ package VAST::mod_internal; our @ISA = ('VAST::Base'); 
     314} 
     315 
     316{ package VAST::module_name; our @ISA = ('VAST::Base'); 
     317} 
     318 
     319{ package VAST::morename; our @ISA = ('VAST::Base'); 
     320} 
     321 
     322{ package VAST::multi_declarator; our @ISA = ('VAST::Base'); 
     323} 
     324 
     325{ package VAST::multisig; our @ISA = ('VAST::Base'); 
     326} 
     327 
     328{ package VAST::name; our @ISA = ('VAST::Base'); 
     329} 
     330 
     331{ package VAST::named_param; our @ISA = ('VAST::Base'); 
     332} 
     333 
     334{ package VAST::nibble; our @ISA = ('VAST::Base'); 
     335} 
     336 
     337{ package VAST::nibbler; our @ISA = ('VAST::Base'); 
     338} 
     339 
     340{ package VAST::noun; our @ISA = ('VAST::Base'); 
     341} 
     342 
     343{ package VAST::nulltermish; our @ISA = ('VAST::Base'); 
     344} 
     345 
     346{ package VAST::number; our @ISA = ('VAST::Base'); 
     347} 
     348 
     349{ package VAST::package_declarator; our @ISA = ('VAST::Base'); 
     350} 
     351 
     352{ package VAST::package_def; our @ISA = ('VAST::Base'); 
     353} 
     354 
     355{ package VAST::parameter; our @ISA = ('VAST::Base'); 
     356} 
     357 
     358{ package VAST::param_sep; our @ISA = ('VAST::Base'); 
     359} 
     360 
     361{ package VAST::param_var; our @ISA = ('VAST::Base'); 
     362} 
     363 
     364{ package VAST::pblock; our @ISA = ('VAST::Base'); 
     365} 
     366 
     367{ package VAST::post; our @ISA = ('VAST::Base'); 
     368} 
     369 
     370{ package VAST::postcircumfix; our @ISA = ('VAST::Base'); 
     371} 
     372 
     373{ package VAST::postfix; our @ISA = ('VAST::Base'); 
     374} 
     375 
     376{ package VAST::postop; our @ISA = ('VAST::Base'); 
     377} 
     378 
     379{ package VAST::pre; our @ISA = ('VAST::Base'); 
     380} 
     381 
     382{ package VAST::prefix; our @ISA = ('VAST::Base'); 
     383} 
     384 
     385{ package VAST::quantified_atom; our @ISA = ('VAST::Base'); 
     386} 
     387 
     388{ package VAST::quantifier; our @ISA = ('VAST::Base'); 
     389} 
     390 
     391{ package VAST::quantmod; our @ISA = ('VAST::Base'); 
     392} 
     393 
     394{ package VAST::quibble; our @ISA = ('VAST::Base'); 
     395} 
     396 
     397{ package VAST::quote; our @ISA = ('VAST::Base'); 
     398} 
     399 
     400{ package VAST::quote_mod; our @ISA = ('VAST::Base'); 
     401} 
     402 
     403{ package VAST::quotepair; our @ISA = ('VAST::Base'); 
     404} 
     405 
     406{ package VAST::regex_block; our @ISA = ('VAST::Base'); 
     407} 
     408 
     409{ package VAST::regex_declarator; our @ISA = ('VAST::Base'); 
     410} 
     411 
     412{ package VAST::regex_def; our @ISA = ('VAST::Base'); 
     413} 
     414 
     415{ package VAST::right; our @ISA = ('VAST::Base'); 
     416} 
     417 
     418{ package VAST::routine_declarator; our @ISA = ('VAST::Base'); 
     419} 
     420 
     421{ package VAST::rxinfix; our @ISA = ('VAST::Base'); 
     422} 
     423 
     424{ package VAST::scoped; our @ISA = ('VAST::Base'); 
     425} 
     426 
     427{ package VAST::scope_declarator; our @ISA = ('VAST::Base'); 
     428} 
     429 
     430{ package VAST::semilist; our @ISA = ('VAST::Base'); 
     431} 
     432 
     433{ package VAST::sigil; our @ISA = ('VAST::Base'); 
     434} 
     435 
     436{ package VAST::signature; our @ISA = ('VAST::Base'); 
     437} 
     438 
     439{ package VAST::sigspace; our @ISA = ('VAST::Base'); 
     440} 
     441 
     442{ package VAST::slurp; our @ISA = ('VAST::Base'); 
     443} 
     444 
     445{ package VAST::special_variable; our @ISA = ('VAST::Base'); 
     446} 
     447 
     448{ package VAST::statement; our @ISA = ('VAST::Base'); 
     449} 
     450 
     451{ package VAST::statement_control; our @ISA = ('VAST::Base'); 
     452} 
     453 
     454{ package VAST::statementlist; our @ISA = ('VAST::Base'); 
     455} 
     456 
     457{ package VAST::statement_mod_cond; our @ISA = ('VAST::Base'); 
     458} 
     459 
     460{ package VAST::statement_mod_loop; our @ISA = ('VAST::Base'); 
     461} 
     462 
     463{ package VAST::statement_prefix; our @ISA = ('VAST::Base'); 
     464} 
     465 
     466{ package VAST::stopper; our @ISA = ('VAST::Base'); 
     467} 
     468 
     469{ package VAST::sublongname; our @ISA = ('VAST::Base'); 
     470} 
     471 
     472{ package VAST::subshortname; our @ISA = ('VAST::Base'); 
     473} 
     474 
     475{ package VAST::sym; our @ISA = ('VAST::Base'); 
     476} 
     477 
     478{ package VAST::term; our @ISA = ('VAST::Base'); 
     479} 
     480 
     481{ package VAST::termish; our @ISA = ('VAST::Base'); 
     482} 
     483 
     484{ package VAST::text; our @ISA = ('VAST::Base'); 
     485} 
     486 
     487{ package VAST::trait; our @ISA = ('VAST::Base'); 
     488} 
     489 
     490{ package VAST::trait_auxiliary; our @ISA = ('VAST::Base'); 
     491} 
     492 
     493{ package VAST::twigil; our @ISA = ('VAST::Base'); 
     494} 
     495 
     496{ package VAST::type_constraint; our @ISA = ('VAST::Base'); 
     497} 
     498 
     499{ package VAST::typename; our @ISA = ('VAST::Base'); 
     500} 
     501 
     502{ package VAST::val; our @ISA = ('VAST::Base'); 
     503} 
     504 
     505{ package VAST::value; our @ISA = ('VAST::Base'); 
     506} 
     507 
     508{ package VAST::variable; our @ISA = ('VAST::Base'); 
     509} 
     510 
     511{ package VAST::variable_declarator; our @ISA = ('VAST::Base'); 
     512} 
     513 
     514{ package VAST::ws; our @ISA = ('VAST::Base'); 
     515} 
     516 
     517{ package VAST::xblock; our @ISA = ('VAST::Base'); 
     518} 
     519 
     520 
     521 
     522if ($0 eq __FILE__) { 
     523    ::MAIN(); 
    81524} 
    82525