diff options
Diffstat (limited to 'graphics/asymptote/runtime.pl')
| -rwxr-xr-x | graphics/asymptote/runtime.pl | 294 |
1 files changed, 294 insertions, 0 deletions
diff --git a/graphics/asymptote/runtime.pl b/graphics/asymptote/runtime.pl new file mode 100755 index 0000000000..5724b40f8e --- /dev/null +++ b/graphics/asymptote/runtime.pl @@ -0,0 +1,294 @@ +#!/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"; + +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); |