#! /usr/bin/perl
#/*@@
#  @file      GridFuncStuff.pl
#  @date      Tue Jan 12 11:07:45 1999
#  @author    Tom Goodale
#  @desc
#
#  @enddesc
#  @version $Id$
#@@*/
use strict;

#/*@@
#  @routine    CreateVariableBindings
#  @date       Thu Jan 28 15:14:20 1999
#  @author     Tom Goodale
#  @desc
#  Creates all the binding files for the variables.
#  @enddesc
#@@*/
sub CreateVariableBindings
{
  my($bindings_dir, $rhinterface_db, $rhparameter_db) = @_;
  my @data = ();

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

  # Create the header files
  if(! -d "include")
  {
    mkdir("include", 0755) || die "Unable to create include directory";
  }

  foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    @data = CreateThornArgumentHeaderFile($thorn, $rhinterface_db);
    my $dataout = join ("\n", @data);
    WriteFile("include/$thorn\_Arguments.h",\$dataout);
  }

  my @thorns = split(" ",$rhinterface_db->{"THORNS"});
  foreach my $thorn (@thorns)
  {
    @data = ();
    push(@data, "#ifndef CCTK_ARGUMENTS_H_");
    push(@data, "#define CCTK_ARGUMENTS_H_ 1");
    push(@data, '/*@@');
    push(@data, '   @header  cctk_Arguments.h');
    push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
    push(@data, '   @desc');
    push(@data, '            Defines the CCTK_ARGUMENTS macro for all thorns');
    push(@data, '   @enddesc');
    push(@data, ' @@*/');
    push(@data, '');
    push(@data, '');
    push(@data, "#include \"${thorn}_Arguments.h\"");

    push(@data, '/* get the CCTK datatype definitions */');
    push(@data, '#include "cctk_Types.h"');
    push(@data, '');
    push(@data, '#ifdef CCODE');
    push(@data, '#include "cGH.h"');
    push(@data, '#include "cctki_GroupsOnGH.h"');

    push(@data, '#define PASS_GROUPSIZE(group, dir)  CCTKGROUPNUM_##group >= 0 ? \\');
    push(@data, '                                    CCTK_ArrayGroupSizeI(GH, dir, CCTKGROUPNUM_##group) : &_cctk_zero');
    push(@data, '');
    push(@data, '#define PASS_GROUPLEN(thorn, group) CCTKGROUPNUM_##group >= 0 ? \\');
    push(@data, '                                    CCTKi_GroupLengthAsPointer(#thorn "::" #group) : &_cctk_zero');
    push(@data, '');
    push(@data, '#define PASS_REFERENCE(var, level)  CCTKARGNUM_##var >= 0 ? \\');
    push(@data, '                                    GH->data[CCTKARGNUM_##var][level] : 0');
    push(@data, '');

    push(@data, "#define CCTK_ARGUMENTS \U${thorn}_CARGUMENTS");
    push(@data, '#define _CCTK_ARGUMENTS _CCTK_CARGUMENTS');
    push(@data, "#define DECLARE_CCTK_ARGUMENTS DECLARE_\U${thorn}_CARGUMENTS");
    push(@data, '#endif');
    push(@data, '');
    push(@data, '#ifdef FCODE');
    push(@data, "#define CCTK_ARGUMENTS \U${thorn}_FARGUMENTS");
    push(@data, '#define _CCTK_ARGUMENTS _CCTK_FARGUMENTS');
    push(@data, "#define DECLARE_CCTK_ARGUMENTS DECLARE_\U${thorn}_FARGUMENTS");
    push(@data, '#endif');

    push(@data, '');
    push(@data, "#define CCTK_FARGUMENTS \U$thorn" . '_FARGUMENTS');
    push(@data, "#define DECLARE_CCTK_FARGUMENTS DECLARE_\U$thorn" . '_FARGUMENTS');
    push(@data, "#define CCTK_CARGUMENTS \U$thorn" . '_CARGUMENTS');
    push(@data, "#define DECLARE_CCTK_CARGUMENTS DECLARE_\U$thorn" . '_CARGUMENTS');
    push(@data, "#endif");
    push(@data, "\n");  # workaround for perl 5.004_04 to add a trailing newline

    my $dataout = join ("\n", @data);
    unless(-d "include/$thorn") {
        mkdir("include/$thorn");
    }
    WriteFile("include/$thorn/cctk_Arguments.h",\$dataout);
    if($thorn eq "Cactus") {
      unless(-d "include/CactusBindings") {
          mkdir("include/CactusBindings");
      }
      WriteFile("include/CactusBindings/cctk_Arguments.h",\$dataout);
    }
    @data = ();
    # alternate
    push @data, "#ifndef _CCTK_H_";
    push @data, "#define _CCTK_H_ 1";
    push @data, "#include \"${thorn}/definethisthorn.h\"";
    push @data, "";
    push @data, "/* Include prototypes for scheduled functions */";
    push @data, "#include \"${thorn}/cctk_ScheduleFunctions.h\"";
    push @data, "#include \"cctk_core.h\"";
    push @data, "#endif";
    push @data, "";
    $dataout = join ("\n", @data);
    WriteFile("include/$thorn/cctk.h",\$dataout);
    if($thorn eq "Cactus") {
      unless(-d "include/CactusBindings") {
          mkdir("include/CactusBindings");
      }
      WriteFile("include/CactusBindings/cctk.h",\$dataout);
    }
  }

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

  my $filelist = "BindingsVariables.c";

  @data = ();
  push(@data, '/*@@');
  push(@data, '   @file    BindingsVariables.c');
  push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
  push(@data, '   @desc');
  push(@data, '            Calls the variable binding routines for all thorns');
  push(@data, '   @enddesc');
  push(@data, ' @@*/');
  push(@data, '');
  push(@data, '');

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

  foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void);");
  }

  push(@data, '');
  push(@data, 'int CCTKi_BindingsVariablesInitialise(void);');
  push(@data, '');

  push(@data, 'int CCTKi_BindingsVariablesInitialise(void)');
  push(@data, '{');
  foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    push(@data, "  if (CCTK_IsThornActive(\"$thorn\"))");
    push(@data, '  {');
    push(@data, "    CactusBindingsVariables_${thorn}_Initialise();");
    push(@data, '  }');
  }

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

  my $dataout = join ("\n", @data);
  WriteFile("Variables/BindingsVariables.c",\$dataout);

  foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    @data = ();
    push(@data, '/*@@');
    push(@data, "   \@file    $thorn.c");
    push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
    push(@data, '   @desc');
    push(@data, "            Creates the CCTK variables for thorn $thorn");
    push(@data, '   @enddesc');
    push(@data, ' @@*/');
    push(@data, '');
    push(@data, '');

    #push(@data, "#define THORN_IS_$thorn 1");
    push(@data, '');
    push(@data, '#include <stddef.h>');
    push(@data, '');
    push(@data, "#include \"$thorn/cctk.h\"");
    push(@data, "#include \"$thorn/cctk_Arguments.h\"");
    push(@data, "#include \"cctk_Parameter.h\"");
    push(@data, '#include "cctk_WarnLevel.h"');
    push(@data, '#include "cctki_Groups.h"');
    push(@data, '#include "cctki_FortranWrappers.h"');
    push(@data, "#include \"$thorn/cctk_ScheduleFunctions.h\"");
    push(@data, '');

    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void);");
    push(@data, "static int CCTKi_BindingsFortranWrapper$thorn(void *_GH, void *fpointer);");
    push(@data, '');
    push(@data, "static int CCTKi_BindingsFortranWrapper$thorn(void *_GH, void *fpointer)");
    push(@data, '{');
    push(@data, '  cGH const *const GH = _GH;');
    push(@data, '  const int _cctk_zero = 0;');
    push(@data, "  void (*function)(\U$thorn\E_C2F_PROTO);");
    push(@data, "  DECLARE_\U$thorn\E_C2F");
    push(@data, "  INITIALISE_\U$thorn\E_C2F");
    push(@data, '  (void) (_cctk_zero + 0);');
    push(@data, '');
    push(@data, "  function = (void (*) (\U$thorn\E_C2F_PROTO)) fpointer;");
    push(@data, "  function (PASS_\U$thorn\E_C2F (GH));");
    push(@data, '');
    push(@data, '  return (0);');
    push(@data, '}');
    push(@data, '');

    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void)");
    push(@data, '{');
    push(@data, '  const char * warn_mixeddim_gfs = "";');
    push(@data, '  int warn_mixeddim = 0;');
    push(@data, '  const CCTK_INT *allow_mixeddim_gfs;');
    push(@data, '');
    push(@data, '');
    push(@data, '  allow_mixeddim_gfs = CCTK_ParameterGet ("allow_mixeddim_gfs", "Cactus", 0);');
    push(@data, '');

    foreach my $block ("PUBLIC", "PROTECTED", "PRIVATE")
    {
      push(@data, CreateThornGroupInitialisers($thorn, $block, $rhinterface_db, $rhparameter_db));
    }
    push(@data, '');
    push(@data, '  if (*warn_mixeddim_gfs)');
    push(@data, '  {');
    push(@data, '    if (allow_mixeddim_gfs && *allow_mixeddim_gfs)');
    push(@data, '    {');
    push(@data, '      CCTK_VWarn (2, __LINE__, __FILE__, "Cactus",');
    push(@data, '                  "CCTKi_CreateGroup: Working dimension already set, "');
    push(@data, '                  "'
          . "creating GF group '\%s' with different dimension \%d\",");
    push(@data, '                  warn_mixeddim_gfs, warn_mixeddim);');

    push(@data, '    }');
    push(@data, '    else');
    push(@data, '    {');
    push(@data, '      CCTK_VWarn (0, __LINE__, __FILE__, "Cactus",');
    push(@data, '                  "CCTKi_CreateGroup: Working dimension already set, "');
    push(@data, '                  "'
              . "cannot create GF group '\%s' with dimension \%d\",");
    push(@data, '                  warn_mixeddim_gfs, warn_mixeddim);');
    push(@data, '    }');
    push(@data, ' }');
    push(@data, '');
    push(@data, "  CCTKi_RegisterFortranWrapper(\"$thorn\", CCTKi_BindingsFortranWrapper$thorn);");

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

    my $dataout = join ("\n", @data);
    WriteFile("Variables/$thorn.c",\$dataout);

    $filelist .= " $thorn.c";
  }

  $dataout = "SRCS = $filelist\n";
  WriteFile("Variables/make.code.defn",\$dataout);

  chdir $start_dir;
}


#/*@@
#  @routine    GetThornArguments
#  @date       Thu Jan 28 14:31:38 1999
#  @author     Tom Goodale
#  @desc
#  Gets a list of all the variables available for a thorn in a
#  particular block.
#  @enddesc
#@@*/
sub GetThornArguments
{
  my($this_thorn, $block, $rhinterface_db) = @_;
  my %arguments = ();
  my @other_imps = ();

  my $my_imp = $rhinterface_db->{"\U$this_thorn IMPLEMENTS"};

  if($block eq "PUBLIC")
  {
    @other_imps = split(" ",$rhinterface_db->{"IMPLEMENTATION \U$my_imp\E ANCESTORS"});
  }
  elsif($block eq "PROTECTED")
  {
    @other_imps = split(" ", $rhinterface_db->{"IMPLEMENTATION \U$my_imp\E FRIENDS"});
  }
  elsif($block eq "PRIVATE")
  {
    @other_imps = ();
  }
  else
  {
    die "Unknown block type $block!!!\n";
  }

  my $sep = '';
  foreach my $imp (@other_imps,$my_imp)
  {

    next if (! defined $imp);

    my $thorn;

    if ($block eq "PRIVATE")
    {
      $thorn = $this_thorn;
    }
    else
    {
      $rhinterface_db->{"IMPLEMENTATION \U$imp\E THORNS"} =~ m:([^ ]*):;

      $thorn = $1;
    }

    foreach my $group (split(" ",$rhinterface_db->{"\U$thorn $block GROUPS\E"}))
    {
      my $vtype = $rhinterface_db->{"\U$thorn GROUP $group VTYPE\E"};
      my $gtype = $rhinterface_db->{"\U$thorn GROUP $group GTYPE\E"};
      my $ntimelevels = $rhinterface_db->{"\U$thorn GROUP $group TIMELEVELS\E"};

      my $type = "$vtype";

      my $vararraysize = $rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"};
      my $compactgroup = $rhinterface_db->{"\U$thorn GROUP $group\E COMPACT"};

      if($gtype eq 'GF' || $gtype eq 'ARRAY' || ($gtype eq 'SCALAR' && defined($vararraysize)))
      {
        $type .= ' (';

        if(defined($vararraysize) && $compactgroup == 1)
        {
          $type .= "${group}_length";
          $sep = ',';
        }
        else
        {
          $sep = '';
        }

        for(my $dim =0; $dim < $rhinterface_db->{"\U$thorn GROUP $group DIM\E"}; $dim++)
        {
# FIXME: quick hack to shorten argument names
#          $type .= "${sep}cctkv$dim$group";
          if ($gtype ne 'GF')
          {
            $type .= "${sep}X$dim$group";
          }
          else
          {
            my $dim1=$dim+1;
            if ($dim<3)
            {
              $type .= "${sep}cctk_ash$dim1";
            }
            else
            {
              $type .= "${sep}cctk_ash($dim1)";
            }
          }
          $sep = ',';
          if ($gtype ne 'GF')
          {
          if($block eq 'PRIVATE')
          {
# FIXME: quick hack to shorten argument names
#            $arguments{"cctkv$dim$group"} = "(STORAGESIZE($thorn\::$group, $dim))";
            $arguments{"X$dim$group"} = "(STORAGESIZE($thorn\::$group, $dim))";
          }
          else
          {
# FIXME: quick hack to shorten argument names
#            $arguments{"cctkv$dim$group"} = "(STORAGESIZE($imp\::$group, $dim))";
            $arguments{"X$dim$group"} = "(STORAGESIZE($imp\::$group, $dim))";
          }
        }
        }
        if(defined($vararraysize) && $compactgroup == 0)
        {
          $type .= "$sep${group}_length";
        }
        $type .= ')';

        if(defined($vararraysize))
        {
          if($block eq 'PRIVATE')
          {
            $arguments{"${group}_length"} = "(GROUPLENGTH($thorn\::$group)";
          }
          else
          {
            $arguments{"${group}_length"} = "(GROUPLENGTH($imp\::$group)";
          }
        }
      }

      if($block eq 'PRIVATE')
      {
        $type .= "!$thorn\::$group";
      }
      else
      {
        $type .= "!$imp\::$group";
      }

      $type .="!$ntimelevels";

      if(defined($vararraysize))
      {
        $type .= '![0]';
      }
      else
      {
        $type .= '!';
      }

      foreach my $variable (split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"}))
      {
        $arguments{$variable} = $type;
      }
    }
  }

  return %arguments;
}


#/*@@
#  @routine    CreateFortranArgumentDeclarations
#  @date       Thu Jan 28 14:32:57 1999
#  @author     Tom Goodale
#  @desc
#  Creates the requisite argument list declarations for Fortran.
#  @enddesc
#@@*/
sub CreateFortranArgumentDeclarations
{
  my(%arguments) = @_;
  my(@declarations) = ();

  # Put all storage arguments first.
  foreach my $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@declarations, "INTEGER $argument");
    }
  }

  # Now deal with the rest of the arguments
  foreach my $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    my $type        = $1;
    my $dimensions  = $2;
    my $ntimelevels = $4;

    for(my $level = 0; $level < $ntimelevels; $level++)
    {
      push(@declarations, "CCTK_DECLARE(CCTK_$type,$argument,$dimensions)");

      # Modify the name for the time level
      $argument .= '_p';
    }

    if(! $type =~ /^(BYTE|INT|INT1|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      CST_error(0,"Unknown argument type \"$type\"","",__LINE__,__FILE__);
    }
  }
  push(@declarations, '');

  return @declarations;

}


#/*@@
#  @routine    CreateCArgumentDeclarations
#  @date       Jun 29 1999
#  @author     Tom Goodale, Gabrielle Allen
#  @desc
#  Creates the requisite argument list declarations for C.
#  @enddesc
#@@*/
sub CreateCArgumentDeclarations
{
  my(%arguments) = @_;
  my(@declarations) = ();


  # Now deal with the rest of the arguments
  foreach my $varname (sort keys %arguments)
  {
    next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$varname} =~ m\^([^! ]+) ?([^!]*)?!([^!]*)::([^!]*)!([^!]*)!([^!]*)\;

    my $type           = $1;
    my $implementation = "\U\"$3\"";
    my $ntimelevels    = $5;
    my $var            = "\"$varname$6\"";
    my $fullvar        = "\"$3::$varname$6\"";

    if(! $type =~ /^(BYTE|INT|INT1|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
    }

    my $varname0 = $varname;
    push(@declarations, "static int cctki_vi_$varname0 = -100;");
    push(@declarations, "if (cctki_vi_$varname0 == -100) cctki_vi_$varname0 = CCTK_VarIndex($fullvar);");

    for(my $level = 0; $level < $ntimelevels; $level++)
    {
       push(@declarations, "CCTK_DECLARE_INIT (CCTK_$type * restrict const, $varname, (CCTK_$type *) CCTKi_VarDataPtrI(cctkGH, $level, cctki_vi_$varname0));");

      # Modify the name for the time level
      $varname .= '_p';
    }
  }

  return @declarations;

}


#/*@@
#  @routine    CreateFortranArgumentList
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the argument list a Fortran subroutine sees.
#  @enddesc
#@@*/
sub CreateFortranArgumentList
{
  my(%arguments) = @_;
  my(@argumentlist) = ();

  # Put all storage arguments first.
  foreach my $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@argumentlist, $argument);
    }
  }

  # Now deal with the rest of the arguments
  foreach my $varname (sort keys %arguments)
  {
    next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$varname} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    my $ntimelevels = $4;

    for(my $level = 0; $level < $ntimelevels; $level++)
    {
      push(@argumentlist, $varname);

      # Modify the name for the time level
      $varname .= '_p';
    }
  }

  return join(',', @argumentlist);
}

#/*@@
#  @routine    CreateCArgumentStatics
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the declarations of static variables used to speed up
#  construction of arguments to pass to Fortran.
#  @enddesc
#@@*/
sub CreateCArgumentStatics
{
  my(%arguments) = @_;
  my(@declarations) = ();

  my $allgroups = '';
  foreach my $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    push(@declarations, "static int CCTKARGNUM_$argument = -1;");
    $arguments{$argument} =~ /::([^!]+)![0-9]+/;
    my $group = $1;

    if ($allgroups !~ / $group /)
    {
      $allgroups .= " $group ";
      push(@declarations, "static int CCTKGROUPNUM_$group = -1;");
    }
  }

  return @declarations;
}


#/*@@
#  @routine    CreateCArgumentInitialisers
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the code to initialise the statics.
#  @enddesc
#@@*/
sub CreateCArgumentInitialisers
{
  my(%arguments) = @_;
  my(@initialisers) = ();

  my $allgroups = '';
  foreach my $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m,^([^! ]+) ?([^!]*)?!([^!]*)\::([^!]*)!([^!]*)!([^!]*),;
    my $qualifier = $3;
    my $varsuffix = $6;

    push(@initialisers, "if(CCTKARGNUM_$argument == -1) CCTKARGNUM_$argument = CCTK_VarIndex(\"$qualifier\::$argument$varsuffix\");");

    $arguments{$argument} =~ /\::([^!]+)/;
    my $group = $1;
    if ($allgroups !~ / $group /)
    {
      $allgroups .= " $group ";
      push(@initialisers, "if(CCTKGROUPNUM_$group == -1) CCTKGROUPNUM_$group = CCTK_GroupIndex(\"$qualifier\::$group\");");
    }
  }

  return @initialisers;
}

#/*@@
#  @routine    CreateCArgumentPrototype
#  @date       Thu Jan 28 14:36:25 1999
#  @author     Tom Goodale
#  @desc
#  Creates the prototype needed to call a Fortran function from C.
#  @enddesc
#@@*/
sub CreateCArgumentPrototype
{
  my(%arguments) = @_;
  my(@prototype) = ();

  # Put all storage arguments first.
  foreach my $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@prototype, 'const int *');
    }
  }

  # Now deal with the rest of the arguments
  foreach my $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*):;

    if($arguments{$argument} !~ m:STORAGESIZE|GROUPLENGTH:)
    {
      $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

      my $type        = $1;
      my $ntimelevels = $4;

      for(my $level = 0; $level < $ntimelevels; $level++)
      {
        push(@prototype, "CCTK_$type *");
      }

      if($type !~ /^(CHAR|BYTE|INT|INT1|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
      {
        CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
      }
    }
  }

  return join(',', @prototype);
}



#/*@@
#  @routine    CreateCArgumentList
#  @date       Thu Jan 28 14:37:07 1999
#  @author     Tom Goodale
#  @desc
#  Creates the argument list used to call a Fortran function from C.
#  @enddesc
#@@*/
sub CreateCArgumentList
{
  my(%arguments) = @_;
  my(@arglist) = ();


  # Put all storage arguments first.
  foreach my $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m/STORAGESIZE\([^,]*::([^,]*),\s*(\d+)/)
    {
      push(@arglist, "PASS_GROUPSIZE($1, $2)");
    }
    elsif($arguments{$argument} =~ m/GROUPLENGTH\(([^:]*)::([^)]*)\)/)
    {
      push(@arglist, "PASS_GROUPLEN($1, $2)");
    }
  }

  # Now deal with the rest of the arguments
  foreach my $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    my $type        = $1;
    my $ntimelevels = $4;
    $arguments{$argument} =~ /\::([^!]+)/;
    my $group = $1;

    for(my $level = 0; $level < $ntimelevels; $level++)
    {
      push(@arglist, "(CCTK_$type *)(PASS_REFERENCE($argument, $level))");
    }

    if($type =~ /^(CHAR|BYTE|INT|INT1|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      # DEPRECATED IN BETA 10
      if($type eq 'CHAR')
      {
        CST_error(1,"CCTK_CHAR is replaced by CCTK_BYTE, please change your code","",__LINE__,__FILE__);
      }
    }
    else
    {
      CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
    }
  }

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

#/*@@
#  @routine    CreateThornArgumentHeaderFile
#  @date       Thu Jan 28 14:37:58 1999
#  @author     Tom Goodale
#  @desc
#  Creates all the argument list stuff necessary to call Fortran from C
#  @enddesc
#@@*/
sub CreateThornArgumentHeaderFile
{
  my($this_thorn, $rhinterface_db) = @_;
  my @returndata = ();
  my %hasvars = ();

  # Header Data
  push(@returndata, '/*@@');
  push(@returndata, "   \@header  ${this_thorn}_Arguments.h");
  push(@returndata, '   @author  Automatically generated by GridFuncStuff.pl');
  push(@returndata, '   @desc');
  push(@returndata, '            Defines macros to declare/define/pass function arguments');
  push(@returndata, "            in calls from C to Fortran for thorn $this_thorn");
  push(@returndata, '   @enddesc');
  push(@returndata, ' @@*/');
  push(@returndata, '');
  push(@returndata, '');

  my $thorn = "\U$this_thorn";

  # Create the basic thorn block definitions
  foreach my $block ("PRIVATE", "PROTECTED", "PUBLIC")
  {

    my %data = GetThornArguments($this_thorn, $block, $rhinterface_db);

    # Remember if there actually are any arguments here.
    $hasvars{$block} = 1 if(keys %data > 0) ;

    # Do the fortran definitions
    push(@returndata, '#ifdef FCODE');

    # Create the fortran argument declarations
    push(@returndata, "#define DECLARE_${thorn}_${block}_FARGUMENTS \\");
    my @data = CreateFortranArgumentDeclarations(%data);
    push(@returndata, join ("&&\\\n", @data));
    push(@returndata, '');

    # Create the fortran argument list
    push(@returndata, "#define ${thorn}_${block}_FARGUMENTS \\");
    push(@returndata, CreateFortranArgumentList(%data));
    push(@returndata, '');

    push(@returndata, '#endif /* FCODE */');
    push(@returndata, '');


    ##########################################################

    # Do the C definitions
    push(@returndata, '#ifdef CCODE');

    # Create the C argument declarations
    push(@returndata, "#define DECLARE_${thorn}_${block}_CARGUMENTS \\");
    @data = CreateCArgumentDeclarations(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument variable number statics
    push(@returndata, "#define DECLARE_${thorn}_${block}_C2F \\");
    @data = CreateCArgumentStatics(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument variable number statics initialisers
    push(@returndata, "#define INITIALISE_${thorn}_${block}_C2F \\");
    @data = CreateCArgumentInitialisers(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument prototypes
    push(@returndata, "#define ${thorn}_${block}_C2F_PROTO \\");
    push(@returndata, CreateCArgumentPrototype(%data));
    push(@returndata, '');

    # Create the C argument list
    push(@returndata, "#define PASS_${thorn}_${block}_C2F(GH) \\");
    push(@returndata, CreateCArgumentList(%data));

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

  ################################################################

  # Create the final thorn argument macros

  my $fortran_arguments = "#define ${thorn}_FARGUMENTS _CCTK_FARGUMENTS";
  my $fortran_declarations = "#define DECLARE_${thorn}_FARGUMENTS _DECLARE_CCTK_FARGUMENTS";
  my $c_declarations = "#define \UDECLARE_${thorn}_CARGUMENTS _DECLARE_CCTK_CARGUMENTS";
  my $c_argument_prototypes = "#define \U${thorn}_C2F_PROTO _CCTK_C2F_PROTO";
  my $c_argument_lists = "#define PASS_\U${thorn}_C2F(GH) _PASS_CCTK_C2F(GH)";
  my $c_declare_statics = "#define DECLARE_\U${thorn}_C2F _DECLARE_CCTK_C2F";
  my $c_initialize_statics = "#define INITIALISE_\U${thorn}_C2F _INITIALISE_CCTK_C2F";
  foreach my $block ("PRIVATE", "PROTECTED", "PUBLIC")
  {
    if($hasvars{$block})
    {
      $fortran_arguments .= ", ${thorn}_${block}_FARGUMENTS";
      $fortran_declarations .= " DECLARE_${thorn}_${block}_FARGUMENTS";
      $c_declarations .= " DECLARE_${thorn}_${block}_CARGUMENTS";
      $c_argument_prototypes .= ", ${thorn}_${block}_C2F_PROTO";
      $c_argument_lists .= ", PASS_${thorn}_${block}_C2F(GH)";
      $c_declare_statics .= " DECLARE_${thorn}_${block}_C2F";
      $c_initialize_statics .= " INITIALISE_${thorn}_${block}_C2F";
    }
  }

  # Do the Fortran argument lists
  push(@returndata, '#ifdef FCODE');
  push(@returndata, $fortran_arguments);
  push(@returndata, '');
  push(@returndata, $fortran_declarations);
  push(@returndata, '');
  push(@returndata, '#endif /* FCODE */');
  push(@returndata, '');

  # Do the C argument lists
  push(@returndata, '#ifdef CCODE');
  push(@returndata, $c_declarations);
  push(@returndata, '');
  push(@returndata, $c_argument_prototypes);
  push(@returndata, '');
  push(@returndata, $c_argument_lists);
  push(@returndata, '');
  push(@returndata, $c_declare_statics);
  push(@returndata, '');
  push(@returndata, $c_initialize_statics);
  push(@returndata, '');
  push(@returndata, "#define ${thorn}_CARGUMENTS cGH *cctkGH");
  push(@returndata, '');
  push(@returndata, '#endif /* CCODE */');

  push(@returndata, '');

  return @returndata;
}



#/*@@
#  @routine    CreateThornGroupInitialisers
#  @date       Thu Jan 28 14:38:56 1999
#  @author     Tom Goodale
#  @desc
#  Creates the calls used to setup groups for a particular thorn block.
#  @enddesc
#@@*/
sub CreateThornGroupInitialisers
{
  my($thorn, $block, $rhinterface_db, $rhparameter_db) = @_;
  my @data = ();

  my $imp = $rhinterface_db->{"\U$thorn\E IMPLEMENTS"};

  foreach my $group (split(" ", $rhinterface_db->{"\U$thorn $block GROUPS"}))
  {
    my $type = $rhinterface_db->{"\U$thorn GROUP $group\E GTYPE"};

    # Check consistency of SIZE and (optional) GHOSTSIZE options for arrays
    if ($type eq 'ARRAY')
    {
      my $message = '';
      my $size = $rhinterface_db->{"\U$thorn GROUP $group\E SIZE"};
      CheckArraySizes($size,$thorn,$rhparameter_db,$rhinterface_db,$group);
      my $dim = $rhinterface_db->{"\U$thorn GROUP $group\E DIM"};
      my $numsize = split (',', $size);
      if ($dim != $numsize)
      {
        if ($numsize == 0)
        {
          $message = "Array sizes not provided for group '$group' in '$thorn'";
        }
        else
        {
          $message = "Array dimension $dim doesn't match the $numsize ".
                     "array sizes\n     ($size) for '$group' in '$thorn'";
        }
        my $hint = "Array sizes must be comma separated list of $dim " .
                "constants or parameters";
        CST_error(0,$message,$hint,__LINE__,__FILE__);
      }
      my $ghostsize = $rhinterface_db->{"\U$thorn GROUP $group\E GHOSTSIZE"};
      if ($ghostsize)
      {
        CheckArraySizes($ghostsize,$thorn,$rhparameter_db,$rhinterface_db,$group);
        my $numghostsize = split (',', $ghostsize);
        if ($dim != $numghostsize)
        {
          if ($numghostsize == 0)
          {
            $message = "Array sizes not provided for group '$group' in '$thorn'";
          }
          else
          {
            $message = "Array dimension $dim doesn't match the $numghostsize ".
                       "array ghossizes\n     ($size) for '$group' in '$thorn'";
          }
          my $hint = "Array ghostsizes must be comma separated list of $dim " .
                  "constants or parameters";
          CST_error(0,$message,$hint,__LINE__,__FILE__);
        }
      }
    }

    my $line = "  if (CCTKi_CreateGroup (\"\U$group\", \"$thorn\", \"$imp\",";
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP ${group}\E GTYPE"}
          . '", "'
          . $rhinterface_db->{"\U$thorn GROUP ${group}\E VTYPE"}
          . '", "'
          . $block
          . '",';
    push(@data, $line);
    $line = '                         '
          . $rhinterface_db->{"\U$thorn GROUP $group\E DIM"}
          . ', '
          . $rhinterface_db->{"\U$thorn GROUP $group\E TIMELEVELS"}
          . ',';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E DISTRIB"}
          . '",';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E SIZE"}
          . '", "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E GHOSTSIZE"}
          . '",';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E TAGS"}
          . '",';
    push(@data, $line);

    # Is it a vector group ?
    my @variables = split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"});
    if(defined($rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"}))
    {
      # Check that the size is allowed.
      CheckArraySizes($rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"},$thorn,$rhparameter_db,$rhinterface_db,$group);
      # Pass in the size of the GV array, which may be a valid parameter expression
      $line = '                         "'
            . $rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"}
            . '",';
      push(@data, $line);
    }
    else
    {
      $line = '                         NULL,';
      push(@data, $line);
    }

    $line = '                         ' . scalar(@variables);

    foreach my $variable (@variables)
    {
      $line .= ",\n                         \"$variable\"";
    }

    $line .= ') == 1)';
    push(@data, $line);

    push(@data, '  {');
    push(@data, "    warn_mixeddim_gfs = \"$group\";");
    push(@data, '    warn_mixeddim = '
                . $rhinterface_db->{"\U$thorn GROUP $group\E DIM"} . ';');
    push(@data, '  }');
  }

  return @data;
}

#/*@@
#  @routine    CheckArraySizes
#  @date       Thu May 10 2001
#  @author     Gabrielle Allen
#  @desc
#              Arrays sizes must be given as a comma-separated list of
#                - integer contants (no sign character)
#                - parameter names (either fullname or just the basename)
#                  optionally with a "+/-<integer constant>" postfix
#  @enddesc
#@@*/
sub CheckArraySizes
{
  my($size,$thornname,$rhparameter_db,$rhinterface_db,$group) = @_;

  # append a dummy space character to catch expressions with trailing commas
  $size .= ' ';
  foreach my $par (split(",",$size))
  {
    VerifyParameterExpression($par,$thornname,$rhparameter_db,$rhinterface_db,$group);
  }

}

#/*@@
#  @routine    VerifyParameterExpression
#  @date       Sat Oct 13 16:40:07 2001
#  @author     Tom Goodale
#  @desc
#  Does some sanity checking on an arithmetic expression
#  involving parameter values.
#  Parameter names can be bare, in which case they are assumed to be
#  from the current thorn, or qualified, in which case they should
#  refer either to the current thorn or a valid shared parameter.
#  @enddesc
#@@*/
sub VerifyParameterExpression
{
  my($expression,$thornname,$rhparameter_db,$rh_interface_db,$group) = @_;
  my $msg = "Array size in '$thornname' is an invalid arithmetic expression\n"
            . '          ';

  # Eliminate white space in expression
  $expression =~ s/\s+//g;

  # First do some global checks
  if($expression !~ m%^[-+*/a-zA-Z0-9_():\[\]]+$%)
  {
    CST_error(0, $msg . "'$expression' contains invalid characters",
               '',__LINE__,__FILE__);
  }

  my $count = 0;

  for my $i (split(//,$expression))
  {
    $count++ if($i eq "(");
    $count-- if($i eq ")");

    if($count < 0)
    {
      CST_error(0, $msg . "'$expression' has too many closing parentheses",
                 '',__LINE__,__FILE__);
    }
  }

  if($count > 0)
  {
    CST_error(0, $msg . "'$expression' has unmatched parentheses",
               '',__LINE__,__FILE__);
  }


  if($expression =~ m:[-+*/]$:)
  {
    CST_error(0, $msg . "'$expression' ends with an operator",
               '',__LINE__,__FILE__);

  }

  # Now split the string on operators and parentheses
  my @fields = split(/([-+*\/()])/, $expression);

  for my $i (@fields)
  {
    # Get rid of any empty tokens
    next if($i =~ m:^\s*$:);

    # Deal with the easy valid cases

    next if($i =~ m:^[-+/*]\(*$:);
    next if($i =~ m:^\)*[-+/*]$:);
    next if($i =~ m:^\(+$:);
    next if($i =~ m:^\)+$:);
    next if($i =~ m:^\d+$:);

    # Now check if it is a valid parameter name
    if($i =~ m:^([a-zA-Z][a-zA-Z0-9_]*)(\:\:([a-zA-Z][a-zA-Z0-9_]*))?:)
    {
      my $thorn;
      my $base;
      if (defined $2)
      {
        $thorn = $1;
        $base = $3;
      }
      else
      {
        $thorn = $thornname;
        $base = $1;
      }

      if($thorn =~ m/^$thornname$/i)
      {
        # check if the parameter really exists
        # FIXME: should also translate and check implementation for restricted and global params.
        if ($rhparameter_db->{"\U$thorn Private\E variables"} !~ m:$base:i &&
            $rhparameter_db->{"\U$thorn Global\E variables"} !~ m:$base:i &&
            $rhparameter_db->{"\U$thorn Restricted\E variables"} !~ m:$base:i)
        {
          CST_error(0,"Expression '$expression' in group: $group, type: " . $rh_interface_db->{"\U$thorn GROUP ${group}\E GTYPE"} . " and thorn: '$thornname' contains a constant which isn\'t a parameter",
                     '',__LINE__,__FILE__);
        }
      }
      else
      {
        # Parameter is from a different implementation

        my $implementation = $thorn;

        # Is it a global parameter?
        if ($rhparameter_db->{"GLOBAL PARAMETERS"} =~ m/$i/i)
        {
          # It is a global parameter, all is o.k.
        }
        elsif($rhparameter_db->{"\U$thornname SHARES\E implementations"} =~ m/\b$implementation\b/i)
        {
          # Ok, so it does share from this implementation
          if($rhparameter_db->{"\U$thornname SHARES $implementation\E variables"} !~ m/\b$base\b/i)
          {
            CST_error(0,"Array size '$expression' in '$thornname' contains a reference to a parameter from $implementation" .
                       " which is neither USED nor EXTENDED",
                       '',__LINE__,__FILE__);
          }
        }
        else
        {
          CST_error(0,"Array size '$expression' in '$thornname' contains a reference to a parameter from $implementation" .
                     " which is not global nor shared",
                     '',__LINE__,__FILE__);
        }
      }
    }
    elsif($i =~ m:^\(\)$:)
    {
      # Empty parenthesis - bad
      CST_error(0, $msg . "'$expression' contains empty parentheses",
                 '',__LINE__,__FILE__);
    }
    elsif($i =~ m:[-+/*]{2,}:)
    {
      # Two operators in a row - bad
      CST_error(0, $msg . "'$expression' contains two operators in a row",
                 '',__LINE__,__FILE__);
    }
    elsif($i =~ m:[-+/*]\):)
    {
      # Operator followed by closing parenthesis - bad
      CST_error(0, $msg . "'$expression' has a missing operand",
                 '',__LINE__,__FILE__);
    }
    elsif($i =~ m:\([-+/*]:)
    {
      # Opening parenthesis followed by operator - bad
      CST_error(0, $msg . "'$expression' has a missing operand",
                 '',__LINE__,__FILE__);
    }
    else
    {
      # I've run out of imagination
      CST_error(0, $msg . "'$expression' contains unrecognised token '$i'",
                 '',__LINE__,__FILE__);
    }
  }

}

1;