#!/usr/bin/env perl
######
# runtime.pl
# Tom Prince 2004/4/15
#
#  Generate the runtime functions used by the vm::stack machine.
#
#####

use strict;
use warnings;

use Getopt::Long;

my $opsymbolsFile;
my $runtimeBaseFile;
my $prefix;
my $srcTemplateDir;
my $headerOutDir;
my $srcOutDir;

GetOptions(
    "opsym-file=s"        => \$opsymbolsFile,
    "runtime-base-file=s" => \$runtimeBaseFile,
    "src-template-dir=s"  => \$srcTemplateDir,
    "prefix=s"            => \$prefix,
    "header-out-dir=s"    => \$headerOutDir,
    "src-out-dir=s"       => \$srcOutDir
) || die("Argument error");

my $outHeaderFile = "$headerOutDir/$prefix.h";
my $outSrcFile = "$srcOutDir/$prefix.cc";

my $stack = "Stack";

my $errors = 0;

sub report_error {
    my $filename = shift;
    my $line = shift;
    my $error = shift;
    print STDERR "$filename:$line: $error\n";
    $errors = 1;
}

sub assoc_error {
    my $filename = shift;
    my $line = shift;
    my $type = shift;
    report_error($filename, $line, "no asy type associated to '$type'");
}

sub clean_type {
    for (@_) {
        s/\s//g;
    }
}

sub clean_params {
    for (@_) {
        s/\n//g;
    }
}

my %type_map;
sub read_types {
    my @types = split /\n/, shift;
    my $filename = shift;
    my $line = shift;
    for (@types) {
        ++$line;
        # Remove // comments.
        s/\/\/.*//g;

        # Skip blank lines.
        next if /^\s*$/;

        my ($type,$code) =
            m|(\w*(?:\s*\*)?)
              \s*=>\s*
              (.*)
              |x;
        if (not $type) {
            report_error($filename, $line, "bad type declaration");
        }
        clean_type($type);
        $type_map{$type} = $code;
    }
}

# Scrape the symbol names of the operators from opsymbols.h.
my %opsymbols = ();
open(my $opsyms, $opsymbolsFile) ||
        die("Couldn't open $opsymbolsFile");
while (<$opsyms>) {
    if (m/^OPSYMBOL\(\"(.*)\", ([A-Za-z_]+)\);/) {
        $opsymbols{ $1 } = $2;
    }
}

close($opsyms);

# Turn a name into a symbol.
sub symbolize {
    my $name = shift;
    if ($name =~ /^[A-Za-z0-9_]+$/) {
        return "SYM($name)";
    }
    if ($opsymbols{ $name }) {
        return $opsymbols{ $name };
    }
    if ($name =~ /operator (\w+)/ && $opsymbols{ $1 }) {
      return $opsymbols{ $1 }
    }
    return "symbol::trans(\"" . $name . "\")"
}

sub asy_params {
    my $params = shift;
    my @params = split m/,\s*/, $params;
    my $filename = shift;
    my $line = shift;
    for (@params) {
        my ($explicit, $type, $name, $default) =
            m|^\s*
              (explicit)*\s*(\w*(?:\s*\*)?)
              \s*
              (\w*)(=*)|xs;
        clean_type($type);
        if (not $type_map{$type}) {
            assoc_error($filename, $line, $type);
        }
        $_ = "formal(" . $type_map{$type} . ", " .
        symbolize(lc($name)) . ", " .
	    ($default ? "true" : "false") . ", " .
	    ($explicit ? "true" : "false") . ")";
    }
    return @params;
}

sub c_params {
   my @params = @_;
   for (@params) {
       my ($explicit, $type, $name, $default, $value) =
            m|^\s*
              (explicit)*\s*(\w*(?:\s*\*)?)
              \s*
              (\w*)(=*)([\w.+\-]*)|xs;
       $_ = "  $type $name=vm::pop" . ($type =~ /^item$/ ? "" : "<$type>") .
	   "($stack" . ($default ? "," . $value : "") . ");\n";
   }
   reverse @params;
}

$/ = "\f\n";

open STDIN, "<$srcTemplateDir/$prefix.in" or die "can't open input file $srcTemplateDir/$prefix.in";
open BASE, "<$runtimeBaseFile" or die "can't open $runtimeBaseFile";
open STDOUT, ">$outSrcFile" or die "can't open output file $outSrcFile";

binmode STDIN, ":unix:crlf";
binmode BASE, ":unix:crlf";

my $autogenerated=
"/***** Autogenerated from $prefix.in; changes will be overwritten *****/\n\n";

my $basesource_line = 1;
my $source_line = 1;

print $autogenerated;

print "#line $basesource_line \"$srcTemplateDir/runtimebase.in\"\n";
my $baseheader = <BASE>;
print $baseheader;
$basesource_line += ($baseheader =~ tr/\n//);;
my $basesource_type_line = $basesource_line;

print "#line $source_line \"$srcTemplateDir/$prefix.in\"\n";
my $header = <>;
print $header;
$source_line += ($header =~ tr/\n//);;
my $source_type_line = $source_line;

my $basetypes = <BASE>;
$basesource_line += ($basetypes =~ tr/\n//);;

my $types = <>;
$source_line += ($types =~ tr/\n//);;

print "#line $basesource_line \"$srcTemplateDir/runtimebase.in\"\n";
$baseheader = <BASE>;
print $baseheader;
$basesource_line += ($baseheader =~ tr/\n//);;

print "#line $source_line \"$prefix.in\"\n";
$header = <>;
print $header;
$source_line += ($header =~ tr/\n//);;

print "\n#ifndef NOSYM";
print "\n#include \"$prefix.symbols.h\"\n";
print "\n#endif";
print "\nnamespace run {\n";

read_types($basetypes, "runtimebase.in", $basesource_type_line);

read_types($types, "$prefix.in", $source_type_line);

### Begining of `$prefix.h'
my @header;
push @header, $autogenerated;
# TODO: Capitalize prefix
push @header, "#pragma once\n";
push @header, "namespace run {\n";

my $count = 0;
my @builtin;
while (<>) {
  my ($comments,$type,$name,$cname,$params,$code) =
    m|^((?:\s*//[^\n]*\n)*) # comment lines
      \s*
      (\w*(?:\s*\*)?)   # return type
      \s*
      ([^(:]*)\:*([^(]*) # function name
      \s*
      \(([\w\s*,=.+\-]*)\)  # parameters
      \s*
      \{(.*)}           # body
      |xs;

  if (not $type) {
      report_error("$prefix.in", $source_line, "bad function definition");
  }

  if($cname) {push @header, "void $cname(vm::stack *);\n";}
  else {$cname="gen_$prefix${count}";}  # Unique C++ function name

  clean_type($type);

  my @params = split m/,\s*/, $params;

  # Build addFunc call for asymptote
  if($name) {
  $name =~ s/Operator\s*//;
  if (not $type_map{$type}) {
      assoc_error("$prefix.in", $source_line, $type);
  }
  my @asy_params = asy_params($params, "$prefix.in", $source_line);
  push @builtin, "#line $source_line \"$srcTemplateDir/$prefix.in\"\n"
      . "  addFunc(ve, run::" . $cname
      . ", " . $type_map{$type}
      . ", " . symbolize($name)
      . ( @params ? ", " . join(", ",@asy_params)
                   : "" )
      . ");\n";
  }

  # Build REGISTER_BLTIN command for builtin functions which are not added to
  # the environment.
  if (not $name and $cname) {
    push @builtin, "#line $source_line \"$srcTemplateDir/$prefix.in\"\n"
      . "  REGISTER_BLTIN(run::" . $cname
      . ',"' . $cname . '"' . ");\n";
  }

  # Handle marshalling of values to/from stack
  my $qualifier = ($type eq "item" ? "" : "<$type>");
  $code =~ s/\breturn ([^;]*);/{$stack->push$qualifier($1); return;}/g;
  my $args = join("",c_params(@params));

  print $comments;
  my $ncomments = ($comments =~ tr/\n//);
  $source_line += $ncomments;
  print "#line $source_line \"$srcTemplateDir/$prefix.in\"\n";
  my $prototype=$type . " " . $name . "(" . $params . ");";
  my $nprototype = ($prototype =~ tr/\n//)+1;
  $source_line += $nprototype;
  if($name) {
    clean_params($prototype);
    print "// $prototype\n";
  }
  print "void $cname(stack *";
  if($type ne "void" or $params ne "") {print $stack;}
  print ")\n{\n$args";
  print "#line $source_line \"$srcTemplateDir/$prefix.in\"";
  print "$code}\n\n";

  $source_line -= $ncomments+$nprototype;
  $source_line += ($_ =~ tr/\n//);
  ++$count;
}

print "} // namespace run\n";

print "\nnamespace trans {\n\n";
print "void gen_${prefix}_venv(venv &ve)\n{\n";
print @builtin;
print "}\n\n";
print "} // namespace trans\n";

### End of `header.h'
push @header, "}\n\n";

undef $/;
my $orig_header = "";
my $HEADER;
if (-e $outHeaderFile) {
    open $HEADER, "<", $outHeaderFile;
    $orig_header = <$HEADER>;
    close $HEADER;
}

my $new_header = join "", @header;
if ($new_header ne $orig_header) {
	open $HEADER, ">", $outHeaderFile;
	print $HEADER $new_header;
    close $HEADER;
}

if ($errors) {
  unlink($outHeaderFile);
  unlink($outSrcFile);
}
exit($errors);