I2PIR.trg

{ #  Example of support code
  use List::Util qw(reduce);
  my %Op = (PLUS=>'+', MINUS => '-', TIMES=>'*', DIV => '/');
}

algebra = fold wxz zxw neg;

fold: /TIMES|PLUS|DIV|MINUS/:b(NUM, NUM) => { 
  my $op = $Op{ref($b)};

  croak "Unexpected tree shape: ".$_[0]->str." can't find number in the expected place\n" unless exists ($NUM[0]->{attr}) && ($NUM[0]->{attr} =~ /^\d+/);

  $NUM[0]->{attr} = eval  "$NUM[0]->{attr} $op $NUM[1]->{attr}";
  $_[0] = $NUM[0]; 
}

zxw: TIMES(NUM, .) and {$NUM->{attr} == 0} => { $_[0] = $NUM }

wxz: TIMES(., NUM) and {$NUM->{attr} == 0} => { $_[0] = $NUM }

neg: NEG(NUM) => { $NUM->{attr} = -$NUM->{attr}; $_[0] = $NUM }

{{ 
  my $num = 1; # closure

  sub new_N_register {
    return '$N'.$num++;
  }
}}

reg_assign: $x  => { 
    if (ref($x) =~ /VAR|NUM/) {
      $x->{reg} = $x->{attr};
      return 1;
    }
    if (ref($x) =~ /ASSIGN/) {
      $x->{reg} = $x->child(0)->{attr};
      return 1;
    }
    $_[0]->{reg} = new_N_register(); 
  }


translation = t_num t_var t_op t_neg t_assign t_list t_print;

t_num: NUM => { $NUM->{tr} = $NUM->{attr} }

{ our %s; }

t_var: VAR => { 
   croak "Unexpected tree shape: ".$_[0]->str." can't find identifier in VAR node\n" unless exists $_[0]->{attr};
   $s{$_[0]->{attr}} = "num"; 
   $_[0]->{tr} = $_[0]->{attr}; 
}

t_op:  /TIMES|PLUS|DIV|MINUS/:b($x, $y) => {
    my $op = $Op{ref($b)};
    $b->{tr} = "$b->{reg} = $x->{reg} $op $y->{reg}"; 
  }

t_neg: NEG($exp) => { $NEG->{tr} = "$NEG->{reg} = - $exp->{reg}"; }

t_assign: ASSIGN($v, $e) => { 
  $s{$v->{attr}} = "num";
  $ASSIGN->{tr} = "$v->{reg} = $e->{reg}" 
}

{ my $cr = '\\n'; }
t_print: PRINT(., $var) => {
    $s{$var->{attr}} = "num";

    $PRINT->{tr} =<<"EOP";
print "$var->{attr} = "
print $var->{attr}
print "$cr"
EOP
  }

{
  # Concatenates the translations of the subtrees
  sub cat_trans {
    my $t = shift;

    my $tr = "";
    for ($t->children) {
      (ref($_) =~ m{NUM|VAR|TERMINAL}) 
        or $tr .= cat_trans($_)."\n" 
    }
    $tr .= $t->{tr} ;
  }
}

t_list: EXPS(@S) 
  => {
    $EXPS->{tr} = "";
    my @tr = map { cat_trans($_) } @S;
    $EXPS->{tr} = 
      reduce { "$a\n$b" } @tr if @tr;
  }