#!/usr/bin/perl -w
#
# See the file $PREFIX/lib/matwrap/matwrap.pod for
# extensive documentation.
#
# Copyright (c) 1997 Gary R. Holt. This is distributed under the terms of the
# perl artistic license (http://language.perl.com/misc/Artistic.html).
#
require 5.002;
#
# Some stuff needed by the automatic install:
#
use Cwd;
$PREFIX = &Cwd::cwd();
# This is the location of our source tree.
unshift(@INC, "$PREFIX"."/matwrap");
# Add our library directory.
#
# Parse the command line arguments:
#
@cpp_ignore_dirs = ('/usr/include/', '/usr/local/include/');
# Directory hierarchies to ignore when the
# -cpp switch is active. These should be
# followed by a trailing slash to avoid
# matching something like /usr/include_others.
%cpp_ignore_files = (); # Files we're specifically supposed to ignore.
$include_str = ''; # A list of files to #include.
($progname = $0) =~ s@.*/@@; # Format program name for error messages.
$dim_type = 'int'; # The C type to use for array indices and
# dimensions.
@files = (); # No files to parse.
$debug = 0; # Not in debug mode.
$cpp_flag = 0; # Default to not running the C preprocessor.
#@comments = (); # Where we store the comments.
@strings = (); # Where we store quoted strings, etc.
@brace_strs = (); # Where we store strings surrounded by braces
# which we removed.
%variables = (); # Type of each global non-static variable.
%functions = (); # The prototype, etc., of each global
# function, indexed by function name. Elements
# are associative arrays (see the .pod file
# for more details).
%classes = (); # Elements are indexed by class names and are
# associative arrays of members of each class.
# If the members are themselves an associative
# array, then they are functions (see the .pod
# file for details on format); otherwise
# they are fields and the type is given by the
# value.
%derived_classes = (); # For each class, contains an array of names
# of classes that derive from this class.
@basic_type_keywords = (qw(short long signed unsigned
float double int char
complex Complex const));
@basic_types{@basic_type_keywords} = @basic_type_keywords;
%typedef = # Contains definitions of types.
(%basic_types, # Fill out the types with the known types.
# Unknown words in the type field will be
# assumed to be argument names (for function
# arguments) and will be ignored. We also
# ignore some keywords like 'inline' and
# 'virtual' and 'extern'.
'void' => 'void', # Other type words relevant for functions:
'static' => 'static',
'const' => 'const', # Keep 'const' around.
'inline' => '' # Delete occurences of 'inline'.
);
%novectorize_types = (); # Non-zero for all types which we don't want
# to vectorize at all, even if we could.
#
# Search the argument list for the -language option:
#
for (0..(@ARGV-2)) {
if ($ARGV[$_] eq '-language') { # Is the language specified?
$language = $ARGV[$_+1]; # Get the language name.
splice(@ARGV, $_, 2); # Remove the elements.
require "wrap_$language.pl"; # Load the language file.
&{"${language}::parse_argv"}(\@ARGV); # Let it see the options first.
last; # Stop scannining @ARGV for -language.
}
}
defined($language) or die("$progname: must specify output language\n");
while ($_ = shift(@ARGV)) { # Get the next argument:
if (/^-cpp$/) { # Run the C preprocessor?
$cpp_flag = 1; # Remember to run the C preprocessor.
last; # Remember the arguments.
} elsif (/^-cpp_ignore$/) { # More things for the C preprocessor to ignore?
$_ = shift(@ARGV); # Get the next argument.
if (-d $_) { # Is this a directory?
push(@cpp_ignore_dirs, "$_/"); # Remember the directory.
} else {
$cpp_ignore_files{$_} = 1; # Remember to ignore this file.
}
} elsif (/^-debug$/) { # Dump out definitions?
$debug = 1;
} elsif (/^-language$/) { # A repeated -language qualifier?
die("$progname: two -languages specified\n");
} elsif (/^-wrap_?only$/) { # Specify explicitly what to wrap:
$wraponly_classes = {}; # Indicate that we're only supposed to wrap
$wraponly_globals = {}; # selected things.
while ($_ = shift(@ARGV)) { # Get the next argument.
if ($_ eq 'class') { # Wrap the whole class?
$wraponly_classes->{shift(@ARGV)} = 1; # Wrap this class.
} else {
$wraponly_globals->{$_} = 1; # Wrap this function/variable.
}
}
} elsif (/^-o$/) { # Specify output file?
$outfile = shift(@ARGV); # Next parameter is output file.
}
#
# Unrecognized switch:
#
elsif (/^-$/) { # Is it an option?
die("$progname: illegal option $_\n");
} else { # Not an option, must be a file name.
push(@files, $_);
}
}
unless (defined($outfile)) { # Was an output file name explicitly specified?
if ($cpp_flag) {
die("$progname: -o must be explicitly specified before the -cpp flag\n");
} else {
$outfile = &{"${language}::get_outfile"}(\@files); # Get the file name.
print STDERR "$progname: output file is $outfile\n";
}
}
if (@files) { # Any files explicitly named?
local ($/) = undef; # Slurp in files all at once.
# This makes parsing much simpler.
foreach $file (@files) { # Parse our list of files.
if ($file =~ /\.[hH]{1,2}$/) {
$include_str .= "#include \"$file\"\n"; # We'll probably need to include
# this file in the generated code.
} else {
warn("$progname: $file is not an include file\n");
}
open(INFILE, $file) || die("$progname: can't open $file--$!\n");
$_ = <INFILE>; # Read the whole file.
close(INFILE); # Done with the file.
eval { &parse_str($_); }; # Parse this string.
$@ and warn("In file $file:\n$@");
}
}
if ($cpp_flag) { # Run the C preprocessor?
grep($_ eq '-E', @ARGV) or # If -E isn't already present somewhere,
splice(@ARGV, 1, 0, '-E'); # add -E after the first word.
#
# Start up the child process. Don't use the simple OPEN() because that's
# likely to get fouled up if any of the arguments had to be quoted because
# they contained special characters. Instead, we want to use exec()
# with a list argument.
#
my $pid = open(CPP, "-|"); # Fork and open a process.
if (!defined($pid)) { # Did the fork succede?
die("$progname: can't fork C preprocessor--$!\n");
}
if ($pid == 0) { # We're the child?
exec @ARGV; # Execute the preprocessor.
die("Exec of C preprocessor failed--$!\n");
}
#
# We're the parent--read from the C preprocessor and parse the stuff as we
# see it.
#
my $accum_str = '';
my $fname = '';
my $remember_defs_in_file = 1; # True if we're reading input from a file
# for which we want to remember function
# definitions.
while (defined($_ = <CPP>)) { # Read another line.
if (/^\#(?:line)?\s+(?:\d+)\s+\"(\S+?)\"/) {
# Switching to a different include file?
$1 eq $fname and next; # Skip if from the same file.
if ($remember_defs_in_file) { # Supposed to remember definitions we read?
parse_str($accum_str); # Parse them.
} else {
parse_for_typedefs($accum_str); # Just look for typedefs and other
# simple things, ignoring function defs.
}
#
# Try to figure out whether we need to include this file in the wrapper
# code or not. Our rule is that if it is a .h file which was included
# from the top level .c or .cxx file, then we want to include it in the
# wrapper file. Otherwise, it was included by some other .h file and we
# don't need to include it explicitly. This may lead to our including
# more than we really need to but it's likely to make code that will work.
#
my $last_fname = $fname; # Remember what file we used to be in.
$fname = $1; # Remember the new file name.
if ($fname =~ /\.[hH]{1,2}$/ && # Is this a .h file?
$last_fname !~ /\.[hH]{1,2}$/) { # Last file was a .c or .cxx file?
# Then it must have been included at the
# top level. Add it to our list.
my $incstr = $fname; # Assume we include the file as is.
if ($incstr =~ s@^/usr/include/@@ || # Is it a system include file?
$incstr =~ s@^/usr/local/include/@@ ||
$incstr =~ s@.*/gcc-lib/.*/include/@@) { # Is it a system include
# file that was fixed by gcc?
$include_str .= "#include <$incstr>\n"; # Use a different syntax.
} else {
$include_str .= "#include \"$incstr\"\n"; # Include it normally.
}
}
if ($cpp_ignore_files{$fname} || # An explicitly disqualified file?
grep(substr($fname, 0, length($_)) eq $_, @cpp_ignore_dirs) ||
# Or does it begin with the list of forbidden
# directories?
$fname =~ m@/gcc-lib/@) { # Somewhere in gcc fixed includes?
$remember_defs_in_file = 0; # We're not really interested in this file.
} else {
$remember_defs_in_file = 1; # This is a file we are actually
# interested in.
}
$accum_str = ''; # Start accumulating from scratch now.
} else {
$accum_str .= $_;
}
}
close(CPP); # Done with the C preprocessor.
($? >> 8) and die("$progname: C preprocessor exited with error status\n");
$remember_defs_in_file and parse_str($accum_str);
# Parse the remaining stuff.
}
if ($debug) {
#
# DEBUG: dump out the definitions.
#
print "Typedefs:\n";
foreach (sort keys %typedef) {
print " $_ => $typedef{$_}\n";
}
print "\nVariables:\n";
foreach (sort keys %variables) {
print " $variables{$_} $_\n"; # Print the type and name.
}
print "\nFunctions:\n";
foreach (sort keys %functions) {
dump_function(" ", $functions{$_});
}
print "\nClasses:\n";
foreach $cls (sort keys %classes) {
print " $cls:\n";
my $members = $classes{$cls};
foreach (sort keys %$members) {
if (ref($members->{$_}) eq '') { # Is it a member field?
print " $members->{$_} $_;\n"; # Print it as such.
} else { # It's a member function:
dump_function(" ", $members->{$_});
}
}
}
}
#
# Now write the output file:
#
$fh = &{"${language}::initialize"}($outfile, \@files, \@ARGV, $include_str);
# Initialize the output file.
select($fh); # Make the output file be the default file
# handle.
&output_vectorizing_subs; # Output a couple of special C functions for
# vectorizing.
if (%wraponly_classes) { # Only wrapping a few classes?
output_class_conversion_func(keys %wraponly_classes);
# Only allow inheritance relationships between
# them.
print &{"${language}::pointer_conversion_functions"}; # We'll need the functions to
# convert pointers.
} elsif (keys %classes) { # Do we know about any classes?
output_class_conversion_func(keys %classes); # Handle all inheritance
# relationships among all known classes.
print &{"${language}::pointer_conversion_functions"}; # We'll need the functions to
# convert pointers.
}
foreach (sort keys %variables) { # First wrap all the global variables.
wrap_variable($variables{$_}, $_, "")
if (!%wraponly_globals || $wraponly_globals{$_});
}
foreach (sort keys %functions) { # Now wrap all the global functions.
wrap_function($functions{$_})
if (!%wraponly_globals || $wraponly_globals{$_});
}
#
# Now wrap all the classes:
#
foreach $cls (sort keys %classes) {
if (!defined($wraponly_classes) || # Wrap all classes?
defined($wraponly_classes->{$cls})) { # Supposed to wrap this class?
my $members = $classes{$cls}; # Access member table.
foreach (sort keys %$members) { # Look at each member:
if (ref($members->{$_}) eq '') { # Is it a member field?
wrap_variable($members->{$_}, $_, $cls); # Wrap as a variable.
} else { # It's a member function:
wrap_function($members->{$_}); # Wrap it appropriately.
}
}
}
}
&{"${language}::finish"}(); # We're done!
###############################################################################
#
# Code to parse the input files:
#
#
# Just extract the typedefs from a string. Arguments:
# 1) The string.
#
# Side effects:
# New types may be added to the %typedefs array.
#
# Function and variable definitions are ignored.
#
sub parse_for_typedefs {
local ($_) = @_; # Access the argument.
s{\\[\0-\377]}{}g; # Delete all backslash escapes.
s{/\* [\0-\377]*? \*/ | # Old C-style comment.
//.* | # New C++ style comments.
\" .*? \" | # Double quoted string.
\' .*? \' # Single quoted string.
}{}xg; # Delete comments and quoted strings.
s/\bextern\s*\"[^\"]*\"//g; # Remove all the "extern "C"" declarations.
# Note that this will leave an extra trailing
# brace. I don't care.
1 while s{\{[^\{\}]*\}}{}g; # Now remove expressions in braces.
s{\b(?:struct|class)\s+(\w+)}{
# Pick out all the "class xyz", "struct xyz",
# and "typedef struct {} xyz" declarations.
$typedef{$1} ||= $1; # Call these a fundamental type from now on,
# unless we already knew a different name for
# it.
""; # Delete the typedef.
}eg;
s{\btypedef\s+(\w[\w<>\*\[\]\&\s]*?)\s*\b(\w+)\s*;}{ # Find a typedef.
$typedef{$2} = canonicalize_type($1, 1); # Remember it.
"";
}eg;
}
#
# Handle all the definitions contained in a string. Arguments:
# 1) The string.
#
# Side effects: adds entries to the following arrays:
# $variables{name} Contains type of variable.
# $functions{name} Points to an array containing (as element 0)
# the return type of the function, and
# (as elements 1-n) type types of its arguments.
# $classes{name} Points to an associative array containing
# the member functions and their types, encoded
# like the elements of the $function array.
#
sub parse_str {
local ($_) = @_; # Access the argument.
#
# Replace all things that could confuse a simple-minded parser by a tag.
# We want to make sure that our brace and parenthesis matching is accurate,
# so we remove all comments and quoted strings. This is a little tricky
# to do accurately because there could be quotes inside of comments or
# (partial) comments inside of quoted strings. We also should handle \" and
# \' properly. The algorithm for doing this is:
# 1) Remove all backslash escapes.
# 2) Remove all comments and quoted strings at once using an ugly and
# slow regular expression (which seems to work).
# Comments and quoted strings are removed and are replaced by a tag value which
# is just some binary characters surrounding a number. The number is the
# index into the array where we stored the string.
#
s@//(%\w+)@\n$1@g; # Convert //%input into %input. This allows
# declarations to be put into C files.
s{\\[\0-\377]}{push(@strings, $&); # First remove all backslash escapes.
"\01$#strings\02"; }eg; # Leave a tag.
s{/\* [\0-\377]*? \*/ | # Old C-style comment.
//.* (?:\n[ \t]*//.*)* | # Several lines of new C++ style comments.
\" .*? \" | # Double quoted string.
\' .*? \' # Single quoted string.
}{
if (substr($&, 0, 1) eq '/') { # Was this a comment?
# push(@comments, $&); # Save it.
# "\03$#comments\04"; # Leave the tag.
""; # Strip out the comments.
} else { # No, it must have been a string.
push(@strings, $&); # Save it in a different place.
"\01$#strings\02"; # Leave a different tag.
}
}xeg;
s{%novectorize_type\s+(.*)}{ # Any types we're not supposed to vectorize?
my @types = map(canonicalize_type($_), split(',', $1));
# Get the types.
@novectorize_types{@types} = (1) x (@types); # Mark these types as used.
''; # Replace the %novectorize_type declaration
# with nothing.
}eg;
#
# Now pull out all expressions in braces. This has to be done in several
# scans so we handle nested braces. Because we have protected comments
# and quoted strings, there shouldn't be any problem with braces inside
# quotes.
#
s/\bextern\s+\01\d+\02\s*\{?//g; # Remove all the "extern "C"" declarations.
# (We don't have to worry about these; the
# C++ compiler will handle them. Note that
# this may leave an extra brace. I don't care.
1 while s{\{[^\{\}]*\}}{ # Now remove expressions in braces.
push(@brace_strs, $&); # Save the expression.n
"\05$#brace_strs\06"; # Replace it by a tag.
}eg; # This has to be done in a loop because we
# remove the innermost braces first, followed
# by the next, etc.
s{ template \s+ <.*?> .*?[;\06] }{}xg; # Strip out template definitions.
s{__attribute__.*?([;\06])}{$1}g; # Strip out attribute declarations.
#
# At this point we have parsed the file so that all comments and expressions
# of braces have been removed. Now go through sequentially and try to parse
# all #defines, typedefs, etc.
#
# Currently we only handle simple typedefs, where the type name is the last
# expression before the semicolon. Maybe later we'll handle function and
# array typedefs.
#
s/^\s*\#.*\n//mg; # Remove all preprocessor directives.
s{\btypedef\s+(\w[\w<>\s\*\&]+?)(\w+)\s*;}{
$typedef{$2} = canonicalize_type($1); # Store the type name.
""; # Remove the typedef from the file.
}eg;
s{\b(?:class|struct|typedef\s+struct\s+\05\d+\06)\s+(\w+)\s*;}{
$typedef{$1} or # Do we already know of this type?
$typedef{$1} = $1; # Remember that we know this type.
""; # Delete the definition.
}eg; # Strip out forward class definitions.
#
# Look for variable definitions:
#
1 while s{
(^|[;\06]) # Match beginning of statement (end of last).
\s* # Whitespace.
(\w[\w<>\s\*\&]+?) # The type of the variable.
([\w:]+(?:\s*,\s*\w+)*)\s* # The name of the variable(s).
(?:=[^;]+)? # An optional assignment expression.
; # The final semicolon.
}{
my $delim = $1;
my $orig_type = $2; # Remember the original type.
my @vars = split(/\s*,\s*/, $3); # Get a list of variables.
if (!defined($wraponly_globals) || # Are we supposed to wrap any of these
grep($wraponly_globals->{$_}, @vars)) { # variables?
my $type = canonicalize_type($orig_type); # Get the type.
unless ($type =~ /^static /) { # Skip static variables.
foreach (@vars) { # Look at each variable:
next if /:/; # Skip static member data, since these will
# be handled when we see the class definition.
$variables{$_} = $type; # Remember the variable.
}
}
}
$delim; # Remove the whole definition.
}xeg;
#
# Look for function declarations:
#
1 while s{
(?:^|\G|[;\}\06]) # Match beginning of statement (end of last).
\s* # Whitespace between statements.
(\w[\w<>\s\*\&]*?)? # The return type of the function.
(\w+)\s* # The name of the function.
# Note that this does not match member
# functions, whose prototypes are given in
# the class declaration.
\(([:<>\w\s\*\&,]*)\)\s* # The function arguments.
(?:; | # The trailing semicolon, for a prototype.
\05\d+\06)\s* # The body of the function.
((?:\s*%.*\n)+)? # Any additional modifiers.
}{
my ($fdef, $fname);
if (!defined($wraponly_globals) || # Wrap all functions?
defined($wraponly_globals->{$2})) { # This is a function we want?
eval {
($fdef, $fname) = parse_function($1, "", $2, $3, split(/\n\s*/, $4 || ""));
# Parse the function definition.
};
if ($@) { # Was there an error?
print STDERR "$progname: error parsing definition of $1 $2:\n$@\n";
} else {
defined($fdef) and $functions{$fname} = $fdef;
# If it wasn't a static function, remember it.
}
}
''; # Just remove the whole statement.
}xeg;
#
# Look for class or structure definitions:
#
1 while s{
(?:^|\G|[;\06]) # End of last statement.
\s* # Whitespace separating statements.
(class|struct) \s+ (\w+) \s* # The name of the class.
(:[\w\s,]+)? # The inheritance list.
\05(\d+)\06 \s* # The body of the class definition.
; # The trailing semicolon.
}{
parse_class($1, $2, $3, $brace_strs[$4]); # Parse the class definition.
# We parse the class definition even if
# it was not specified in a -wraponly
# declaration, because some other listed class
# may inherit from it.
''; # Just remove the whole statement.
}xeg;
#
# Strip out member function definitions, so we don't give bogus error messages:
#
s{
(?:^|\G|[;\06]) # End of last statement.
\s* # Whitespace separating statements.
(?:[\w\s\*\&]+?) # The return type of the function.
(?:\w+::\~?\w+)\s* # The name of the function.
\((?:[:\w\s\*\&,]*)\)\s* # The function arguments.
(?:const\s*)? # An optional const modifier.
(?:; | # The trailing semicolon, for a prototype.
\05\d+\06) # The body of the function.
}{
}xg;
if (/\w/) { # Some non-punctuation that we didn't recognize?
s/(?:[ \t]*\n)+/\n/g; # Collapse multiple newlines into 1.
s/\05\d+\06/{ ... }/g; # Put braces back in understandable form.
1 while s/\01(\d+)\02/$strings[$1]/g; # Put quoted strings back too.
die "Warning: unrecognized text:\n$_\n";
}
}
#
# Parse a function prototype. Arguments:
# 1) The return type of the function.
# 2) The class of the function.
# 3) The name of the function.
# 4) The argument list for the function (not including the THIS argument for
# member functions).
# 5-n) Additional declarations (%input, etc.), if any.
#
# Returns a reference to the %function_def array appropriate to this function.
# Returns undef if it was a static function.
#
# Also returns the name of the function, which will be different from the name
# passed if there was a %name directive.
#
sub parse_function {
my ($ftype, $class, $fname, $arglist, @addl_decls) = @_;
# Access the arguments.
$ftype = canonicalize_type($ftype); # Get the type of the function.
my $static_flag = ($ftype =~ s/\bstatic\s*//); # Is the function static?
# (This also removes "static" from the type.)
$static_flag and $class eq '' and return undef;
# Don't try to make an entry for static
# functions since we can't access them
# anyway.
#
# Process the argument list. First, we pretty up the list of printable
# arguments, and then we convert that to our internal types.
#
$arglist =~ s/^\s*void\s*$//; # Change argument of "void" to "".
if ($arglist =~ /[\(\)]/) { # Does it have stuff we don't understand?
warn("$progname: function pointers and other complex types not accepted
in definition of function $fname, arglist $arglist\n");
return undef; # Skip this function.
}
my @args = split(/,/, $arglist); # Access the argument list.
$class and !$static_flag and # If this is a non-static member function,
unshift(@args, "$class *THIS"); # pass the class pointer as the first
# argument.
$ftype ne 'void' and # Pretend the return value is the first
unshift(@args, "$ftype retval"); # argument for the moment. We'll take
# it off later.
my @canon_args = map { canonicalize_type($_) } @args;
# Get the canonical types.
#
# Try to infer as much of the rest of the definition as possible. We can
# infer everything if there are no pointer or reference types.
#
# First give names to all arguments that don't have any:
#
my $script_name; # The name of the function in the scripting
# language, if different.
my $vectorize; # Whether or not to vectorize this function.
my @argnames = map { # Get names for each argument to C function.
(($args[$_] =~ /(\w+)\s*(?:=|$)/ && # Take last word in type as
!exists($typedef{$1})) ? # arg name if it's not a type.
$1 : # Use the name if it was there.
"_arg$_"); # Generate a name for the argument.
} 0..(@args-1); # Get the specified names for each argument.
my %args; # This array will become the "args" field of
# the %function_def array.
#
# Process the argument declarations:
#
my $argidx;
foreach $argidx (0 .. (@argnames-1)) {
my $argname = $argnames[$argidx]; # Access the argument name.
my $argtype = $canon_args[$argidx]; # Access its type.
my $decl = ($args{$argname} = {}); # Create a declaration for this arg.
$decl->{vectorize} = !$novectorize_types{$argtype};
# Vectorize unless this type is not supposed to
# be vectorized. (We may turn off the
# vectorize flag for several reasons below.)
$decl->{c_var_name} = "_arg_$argname"; # Generate a unique name.
# Default to passing by value.
$decl->{type} = $argtype; # Remember the type.
$argtype =~ s/\bconst\b\s*//g; # Strip out const to avoid multiplicities of
# types.
$argtype =~ s/ ?\&$//; # Strip off passsing by C++ reference.
#
# If there's an extra '*' on the end of a type we recognize, we assume that
# we pass it by reference and put a & in front of the variable.
#
if ($argtype =~ /^(.*?)\s*\*$/ && $argtype ne 'char *' && # Is this a pointer?
is_basic_type($1)) { # And it's not a structure?
$argtype = $1; # Strip off the trailing *.
$decl->{pass_by_pointer_reference} = 1; # Remember to put & in front of
# call.
} else {
$decl->{pass_by_pointer_reference} = 0; # Don't put & in front of call.
}
$decl->{basic_type} = $argtype; # Store the modified type.
}
$ftype ne 'void' and
$args{'retval'}{source} = 'output'; # "retval" is always an output var.
#
# Look at the additional declarations and convert things like
# %input x(a,b), y(a,b)
# into two separate declarations:
# %input x(a,b)
# %input y(a,b)
#
@paren_expr = (); # No parenthesized subexpressions known yet.
# Note that this is a global variable, because
# it's used in parse_dimension_decl.
my @decl_copy;
foreach (@addl_decls) {
1 while s{(\([^()]*\))}{ # Get rid of parenthesized sub-expressions
# since they can cause problems.
push(@paren_expr, $1); # Save the parenthesized expression.
"\01$#paren_expr\02"; }eg; # Replace it with a tag.
# Convert "%input x(a), y" into two
# separate declaraions, "%input x(a)" and
# "%input y".
push(@decl_copy, "%$1 $2")
while (s/^\s*\%\s*(input|modify|output)\s+(\w+(?:\s*\01\d+\02)?)\s*,\s*(.*)/%$1 $3/);
push(@decl_copy, $_); # Save what's left.
}
#
# Now parse all of the % declarations:
#
foreach (@decl_copy) {
if (/^\s*%\s*(input|modify|output)\s+(\w+)(?:\s*\01(\d+)\02)?\s*$/) { # Input argument?
my $arg = $args{$2}; # Point to the argument description.
defined($arg) ||
die("In definition of ${class}::$fname:\n Illegal argument name $2\n");
$arg->{source} and
die("In definition of ${class}::$fname:\n Illegal reuse of argument $2\n");
$arg->{source} = $1; # Remember the variable type.
if (defined($3)) { # Is this a vector?
$arg->{dimension} = parse_dimension_decl($paren_expr[$3], \%args);
$arg->{basic_type} =~ s/\s*\*$//
# If this was declared as a pointer, change
# the basic type by taking off a '*'. Thus
# char * goes into char, and float ** goes
# into float.
unless $arg->{pass_by_pointer_reference};
# If we already marked it to pass by reference,
# then we already took off the '*'.
}
elsif ($2 ne 'retval' && # Can't alter the type of retval.
$1 ne 'input' && # Is this a modify/output variable and it's
substr($args{$2}{basic_type}, -1) eq '*' && # being passed as a
# pointer? E.g., char * when passed as modify
# output should have a basic type of char.
!$arg->{pass_pointer_by_reference}) {
# We didn't already strip off the '*'?
$arg->{pass_by_pointer_reference} = 1; # Pass a reference.
$arg->{basic_type} =~ s/\s*\*//; # Strip off the *.
}
}
elsif (/^\s*%\s*name\s+(\w+)\s*$/) { # Name of function in scripting language?
$script_name = $1; # Remember that.
} elsif (/^\s*%\s*(no)?vectorize\s*$/) { # Vectorize or not?
$vectorize = !defined($1); # Remember the value.
} elsif (/^\s*%\s*nowrap\s*$/) { # Don't wrap this function?
return undef; # Quit now.
} elsif (/^\s*%\s*name\s+(\w+)\s*$/) { # Change the name of the function:
$fname = $1; # Remember the new name.
} else {
1 while s/\01(\d+)\02/$paren_expr[$1]/; # Put all the parenthesized
# sub-expressions back to print it out properly.
die("In definition of function ${class}::$fname:
unrecognized declaration $_\n");
}
}
#
# Now for each of the input/modify variables whose dimension is given by
# a C expression, see if we can find a way to compute the variable in the
# expression. If so, we can eliminate the dimension variable from the
# argument list.
#
foreach $argname (@argnames) {
my $arg = $args{$argname}; # Get this argument.
$arg->{source} ||= 'input'; # Make all unspecified arguments input args.
$arg->{dimension} ||= []; # Default to a dimensionless variable.
next unless @{$arg->{dimension}}; # Skip if not an array argument.
$arg->{pass_by_pointer_reference} = 0; # If it's an array argument, we
# want this to be 0.
next unless ($arg->{source} eq 'input' || # Skip if not an argument whose
$arg->{source} eq 'modify'); # value we are given.
my $dimidx = 0;
foreach (@{$arg->{dimension}}) { # Look at the expression for each dimension.
#
# See if we can invert this expression to determine the value of a
# dimensional variable. If so, then we can remove the argument from the
# argument list.
#
# We can only invert simple arithmetic expressions, i.e., things in which
# only one argument is present, and which are of the form
# arg
# arg+1
# arg-1
# 2*arg
# 2*arg-1
# Expressions may not be substituted for the '1' and '2', though any other
# integer may be.
#
# Other forms we can't handle, so we require that the value be specified.
#
if (/^_arg_(\w+)$/) { # Just the argument word by itself?
$args{$1}{calculate} = "dim($argname, $dimidx)";
$args{$1}{source} = 'dimension'; # Mark as a dimensional variable.
} elsif (/^_arg_(\w+)\s*([-+])\s*(\d+)$/) { # First or second form?
$args{$1}{calculate} ||= "dim($argname, $dimidx)" .
($2 eq '-' ? '+' : '-') . $3;
$args{$1}{source} = 'dimension'; # Mark as a dimensional variable.
} elsif (/^(\d+)\s*\*\s*_arg_(\w+)$/) { # Simple multiplication?
$args{$2}{calculate} ||= "dim($argname, $dimidx)/$1";
$args{$2}{source} = 'dimension'; # Mark as a dimensional variable.
} elsif (/^(\d+)\s*\*\s*_arg_(\w+)\s*([-+])\s*\d+$/) {
$args{$2}{calculate} ||= "(dim($argname, $dimidx)" .
($3 eq '-' ? '+' : '-') . "$4)/$1";
$args{$2}{source} = 'dimension'; # Mark as a dimensional variable.
}
$dimidx++;
}
}
#
# Now form the list of input/output/modify arguments in order, removing
# dimensional arguments:
#
my (@inputs, @modifies, @outputs); # Array of argument names that will be
# the input/modify/output variables.
foreach $argname (@argnames) {
next if exists($args{$argname}{calculate}); # Do we know how to calculate
# this variable from the others?
if ($args{$argname}{source} =~ /^input|dimension$/) {
# It will be 'dimension' if this is an argument
# that specifies another argument's dimension
# but we couldn't actually calculate the
# argument because the expression wasn't
# invertible, e.g., %input a((b > 0) ? b : -b)
# defines b as a dimensional variable but
# b cannot be calculated so it must be
# explicitly specified.
push(@inputs, $argname);
} elsif ($args{$argname}{source} eq 'modify') {
push(@modifies, $argname);
} elsif ($args{$argname}{source} eq 'output') {
push(@outputs, $argname);
} else {
die("internal error, invalid argument source '$args{$argname}{source}'");
}
}
if ($ftype ne 'void') { # Was there a return type?
shift(@argnames); # Remove the return value from the argument
shift(@canon_args); # list since it is handled separately.
}
unless (defined($vectorize)) { # Did we get a %(no)vectorize?
if ((@outputs != 0 && @inputs != 0 || @modifies != 0) &&
# Don't try to vectorize it if there aren't
# any output arguments or any input args.
grep($_->{source} ne 'output' && $_->{vectorize} != 0, values %args)) {
# Don't try to vectorize this function if
# none of its arguments can be vectorized.
$vectorize = 1;
} else {
$vectorize = 0;
}
}
if (!$vectorize) { # Not vectorizing this function?
foreach $arg (values %args) {
$arg->{vectorize} = 0; # Mark each of the arguments as not vectorized.
}
}
#
# Now we've generated all the pieces for the %function_def array. Fill in
# all of the fields:
#
({ name => $fname,
class => $class,
script_name => $script_name,
static => $static_flag,
inputs => \@inputs,
modifies => \@modifies,
outputs => \@outputs,
returns => $ftype,
args => \%args,
argnames => \@argnames,
vectorize => $vectorize
},
$fname);
}
#
# The following subroutine parses a dimension declaration, e.g.,
# %output varname(dim1, dim2)
# Arguments:
# 1) The dimension string (including parentheses).
# 2) A reference to an associative array where we store the names of dimension
# variables.
#
# Returns: a reference to a list which will become the "dimension" field
# of the "args" subfield of the %function_def array, i.e.,
# [dim1, dim2]
# where dim1 and dim2 are expressions which are the dimensional values.
# These expressions may contain the parameter names or other C expressions.
# The parameter names are substituted to their C equivalents, and any
# arguments which appear in them are declared not vectorized.
#
# Global variable inputs: @paren_expr contains all parenthesized expressions
# that were removed to facilitate parsing.
#
sub parse_dimension_decl {
my ($dimstr, $args) = @_; # Name the arguments.
$dimstr =~ s/^\((.*)\)$/$1/; # Strip the parentheses.
my @dims = split(/,/, $dimstr || ""); # Split into components.
foreach (@dims) {
1 while s/\01(\d+)\02/$paren_expr[$1]/; # Replace parenthesized
# expressions; now commas in parentheses can't
# hurt us since we've already done the split.
s/^\s+//; # Remove leading whitespace.
s/\s+$//; # Remove trailing whitespace.
#
# Find any parameter names in this dimension declaration.
#
my @expr_tokens = split(/(\W+)/, $_); # Split it on non-words (operators),
# but put the operators into the array.
my $idx;
my $n_params = 0; # The number of parameters that were contained
# in this expression.
for ($idx = 0; $idx < @expr_tokens; ++$idx) { # Look at each token:
my $arg = $args->{$expr_tokens[$idx]}; # See if this word is in the
# argument list.
next unless defined($arg); # Skip if it's an operator or some other
# word.
$arg->{vectorize} = 0; # This argument may not be vectorized, since
# it determines the dimensions of other args.
$arg->{source} = 'dimension'; # Remember this is a dimension variable.
$expr_tokens[$idx] = $arg->{c_var_name};
# Replace it in the expression so that we
# know how to do the dimension checking.
}
if (@expr_tokens == 1) { # Only one thing?
$_ = $expr_tokens[0]; # Put it back (in case we changed it).
} else {
$_ = '(' . join('', @expr_tokens) . ')'; # Put the expression in
# parentheses.
}
}
return \@dims;
}
#
# The following subroutine parses a class definition. Arguments:
# 1) "class" or "struct" (so we know what's private and public).
# 2) The name of the class.
# 3) The inheritance list (with a leading colon).
# 4) The body of the function.
#
# Fills out the following global variables:
# $classes{name} Points to an associative array containing
# the member functions and their types. Each
# entry is a list where the first element is
# the type of the function and the remaining
# elements are the types of its arguments.
#
sub parse_class {
my ($class_struct, $classname, $inh_list, $class_def) = @_;
# Name the arguments.
local ($_); # Don't mess up caller's $_.
my %members; # Where we store member function info.
if ($typedef{$classname}) { # Is another name already known for this
$classname = $typedef{$classname}; # class? Change the name if so.
}
$classes{$classname} = \%members; # Make a null associative array.
$typedef{$classname} = $classname; # Remember that we know of this type.
$derived_classes{$classname} = []; # Currently this class is not a base class
# for anything yet.
#
# First parse the inheritance list. Note that since we're parsing classes
# in the same order that the C++ compiler sees them, all the preceding
# classes should be defined.
#
if (defined($inh_list)) { # Is there an inheritance list?
my @base_classes = split(/\s*,\s*/, substr($inh_list, 1)); # Extract them.
# The substr skips the leading colon.
foreach (@base_classes) {
s/^\s+//; # Strip leading spaces.
s/\s+$//; # Strip trailing spaces.
s/\s*virtual\s+//; # Remove the virtual keyword.
next if /^private\b/ || /^protected\b/;
# Not interested in protected members.
s/^public\s+// or # public not explicitly specified?
$class_struct = 'struct' # public is assumed if a struct.
or next; # Skip it--it's private.
unless (defined($derived_classes{$_})) { # Do we understand this base class?
warn("$progname: warning: in class $classname
I don't understand base class $_, skipping its member functions\n");
next; # Skip this class.
}
push(@{$derived_classes{$_}}, $classname); # Remember that this class is
# derived from this base class.
}
}
#
# Now we've dealt with the inheritance. Parse this class. First get rid
# of all the private and protected members:
#
$_ = $class_def; # Access the class definition.
$class_struct eq 'class' and
$_ = "; private: $_"; # Everything in a class is private up until
# the first "public:" declaration. Note that
# we put a semicolon in so we can anchor
# statements.
my $private_members = ''; # No private members known yet.
1 while s{\b(?:private|protected):(.*?)\bpublic:}{
$private_members .= $1; # Remember the private members.
"public:";
}esg; # Delete everything between any
# private: and public:. The loop is necessary
# to handle a sequence like
# protected: private: public:; the first
# iteration will turn it into protected:public:
# and the second will eliminate the protected
# section.
s{\b(?:private|protected):(.*)}{
$private_members .= $1;
"";
}es; # Delete everything after the last private:
# or protected:.
s/\bpublic://g; # Strip out any extra public: declarations.
#
# Now parse the member functions of the class. At this point we know that the
# body of the class begins with ";" or "{".
#
1 while s/([\{;\06])\s*typedef\s.*?;/$1/g; # Remove any typedefs.
1 while s/([\{;\06])\s*(class|struct).*?[;\06]/$1/g;
# Remove any nested classes.
1 while s/([\{;\06])\s*friend\s.*?;/$1/g; # Remove any friends.
1 while s/([\{;\06])[^;\06]*\boperator\b[^;\06]*[;\06]/$1/g;
# Remove any definition of operators.
1 while s{
([\{;\06]) # Match beginning of statement (end of last).
# (Note that we stuck a semicolon at the
# beginning so this will work even for the
# first definition.)
\s* # Whitespace between statements.
([<>\w\s\*\&]*?)? # The return type of the function.
(\~?\w+)\s* # The name of the function.
# Note that this does not match member
# functions, whose prototypes are given in
# the class declaration.
\(([^\)\(]*)\)\s* # The function arguments.
(?:const\s*)? # Optional const qualifier.
(?::[^;\05]+)? # Initializers (for constructors).
(?:; | # The trailing semicolon, for a prototype.
\05\d+\06)\s* # The body of the function.
((?:%.*\n\s*)+)? # Any additional modifiers.
}{
my ($funcname, $functype) = ($3, $2);
if ($funcname eq $classname) { # Is this a constructor?
$funcname = "new"; # Change it to the new function.
$functype = "static $classname *THIS"; # Change the return type.
}
elsif ($funcname eq "~$classname") { # Is this a destructor?
$funcname = "delete"; # Change its name
$functype = "void"; # and its return type.
}
my $fdef;
eval {
($fdef, $funcname) = parse_function($functype, $classname, $funcname, $4,
split(/\n\s*/, $5 || "")); # Parse it.
};
if ($@) { # Was there an error?
print STDERR "$progname: error parsing definition of $functype ${classname}::$funcname:\n$@\n";
} else {
defined($fdef) and $members{$funcname} = $fdef; # Remember definition
# unless it was marked nowrap.
}
$1; # Remove the member function definition.
}xeg;
#
# Parse member fields:
#
1 while s{
([\{;\06]) # Match beginning of statement (end of last).
\s* # Whitespace.
([\w\s\*\&]+?) # The type of the variable.
(\w+(?:\s*,\s*\w+)*)\s* # The name of the variable(s).
(?:=[^;]+)? # An optional assignment expression.
; # The final semicolon.
}{
my $delim = $1;
my $type = canonicalize_type($2);
foreach (split(/\s*,\s*/, $3)) { # Look at each variable.
$members{$_} = $type; # Remember this type.
}
$delim; # Remove the whole definition.
}xeg;
/\w/ and print STDERR "Warning: unrecognized text in definition of class $classname:\n$_\n";
#
# Add a new and a delete to this class if there isn't one, because that's the
# only way to create and destroy members of the class:
#
unless ($members{"new"} || # Already a new function?
$private_members =~ /\b$classname\s*\(/) { # Constructor is private?
$members{"new"} = (parse_function("static $classname *", $classname, "new",""))[0];
}
unless ($members{"delete"} || # Already a delete function?
$private_members =~ /\~$classname\s*\(/) { # Destructor is private?
$members{"delete"} = (parse_function("void", $classname, "delete", ""))[0];
}
}
#
# The following function is called to convert a type into a canonical format.
# It handles typedefs and puts the '*' and '&' in the appropriate locations.
# Arguments:
# 1) The type name to canonicalize.
# 2) True if unrecognized words should be understood as builtin types that we
# don't understand.
#
sub canonicalize_type {
my ($type, $new_type_flag) = @_; # Access the argument.
my $oldval = $type;
$type =~ s/=.*//; # A default value can be specified, and we
# should ignore it.
if ($new_type_flag) { # Add unrecognized words to the basic type list?
$type =~ s{\w+}{$typedef{$&} ||= $&}eg;
} else {
$type =~ s{\w+}{$typedef{$&} || ''}eg; # Translate the typedefs, and delete
# any words that we don't care about, like
# 'inline', or function arguments names.
}
$type =~ s/\[\]/\*/; # Convert float[] into float *.
$type =~ s/</ < /g; # Put a space after template brackets.
$type =~ s/>/ > /g;
$type =~ s/\s+/ /g; # Convert whitespace into spaces.
$type =~ s/^ //; # Strip leading whitespace.
$type =~ s/ $//; # Strip trailing whitespace.
$type =~ s/ ([\*\&])/$1/g; # Remove spaces between '*' and '&'.
$type =~ s/[\*\&]/ $&/; # Put a space before the first one.
if ($type eq ''){
$oldval =~ s/\s+/ /g; # Pretty-print the type.
die("unrecognized type '$oldval'\n");
}
# print STDERR "Canonicalizing $oldval => $type\n";
$type;
}
#
# Dump out the definition of a function (for debug purposes). Arguments:
# 1) A string used to prefix each line so the indentation looks right.
# 2) The %function_def array.
#
sub dump_function {
my ($indent_str, $faa) = @_; # Name the arguments.
printf("%s%s%s %s::%s(%s)\n", $indent_str, $faa->{static} ? "static " : "",
$faa->{returns}, $faa->{class}, $faa->{name},
join(", ",
map({ $faa->{args}{$_}{type} . " " . $_ } @{$faa->{argnames}})));
# Print out the C++ function prototype.
printf("%s [%s] = %s(%s)\n", $indent_str,
join(", ", @{$faa->{outputs}}, @{$faa->{modifies}}),
$faa->{script_name} || ($faa->{class} ? $faa->{class} . "_" : "" ) . $faa->{name},
join(", ", @{$faa->{inputs}}));
# Print out the scripting language prototype.
foreach (@{$faa->{outputs}}, @{$faa->{modifies}}, @{$faa->{inputs}}) {
printf("%s %s %s: basic type = %s, vectorize = %d, dimension = [%s]\n",
$indent_str, $faa->{args}{$_}{source}, $_,
$faa->{args}{$_}{basic_type},
$faa->{args}{$_}{vectorize},
join(", ", @{$faa->{args}{$_}{dimension}}));
if (exists($faa->{args}{$_}{calculate})) { # A dimension argument?
printf("%s Calculate from %s\n", $indent_str,
$faa->{args}{$_}{calculate});
}
}
printf("%s %svectorized\n", $indent_str, $faa->{vectorize} ? "" : "not ");
}
#
# Return true if the type is a basic type that can be freely and easily
# copied.
#
sub is_basic_type {
my ($typename) = @_; # Access the argument.
if ($typename =~ /\*$/) { # Is it a pointer type?
return 1; # Pointers can be freely copied.
}
foreach (split(' ', $typename)) { # Look at all the words:
return 0 unless exists($basic_types{$_}); # Skip if not a basic type word.
}
return 1; # It's a basic type.
}
###############################################################################
#
# Code to produce the wrappers:
#
# All subroutines below this point may output C code to the default file handle
# which has been redirected to the appropriate place.
#
#
# Output a C++ function which allows a derived class to be substituted for
# a base class in a function argument. This function is called whenver
# the type does not match exactly.
#
# Arguments to the perl function:
# 1-n) The names of the classes to allow inheritance relationships between.
# Classes outside this list are simply not handled.
#
sub output_class_conversion_func {
print("\n" .
"/*\n" .
" * Convert between classes, handling inheritance relationships.\n" .
" * Arguments:\n" .
" * 1) The pointer.\n" .
" * 2) The type code for its class.\n" .
" * 3) The type code for the class you want.\n" .
" *\n" .
" * Returns 0 if the conversion is illegal, or else returns the\n" .
" * desired pointer.\n" .
" * We assume that you have already verified that the type code does\n".
" * not match, so the only valid possibility is an inheritance\n" .
" * relationship.\n" .
" */\n");
#
# See if in fact we know about any inheritance relationships:
#
my $is_inh = 0; # Assume there is no inheritance.
foreach (@_) {
$is_inh = 1, last if @{$derived_classes{$_}} != 0; # Quit if we found one
} # inheritance relationship.
if ($is_inh) { # Is there an inheritance relationship?
print("static void *\n" .
"__cvt_type(void *ptr, unsigned ptr_type, unsigned goal_type)\n" .
"{\n" .
" switch (goal_type)\n" . # Look at the class we want:
" {\n"); # Output the function header.
my $baseclass;
foreach $baseclass (sort @_) { # Look at each of the classes:
my @derived_classes = all_derived_classes($baseclass);
# Get a list of all classes that are derived
# from this one.
next if @derived_classes == 0; # Nothing to do if no one inherits from us.
print (" case @{[pointer_type_code($baseclass . ' *')]}: /* $baseclass */\n" .
" switch (ptr_type)\n" .
" {\n"); # Now look at the type of class we hae.
my $derived_class;
foreach $derived_class (@derived_classes) {
print(" case @{[pointer_type_code($derived_class . ' *')]}: /* $derived_class */\n" .
" return ($baseclass *)($derived_class *)ptr;\n");
}
print (" default:\n" .
" return 0;\n" . # Not derived from the goal class.
" }\n");
}
print(" default:\n" . # Goal class has nothing derived from it.
" return 0;\n" .
" }\n" .
"}\n" .
"\n");
}
else { # No inheritance relationships:
print("static void *\n" .
"__cvt_type(void *, unsigned, unsigned)\n" . # Don't list the
"{\n" . # parameter names, because gcc gives warning
" return 0;\n" . # messages about unused parameters.
"}\n\n");
}
}
#
# Output the functions to set up the arrays for vectorizing.
#
sub output_vectorizing_subs {
print qq{
/*
* Check to see if the vectorizing dimensions on an input argument are
* ok. Arguments:
* 1) The input argument.
* 2) The number of vectorizing dimensions we have so far. This is updated
* if we add more vectorizing dimensions.
* 3) An array containing the existing vectorizing dimensions.
* 4) The number of explicitly declared dimensions, i.e., 0 if this was
* declared as a scalar, 1 if a vector. We vectorize only the dimensions
* higher than the explicitly declared ones.
* 5) A value which is set to 0 if this argument is not vectorized. This
* value is left unaltered if the argument is vectorized.
*
* Returns 0 if there was a problem, 1 if the dimensions were ok.
*/
int
_check_input_vectorize(@{[&{"${language}::arg_declare"}('arg')]},
$dim_type *n_vec_dim,
$dim_type _d[${"${language}::max_dimensions"}],
$dim_type explicit_dims,
$dim_type *vec_stride)
{
int v_idx;
$dim_type n_dims = _n_dims(arg);
if (n_dims > explicit_dims) /* Any additional dimensions? */
{
if (*n_vec_dim == 0) /* No vectorizing dimensions seen yet? */
{ /* This defines the vectorizing dimensions. */
*n_vec_dim = n_dims - explicit_dims; /* Remember the # of dims. */
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
_d[v_idx] = _dim(arg, v_idx+explicit_dims); /* Remember this dim. */
}
else /* Already had some vectorizing dimensions. */
{ /* These must match exactly. */
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
if (_d[v_idx] != _dim(arg, v_idx+explicit_dims)) /* Wrong size? */
return 0; /* Error! */
}
}
/* else if (n_dims < explicit_dims) */ /* Too few dimensions? */
/* return 0; */ /* We don't do this check because there's no way to
* distinguish between a vector and a 3x1 matrix. */
else
*vec_stride = 0; /* Vectorization not required. */
return 1;
}
/*
* Same thing except for modify variables. Arguments:
* 1) The input argument.
* 2) The number of vectorizing dimensions we have so far.
* 3) An array containing the existing vectorizing dimensions.
* 4) The number of explicitly declared dimensions, i.e., 0 if this was
* declared as a scalar, 1 if a vector. We vectorize only the dimensions
* higher than the explicitly declared ones.
* 5) A flag indicating whether this is the first modify variable. This
* flag is passed by reference and updated by this subroutine.
*
* The vectorizing dimensions of modify arguments must exactly match those
* specified for input variables. The difference between this subroutine
* and _check_input_vectorize is that only the first modify variable may
* specify additional vectorizing dimensions.
*
* Returns 0 if there was a problem, 1 if the dimensions were ok.
*/
int
_check_modify_vectorize(@{[&{"${language}::arg_declare"}('arg')]},
$dim_type *n_vec_dim,
$dim_type _d[${"${language}::max_dimensions"}],
$dim_type explicit_dims,
int *first_modify_flag)
{
int v_idx;
$dim_type n_dims = _n_dims(arg);
if (n_dims > explicit_dims) /* Any additional dimensions? */
{
if (*n_vec_dim == 0 && *first_modify_flag) /* No vectorizing dimensions seen yet? */
{ /* This defines the vectorizing dimensions. */
*n_vec_dim = n_dims - explicit_dims; /* Remember the # of dims. */
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
_d[v_idx] = _dim(arg, v_idx+explicit_dims); /* Remember this dim. */
}
else /* Already had some vectorizing dimensions. */
{ /* These must match exactly. */
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
if (_d[v_idx] != _dim(arg, v_idx+explicit_dims)) /* Wrong size? */
return 0; /* Error! */
}
}
/* else if (n_dims < explicit_dims) */ /* Too few dimensions? */
/* return 0; */ /* We don't do this check because there's no way to
* distinguish between a vector and a 3x1 matrix. */
*first_modify_flag = 0; /* Next modify variable will not be first. */
return 1;
}
};
}
#
# Returns a unique type code for a given pointer type. Arguments:
# 1) The type of the pointer.
#
sub pointer_type_code {
my ($type) = @_; # Name the arguments.
#
# In order to guarantee that the same type has the same type code even in
# different wrapper files, we just use a hash of the type as the type code.
# It's very unlikely, though possible, that two unrelated types will have the
# same type code. Maybe we'll fix this later.
#
my $hash_code = 0;
foreach (split(//, $type)) { # Look at each character.
$hash_code = ($hash_code * 29 + ord($_)) & 0x7ffff;
# This assumes a 32- or 64-bit architecture.
# We used to AND with 0x7fffffff but perl 5.005
# seems to handle integer overflow quite
# differently from 5.004, so that doesn't work
# any more.
}
#
# Try to detect the case where hash codes might conflict, and give a warning:
#
if (exists($hash_code_to_type{$hash_code})) { # Already seen this one?
if ($hash_code_to_type{$hash_code} ne $type) { # Conflicting types?
unless ($already_warned{$type, $hash_code_to_type{$hash_code}}) {
warn("matwrap: hash codes for type $type and $hash_code_to_type{$hash_code} conflict;\n These types will not be distinguishable.\n");
$already_warned{$type, $hash_code_to_type{$hash_code}} = 1;
# Don't give this warning twice.
}
}
} else { # Remember this type to check for future
$hash_code_to_type{$hash_code} = $type; # conflicts.
}
return $hash_code;
}
#
# The following subroutine returns all classes which are derived from a given
# class. Arguments:
# 1) The name of the class.
#
# Returns a list of classes as an array.
#
sub all_derived_classes {
my $class = $_[0]; # Access the argument.
my @derived_classes = @{$derived_classes{$class}}; # Get the classes which
# are immediately derived from that class.
foreach (@{$derived_classes{$class}}) { # Now find what is derived from those.
push(@derived_classes, all_derived_classes($_));
}
@derived_classes;
}
#
# Wrap a variable or a constant. Arguments:
# 1) The variable type.
# 2) The variable name.
# 3) The class the variable is in. Blank if global.
#
sub wrap_variable {
my ($type, $name, $class) = @_;
if ($type =~ /^\bconst\b/ &&
$type !~ /\*/) { # Is this a constant?
&{"${language}::declare_const"}($name, $class, $type, "");
} else {
my $sflag = ($type =~ s/^static //) ? "static " : "";
my $fdef =
(parse_function("$sflag$type", $class, "___get_$name", "",
"%name " . ($class ? "${class}_" : "") . "get_$name"))[0];
# The name ___get is treated specially by
# wrap_function.
wrap_function($fdef); # Wrap it.
$fdef = # Make a set function.
(parse_function("${sflag}void", $class, "___set_$name", "$type newval",
"%name " . ($class ? "${class}_" : "") . "set_$name"))[0];
# The name ___set is treated specially by
# wrap_function.
wrap_function($fdef); # Wrap it.
}
}
#
# Wrap a function definition. Arguments:
# 1) The %function_def array for this function.
#
sub wrap_function {
my $faa = bless $_[0], $language; # Access the argument.
# Bless it into the language class so we
# can access functions whose first argument
# is this array using member function syntax.
my $retstr; # Where we accumulate the C code. We don't
# output the C code immediately because
# if the language module die()'s during
# execution of this function, we want to
# skip it and move to the next.
my $args = $faa->{args}; # Argument definitions.
my $arg;
eval { # Protect from die:
$retstr = $faa->function_start(); # Begin the function declaration.
#
# Figure out whether we can vectorize this function. It may be tagged to
# vectorize, but if all arguments are either dimensional arguments or
# tensors of the maximum dimension, then we can't vectorize it. (For example,
# this would be the case in octave for a function that takes only full
# matrix arguments.)
#
my $max_dimensions = 0; # Assume we won't be able to vectorize.
if ($faa->{vectorize}) { # Supposed to vectorize this function?
foreach $argname (@{$faa->{inputs}}, @{$faa->{modifies}}) {
# Look at the arguments to make
# sure we can actually vectorize this many
# dimensions.
$arg = $faa->{args}{$argname};
next unless $arg->{vectorize}; # Ignore non-vectorizable arguments.
if (@{$arg->{dimension}} < ${"${language}::max_dimensions"}) { # Room to vectorize here?
$max_dimensions = ${"${language}::max_dimensions"};
# Turn on the vectorizing.
last; # Other arguments are irrelevant for maximum
# vectorizing dimension.
}
}
foreach $argname (@{$faa->{outputs}}) { # Make sure the outputs don't
$arg = $faa->{args}{$argname}; # have too high dimension.
if ($arg->{vectorize} == 0 || # Not able to vectorize this?
@{$arg->{dimension}} >= ${"${language}::max_dimensions"}) {
$max_dimensions = 0; # Too many output dimensions--no room for
last; # vectorization.
}
}
}
#
# Try to declare all variables at the top so this has a chance of working
# with a C compiler as well as a C++ compiler.
#
if ($max_dimensions) { # Are we vectorizing?
$retstr .= " $dim_type _d[$max_dimensions] = { " . # Allocate space for
join(",", (1) x $max_dimensions) . " };\n"; # dimensions.
$retstr .= " $dim_type _vec_n = 0;\n"; # The number of vectorizing dims.
$retstr .= " $dim_type _vidx;\n"; # An index we use in various places.
$retstr .= " $dim_type _vec_sz;\n"; # The product of the vectorized
# dimensions.
$retstr .= " int first_modify_flag = 1;\n" # Add the modify flag if
if (@{$faa->{modifies}}); # there are any modify arguments.
}
foreach $argname (@{$faa->{argnames}}, # Look at the arguments.
($faa->{returns} eq 'void' ? () : ("retval"))) {
# Also include the return value here.
# Declare space to hold argument values
# and the return from the function, if there
# is one.
$arg = $faa->{args}{$argname};
if ($arg->{vectorize} && $max_dimensions || # Is this argument supposed to be vectorized?
@{$arg->{dimension}}) { # Is it an array?
$retstr .= " $arg->{basic_type} *$arg->{c_var_name};\n"; # Pointer.
} else {
$retstr .= " $arg->{basic_type} $arg->{c_var_name};\n"; # Scalar.
}
}
#
# Calculate all of the dimensional arguments:
#
my (%dims_calculated, %dimvar);
foreach $arg (grep(exists($_->{calculate}), values %$args)) {
my $calc_str = "($arg->{calculate})"; # Put the string in parentheses.
$calc_str =~ s{dim\((\w+), (\d+)\)}{
$dims_calculated{$1, $2} = 1; # Remember that we got this dim.
$dimvar{$1} = 1; # We handled this dimension.
$faa->get_size($1, $2); # Replace dim(varname, n) with the appropriate
}eg; # C expression to get the dimension.
$retstr .= " $arg->{c_var_name} = $calc_str;\n";
# Set the value of this dimensional variable.
}
#
# Now calculate any other arguments which are used as dimensional indices
# but we could not calculate from the given dimensions.
#
foreach $argname (grep($args->{$_}{source} eq 'dimension' &&
!defined($dimvar{$_}), @{$faa->{inputs}})) {
$retstr .= $faa->get_c_arg_scalar($argname); # Get this argument value.
$dimvar{$argname} = 1; # Remember that we got this one.
}
#
# Declare the vectorizing "stride". Virtually all matlab clones store
# multidimensional data using the same layout: a single dimension array.
# Since we can vectorize array arguments, we assume that the least
# significant (fastest varying) dimension(s) is the vector that is
# passed on each successive call to the C function. The stride is the
# product of the least significant dimensions (the ones that the C
# function wanted). To get to the next C function call, the index into
# the serial array is incremented by the vector stride. Note that if the
# object is a scalar or is not vectorized, the vector stride is 0.
#
# We don't need to declare vector strides for dimensional variables, since
# by definition they can't be vectorized.
#
foreach $argname (@{$faa->{inputs}}) {
$arg = $args->{$argname}; # Look at the non-dimensional variables,
# including the output:
$retstr .= " $dim_type _vecstride_$argname = " .
(@{$arg->{dimension}} == 0 ? 1 : join("*", @{$arg->{dimension}})) . ";\n"
if $max_dimensions > 0 && $faa->{args}{$argname}{vectorize};
# Assume this argument will be vectorized.
# This will be set to 0 by check_input_vectorize
# if it is not vectorized.
}
#
# Now verify that the dimension of all arguments are compatible, set up the
# vectorization, and get the pointer to the first argument value.
#
foreach $argname (@{$faa->{inputs}}, @{$faa->{modifies}}) {
# Look at the input arguments:
$arg = $args->{$argname}; # Access the description of argument.
my $dim = @{$arg->{dimension}};
# Get the minimum dimension of the argument.
my @conds;
foreach (0 .. $dim-1) { # Look at the dimension specs.
next if $dims_calculated{$argname, $_}; # Skip if we used this to
# calculate a dimension variable.
push(@conds, " ($dim_type)(" . $faa->get_size($argname, $_) . ") != ($dim_type)(" . $arg->{dimension}[$_] . ")");
# Make sure this dimension matches.
}
#
# See if any additional dimensions are specified. If so, we'll use them
# for vectorizing. All modify arguments must have the additional
# vectorizing dimensions. Input arguments may be either scalars or vectors,
# but if they are vectorized, their dimensions must match.
#
if ($arg->{vectorize} && $dim < $max_dimensions) {
if ($arg->{source} eq 'input') { # Input args
# may or may not have vectorizing dims.
push(@conds, "!_check_input_vectorize(@{[$faa->arg_pass($argname)]}, &_vec_n, _d, " . scalar(@{$arg->{dimension}}) . ", &_vecstride_$argname)");
} else {
push(@conds, "!_check_modify_vectorize(@{[$faa->arg_pass($argname)]}, &_vec_n, _d, " . scalar(@{$arg->{dimension}}) . ", &first_modify_flag)");
}
} else { # Not a vectorizable argument?
push(@conds, $faa->n_dimensions($argname) . " > $dim");
# Make sure it has exactly the right number of
# dimensions. Unfortunately, octave and matlab
# can't distinguish between a vector and a
# n by 1 matrix, so we have to check for less
# than or equal to the number of dimensions.
}
if (@conds) { # Any dimension conditions?
$retstr .= (" if (" . join(" ||\n ", @conds) . ")\n" .
" " . $faa->error_dimension($argname) . "\n");
# Blow up if there's a problem.
}
if ($arg->{vectorize} && $max_dimensions > 0 || @{$arg->{dimension}}) {
$retstr .= $faa->get_c_arg_ptr($argname); # Get a pointer to this arg.
} else {
$retstr .= $faa->get_c_arg_scalar($argname) # Get this argument.
unless $dimvar{$argname}; # Unless we had to get it above because it
# was a dimensional variable.
}
$retstr .= "\n"; # Put an extra blank line in to make it
# more readable.
}
#
# So much for the input arguments. Now handle the output arguments. These
# matrices must be allocated to be the appropriate size:
#
foreach $argname (@{$faa->{outputs}}) {
$arg = $args->{$argname}; # Point to description of argument.
if ($max_dimensions > 0) { # Are we vectorizing?
$retstr .=
$faa->make_output_ptr($argname,
"(" . @{$arg->{dimension}} . " + _vec_n)", # Number of dims.
@{$arg->{dimension}}, # Explicit dimensions.
map({ "_d[$_] " } # Vectorized dims.
0 .. ($max_dimensions-@{$arg->{dimension}}-1)));
} else { # Not vectorizing:
if (@{$arg->{dimension}}) { # Is this a vector?
$retstr .= $faa->make_output_ptr($argname,
scalar(@{$arg->{dimension}}),
@{$arg->{dimension}});
# Make it as a vector.
} else { # It's a scalar:
$retstr .= $faa->make_output_scalar($argname);
}
}
}
#
# Now actually call the C function. Get each of the arguments in a variable
# and then pass it off to the function:
#
$retstr .= (" _vec_sz = " . join('*', map { "_d[$_]" } 0..$max_dimensions-1) . ";\n" .
" for (_vidx = 0; _vidx < _vec_sz; ++_vidx) {\n")
if $max_dimensions; # Add a loop if we're vectorizing.
#
# Get an expression for each argument:
#
my @fargs = map {
$arg = $faa->{args}{$_}; # Access this argument.
my $cexp = $arg->{c_var_name}; # Assume we just use the variable name.
if ($max_dimensions > 0 && $arg->{vectorize}) { # Vectorizing?
if ($arg->{source} eq 'input') { # Do we have a vector stride?
$cexp .= "[_vecstride_$_*_vidx]"; # Add the index.
} else {
$cexp .= "[" . (@{$arg->{dimension}} == 0 ? "" : join("*", @{$arg->{dimension}}) . "*") . "_vidx]";
}
if (@{$arg->{dimension}} || $arg->{pass_by_pointer_reference}) {
"&$cexp"; # Need to pass an address?
} else {
$cexp;
}
} else { # Not a vectorized parameter:
if ($arg->{pass_by_pointer_reference}) { # Pass by reference?
"&$cexp";
} else {
$cexp;
}
}
} @{$faa->{argnames}};
if ($faa->{returns} ne 'void') { # Is there a return code?
if ($max_dimensions) { # Are we vectorizing this?
$retstr .= " $args->{retval}{c_var_name}" . "[_vidx] = ($args->{retval}{basic_type})\n ";
# Store return value in an array.
} else {
$retstr .= " $args->{retval}{c_var_name} = ($args->{retval}{basic_type})\n ";
# Store return value in a scalar.
}
}
my $fcallstr;
if ($faa->{class}) { # Is this a member function?
if ($faa->{static}) { # Is it a static member function?
if ($faa->{name} eq 'new') { # Is this the new function?
$fcallstr = " new $faa->{class}(" .
join(", ", @fargs) . ");\n";
} else {
$fcallstr = " $faa->{class}::$faa->{name}(" . # Specify the class
join(", ", @fargs) . ");\n"; # name explicitly.
}
} else { # It's a member function. First argument is
# actually the class pointer.
if ($faa->{name} eq 'delete') { # Delete the field?
$fcallstr = " delete $fargs[0];\n";
} else {
$fcallstr = " ($fargs[0])->$faa->{name}(" .
join(", ", @fargs[1 .. (@fargs-1)]) . ");\n";
}
}
} else { # It's a boring global function:
$fcallstr = " $faa->{name}(" . join(", ", @fargs) . ");\n";
}
$fcallstr =~ s/___set_(.*?)\((.*)\)/$1 = $2/; # Handle the variable set.
$fcallstr =~ s/___get_(.*?)\(\)/$1/; # Handle the variable get.
$retstr .= $fcallstr; # Call the function.
$retstr .= " }\n" if $max_dimensions; # Terminate the vectorizing loop.
#
# Now we've called the function. Put back all the output and modify variables.
#
foreach $argname (@{$faa->{modifies}}, @{$faa->{outputs}}) {
if ($max_dimensions > 0 || # Vectorizing?
@{$args->{$argname}{dimension}} > 0) { # It's an array of some sort?
$retstr .= $faa->put_val_ptr($argname); # Put back as vector.
} else {
$retstr .= $faa->put_val_scalar($argname); # It's guaranteed to be
} # a scalar.
}
$retstr .= $faa->function_end(); # We're done!
}; # End of eval.
if ($@) { # Was there a problem?
print(STDERR "While wrapping function ",
($faa->{script_name} || $faa->{class} . "::" . $faa->{name}),
":\n$@");
# Print the message.
} else {
print $retstr; # Output the result.
}
}
syntax highlighted by Code2HTML, v. 0.9.1