#!/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.
  }
}