[Patches] GridFuncStuff bug fix and cleanup
Steve White
steve.white at aei.mpg.de
Mon May 1 17:51:28 CDT 2006
Hi again,
Attached find a diff for lib/sbin/GridFuncStuff.pl.
It fixes two minor bugs (that is, bugs that weren't bugging anybody right
now). It also includes an overall cleanup of the code, which begain with
the first bug fix, and resulted in the discovery of the second bug.
The first bug fix was to put in
use strict;
(According to L. Wall, a Perl file without use strict constitutes a bug.)
This resulted in lots of errors about variables needing their scope to be
specified. So I did this.
At the end, I found that I couldn't fix a certain occurrance of $group.
There was no sensible way that it was being set. The code was to produce
a warning concerning creating groups with mixed dimensions. See
'warn_mixeddim_gfs'.
The Perl code was taking a global value of $group set at build time to be
the last group in a loop. However, the offending group is determined at
run time in CreateThornGroupInitializers. So the warning message would
typically be wrong.
Affect code written in
bindings/Variables/<thorn>.c
Also: Perl 5-ied function calls
deleted great wads of commented-out code
Testing
-------
Ran testsuites on my laptop with Whisky benchmark thornlist.
No change was detected in the results.
--
Steve White : Programmer
Max-Planck-Institut für Gravitationsphysik Albert-Einstein-Institut
Am Mühlenberg 1, D-14476 Golm, Germany +49-331-567-7625
-------------- next part --------------
Index: lib/sbin/GridFuncStuff.pl
===================================================================
RCS file: /cactusdevcvs/Cactus/lib/sbin/GridFuncStuff.pl,v
retrieving revision 1.105
diff -u -r1.105 GridFuncStuff.pl
--- lib/sbin/GridFuncStuff.pl 28 Sep 2005 17:09:31 -0000 1.105
+++ lib/sbin/GridFuncStuff.pl 1 May 2006 22:27:52 -0000
@@ -8,7 +8,7 @@
# @enddesc
# @version $Id: GridFuncStuff.pl,v 1.105 2005/09/28 17:09:31 schnetter Exp $
#@@*/
-
+use strict;
#/*@@
# @routine CreateVariableBindings
@@ -21,14 +21,13 @@
sub CreateVariableBindings
{
my($bindings_dir, $rhinterface_db, $rhparameter_db) = @_;
- my(@data);
- my($thorn, $line, $block, $filelist);
+ my @data = ();
if(! -d $bindings_dir)
{
mkdir("$bindings_dir", 0755) || die "Unable to create $bindings_dir";
}
- $start_dir = `pwd`;
+ my $start_dir = `pwd`;
chdir $bindings_dir;
# Create the header files
@@ -37,11 +36,11 @@
mkdir("include", 0755) || die "Unable to create include directory";
}
- foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
+ foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
{
- @data = &CreateThornArgumentHeaderFile($thorn, $rhinterface_db);
- $dataout = join ("\n", @data);
- &WriteFile("include/$thorn\_arguments.h",\$dataout);
+ @data = CreateThornArgumentHeaderFile($thorn, $rhinterface_db);
+ my $dataout = join ("\n", @data);
+ WriteFile("include/$thorn\_arguments.h",\$dataout);
}
@data = ();
@@ -130,7 +129,7 @@
push(@data, '#define DECLARE_CCTK_ARGUMENTS DECLARE_CCTK_FARGUMENTS');
push(@data, '#endif');
- foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
+ foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
{
push(@data, '');
push(@data, "#ifdef THORN_IS_$thorn");
@@ -143,15 +142,15 @@
}
push(@data, "\n"); # workaround for perl 5.004_04 to add a trailing newline
- $dataout = join ("\n", @data);
- &WriteFile("include/cctk_Arguments.h",\$dataout);
+ my $dataout = join ("\n", @data);
+ WriteFile("include/cctk_Arguments.h",\$dataout);
if(! -d "Variables")
{
mkdir("Variables", 0755) || die "Unable to create Variables directory";
}
- $filelist = "BindingsVariables.c";
+ my $filelist = "BindingsVariables.c";
@data = ();
push(@data, '/*@@');
@@ -168,7 +167,7 @@
push(@data, '#include "cctk_ActiveThorns.h"');
push(@data, '');
- foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
+ foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
{
push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void);");
}
@@ -179,7 +178,7 @@
push(@data, 'int CCTKi_BindingsVariablesInitialise(void)');
push(@data, '{');
- foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
+ foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
{
push(@data, " if (CCTK_IsThornActive(\"$thorn\"))");
push(@data, ' {');
@@ -191,10 +190,10 @@
push(@data, '}');
push(@data, "\n"); # workaround for perl 5.004_04 to add a trailing newline
- $dataout = join ("\n", @data);
- &WriteFile("Variables/BindingsVariables.c",\$dataout);
+ my $dataout = join ("\n", @data);
+ WriteFile("Variables/BindingsVariables.c",\$dataout);
- foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
+ foreach my $thorn (split(" ",$rhinterface_db->{"THORNS"}))
{
@data = ();
push(@data, '/*@@');
@@ -246,32 +245,37 @@
push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void)");
push(@data, '{');
- push(@data, ' int warn_mixeddim_gfs;');
+ 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, ' warn_mixeddim_gfs = 0;');
push(@data, ' allow_mixeddim_gfs = CCTK_ParameterGet ("allow_mixeddim_gfs", "Cactus", 0);');
push(@data, '');
- foreach $block ("PUBLIC", "PROTECTED", "PRIVATE")
+ foreach my $block ("PUBLIC", "PROTECTED", "PRIVATE")
{
- push(@data, &CreateThornGroupInitialisers($thorn, $block, $rhinterface_db, $rhparameter_db));
+ push(@data, CreateThornGroupInitialisers($thorn, $block, $rhinterface_db, $rhparameter_db));
}
push(@data, '');
- push(@data, ' if (warn_mixeddim_gfs)');
+ push(@data, ' if (strlen (warn_mixeddim_gfs) > 0)');
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 '$group' with different dimension $rhinterface_db->{\"\U$thorn GROUP $group\E DIM\"}\");");
+ 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 $group with dimension $rhinterface_db->{\"\U$thorn GROUP $group\E DIM\"}\");");
+ push(@data, ' "'
+ . "cannot create GF group \%s with dimension \%d\",");
+ push(@data, ' warn_mixeddim_gfs, warn_mixeddim);');
push(@data, ' }');
push(@data, ' }');
push(@data, '');
@@ -282,28 +286,14 @@
push(@data, '}');
push(@data, "\n"); # workaround for perl 5.004_04 to add a trailing newline
- $dataout = join ("\n", @data);
- &WriteFile("Variables/$thorn.c",\$dataout);
+ my $dataout = join ("\n", @data);
+ WriteFile("Variables/$thorn.c",\$dataout);
$filelist .= " $thorn.c";
}
-# TR 24 Jan 2003
-# Fortran wrappers are now defined and registered in "Variables/$thorn.c"
-#
-# foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
-# {
-# @data = &CreateThornFortranWrapper($thorn);
-# push(@data, "\n"); # workaround for perl 5.004_04 to add a trailing newline
-#
-# $dataout = join ("\n", @data);
-# &WriteFile("Variables/$thorn\_FortranWrapper.c",\$dataout);
-#
-# $filelist .= " $thorn\_FortranWrapper.c";
-# }
-
$dataout = "SRCS = $filelist\n";
- &WriteFile("Variables/make.code.defn",\$dataout);
+ WriteFile("Variables/make.code.defn",\$dataout);
chdir $start_dir;
}
@@ -321,11 +311,10 @@
sub GetThornArguments
{
my($this_thorn, $block, $rhinterface_db) = @_;
- my(%arguments);
- my(@other_imps);
- my($my_imp, $imp, $thorn, $group, $variable, $vtype, $gtype, $type);
+ my %arguments = ();
+ my @other_imps = ();
- $my_imp = $rhinterface_db->{"\U$this_thorn IMPLEMENTS"};
+ my $my_imp = $rhinterface_db->{"\U$this_thorn IMPLEMENTS"};
if($block eq "PUBLIC")
{
@@ -344,14 +333,14 @@
die "Unknown block type $block!!!\n";
}
-# print "Thorn is $this_thorn, implementation $my_imp, block is $block\n";
-# print "Other imps are @other_imps\n";
-
- foreach $imp (@other_imps,$my_imp)
+ my $sep = '';
+ foreach my $imp (@other_imps,$my_imp)
{
next if (! defined $imp);
+ my $thorn;
+
if ($block eq "PRIVATE")
{
$thorn = $this_thorn;
@@ -363,13 +352,13 @@
$thorn = $1;
}
- foreach $group (split(" ",$rhinterface_db->{"\U$thorn $block GROUPS\E"}))
+ foreach my $group (split(" ",$rhinterface_db->{"\U$thorn $block GROUPS\E"}))
{
- $vtype = $rhinterface_db->{"\U$thorn GROUP $group VTYPE\E"};
- $gtype = $rhinterface_db->{"\U$thorn GROUP $group GTYPE\E"};
- $ntimelevels = $rhinterface_db->{"\U$thorn GROUP $group TIMELEVELS\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"};
- $type = "$vtype";
+ my $type = "$vtype";
my $vararraysize = $rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"};
my $compactgroup = $rhinterface_db->{"\U$thorn GROUP $group\E COMPACT"};
@@ -388,7 +377,7 @@
$sep = '';
}
- for($dim =0; $dim < $rhinterface_db->{"\U$thorn GROUP $group DIM\E"}; $dim++)
+ 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";
@@ -446,9 +435,7 @@
$type .= '!';
}
-# print "Group is $group, resulting type is $type\n";
-
- foreach $variable (split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"}))
+ foreach my $variable (split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"}))
{
$arguments{$variable} = $type;
}
@@ -470,11 +457,10 @@
sub CreateFortranArgumentDeclarations
{
my(%arguments) = @_;
- my($argument);
my(@declarations) = ();
# Put all storage arguments first.
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
{
@@ -483,19 +469,17 @@
}
# Now deal with the rest of the arguments
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);
$arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;
- $type = $1;
- $dimensions = $2;
- $ntimelevels = $4;
+ my $type = $1;
+ my $dimensions = $2;
+ my $ntimelevels = $4;
-# print "var $argument - type \"$arguments{$argument}\" - tl $ntimelevels \n";
-
- for($level = 0; $level < $ntimelevels; $level++)
+ for(my $level = 0; $level < $ntimelevels; $level++)
{
push(@declarations, "CCTK_$type $argument$dimensions");
@@ -505,7 +489,7 @@
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__);
+ CST_error(0,"Unknown argument type \"$type\"","",__LINE__,__FILE__);
}
}
push(@declarations, '');
@@ -526,23 +510,22 @@
sub CreateCArgumentDeclarations
{
my(%arguments) = @_;
- my($varname, $imp, $type, $fullname, $ntimelevels);
my(@declarations) = ();
# Now deal with the rest of the arguments
- foreach $varname (sort keys %arguments)
+ foreach my $varname (sort keys %arguments)
{
next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);
$arguments{$varname} =~ m\^([^! ]+) ?([^!]*)?!([^!]*)::([^!]*)!([^!]*)!([^!]*)\;
- $type = $1;
- $implementation = "\U\"$3\"";
- $ntimelevels = $5;
- $var = "\"$varname$6\"";
+ my $type = $1;
+ my $implementation = "\U\"$3\"";
+ my $ntimelevels = $5;
+ my $var = "\"$varname$6\"";
- for($level = 0; $level < $ntimelevels; $level++)
+ for(my $level = 0; $level < $ntimelevels; $level++)
{
push(@declarations, "CCTK_$type * CCTK_RESTRICT $varname = (cctki_dummy_int = \&$varname - \&$varname, (CCTK_$type *) CCTKi_VarDataPtr(cctkGH, $level, $implementation, $var));");
@@ -552,7 +535,7 @@
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__);
+ CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
}
}
@@ -572,11 +555,10 @@
sub CreateFortranArgumentList
{
my(%arguments) = @_;
- my($argument, $varname);
my(@argumentlist) = ();
# Put all storage arguments first.
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
{
@@ -585,15 +567,15 @@
}
# Now deal with the rest of the arguments
- foreach $varname (sort keys %arguments)
+ foreach my $varname (sort keys %arguments)
{
next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);
$arguments{$varname} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;
- $ntimelevels = $4;
+ my $ntimelevels = $4;
- for($level = 0; $level < $ntimelevels; $level++)
+ for(my $level = 0; $level < $ntimelevels; $level++)
{
push(@argumentlist, $varname);
@@ -617,19 +599,16 @@
sub CreateCArgumentStatics
{
my(%arguments) = @_;
- my($argument, $group, $allgroups);
my(@declarations) = ();
- $allgroups = '';
- foreach $argument (sort keys %arguments)
+ 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]+/;
- $group = $1;
-
-# print "ARG is $arguments{$argument}, group is $group\n";
+ my $group = $1;
if ($allgroups !~ / $group /)
{
@@ -653,22 +632,21 @@
sub CreateCArgumentInitialisers
{
my(%arguments) = @_;
- my($argument, $allgroups, $group, $qualifier);
my(@initialisers) = ();
- $allgroups = '';
- foreach $argument (sort keys %arguments)
+ my $allgroups = '';
+ foreach my $argument (sort keys %arguments)
{
next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);
$arguments{$argument} =~ m,^([^! ]+) ?([^!]*)?!([^!]*)\::([^!]*)!([^!]*)!([^!]*),;
- $qualifier = $3;
- $varsuffix = $6;
+ my $qualifier = $3;
+ my $varsuffix = $6;
push(@initialisers, "if(CCTKARGNUM_$argument == -1) CCTKARGNUM_$argument = CCTK_VarIndex(\"$qualifier\::$argument$varsuffix\");");
$arguments{$argument} =~ /\::([^!]+)/;
- $group = $1;
+ my $group = $1;
if ($allgroups !~ / $group /)
{
$allgroups .= " $group ";
@@ -691,10 +669,9 @@
{
my(%arguments) = @_;
my(@prototype) = ();
- my($argument, $type, $ntimelevels);
# Put all storage arguments first.
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
{
@@ -703,7 +680,7 @@
}
# Now deal with the rest of the arguments
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);
@@ -713,17 +690,17 @@
{
$arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;
- $type = $1;
- $ntimelevels = $4;
+ my $type = $1;
+ my $ntimelevels = $4;
- for($level = 0; $level < $ntimelevels; $level++)
+ 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__);
+ CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
}
}
}
@@ -745,11 +722,10 @@
{
my(%arguments) = @_;
my(@arglist) = ();
- my(@argument, $type, $ntimelevels);
# Put all storage arguments first.
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
if($arguments{$argument} =~ m/STORAGESIZE\([^,]*::([^,]*),\s*(\d+)/)
{
@@ -762,18 +738,18 @@
}
# Now deal with the rest of the arguments
- foreach $argument (sort keys %arguments)
+ foreach my $argument (sort keys %arguments)
{
next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);
$arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;
- $type = $1;
- $ntimelevels = $4;
+ my $type = $1;
+ my $ntimelevels = $4;
$arguments{$argument} =~ /\::([^!]+)/;
- $group = $1;
+ my $group = $1;
- for($level = 0; $level < $ntimelevels; $level++)
+ for(my $level = 0; $level < $ntimelevels; $level++)
{
push(@arglist, "(CCTK_$type *)(PASS_REFERENCE($argument, $level))");
}
@@ -783,12 +759,12 @@
# DEPRECATED IN BETA 10
if($type eq 'CHAR')
{
- &CST_error(1,"CCTK_CHAR is replaced by CCTK_BYTE, please change your code","",__LINE__,__FILE__);
+ 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__);
+ CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
}
}
@@ -806,9 +782,8 @@
sub CreateThornArgumentHeaderFile
{
my($this_thorn, $rhinterface_db) = @_;
- my($line, $thorn);
- my(@returndata) = ();
- my(%hasvars);
+ my @returndata = ();
+ my %hasvars = ();
# Header Data
push(@returndata, '/*@@');
@@ -822,22 +797,14 @@
push(@returndata, '');
push(@returndata, '');
- $thorn = "\U$this_thorn";
+ my $thorn = "\U$this_thorn";
# Create the basic thorn block definitions
- foreach $block ("PRIVATE", "PROTECTED", "PUBLIC")
+ foreach my $block ("PRIVATE", "PROTECTED", "PUBLIC")
{
- %data = &GetThornArguments($this_thorn, $block, $rhinterface_db);
+ my %data = GetThornArguments($this_thorn, $block, $rhinterface_db);
-# $print_data = 1;
-# if ($print_data)
-# {
-# foreach $arg (sort keys %data)
-# {
-# print "$this_thorn data: $arg : $data{\"$arg\"}\n";
-# }
-# }
# Remember if there actually are any arguments here.
$hasvars{$block} = 1 if(keys %data > 0) ;
@@ -846,13 +813,13 @@
# Create the fortran argument declarations
push(@returndata, "#define DECLARE_${thorn}_${block}_FARGUMENTS \\");
- @data = &CreateFortranArgumentDeclarations(%data);
+ 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, CreateFortranArgumentList(%data));
push(@returndata, '');
push(@returndata, '#endif /* FCODE */');
@@ -866,30 +833,30 @@
# Create the C argument declarations
push(@returndata, "#define DECLARE_${thorn}_${block}_CARGUMENTS \\");
- @data = &CreateCArgumentDeclarations(%data);
+ @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);
+ @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);
+ @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, CreateCArgumentPrototype(%data));
push(@returndata, '');
# Create the C argument list
push(@returndata, "#define PASS_${thorn}_${block}_C2F(GH) \\");
- push(@returndata, &CreateCArgumentList(%data));
+ push(@returndata, CreateCArgumentList(%data));
push(@returndata, '');
push(@returndata, '#endif /* CCODE */');
@@ -900,14 +867,14 @@
# Create the final thorn argument macros
- $fortran_arguments = "#define ${thorn}_FARGUMENTS _CCTK_FARGUMENTS";
- $fortran_declarations = "#define DECLARE_${thorn}_FARGUMENTS _DECLARE_CCTK_FARGUMENTS";
- $c_declarations = "#define \UDECLARE_${thorn}_CARGUMENTS _DECLARE_CCTK_CARGUMENTS";
- $c_argument_prototypes = "#define \U${thorn}_C2F_PROTO _CCTK_C2F_PROTO";
- $c_argument_lists = "#define PASS_\U${thorn}_C2F(GH) _PASS_CCTK_C2F(GH)";
- $c_declare_statics = "#define DECLARE_\U${thorn}_C2F _DECLARE_CCTK_C2F";
- $c_initialize_statics = "#define INITIALISE_\U${thorn}_C2F _INITIALISE_CCTK_C2F";
- foreach $block ("PRIVATE", "PROTECTED", "PUBLIC")
+ 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})
{
@@ -964,22 +931,22 @@
sub CreateThornGroupInitialisers
{
my($thorn, $block, $rhinterface_db, $rhparameter_db) = @_;
- my(@variables, @data);
- my($imp, $line, $group, $dim, $string, $numsize, $message, $type);
+ my @data = ();
- $imp = $rhinterface_db->{"\U$thorn\E IMPLEMENTS"};
+ my $imp = $rhinterface_db->{"\U$thorn\E IMPLEMENTS"};
- foreach $group (split(" ", $rhinterface_db->{"\U$thorn $block GROUPS"}))
+ foreach my $group (split(" ", $rhinterface_db->{"\U$thorn $block GROUPS"}))
{
- $type = $rhinterface_db->{"\U$thorn GROUP $group\E GTYPE"};
+ my $type = $rhinterface_db->{"\U$thorn GROUP $group\E GTYPE"};
# Check consistency of SIZE and (optional) GHOSTSIZE options for arrays
if ($type eq 'ARRAY')
{
- $size = $rhinterface_db->{"\U$thorn GROUP $group\E SIZE"};
- &CheckArraySizes($size,$thorn,$rhparameter_db,$rhinterface_db,$group);
- $dim = $rhinterface_db->{"\U$thorn GROUP $group\E DIM"};
- $numsize = split (',', $size);
+ 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)
@@ -991,15 +958,15 @@
$message = "Array dimension $dim doesn't match the $numsize ".
"array sizes\n ($size) for '$group' in '$thorn'";
}
- $hint = "Array sizes must be comma separated list of $dim " .
+ my $hint = "Array sizes must be comma separated list of $dim " .
"constants or parameters";
- &CST_error(0,$message,$hint,__LINE__,__FILE__);
+ CST_error(0,$message,$hint,__LINE__,__FILE__);
}
- $ghostsize = $rhinterface_db->{"\U$thorn GROUP $group\E GHOSTSIZE"};
+ my $ghostsize = $rhinterface_db->{"\U$thorn GROUP $group\E GHOSTSIZE"};
if ($ghostsize)
{
- &CheckArraySizes($ghostsize,$thorn,$rhparameter_db,$rhinterface_db,$group);
- $numghostsize = split (',', $ghostsize);
+ CheckArraySizes($ghostsize,$thorn,$rhparameter_db,$rhinterface_db,$group);
+ my $numghostsize = split (',', $ghostsize);
if ($dim != $numghostsize)
{
if ($numghostsize == 0)
@@ -1011,14 +978,14 @@
$message = "Array dimension $dim doesn't match the $numghostsize ".
"array ghossizes\n ($size) for '$group' in '$thorn'";
}
- $hint = "Array ghostsizes must be comma separated list of $dim " .
+ my $hint = "Array ghostsizes must be comma separated list of $dim " .
"constants or parameters";
- &CST_error(0,$message,$hint,__LINE__,__FILE__);
+ CST_error(0,$message,$hint,__LINE__,__FILE__);
}
}
}
- $line = " if (CCTKi_CreateGroup (\"\U$group\", \"$thorn\", \"$imp\",";
+ my $line = " if (CCTKi_CreateGroup (\"\U$group\", \"$thorn\", \"$imp\",";
push(@data, $line);
$line = ' "'
. $rhinterface_db->{"\U$thorn GROUP ${group}\E GTYPE"}
@@ -1052,11 +1019,11 @@
push(@data, $line);
# Is it a vector group ?
- @variables = split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"});
+ 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);
+ 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"}
@@ -1071,71 +1038,24 @@
$line = ' ' . scalar(@variables);
- foreach $variable (@variables)
+ foreach my $variable (@variables)
{
$line .= ",\n \"$variable\"";
- }
+ }
$line .= ') == 1)';
push(@data, $line);
push(@data, ' {');
- push(@data, ' warn_mixeddim_gfs = 1;');
+ push(@data, " warn_mixeddim_gfs = \"$group\";");
+ push(@data, " warn_mixeddim = "
+ . $rhinterface_db->{"\U$thorn GROUP $group\E DIM"} . ';');
push(@data, ' }');
}
return @data;
}
-# TR 24 Jan 2003
-# Fortran wrappers are now defined and registered in "Variables/$thorn.c"
-#
-#sub CreateThornFortranWrapper
-#{
-# my($thorn) = @_;
-# my(@data);
-#
-# @data = ();
-# push(@data, '/*@@');
-# push(@data, " \@file ${thorn}_FortranWrapper.c");
-# push(@data, ' @author Automatically generated by GridFuncStuff.pl');
-# push(@data, ' @desc');
-# push(@data, " Defines the fortran wrappers for scheduled fortran routines of thorn $thorn");
-# push(@data, ' @enddesc');
-# push(@data, ' @@*/');
-# push(@data, '');
-# push(@data, '');
-#
-# push(@data, "#define THORN_IS_$thorn 1");
-# push(@data, '');
-# push(@data, '#include "cctk.h"');
-# push(@data, '#include "cctk_Flesh.h"');
-# push(@data, '#include "cctk_Groups.h"');
-# push(@data, '#include "cctk_Comm.h"');
-# push(@data, '#include "cctk_Arguments.h"');
-# push(@data, '');
-#
-# push(@data, "int CCTKi_BindingsFortranWrapper$thorn(cGH *GH, CCTK_FPOINTER fpointer);");
-# push(@data, '');
-# push(@data, "int CCTKi_BindingsFortranWrapper$thorn(cGH *GH, CCTK_FPOINTER fpointer)");
-# push(@data, '{');
-# 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, '}');
-#
-# return (@data);
-#}
-
-
#/*@@
# @routine CheckArraySizes
# @date Thu May 10 2001
@@ -1150,46 +1070,12 @@
sub CheckArraySizes
{
my($size,$thornname,$rhparameter_db,$rhinterface_db,$group) = @_;
- my($par,$thorn,$base);
# append a dummy space character to catch expressions with trailing commas
$size .= ' ';
- foreach $par (split(",",$size))
+ foreach my $par (split(",",$size))
{
-
-# # check for size to be a constant
-# next if $par =~ /^\d+$/;
-
-# # check for size to be a parameter
-# if ($par =~ /^([A-Za-z]\w*)(::([A-Za-z]\w*))?([+-]\d+)?$/)
-# {
-# if (defined $2)
-# {
-# $thorn = $1;
-# $base = $3;
-# }
-# else
-# {
-# $thorn = $thornname;
-# $base = $1;
-# }
-
-# # check if the parameter really exists
-# 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,"Array size \'$par\' in $thornname is not a parameter",
-# "",__LINE__,__FILE__);
-# }
-# }
-# else
-# {
-# &CST_error(0,"Array size \'$par\' in $thornname has invalid syntax",
-# "",__LINE__,__FILE__);
-# }
-
- &VerifyParameterExpression($par,$thornname,$rhparameter_db,$rhinterface_db,$group);
+ VerifyParameterExpression($par,$thornname,$rhparameter_db,$rhinterface_db,$group);
}
}
@@ -1209,53 +1095,51 @@
sub VerifyParameterExpression
{
my($expression,$thornname,$rhparameter_db,$rh_interface_db,$group) = @_;
- my($i,$count, at fields);
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",
+ CST_error(0, $msg . "'$expression' contains invalid characters",
'',__LINE__,__FILE__);
}
- $count = 0;
+ my $count = 0;
- for $i (split(//,$expression))
+ 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",
+ CST_error(0, $msg . "'$expression' has too many closing parentheses",
'',__LINE__,__FILE__);
}
}
if($count > 0)
{
- &CST_error(0, $msg . "'$expression' has unmatched parentheses",
+ CST_error(0, $msg . "'$expression' has unmatched parentheses",
'',__LINE__,__FILE__);
}
if($expression =~ m:[-+*/]$:)
{
- &CST_error(0, $msg . "'$expression' ends with an operator",
+ CST_error(0, $msg . "'$expression' ends with an operator",
'',__LINE__,__FILE__);
}
# Now split the string on operators and parentheses
- @fields = split(/([-+*\/()])/, $expression);
+ my @fields = split(/([-+*\/()])/, $expression);
- for $i (@fields)
+ for my $i (@fields)
{
# Get rid of any empty tokens
next if($i =~ m:^\s*$:);
@@ -1271,6 +1155,8 @@
# 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;
@@ -1290,7 +1176,7 @@
$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",
+ 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__);
}
}
@@ -1310,14 +1196,14 @@
# 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" .
+ 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" .
+ CST_error(0,"Array size '$expression' in '$thornname' contains a reference to a parameter from $implementation" .
" which is not global nor shared",
'',__LINE__,__FILE__);
}
@@ -1326,31 +1212,31 @@
elsif($i =~ m:^\(\)$:)
{
# Empty parenthesis - bad
- &CST_error(0, $msg . "'$expression' contains empty parentheses",
+ 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",
+ 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",
+ 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",
+ 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'",
+ CST_error(0, $msg . "'$expression' contains unrecognised token '$i'",
'',__LINE__,__FILE__);
}
}
More information about the Patches
mailing list