#! /usr/bin/perl
#/*@@
#  @file      CreateFunctionBindings.pl
#  @date      Sat Feb 10 2001
#  @author    Gabrielle Allen
#  @desc
#
#  @enddesc
#  @version $Id$
#@@*/


#/*@@
#  @routine    CreateFunctionBindings
#  @date       Sat Feb 10 2001
#  @author     Gabrielle Allen
#  @desc
#  Creates bindings for thorn provided functions
#  @enddesc
#@@*/

sub CreateFunctionBindings
{
  my($bindings_dir, $rhinterface_db) = @_;
  my($dataout);
  my($function_db);
  my($registerfiles);

  $registerfiles = 'IsFunctionAliased.c OverloadThorns.c FortranThornFunctions.c DummyThornFunctions.c RegisterThornFunctions.c';

  # Create Function Database
  $function_db = &FunctionDatabase($rhinterface_db);

  # Create directories
  if(! -d $bindings_dir)
  {
    mkdir("$bindings_dir", 0755) || die "Unable to create $bindings_dir";
  }
  $start_dir = `pwd`;

  chdir $bindings_dir;

  if(! -d 'Functions')
  {
    mkdir('Functions', 0755) || die 'Unable to create Functions directory';
  }

  if(! -d 'include')
  {
    mkdir('include', 0755) || die 'Unable to create include directory';
  }


  # Create ThornOverloadables.h
  $dataout = &ThornOverloadables($function_db);
  &WriteFile('include/ThornOverloadables.h',\$dataout);

  # Create DummyThornFunctions.c
  $dataout = &DummyThornFunctions($function_db);
  &WriteFile('Functions/DummyThornFunctions.c',\$dataout);

  # Create OverloadThorns.c
  $dataout = &OverloadThorns();
  &WriteFile('Functions/OverloadThorns.c',\$dataout);

  # Create FortranThornFunctions.c
  $dataout = &FortranThornFunctions($function_db);
  &WriteFile('Functions/FortranThornFunctions.c',\$dataout);

  # Create Thorn Include Prototypes
  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    $dataout = &ThornIncludes($thorn,$function_db,$rhinterface_db);
    &WriteFile("include/${thorn}_Prototypes.h",\$dataout);
  }

  # Create Master Include Prototypes
  $dataout = &ThornMasterIncludes($rhinterface_db);
  &WriteFile('include/cctk_FunctionAliases.h',\$dataout);

  # Create THORN_Register.c
  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    $filename = "${thorn}_Register.c";
    $dataout = &RegisterThornFunctions($thorn,$function_db,$rhinterface_db);
    &WriteFile("Functions/$filename",\$dataout);
    $registerfiles .= " $filename";
  }

  # Create Master registration file RegisterThornFunctions.c
  $dataout = &RegisterAllFunctions($rhinterface_db);
  &WriteFile('Functions/RegisterThornFunctions.c',\$dataout);

  # Create IsFunctionAliased functions
  $dataout = &IsFunctionAliasedBindings($function_db);
  &WriteFile('Functions/IsFunctionAliased.c',\$dataout);

  # Create make.code.defn
  $dataout = "SRCS = $registerfiles";
  &WriteFile("Functions/make.code.defn",\$dataout);

  chdir $start_dir;

  return;
}


#/*@@
#  @routine    IsFunctionAliasedBindings
#  @date       Tue Feb 20 2001
#  @author     Gabrielle Allen
#  @desc
#  Code for returning number of times a function has been overloaded.
#  This should be done in a better way, and include flesh overloaded
#  functions
#  @enddesc
#@@*/

sub IsFunctionAliasedBindings
{
  my($function_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @file    IsFunctionAliased.c');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Query how many times a function is overloaded');
  push(@data, '   @enddesc');
  push(@data, ' @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include <stdlib.h>');
  push(@data, '');
  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '#include "cctk_FortranString.h"');
  push(@data, '');

  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "int CCTKBindings_Overload$function(void *);");
    }
  }

  push(@data, 'int CCTK_IsFunctionAliased(const char *function);');
  push(@data, 'int CCTK_IsFunctionAliased(const char *function)');
  push(@data, '{');
  push(@data, '  int retval = 0;');
  push(@data, '');
  push(@data, '  (void) (function + 0); /* avoid warnings */');
  push(@data, '');

  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "  if (strcmp(function, \"$function\") == 0)");
      push(@data, '  {');
      push(@data, "    retval = CCTKBindings_Overload$function(NULL);");
      push(@data, '  }');
      push(@data, '');
    }
  }

  push(@data, '  return retval;');
  push(@data, '}');
  push(@data, '');

  # Put fortran binding here for the moment
  push(@data, 'void CCTK_FCALL CCTK_FNAME(CCTK_IsFunctionAliased) (int *ret, ONE_FORTSTRING_ARG);');
  push(@data, 'void CCTK_FCALL CCTK_FNAME(CCTK_IsFunctionAliased) (int *ret, ONE_FORTSTRING_ARG)');
  push(@data, '{');
  push(@data, '  ONE_FORTSTRING_CREATE(name);');
  push(@data, '  *ret = CCTK_IsFunctionAliased(name);');
  push(@data, '  free(name);');
  push(@data, '}');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    ThornOverloadables
#  @date       Sat Feb 10
#  @author     Gabrielle Allen
#  @desc
#  Create include file for thorn function overloads
#  @enddesc
#@@*/

sub ThornOverloadables
{
  my($function_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @header  ThornOverloadables.h');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            The overloadable functions from thorns');
  push(@data, '            See OverloadMacros.h to see how to use these.');
  push(@data, '   @enddesc');
  push(@data, ' @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#ifdef OVERLOADABLE_CALL');
  push(@data, '#undef OVERLOADABLE_CALL');
  push(@data, '#endif');
  push(@data, '');
  push(@data, '#ifdef OVERLOABLE_PREFIX');
  push(@data, '#undef OVERLOADABLE_PREFIX');
  push(@data, '#endif');
  push(@data, '');
  push(@data, '#ifdef OVERLOABLE_DUMMY_PREFIX');
  push(@data, '#undef OVERLOADABLE_DUMMY_PREFIX');
  push(@data, '#endif');
  push(@data, '');
  push(@data, '#define OVERLOADABLE_CALL CCTKBindings_');
  push(@data, '#define OVERLOADABLE_PREFIX');
  push(@data, '#define OVERLOADABLE_DUMMY_PREFIX CCTKBindings_Dummy');
  push(@data, '');
  push(@data, '#ifdef ARGUMENTS');
  push(@data, '#undef ARGUMENTS');
  push(@data, '#endif');
  push(@data, '');
  push(@data, '#ifdef RETURN_TYPE');
  push(@data, '#undef RETURN_TYPE');
  push(@data, '#endif');
  push(@data, '');

  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "#define ARGUMENTS $function_db->{\"$function CARGS\"}");
      push(@data, "#define RETURN_TYPE $function_db->{\"$function RET\"}");
      push(@data, '');
      push(@data, "OVERLOADABLE($function)");
      push(@data, '');
      push(@data, '#undef ARGUMENTS');
      push(@data, '#undef RETURN_TYPE');
      push(@data, '');
    }
  }

  push(@data, '#undef OVERLOADABLE_CALL');
  push(@data, '#undef OVERLOADABLE_PREFIX');
  push(@data, '#undef OVERLOADABLE_DUMMY_PREFIX');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    ThornMasterIncludes
#  @date       Thu Feb 15 2001
#  @author     Gabrielle Allen
#  @desc
#  Master file of function prototypes for each thorn
#  @enddesc
#@@*/

sub ThornMasterIncludes
{
  my($rhinterface_db) = @_;
  my(@data);

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @header  cctk_FunctionAliases.h');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Prototypes for overloaded functions used by all thorns');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#ifndef _CCTK_FUNCTIONALIASES_H_');
  push(@data, '#define _CCTK_FUNCTIONALIASES_H_ 1');
  push(@data, '');

  push(@data, '#ifdef CCODE');
  push(@data, 'int CCTK_IsFunctionAliased(const char *function);');
  push(@data, '');
  push(@data, '#endif');
  push(@data, '');

  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    push(@data, "#ifdef THORN_IS_$thorn");
    push(@data, "#include \"${thorn}_Prototypes.h\"");
    push(@data, '#endif');
    push(@data, '');
  }

  push(@data, '#endif  /* _CCTK_FUNCTIONALIASES_H_ */');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    OverloadThorns
#  @date       Tue Feb 20 2001
#  @author     Gabrielle Allen
#  @desc
#  Main file for overloading thorns. Note that the text doesn't change
#  but the contents does depending on the thorn set used. For this reason
#  it is in the bindings and not in the Flesh.
#  @enddesc
#@@*/

sub OverloadThorns
{
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @file    OverloadThornFunctions.c');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Contains routines to overload thorn functions');
  push(@data, '            Uses the overload macros to make sure of consistency ');
  push(@data, '            and to save typing !');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include <stdio.h>');
  push(@data, '#include <stdlib.h>');
  push(@data, '#include <string.h>');
  push(@data, '');

  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '#include "cctk_WarnLevel.h"');
  push(@data, '#include "OverloadMacros.h"');
  push(@data, '');

  push(@data, '/* Define the prototypes for the dummy functions. */');
  push(@data, '#define OVERLOADABLE(name) OVERLOADABLE_DUMMYPROTOTYPE(name)');
  push(@data, '');

  push(@data, '#include "ThornOverloadables.h"');
  push(@data, '');

  push(@data, '#undef OVERLOADABLE');
  push(@data, '');

  push(@data, '#define OVERLOADABLE(name) OVERLOADABLE_FUNCTION(name)');
  push(@data, '');

  push(@data, '#include "ThornOverloadables.h"');
  push(@data, '');

  push(@data, '#undef OVERLOADABLE');
  push(@data, '');

  push(@data, '#undef OVERLOADABLE_CALL');
  push(@data, '#undef OVERLOADABLE_PREFIX');
  push(@data, '#undef OVERLOADABLE_DUMMY_PREFIX');
  push(@data, '');

  push(@data, '/* Initialising Stuff */');
  push(@data, '');

  push(@data, 'void CCTKBindings_SetupThornFunctions(void);');
  push(@data, 'void CCTKBindings_SetupThornFunctions(void)');
  push(@data, '{');
  push(@data, '#undef OVERLOADABLE');
  push(@data, '#define OVERLOADABLE(name) OVERLOADABLE_INITIALISE(name)');
  push(@data, '#include "ThornOverloadables.h"');
  push(@data, '#undef OVERLOADABLE');
  push(@data, '}');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    ThornIncludes.h
#  @date       Thu Feb 15 2001
#  @author     Gabrielle Allen
#  @desc
#  Create function prototypes for each thorn
#  @enddesc
#@@*/

sub ThornIncludes
{
  my($thorn,$function_db,$rhinterface_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, "   \@header  ${thorn}_Prototypes.h");
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Prototypes for overloaded functions used by this thorn');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, "#ifndef _\U$thorn\E_PROTOTYPES_H_");
  push(@data, "#define _\U$thorn\E_PROTOTYPES_H_  1");
  push(@data, '');

  push(@data, '#ifdef CCODE');

  foreach $function (split(' ',($rhinterface_db->{"\U$thorn USES FUNCTION\E"})))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "extern $function_db->{\"$function RET\"} (*$function)($function_db->{\"$function CARGS\"});");
    }
  }

  push(@data, '#endif /* CCODE */');
  push(@data, '');

  push(@data, '#endif');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    RegisterAllFunctions
#  @date       Sun Feb 11 2001
#  @author     Gabrielle Allen
#  @desc
#  Create file to call all thorn function registration
#  @enddesc
#@@*/

sub RegisterAllFunctions
{
  my($rhinterface_db) = @_;
  my(@data) = ();

  push(@data, '/*@@');
  push(@data, '   @file    RegisterAllFunctions.c');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Register aliased functions from active thorns');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '#include "cctk_ActiveThorns.h"');
  push(@data, '');

  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    push(@data, "int CCTKBindings_${thorn}Aliases(void);");
  }

  push(@data, 'int CCTKBindings_RegisterThornFunctions(void);');
  push(@data, 'int CCTKBindings_RegisterThornFunctions(void)');
  push(@data, '{');
  push(@data, '  int retval = 0;');

  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    push(@data, "  if (CCTK_IsThornActive(\"$thorn\"))");
    push(@data, '  {');
    push(@data, "    retval += CCTKBindings_${thorn}Aliases();");
    push(@data, '  }');
  }
  push(@data, '  return retval;');
  push(@data, '}');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    DummyThornFunctions
#  @date       Sat Feb 10
#  @author     Gabrielle Allen
#  @desc
#  Check contents for ThornOverloadables_h
#  @enddesc
#@@*/

sub DummyThornFunctions
{
  my($function_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @header  DummyThornFunctions.h');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Dummy functions for overloaded thorn functions');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include <stdlib.h>');
  push(@data, '');
  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '#include "cctk_WarnLevel.h"');
  push(@data, '');

  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      $ret = $function_db->{"$function RET"};

      push(@data, "$ret CCTKBindings_Dummy$function($function_db->{\"$function CARGS\"});");
      push(@data, "$ret CCTKBindings_Dummy$function($function_db->{\"$function CARGS\"})");
      push(@data, '{');

      # Make sure we use all arguments to avoid warnings
      foreach $arg (split(',',$function_db->{"$function CARGS"}))
      {
        $arg =~ m:.*\s+\**([^\s*\*]+)\s*:;
        push(@data, "  (void) ($1 + 0);");
      }
      push(@data, '  CCTK_Warn(1, __LINE__, __FILE__, "Bindings",');
      push(@data, "            \"CCTKBindings_Dummy$function: Calling thorn function $function which has not been overloaded\");");
      if ($ret =~ m:INT:i)
      {
        push(@data, '  return -1;');
      }
      elsif ($ret =~ m:REAL:i)
      {
        push(@data, '  return 0;');
      }
      push(@data, '}');
      push(@data, '');
    }
  }
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    RegisterThornFunctions
#  @date       Sun Feb 11 2001
#  @author     Gabrielle Allen
#  @desc
#  Create contents for files to register aliased functions
#  @enddesc
#@@*/

sub RegisterThornFunctions
{
  my($thorn,$function_db,$rhinterface_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, "   \@header  ${thorn}_Register.h");
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, "            Register aliased functions for $thorn");
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '');

  foreach $function (split(' ',$rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E"}))
  {
    if ($function !~ m:^\s*$:)
    {
      $provided_with = $rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E $function WITH"};
      $ret = $function_db->{"$function RET"};
      $args = $function_db->{"$function CARGS"};

      push(@data, "$ret $provided_with($args);");
      push(@data, "int CCTKBindings_Overload$function($ret (* $function)($args));");
    }
  }
  push(@data, '');
  push(@data, "int CCTKBindings_${thorn}Aliases(void);");
  push(@data, "int CCTKBindings_${thorn}Aliases(void)");
  push(@data, '{');
  push(@data, '  int retval = 0; /* returns minus number of failed overloads */');
  push(@data, '  int ierr = 0;');
  push(@data, '');
  push(@data, '  retval = ierr; /* use ierr to prevent warnings */');
  push(@data, '');

  foreach $function (split(' ',$rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E"}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "  ierr = CCTKBindings_Overload$function($rhinterface_db->{\"\U$thorn PROVIDES FUNCTION\E $function WITH\"});");
      push(@data, '  retval = (ierr == 0) ? retval-- : retval;');
    }
  }

  push(@data, '  return retval;');
  push(@data, '}');
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    FortranThornFunctions
#  @date       Sat Feb 10 2001
#  @author     Gabrielle Allen
#  @desc
#  Create fortran wrappers for thorn functions
#  @enddesc
#@@*/

sub FortranThornFunctions
{
  my($function_db) = @_;
  my(@data) = ();

  # Header Data
  push(@data, '/*@@');
  push(@data, '   @header  FortranThornFunctions.h');
  push(@data, '   @author  Automatically generated by CreateFunctionBindings.pl');
  push(@data, '   @desc');
  push(@data, '            Fortran wrappers for overloaded thorn functions');
  push(@data, '   @enddesc');
  push(@data, '  @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include <stdlib.h>');
  push(@data, '');
  push(@data, '#include "cctk_Flesh.h"');
  push(@data, '#include "cctk_WarnLevel.h"');
  push(@data, '#include "cctk_FortranString.h"');
  push(@data, '');

  # Do aliased function prototypes
  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "extern $function_db->{\"$function RET\"} (*$function)($function_db->{\"$function CARGS\"});");
    }
  }
  push(@data, '');
  push(@data, '');

  foreach $function (split(' ',$function_db->{'FUNCTIONS'}))
  {
    if ($function !~ m:^\s*$:)
    {
      push(@data, "$function_db->{\"$function RET\"} CCTK_FCALL CCTK_FNAME($function)");
      $line = "($function_db->{\"$function WARGS\"}";
      if ($function_db->{"$function STRINGS"} == 1)
      {
        $line .= ', ONE_FORTSTRING_ARG';
      }
      elsif ($function_db->{"$function STRINGS"} == 2)
      {
        $line .= ', TWO_FORTSTRINGS_ARGS';
      }
      elsif ($function_db->{"$function STRINGS"} == 3)
      {
        $line .= ', THREE_FORTSTRINGS_ARGS';
      }
      $line .= ')';

      # prototype
      push(@data, "$line;");

      # call
      push(@data, "$function_db->{\"$function RET\"} CCTK_FCALL
CCTK_FNAME($function)");      
      push(@data, $line);
      push(@data, '{');

      if ($function_db->{"$function TYPE"} =~ 'FUNC')
      {
        push(@data, "  $function_db->{\"$function RET\"} cctki_retval;");
      }

      if ($function_db->{"$function STRINGS"} == 1)
      {
        push(@data, 'ONE_FORTSTRING_CREATE(cctki_string1)');
      }
      elsif ($function_db->{"$function STRINGS"} == 2)
      {
        push(@data, 'TWO_FORTSTRINGS_CREATE(cctki_string1, cctki_string2)');
      }
      elsif ($function_db->{"$function STRINGS"} == 3)
      {
        push(@data, 'THREE_FORTSTRINGS_CREATE(cctki_string1, cctki_string2, cctki_string3)');
      }

      if ($function_db->{"$function TYPE"} =~ 'FUNC')
      {
        push(@data, '  cctki_retval = ');
      }

      push(@data, "    $function($function_db->{\"$function WCALL\"}");

      if ($function_db->{"$function STRINGS"} == 1)
      {
        push(@data, ', cctki_string1');
      }
      elsif ($function_db->{"$function STRINGS"} == 2)
      {
        push(@data, ', cctki_string1, cctki_string2');
      }
      elsif ($function_db->{"$function STRINGS"} == 3)
      {
        push(@data, ', cctki_string1, cctki_string2, cctki_string3');
      }

      push(@data, ');');

      if ($function_db->{"$function STRINGS"} == 1)
      {
        push(@data, '  free(cctki_string1);');
      }
      elsif ($function_db->{"$function STRINGS"} == 2)
      {
        push(@data, '  free(cctki_string1);');
        push(@data, '  free(cctki_string2);');
      }
      elsif ($function_db->{"$function STRINGS"} == 3)
      {
        push(@data, '  free(cctki_string1);');
        push(@data, '  free(cctki_string2);');
        push(@data, '  free(cctki_string3);');
      }

      if ($function_db->{"$function TYPE"} =~ 'FUNC')
      {
        push(@data, '  return cctki_retval;');
      }

      push(@data, '}');
    }
  }
  push(@data, "\n");   # workaround for perl 5.004_04 to add a trailing newline

  return join ("\n", @data);
}


#/*@@
#  @routine    FunctionDatabase
#  @date       Wed Dec 06 11.37
#  @author     Gabrielle Allen
#  @desc
#  Check consistency for Thorn Functions and create database
#  @enddesc
#@@*/

sub FunctionDatabase
{
  my($rhinterface_db) = @_;
  my($thorn,$inret,$inargs,$message,$function);

  $function_db->{'FUNCTIONS'}= ' ';
  $function_db->{'PROVIDED FUNCTIONS'}= ' ';


  # Add used functions to database
  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    foreach $function (split(' ',($rhinterface_db->{"\U$thorn FUNCTIONS\E"})))
    {
      $inargs = $rhinterface_db->{"\U$thorn FUNCTION\E $function ARGS"};
      $inret  = $rhinterface_db->{"\U$thorn FUNCTION\E $function RET"};

      ($nstrings,$types,$c,$fortran,$wrappercall,$wrapperargs,$cargs) = &ParseArguments($inret,$inargs);

      if ($function_db->{'FUNCTIONS'} =~ / $function / && $function !~ /^\s*$/)
      {
        if ($types ne $function_db->{"$function TYPES"})
        {
          $message = "Argument types for aliased $function do not match";
          &CST_error(0,$message,'',__LINE__,__FILE__);
        }
        if ($inret ne $function_db->{"$function RET"})
        {
          $message = "Return types for aliased $function do not match";
          &CST_error(0,$message,'',__LINE__,__FILE__);
        }
      }
      else
      {
        if ($inret =~ m:^\s*void\s*$:)
        {
          $function_db->{"$function CARGS"} = 'SUB';
        }
        else
        {
          $function_db->{"$function CARGS"} = 'FUNC';
        }

        if ($c)
        {
          if ($fortran)
          {
            $function_db->{"$function LANG"} = 'FC';
          }
          else
          {
            $function_db->{"$function LANG"} = 'C';
            $message = "Fortran wrapper not created for alias $function";
            &CST_error(1,$message,'',__LINE__,__FILE__);
          }
        }
        else
        {
          $function_db->{"$function LANG"} = '';
          $message = "Can't create alias for $function";
          &CST_error(0,$message,'',__LINE__,__FILE__);
        }

        if ($rhinterface_db->{"\U$thorn FUNCTION\E $function RET"} eq 'void')
        {
          $function_db->{"$function TYPE"} = 'SUB';
        }
        else
        {
          $function_db->{"$function TYPE"} = 'FUNC';
        }

        $function_db->{'FUNCTIONS'} .= "$function ";
        $function_db->{"$function STRINGS"} = $nstrings;
        $function_db->{"$function CARGS"} = $cargs;
        $function_db->{"$function TYPES"} = $types;
        $function_db->{"$function WARGS"} = $wrapperargs;
        $function_db->{"$function WCALL"} = $wrappercall;
        $function_db->{"$function RET"} = $rhinterface_db->{"\U$thorn FUNCTION\E $function RET"};
      }
    }
  }

  # Check consistency of providing functions
  foreach $thorn (split(' ',$rhinterface_db->{'THORNS'}))
  {
    foreach $function (split(' ',($rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E"})))
    {
      $inargs = $rhinterface_db->{"\U$thorn FUNCTION\E $function ARGS"};
      $inret  = $rhinterface_db->{"\U$thorn FUNCTION\E $function RET"};

      ($nstrings,$types,$c,$fortran,$wrappercall,$wrapperargs,$cargs) = &ParseArguments($inret,$inargs);

      if ($function_db->{'FUNCTIONS'} =~ / $function / && $function !~ /^\s*$/)
      {
        if ($types ne $function_db->{"$function TYPES"})
        {
          $message = "Argument types for aliased $function do not match";
          &CST_error(0,$message,'',__LINE__,__FILE__);
        }
        if ($inret ne $function_db->{"$function RET"})
        {
          $message = "Return types for aliased $function do not match";
          &CST_error(0,$message,'',__LINE__,__FILE__);
        }
      }
      $function_db->{'PROVIDED FUNCTIONS'} .= "$function ";
    }
  }

  # Check to see if any functions are potentially used and not provided
  foreach $function (split(' ',($function_db->{'FUNCTIONS'})))
  {
    if ($function_db->{'PROVIDED FUNCTIONS'} !~ / $function /)
    {
      $message = "Aliased function $function is not provided by any thorn";
      &CST_error(1,$message,'',__LINE__,__FILE__);
    }
  }

  return $function_db;
}


#/*@@
#  @routine    ParseArguments
#  @date       Sun Feb 11 2001
#  @author     Gabrielle Allen
#  @desc
#  Parse the argument list and create versions for C and Fortran
#  @enddesc
#@@*/

sub ParseArguments
{
  my($ret,$args) = @_;
  my($number_args);

#  print "\nParsing Arguments\n";
#  print "=================\n";
#  print "All args: $args\n";

  $fwrapperargs     = '';
  $fwrappercallargs = '';
  $ccallargs        = '';
  $types            = '';
  $number_args  = split(',',$args);

  # Need to count strings for fortran wrappers
  $number_strings = 0;

  # Will be set to zero if can't generate a fortran wrapper
  $fortran = 1;
  # Will be set to zero if can't add the aliased C function
  $c = 1;

  foreach $arg (split(',',$args))
  {

#    print "  Arg is $arg\n";

    # last part is the argument name
    $arg =~ m:(.*)\s+([^\s]+)\s*:;
    $name = $2;
    $type = $1;
    $name =~ s:^\s*::;
    $name =~ s:\s*$::;
    $type =~ s:^\s*::;
    $type =~ s:\s*$::;

    $types = "$types $type";

#    print "    Name is $name\n";
#    print "    Type is $type\n";

    # treat string differently

    if ($type =~ m/CCTK_STRING/)
    {
      $number_strings++;
      $ccallargs .= "$type $name, ";
    }
    elsif ($type =~ m/CCTK_(INT|REAL|POINTER|FPOINTER)/)
    {
      if ($number_strings)
      {
        $fortran = 0;
      }
      # look for an array
      if ($type =~ m/^\s*(CCTK_INT??|CCTK_REAL??):ARRAY\s*$/)
      {
        $ccallargs .= "$1 *$name, ";
        $fwrapperargs .= "$1 *$name, ";
        $fwrappercallargs .= "$name, ";
      }
      elsif ($type =~ m/^\s*CCTK_POINTER\s*$/)
      {
        $ccallargs .= "$type $name, ";
        $fwrapperargs .= "$type *$name, ";
        $fwrappercallargs .= "$name, ";
      }
      else
      {
        $ccallargs .= "$type $name, ";
        $fwrapperargs .= "$type *$name, ";
        $fwrappercallargs .= "*$name, ";
      }
    }
    else
    {
      $fortran = 0;
      $c = 0;
      $message = "Error parsing aliased function argument $arg";
      &CST_error(1,$message,'',__LINE__,__FILE__);
    }
  }

  # Remove trailing comma
  $ccallargs =~ s/,\s$//;
  $fwrapperargs =~ s/,\s$//;
  $fwrappercallargs =~ s/,\s$//;

  # Can't do more than three strings for fortran
  if ($number_strings > 3)
  {
    $fortran = 0;
  }

  return ($number_strings,$types,$c,$fortran,$fwrappercallargs,$fwrapperargs,$ccallargs);
}

1;