languages/APL/src/parser/actions.pm

   1 # Copyright (C) 2008, The Perl Foundation.
   2 # $Id$
   3
   4 =begin comments
   5
   6 APL::Grammar::Actions - ast transformations for APL
   7
   8 This file contains the methods that are used by the parse grammar
   9 to build the PAST representation of an APL program.
  10 Each method below corresponds to a rule in F<src/parser/grammar.pg>,
  11 and is invoked at the point where C<{*}> appears in the rule,
  12 with the current match object as the first argument.  If the
  13 line containing C<{*}> also has a C<#= key> comment, then the
  14 value of the comment is passed as the second argument to the method.
  15
  16 =end comments
  17
  18 class APL::Grammar::Actions;
  19
  20 method TOP($/) {
  21     my $catchpir := "    get_results '0,0', $P0, $S0\n    print $S0\n    exit 1\n";
  22     my $past := PAST::Op.new( $( $<statement_list> ),
  23                               PAST::Op.new( :inline( $catchpir) ),
  24                               :pasttype('try'),
  25                               :node($/) );
  26     make $past;
  27 }
  28
  29 method statement_list($/) {
  30     my $past := PAST::Stmts.new( :node($/) );
  31     for $<statement> {
  32         $past.push( $( $_ ) );
  33     }
  34     make $past;
  35 }
  36
  37 method statement($/) {
  38     my $past := $( $<expression> );
  39     if $past.WHAT() ne 'Op' || $past.pasttype() ne 'copy' {
  40         $past := PAST::Op.new( $past, :name('aplprint'), :node( $/ ) );
  41     }
  42     make $past;
  43 }
  44
  45
  46 method expression($/, $key) {
  47     our %inlinetable;
  48     if ($key eq 'assign') {
  49         my $past := PAST::Op.new( $($<target>),
  50                                   $($<expression>),
  51                                   :pasttype('copy'),
  52                                   :node($/) );
  53         make $past;
  54     }
  55     elsif ($key eq 'monadic') {
  56         my $name := 'monadic:' ~ $<monadic_identifier>;
  57         my $past := PAST::Op.new( $($<expression>), :node($/) );
  58         if %inlinetable{$name} {
  59             $past.inline( %inlinetable{$name} );
  60         }
  61         else {
  62             $past.name($name);
  63         }
  64         make $past;
  65     }
  66     else {
  67         my $past := $( $<subexpression> );
  68         if $<dyadic_identifier>[0] {
  69             my $name := 'dyadic:' ~ $<dyadic_identifier>[0];
  70             $past := PAST::Op.new( $past,
  71                                    $($<expression>[0]),
  72                                    :node($/) );
  73             if %inlinetable{$name} {
  74                 $past.inline(%inlinetable{$name});
  75             }
  76             else {
  77                 $past.name($name);
  78             }
  79         }
  80         make $past;
  81     }
  82 }
  83
  84
  85 method subexpression($/) {
  86     make $( $<simple_expression> );
  87 }
  88
  89
  90 method simple_expression($/, $key) {
  91     make $( $/{$key} );
  92 }
  93
  94 method target($/) {
  95     my $past := $( $<variable_identifier> );
  96     $past.lvalue(1);
  97     make $past;
  98 }
  99
 100 method array_identifier($/, $key) {
 101     make $( $/{$key} );
 102 }
 103
 104 method constant($/, $key) {
 105     make $( $/{$key} );
 106 }
 107
 108 method numeric_constant($/) {
 109     if +$<decimal_representation> != 1 {
 110         my $past := PAST::Op.new( :name('aplvector'), :node($/) );
 111         for $<decimal_representation> {
 112             $past.push( $( $_ ) );
 113         }
 114         make $past;
 115     }
 116     else {
 117         make $( $<decimal_representation>[0] );
 118     }
 119 }
 120
 121 method decimal_representation($/) {
 122     my $value := ~$/;
 123     $value.replace("\x207b", '-');
 124     PIR q<    $P0 = find_lex '$value'  >;
 125     PIR q<    $S0 = $P0                >;
 126     PIR q<    $I0 = index $S0, '.'     >;
 127     PIR q<    unless $I0 < 0 goto ffff >;
 128     PIR q<    $I0 = index $S0, 'E'     >;
 129     PIR q<    unless $I0 < 0 goto ffff >;
 130     PIR q<    concat $P0, '.'          >;
 131     PIR q<  ffff:                      >;
 132     make PAST::Val.new( :value($value), :returns('Float'), :node($/) );
 133 }
 134
 135 method variable_identifier($/) {
 136     make PAST::Var.new( :name( ~$/ ),
 137                         :viviself('Undef'),
 138                         :scope('package'),
 139                         :node( $/ ) );
 140 }
 141
 142 method character_constant_double($/) {
 143     my $value := ~$/[0];
 144     $value.replace('""', '"');
 145     make PAST::Op.new( PAST::Val.new( :value($value) ),
 146                        :name('aplstring'),
 147                        :node( $/ ) );
 148 }
 149
 150 method character_constant_single($/) {
 151     my $value := ~$/[0];
 152     $value.replace("''", "'");
 153     make PAST::Op.new( PAST::Val.new( :value($value) ),
 154                        :name('aplstring'),
 155                        :node( $/ ) );
 156 }
 157
 158
 159 # Local Variables:
 160 #   mode: cperl
 161 #   cperl-indent-level: 4
 162 #   fill-column: 100
 163 # End:
 164 # vim: expandtab shiftwidth=4:
 165