summaryrefslogtreecommitdiff
path: root/graphics/asymptote/runtime.pl
diff options
context:
space:
mode:
Diffstat (limited to 'graphics/asymptote/runtime.pl')
-rwxr-xr-xgraphics/asymptote/runtime.pl294
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);