#!/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 () { 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, "$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 = ; 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 = ; $basesource_line += ($basetypes =~ tr/\n//);; $types = <>; $source_line += ($types =~ tr/\n//);; print "#line $base_source_line \"runtimebase.in\"\n"; $baseheader = ; 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 =
; $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);