diff options
Diffstat (limited to 'Build/source/utils/asymptote/runtime.pl')
| -rwxr-xr-x | Build/source/utils/asymptote/runtime.pl | 121 |
1 files changed, 102 insertions, 19 deletions
diff --git a/Build/source/utils/asymptote/runtime.pl b/Build/source/utils/asymptote/runtime.pl index 74dde0506aa..e43813ad1c4 100755 --- a/Build/source/utils/asymptote/runtime.pl +++ b/Build/source/utils/asymptote/runtime.pl @@ -7,8 +7,31 @@ # ##### +$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; @@ -24,19 +47,34 @@ sub clean_params { 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; } } sub asy_params { - my @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* @@ -44,6 +82,9 @@ sub asy_params { \s* (\w*)(=*)|xs; clean_type($type); + if (not $type_map{$type}) { + assoc_error($filename, $line, $type); + } $_ = "formal(" . $type_map{$type} . ", \"" . lc($name) . "\"" . ", " . ($default ? "true" : "false") . ", " . ($explicit ? "true" : "false") . ")"; @@ -67,37 +108,57 @@ sub c_params { $/ = "\f\n"; -open STDIN, "<runtime.in"; -open STDOUT, ">runtime.cc"; +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"; my $autogenerated= -"/***** Autogenerated from runtime.in; changes will be overwritten *****/\n\n"; +"/***** Autogenerated from $prefix.in; changes will be overwritten *****/\n\n"; +my $base_source_line = 1; my $source_line = 1; print $autogenerated; -print "#line $source_line \"runtime.in\"\n"; +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 $source_line \"runtime.in\"\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 "\nnamespace run {\n"; -read_types($types); +read_types($basetypes, "runtimebase.in", $basesource_type_line); + +read_types($types, "$prefix.in", $source_type_line); -### Begining of `runtime.h' +### Begining of `$prefix.h' push @header, $autogenerated; -push @header, "#ifndef RUNTIME_H\n"; -push @header, "#define RUNTIME_H\n\n"; +# TODO: Capitalize prefix +push @header, "#ifndef " . $prefix . "_H\n"; +push @header, "#define " . $prefix . "_H\n"; push @header, "namespace run {\n"; my $count = 0; @@ -114,8 +175,12 @@ while (<>) { \{(.*)} # 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${count}";} # Unique C++ function name + else {$cname="gen_$prefix${count}";} # Unique C++ function name clean_type($type); @@ -124,15 +189,27 @@ while (<>) { # Build addFunc call for asymptote if($name) { $name =~ s/Operator\s*//; - push @builtin, "#line $source_line \"runtime.in\"\n" + 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} . ", " . '"' . $name . '"' - . ( @params ? ", " . join(", ",asy_params(@params)) + . ( @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; @@ -141,7 +218,7 @@ while (<>) { print $comments; $ncomments = ($comments =~ tr/\n//); $source_line += $ncomments; - print "#line $source_line \"runtime.in\"\n"; + print "#line $source_line \"$prefix.in\"\n"; my $prototype=$type . " " . $name . "(" . $params . ");"; $nprototype = ($prototype =~ tr/\n//)+1; $source_line += $nprototype; @@ -152,7 +229,7 @@ while (<>) { print "void $cname(stack *"; if($type ne "void" or $params ne "") {print $stack;} print ")\n{\n$args"; - print "#line $source_line \"runtime.in\""; + print "#line $source_line \"$prefix.in\""; print "$code}\n\n"; $source_line -= $ncomments+$nprototype; @@ -163,20 +240,26 @@ while (<>) { print "} // namespace run\n"; print "\nnamespace trans {\n\n"; -print "void gen_base_venv(venv &ve)\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 // RUNTIME_H\n"; +push @header, "#endif // ". $prefix . "_H\n"; undef $/; -open HEADER, "<", "runtime.h"; +open HEADER, "<", "$prefix.h"; $orig_header = <HEADER>; $new_header = join "", @header; if ($new_header ne $orig_header) { - open HEADER, ">", "runtime.h"; + open HEADER, ">", "$prefix.h"; print HEADER $new_header; } + +if ($errors) { + unlink("$prefix.h"); + unlink("$prefix.cc"); +} +exit($errors); |