#! /usr/bin/perl -w
#
# This program created 2004, Dan Sugalski. The code in this file is in
# the public domain--go for it, good luck, don't forget to write.
use strict;
use Parse::RecDescent;
use Data::Dumper;

# Take the source and destination files as parameters
my ($source, $destination) = @ARGV;

my %global_vars;
my $tempcount = 0;
my (%temps) = (P => 0,
	       I => 0,
	       N => 0,
	       S => 0
	      );

# AUTOACTION simplifies the creation of a parse tree by specifying an action 
# for each production (ie action is { [@item] })
$::RD_AUTOACTION = q{ [@item] };

my $grammar = <<'EOG';
field: /\b\w+\b/

stringconstant: /'[^']*'/ |
 		/"[^"]*"/ 
#"
float: /[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/

constant: float | stringconstant

addop: '+' | '-'
mulop: '*' | '/'
modop: '%'
cmpop: '<>' | '>='| '<=' | '<' | '>' | '='
logop: 'and' | 'or'

parenexpr: '(' expr ')'

simplevalue: parenexpr | constant | field 

modval: <leftop: simplevalue modop simplevalue>

mulval: <leftop: modval mulop modval>

addval: <leftop: mulval addop mulval>

cmpval: <leftop: addval cmpop addval>

logval: <leftop: cmpval logop cmpval>

expr: logval 

declare: 'declare' field

assign: field '=' expr

print: 'print' expr

statement: assign | print | declare
EOG

# ?? Makes emacs cperl syntax highlighting mode happier
my $parser = Parse::RecDescent->new($grammar);

my @nodes;
open SOURCE, "<$source" or die "Can't open source program ($!)";

while (<SOURCE>) {
    # Strip the trailing newline and leading spaces. If the line is
    # blank, then skip it
    chomp;
    s/^\s+//;
    next unless $_;

    # Parse the statement and throw an error if something went wrong
    my $node = $parser->statement($_);
    die "Bad statement" if !defined $node;

    # put the parsed statement onto our list of nodes for later treatment
    push @nodes, $node;
}

print Dumper(\@nodes);
#exit;

# At this point we have parsed the program and have a tree of it
# ready to process. So lets do so. First we set up our node handlers.

my (%handlers) = (addval => \&handle_generic_val,
		  assign => \&handle_assign,
		  cmpval => \&handle_generic_val,
		  constant => \&delegate,
		  declare => \&handle_declare,
		  expr => \&delegate,
		  field => \&handle_field,
		  float => \&handle_float,
		  logval => \&handle_generic_val,
		  modval => \&handle_generic_val,
		  mulval => \&handle_generic_val,
		  negfield => \&handle_negfield,
		  parenexpr => \&handle_paren_expr,
		  print => \&handle_print,
		  simplevalue => \&delegate,
		  statement => \&delegate,
		  stringconstant => \&handle_stringconstant,
		 );

# Open the output file and emit the preamble
open PIR, ">$destination" or die "Can't open destination ($!)";
print PIR <<HEADER;
.sub __MAIN prototyped
  .param pmc argv
HEADER

foreach my $node (@nodes) {
    my @lines = process_node(@$node);
    print PIR join("", @lines);
}

print PIR <<FOOTER;
  end
.end
FOOTER

# The value of the last expression evaluated 
sub last_expr_val {
    return $::last_expr;
}

# Setting the last expression evaluated's value
sub set_last_expr_val {
    $::last_expr = $_[0];
}

sub process_node {
  my (@elems) = @_;
  return "\n" unless @elems;
  return "\n" unless defined($elems[0]);
  if (ref $elems[0]) {
    return process_node(@{$elems[0]});
  } elsif (exists($handlers{$elems[0]})) {
    return $handlers{$elems[0]}->(@elems);
  } else {
    return "***", $elems[0], "***\n";
  }
}  

sub handle_assign {
    my ($nodetype, $destvar, undef, $expr) = @_;
    my @nodes;
    push @nodes, process_node(@$expr);
    my $rhs = last_expr_val();
    push @nodes, process_node(@$destvar);
    my $lhs = last_expr_val();
    push @nodes, "  $lhs = $rhs\n";
    return @nodes;
}

sub handle_declare {
    my ($nodetype, undef, $var) = @_;
    my @lines;

    my $varname = $var->[1];

    # Does it exist?
    if (defined $global_vars{$varname}) {
	die "Multiple declaration of $varname";
    }
    $global_vars{$varname}++;
    push @lines, "  .local pmc $varname\n";
    push @lines, "  new $varname, .PerlInt\n";
    return @lines;
}

sub handle_field {
    my ($nodetype, $fieldname) = @_;
    if (!exists $global_vars{$fieldname}) {
	die "undeclared field $fieldname used";
    }
    set_last_expr_val($fieldname);
    return;
}

sub handle_float {
    my ($nodetype, $floatval) = @_;
    set_last_expr_val($floatval);
    return;
}

sub handle_generic_val {
  my (undef, $terms) = @_;
  my (@terms) = @$terms;

  # Process the LHS
  my $lhs = shift @terms;
  my @tokens;
  push @tokens, process_node(@$lhs);

  my ($op, $rhs);

  # Now keep processing the RHS as long as we have it
  while (@terms) {
      $op = shift @terms;
      $rhs = shift @terms;
      my $val = last_expr_val();
      my $oper = $op->[1];
      
      push @tokens, process_node(@$rhs);
      my $other_val = last_expr_val();

      my $dest = $temps{P}++;

      foreach ($oper) {
	  # Simple stuff -- addition, subtraction, multiplication,
	  # division, and modulus. Just a quick imcc transform
	  /(\+|\-|\*|\/|%)/ && do { push @tokens, "new \$P$dest, .PerlInt\n";
				    push @tokens, "\$P$dest = $val $oper $other_val\n";
				    set_last_expr_val("\$P$dest");
				    last;
				  };
	  /and/ && do { push @tokens, "new \$P$dest, .PerlInt\n";
			push @tokens, "\$P$dest = $val && $other_val\n";
			set_last_expr_val("\$P$dest");
			last;
		      };
	  /or/ && do { push @tokens, "new \$P$dest, .PerlInt\n";
		       push @tokens, "\$P$dest = $val || $other_val\n";
		       set_last_expr_val("\$P$dest");
		       last;
		     };
	  /<>/ && do { my $label = "eqcheck$tempcount";
		       $tempcount++;
		       push @tokens, "new \$P$dest, .Integer\n";
		       push @tokens, "\$P$dest = 1\n";
		       push @tokens, "ne $val, $other_val, $label\n";
		       push @tokens, "\$P$dest = 0\n";
		       push @tokens, "$label:\n";
		       set_last_expr_val("\$P$dest");
		       last;
		     };	
	  /=/ && do { my $label = "eqcheck$tempcount";
		  $tempcount++;
		  push @tokens, "new \$P$dest, .Integer\n";
		  push @tokens, "\$P$dest = 1\n";
		  push @tokens, "eq $val, $other_val, $label\n";
		  push @tokens, "\$P$dest = 0\n";
		  push @tokens, "$label:\n";
		  set_last_expr_val("\$P$dest");
		  last;
		};	
          /</ && do { my $label = "eqcheck$tempcount";
		      $tempcount++;
		      push @tokens, "new \$P$dest, .Integer\n";
		      push @tokens, "\$P$dest = 1\n";
		      push @tokens, "lt $val, $other_val, $label\n";
		      push @tokens, "\$P$dest = 0\n";
		      push @tokens, "$label:\n";
		      set_last_expr_val("\$P$dest");
		      last;
		    };	
	  />/ && do { my $label = "eqcheck$tempcount";
		      $tempcount++;
		      push @tokens, "new \$P$dest, .Integer\n";
		      push @tokens, "\$P$dest = 1\n";
		      push @tokens, "gt $val, $other_val, $label\n";
		      push @tokens, "\$P$dest = 0\n";
		      push @tokens, "$label:\n";
		      set_last_expr_val("\$P$dest");
		      last;
		    };	
	  die "Can't handle $oper";
      }
  }
  return @tokens;
}

sub handle_paren_expr {
    my ($nodetype, undef, $expr, undef) = @_;
    return process_node(@$expr);
}

sub handle_stringconstant {
    my ($nodetype, $stringval) = @_;
    set_last_expr_val($stringval);
    return;
}

sub handle_print {
    my ($nodetype, undef, $expr) = @_;
    my @nodes;
    push @nodes, process_node(@$expr);
    my $val = last_expr_val();
    push @nodes, "  print $val\n";
    return @nodes;
}

sub delegate {
    my ($nodetype, $nodeval) = @_;
    return process_node(@$nodeval);
}