path: root/Build/source/utils/asymptote/runtime.pl

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

$prefix = shift(@ARGV);
if (not $prefix) {
    print STDERR "usage: ./runtime.pl module_name\n";
    exit(1);
}

$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(opsyms, "opsymbols.h") ||
        die("Couldn't open opsymbols.h");
while (<opsyms>) {
    if (m/^OPSYMBOL\(\"(.*)\", ([A-Za-z_]+)\);/) {
        $opsymbols{ $1 } = $2;
    }
}

# 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, "<$prefix.in" or die "can't open input file $prefix.in";
open BASE, "<runtimebase.in" or die "can't open runtimebase.in";
open STDOUT, ">$prefix.cc" or die "can't open output file $prefix.cc";

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

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

my $base_source_line = 1;
my $source_line = 1;

print $autogenerated;

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

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

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

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

print "#line $base_source_line \"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'
push @header, $autogenerated;
# TODO: Capitalize prefix
push @header, "#ifndef " . $prefix . "_H\n";
push @header, "#define " . $prefix . "_H\n";
push @header, "namespace run {\n";

my $count = 0;
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 \"$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 \"$prefix.in\"\n"
      . "  REGISTER_BLTIN(run::" . $cname
      . ',"' . $cname . '"' . ");\n";
  }

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

  print $comments;
  $ncomments = ($comments =~ tr/\n//);
  $source_line += $ncomments;
  print "#line $source_line \"$prefix.in\"\n";
  my $prototype=$type . " " . $name . "(" . $params . ");";
  $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 \"$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";
push @header, "#endif // ". $prefix . "_H\n";

undef $/;
open HEADER, "<", "$prefix.h";
$orig_header = <HEADER>;
$new_header = join "", @header;
if ($new_header ne $orig_header) {
	open HEADER, ">", "$prefix.h";
	print HEADER $new_header;
}

if ($errors) {
  unlink("$prefix.h");
  unlink("$prefix.cc");
}
exit($errors);