#!/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);

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.