diff options
| -rw-r--r-- | lib/make/make.config.defn.in | 2 | ||||
| -rw-r--r-- | lib/sbin/CST | 7 | ||||
| -rw-r--r-- | lib/sbin/CreateFunctionBindings.pl | 716 | ||||
| -rw-r--r-- | lib/sbin/interface_parser.pl | 126 | ||||
| -rw-r--r-- | src/include/cctk.h | 1 | ||||
| -rw-r--r-- | src/main/InitialiseCactus.c | 2 | ||||
| -rw-r--r-- | src/main/Subsystems.c | 4 |
7 files changed, 723 insertions, 135 deletions
diff --git a/lib/make/make.config.defn.in b/lib/make/make.config.defn.in index 879dc531..5bf88e1f 100644 --- a/lib/make/make.config.defn.in +++ b/lib/make/make.config.defn.in @@ -111,7 +111,7 @@ F90_POSTPROCESSING = @F90_POSTPROCESSING@ # Exclude some files from the dependency lists -DEP_EXCLUDE_FILES = CParameterStructNames\.h|cctk_Arguments\.h|definethisthorn\.h|FParameters.h|CParameters\.h +DEP_EXCLUDE_FILES = cctk_FunctionAliases\.h|CParameterStructNames\.h|cctk_Arguments\.h|definethisthorn\.h|FParameters.h|CParameters\.h # Command used to get the working directory GET_WD = @GET_WD@ diff --git a/lib/sbin/CST b/lib/sbin/CST index e18e0617..bbff1bb6 100644 --- a/lib/sbin/CST +++ b/lib/sbin/CST @@ -6,7 +6,7 @@ # @desc # Parses the the configuration files for thorns. # @enddesc -# @version $Header: /mnt/data2/cvs2svn/cvs-repositories/Cactus/lib/sbin/CST,v 1.39 2000-09-17 09:45:45 allen Exp $ +# @version $Header: /mnt/data2/cvs2svn/cvs-repositories/Cactus/lib/sbin/CST,v 1.40 2001-02-24 17:31:08 allen Exp $ #@@*/ # Global parameter to track the number of errors from the CST @@ -76,6 +76,7 @@ require "$sbin_dir/CSTUtils.pl"; require "$sbin_dir/CreateParameterBindings.pl"; require "$sbin_dir/CreateImplementationBindings.pl"; require "$sbin_dir/CreateScheduleBindings.pl"; +require "$sbin_dir/CreateFunctionBindings.pl"; require "$sbin_dir/BuildHeaders.pl"; ####################################################################### @@ -538,12 +539,14 @@ sub CreateBindings &CreateVariableBindings($bindings_dir, $rhinterface_db); print " Creating schedule bindings...\n"; &CreateScheduleBindings($bindings_dir, $rhinterface_db, $rhschedule_db); + print " Creating function bindings...\n"; + &CreateFunctionBindings($bindings_dir, $rhinterface_db); # Place an appropriate make.code.defn in the bindings directory. chdir $bindings_dir; $dataout = "SRCS = \n"; - $dataout .= "SUBDIRS = Implementations Parameters Variables Schedule\n"; + $dataout .= "SUBDIRS = Functions Implementations Parameters Variables Schedule\n"; &WriteFile("make.code.defn",\$dataout); # Go back to where we started. diff --git a/lib/sbin/CreateFunctionBindings.pl b/lib/sbin/CreateFunctionBindings.pl index 84906001..da2bbc94 100644 --- a/lib/sbin/CreateFunctionBindings.pl +++ b/lib/sbin/CreateFunctionBindings.pl @@ -2,7 +2,7 @@ #/*@@ # @file CreateFunctionBindings.pl # @date Sat Feb 10 2001 -# @author Tom Goodale +# @author Gabrielle Allen # @desc # # @enddesc @@ -66,12 +66,35 @@ sub CreateFunctionBindings &WriteFile("DummyThornFunctions.c",\$dataout); chdir $bindings_dir; +# Create OverloadThorns.c + chdir "Functions"; + $dataout = &OverloadThorns(); + &WriteFile("OverloadThorns.c",\$dataout); + chdir $bindings_dir; + # Create FortranThornFunctions.c chdir "Functions"; $dataout = &FortranThornFunctions($function_db); &WriteFile("FortranThornFunctions.c",\$dataout); chdir $bindings_dir; +# Create Thorn Include Prototypes + chdir "include"; + foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) + { + $filename = $thorn."_Prototypes.h"; + $dataout = &ThornIncludes($thorn,$function_db,$rhinterface_db); + &WriteFile($filename,\$dataout); + } + chdir $bindings_dir; + +# Create Master Include Prototypes + chdir "include"; + $filename = "cctk_FunctionAliases.h"; + $dataout = &ThornMasterIncludes($rhinterface_db); + &WriteFile($filename,\$dataout); + chdir $bindings_dir; + # Create THORN_Register.c chdir "Functions"; $registerfiles = ""; @@ -90,11 +113,15 @@ sub CreateFunctionBindings &WriteFile("RegisterThornFunctions.c",\$dataout); chdir $bindings_dir; - +# Create IsOverloaded functions + chdir "Functions"; + $dataout = &IsOverloadedBindings($function_db); + &WriteFile("IsOverloaded.c",\$dataout); + chdir $bindings_dir; # Create make.code.defn chdir "Functions"; - $dataout = "\nSRCS = FortranThornFunctions.c DummyThornFunctions.c RegisterThornFunctions.c $registerfiles\n\n"; + $dataout = "\nSRCS = IsOverloaded.c OverloadThorns.c FortranThornFunctions.c DummyThornFunctions.c RegisterThornFunctions.c $registerfiles\n\n"; &WriteFile("make.code.defn",\$dataout); chdir $start_dir; @@ -103,6 +130,119 @@ sub CreateFunctionBindings #/*@@ +# @routine IsOverloadedBindings +# @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 +# @calls +# @calledby +# @history +# +# @endhistory +# +#@@*/ + +sub IsOverloadedBindings +{ + my($function_db) = @_; + my($dataout,$line,@data); + + # Header Data + $line = "/*\@\@\n"; + push(@data, $line); + $line = " \@header IsOverloaded.c\n"; + push(@data, $line); + $line = " \@desc\n"; + push(@data, $line); + $line = " Query how many times a function is overloaded\n"; + push(@data, $line); + $line = " \@enddesc \n"; + push(@data, $line); + $line = " \@\@*/\n\n"; + push(@data, $line); + + $line = "\#include <stdlib.h>\n\n"; + push(@data, $line); + $line = "\#include \"cctk_Flesh.h\"\n\n"; + push(@data, $line); + $line = "\#include \"cctk_FortranString.h\"\n\n"; + push(@data, $line); + + foreach $function (split(" ",$function_db->{"FUNCTIONS"})) + { + if ($function !~ m:^\s*$:) + { + $line = "int CCTKBindings_Overload$function(void *);\n"; + push(@data, $line); + } + } + + $line = "int CCTK_IsOverloaded(const char *function);\n"; + push(@data, $line); + + $line = "int CCTK_IsOverloaded(const char *function)\n"; + push(@data, $line); + $line = "{\n"; + push(@data, $line); + $line = " int retval=0;\n\n"; + push(@data, $line); + + foreach $function (split(" ",$function_db->{"FUNCTIONS"})) + { + if ($function !~ m:^\s*$:) + { + $line = " if (strcmp(function,\"$function\")==0)\n"; + push(@data, $line); + $line = " {\n"; + push(@data, $line); + $line = " retval = CCTKBindings_Overload$function(NULL);\n"; + push(@data, $line); + $line = " }\n\n"; + push(@data, $line); + } + } + + $line = " return retval;\n"; + push(@data, $line); + $line = "}\n\n\n"; + push(@data, $line); + + # Put fortran binding here for the moment + $line = "void CCTK_FCALL CCTK_FNAME(CCTK_IsOverloaded)\n"; + push(@data, $line); + $line = " (int *ret, ONE_FORTSTRING_ARG);\n"; + push(@data, $line); + $line = "void CCTK_FCALL CCTK_FNAME(CCTK_IsOverloaded)\n"; + push(@data, $line); + $line = " (int *ret, ONE_FORTSTRING_ARG)\n"; + push(@data, $line); + $line = "{\n"; + push(@data, $line); + $line = " ONE_FORTSTRING_CREATE(name);\n"; + push(@data, $line); + $line = " *ret = CCTK_IsOverloaded(name);\n"; + push(@data, $line); + $line = " free(name);\n"; + push(@data, $line); + $line = "}\n"; + push(@data, $line); + + + $dataout = ""; + foreach $line (@data) + { + $dataout .= $line; + } + + return $dataout; +} + + +#/*@@ # @routine ThornOverloadables # @date Sat Feb 10 # @author Gabrielle Allen @@ -220,6 +360,255 @@ sub ThornOverloadables } + +#/*@@ +# @routine ThornMasterIncludes +# @date Thu Feb 15 2001 +# @author Gabrielle Allen +# @desc +# Master file of function prototypes for each thorn +# @enddesc +# @calls +# @calledby +# @history +# +# @endhistory +# +#@@*/ + +sub ThornMasterIncludes +{ + my($rhinterface_db) = @_; + my($line,@data,$dataout,$thorn); + + # Header Data + $line = "/*\@\@\n"; + push(@data, $line); + $line = " \@header cctk_FunctionAliases.h\n"; + push(@data, $line); + $line = " \@desc\n"; + push(@data, $line); + $line = " Prototypes for overloaded functions used by all thorn\n"; + push(@data, $line); + $line = " \@enddesc \n"; + push(@data, $line); + $line = " \@\@*/\n\n"; + push(@data, $line); + $line = "\#ifndef _CCTK_FUNCTIONALIASES_H_\n"; + push(@data, $line); + $line = "\#define _CCTK_FUNCTIONALIASES_H_\n\n"; + push(@data, $line); + + $line = "\#ifdef CCODE\n"; + push(@data, $line); + $line = "int CCTK_IsOverloaded(const char *function);\n\n"; + push(@data, $line); + $line = "\#endif\n\n"; + push(@data, $line); + + foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) + { + $line = "\#ifdef THORN_IS_$thorn\n"; + push(@data, $line); + $line = "\#include \"$thorn"."_Prototypes.h\"\n"; + push(@data, $line); + $line = "\#endif\n\n"; + push(@data, $line); + } + + $line = "\#endif\n\n"; + push(@data, $line); + + $dataout = ""; + foreach $line (@data) + { + $dataout .= $line; + } + + return $dataout; +} + + + +#/*@@ +# @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 +# @calls +# @calledby +# @history +# +# @endhistory +# +#@@*/ + +sub OverloadThorns +{ + my($line,@data,$dataout); + + # Header Data + $line = "/*\@\@\n"; + push(@data, $line); + $line = "\@file OverloadThornFunctions.c\n"; + push(@data, $line); + $line = "\@desc \n"; + push(@data, $line); + $line = "Contains routines to overload thorn functions\n"; + push(@data, $line); + $line = "Uses the overload macros to make sure of consistency and\n"; + push(@data, $line); + $line = "to save typing !\n"; + push(@data, $line); + $line = "\@enddesc\n"; + push(@data, $line); + $line = "\@\@*/\n\n"; + push(@data, $line); + + $line = "\#include <stdio.h>\n"; + push(@data, $line); + $line = "\#include <stdlib.h>\n"; + push(@data, $line); + $line = "\#include <string.h>\n\n"; + push(@data, $line); + + $line = "\#include \"cctk_Flesh.h\"\n"; + push(@data, $line); + $line = "\#include \"cctk_WarnLevel.h\"\n"; + push(@data, $line); + $line = "\#include \"OverloadMacros.h\"\n\n"; + push(@data, $line); + + $line = "/* Define the prototypes for the dummy functions. */\n"; + push(@data, $line); + $line = "\#define OVERLOADABLE(name) OVERLOADABLE_DUMMYPROTOTYPE(name)\n\n"; + push(@data, $line); + + $line = "\#include \"ThornOverloadables.h\"\n\n"; + push(@data, $line); + + $line = "\#undef OVERLOADABLE\n\n"; + push(@data, $line); + + $line = "\#define OVERLOADABLE(name) OVERLOADABLE_FUNCTION(name)\n\n"; + push(@data, $line); + + $line = "\#include \"ThornOverloadables.h\"\n\n"; + push(@data, $line); + + $line = "\#undef OVERLOADABLE\n\n"; + push(@data, $line); + + $line = "\#undef OVERLOADABLE_CALL\n"; + push(@data, $line); + $line = "\#undef OVERLOADABLE_PREFIX\n"; + push(@data, $line); + $line = "\#undef OVERLOADABLE_DUMMY_PREFIX\n\n"; + push(@data, $line); + + $line = "/* Initialising Stuff */\n\n"; + push(@data, $line); + + $line = "void CCTKBindings_SetupThornFunctions(void);\n"; + push(@data, $line); + $line = "void CCTKBindings_SetupThornFunctions(void)\n"; + push(@data, $line); + $line = "{\n"; + push(@data, $line); + $line = "\#undef OVERLOADABLE\n"; + push(@data, $line); + $line = "\#define OVERLOADABLE(name) OVERLOADABLE_INITIALISE(name)\n"; + push(@data, $line); + $line = "\#include \"ThornOverloadables.h\"\n"; + push(@data, $line); + $line = "#undef OVERLOADABLE\n"; + push(@data, $line); + $line = "}\n\n"; + push(@data, $line); + + $dataout = ""; + foreach $line (@data) + { + $dataout .= $line; + } + + return $dataout; +} + + + +#/*@@ +# @routine ThornIncludes.h +# @date Thu Feb 15 2001 +# @author Gabrielle Allen +# @desc +# Create function prototypes for each thorn +# @enddesc +# @calls +# @calledby +# @history +# +# @endhistory +# +#@@*/ + +sub ThornIncludes +{ + + my($thorn,$function_db,$rhinterface_db) = @_; + my($line,@data,$dataout,$function); + + # Header Data + $line = "/*\@\@\n"; + push(@data, $line); + $line = " \@header $thorn"."_Prototypes.h\n"; + push(@data, $line); + $line = " \@desc\n"; + push(@data, $line); + $line = " Prototypes for overloaded functions used by this thorn\n"; + push(@data, $line); + $line = " \@enddesc \n"; + push(@data, $line); + $line = " \@\@*/\n\n"; + push(@data, $line); + $line = "\#ifndef _\U$thorn\E_PROTOTYPES_H_\n"; + push(@data, $line); + $line = "\#define _\U$thorn\E_PROTOTYPES_H_\n\n"; + push(@data, $line); + + + $line = "\#ifdef CCODE\n"; + push(@data, $line); + + foreach $function (split(" ",($rhinterface_db->{"\U$thorn USES FUNCTION\E"}))) + { + if ($function !~ m:^\s*$:) + { + $line = "extern $function_db->{\"$function RET\"} (*$function)($function_db->{\"$function CARGS\"});\n"; + push(@data, $line); + } + } + + $line = "\#endif /*CCODE*/\n\n"; + push(@data, $line); + + $line = "\#endif\n\n"; + push(@data, $line); + + $dataout = ""; + foreach $line (@data) + { + $dataout .= $line; + } + + return $dataout; +} + + #/*@@ # @routine RegisterAllFunctions # @date Sun Feb 11 2001 @@ -250,6 +639,14 @@ sub RegisterAllFunctions push(@data, $line); $line = " \@enddesc \n"; push(@data, $line); + $line = " \@returntype int\n"; + push(@data, $line); + $line = " \@returndesc \n"; + push(@data, $line); + $line = " Minus number of failed overloads\n"; + push(@data, $line); + $line = " \@endreturndesc\n"; + push(@data, $line); $line = " \@\@*/\n\n"; push(@data, $line); $line = "\#include \"cctk_Flesh.h\"\n"; @@ -259,27 +656,30 @@ sub RegisterAllFunctions foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) { - $line = "int ".$thorn."_RegisterAliases(void);\n"; + $line = "int CCTKBindings_".$thorn."Aliases(void);\n"; push(@data, $line); } - $line = "int CCTKi_BindingsRegisterThornFunctions(void);\n\n"; + $line = "int CCTKBindings_RegisterThornFunctions(void);\n\n"; push(@data, $line); - $line = "int CCTKi_BindingsRegisterThornFunctions(void)\n"; + $line = "int CCTKBindings_RegisterThornFunctions(void)\n"; push(@data, $line); $line = "{\n"; push(@data, $line); + $line = " int retval = 0;\n"; + push(@data, $line); + foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) { $line = " if (CCTK_IsThornActive(\"$thorn\"))\n"; push(@data, $line); $line = " {\n"; push(@data, $line); - $line = " $thorn"."_RegisterAliases();\n"; + $line = " retval =+ CCTKBindings_".$thorn."Aliases();\n"; push(@data, $line); $line = " }\n"; push(@data, $line); } - $line = " return 0;\n"; + $line = " return retval;\n"; push(@data, $line); $line = "}\n"; push(@data, $line); @@ -327,6 +727,8 @@ sub DummyThornFunctions push(@data, $line); $line = " \@\@*/\n\n"; push(@data, $line); + $line = "\#include <stdlib.h>\n\n"; + push(@data, $line); $line = "\#include \"cctk_Flesh.h\"\n"; push(@data, $line); $line = "\#include \"cctk_WarnLevel.h\"\n\n"; @@ -336,14 +738,69 @@ sub DummyThornFunctions { if ($function !~ m:^\s*$:) { - $line = "$function_db->{\"$function RET\"} CCTKBindings_Dummy$function($function_db->{\"$function CARGS\"})\n"; + $ret = $function_db->{"$function RET"}; + + $line = "$ret CCTKBindings_Dummy$function($function_db->{\"$function CARGS\"});\n"; + push(@data, $line); + $line = "$ret CCTKBindings_Dummy$function($function_db->{\"$function CARGS\"})\n"; push(@data, $line); $line = "{\n"; push(@data, $line); - $line = " CCTK_Warn(0,__LINE__,__FILE__,\"Bindings\",\n"; + + # Make sure we use all arguments to avoid warnings + $line = " CCTK_INT cctk_dummy_int;\n"; + push(@data, $line); + $line = " CCTK_REAL cctk_dummy_real;\n"; + push(@data, $line); + $line = " void *cctk_dummy_pointer;\n"; + push(@data, $line); + $line = " cctk_dummy_int=0;\n"; + push(@data, $line); + $line = " cctk_dummy_int+=0;\n"; + push(@data, $line); + $line = " cctk_dummy_real=0;\n"; + push(@data, $line); + $line = " cctk_dummy_real+=0;\n"; + push(@data, $line); + $line = " cctk_dummy_pointer=NULL;\n"; + push(@data, $line); + $line = " cctk_dummy_pointer=(CCTK_REAL *)cctk_dummy_pointer;\n"; + push(@data, $line); + foreach $arg (split(",",$function_db->{"$function CARGS"})) + { + $arg =~ m:(.*\s+\**)([^\s*\*]+)\s*:; + $type=$1; + $name=$2; + if ($type =~ /[^\*]*\*\s*/ && $type !~ "const") + { + $line = " cctk_dummy_pointer=(void *)$name;\n"; + push(@data, $line); + } + elsif ($type =~ /int/i) + { + $line = " cctk_dummy_int=$name;\n"; + push(@data, $line); + } + elsif ($type =~ /real/i) + { + $line = " cctk_dummy_real=$name;\n"; + push(@data, $line); + } + } + $line = " CCTK_Warn(1,__LINE__,__FILE__,\"Bindings\",\n"; push(@data, $line); $line = " \"CCTKBindings_Dummy$function: Calling thorn function $function which has not been overloaded\");\n"; push(@data, $line); + if ($ret =~ m:INT:i) + { + $line = "return -1;"; + push(@data, $line); + } + elsif ($ret =~ m:REAL:i) + { + $line = "return 0;"; + push(@data, $line); + } $line = "}\n\n"; push(@data, $line); } @@ -378,12 +835,12 @@ sub DummyThornFunctions sub RegisterThornFunctions { my($thorn,$function_db,$rhinterface_db) = @_; - my($dataout,$line,@data); + my($dataout,$line,@data,$function); # Header Data $line = "/*\@\@\n"; push(@data, $line); - $line = " \@header RegisterThornFunctions.h\n"; + $line = " \@header $thorn"."_Register.h\n"; push(@data, $line); $line = " \@desc\n"; push(@data, $line); @@ -400,27 +857,46 @@ sub RegisterThornFunctions { if ($function !~ m:^\s*$:) { - $line = "$function_db->{\"$function RET\"} $rhinterface_db->{\"\U$thorn PROVIDES FUNCTION\E $function WITH\"}($function_db->{\"$function CARGS\"});\n"; - push(@data, $line); + $provided_with = $rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E $function WITH"}; + $ret = $function_db->{"$function RET"}; + $args = $function_db->{"$function CARGS"}; + + $line = "$ret $provided_with($args);\n"; + push(@data, $line); + $line = "int CCTKBindings_Overload$function($ret (* $function)($args));\n"; + push(@data, $line); } } - $line = "int ".$thorn."_RegisterAliases(void);\n"; + $line = "\n"; push(@data, $line); - $line = "int ".$thorn."_RegisterAliases(void)\n"; + $line = "int CCTKBindings_".$thorn."Aliases(void);\n"; + push(@data, $line); + $line = "\n"; + push(@data, $line); + $line = "int CCTKBindings_".$thorn."Aliases(void)\n"; push(@data, $line); $line = "{\n"; push(@data, $line); + $line = " int retval=0; /* returns minus number of failed overloads */\n"; + push(@data, $line); + $line = " int ierr=0;\n\n"; + push(@data, $line); + $line = " retval = ierr; /* use ierr to prevent warnings */\n\n"; + push(@data, $line); + foreach $function (split(" ",$rhinterface_db->{"\U$thorn PROVIDES FUNCTION\E"})) { if ($function !~ m:^\s*$:) { - $line = "CCTKBindings_Overload$function($rhinterface_db->{\"\U$thorn PROVIDES FUNCTION\E $function WITH\"});\n"; + $line = " ierr = CCTKBindings_Overload$function($rhinterface_db->{\"\U$thorn PROVIDES FUNCTION\E $function WITH\"});\n"; + push(@data, $line); + $line = " retval = (ierr == 0) ? retval-- : retval;\n"; push(@data, $line); } } - $line = "return 0;\n"; + $line = " return retval;\n"; push(@data, $line); $line = "}\n"; push(@data, $line); @@ -453,7 +929,7 @@ sub RegisterThornFunctions sub FortranThornFunctions { my($function_db) = @_; - my($dataout,$line,@data); + my($dataout,$line,@data,$function); # Header Data $line = "/*\@\@\n"; @@ -468,42 +944,53 @@ sub FortranThornFunctions push(@data, $line); $line = " \@\@*/\n\n"; push(@data, $line); + $line = "\#include <stdlib.h>\n\n"; + push(@data, $line); $line = "\#include \"cctk_Flesh.h\"\n"; push(@data, $line); $line = "\#include \"cctk_WarnLevel.h\"\n\n"; push(@data, $line); - $line = "\#include \"cctk_FunctionAliases.h\"\n\n"; - push(@data, $line); $line = "\#include \"cctk_FortranString.h\"\n\n"; push(@data, $line); + # Do aliased function prototypes foreach $function (split(" ",$function_db->{"FUNCTIONS"})) { if ($function !~ m:^\s*$:) { - $line = "$function_db->{\"$function RET\"} CCTK_FCALL CCTK_FNAME($function)\n"; - push(@data, $line); - $line = "($function_db->{\"$function WARGS\"}"; - push(@data, $line); + $line = "extern $function_db->{\"$function RET\"} (*$function)($function_db->{\"$function CARGS\"});\n"; + push(@data, $line); + } + } + $line = "\n\n"; + push(@data, $line); + + foreach $function (split(" ",$function_db->{"FUNCTIONS"})) + { + if ($function !~ m:^\s*$:) + { + $line = "$function_db->{\"$function RET\"} CCTK_FCALL CCTK_FNAME($function)\n"; + $line .= "($function_db->{\"$function WARGS\"}"; if ($function_db->{"$function STRINGS"} == 1) { - $line = ", ONE_FORTSTRING_ARG"; - push(@data, $line); + $line .= ", ONE_FORTSTRING_ARG"; } elsif ($function_db->{"$function STRINGS"} == 2) { - $line = ", TWO_FORTSTRINGS_ARGS"; - push(@data, $line); + $line .= ", TWO_FORTSTRINGS_ARGS"; } elsif ($function_db->{"$function STRINGS"} == 3) { - $line = ", THREE_FORTSTRINGS_ARGS"; - push(@data, $line); + $line .= ", THREE_FORTSTRINGS_ARGS"; } - $line = ")\n"; - push(@data, $line); + $line .= ")"; + + # prototype + push(@data, "$line;\n"); + # call + push(@data, "$line\n"); $line = "{\n"; push(@data, $line); @@ -611,21 +1098,36 @@ sub FortranThornFunctions sub FunctionDatabase { my($rhinterface_db) = @_; + my($thorn,$inret,$inargs,$message,$function); + + $function_db->{"FUNCTIONS"}= " "; + $function_db->{"PROVIDED FUNCTIONS"}= " "; - foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) + # Add used functions to database + foreach $thorn (split(" ",$rhinterface_db->{"THORNS"})) { -# print "$thorn\n"; - foreach $function (split(" ",($rhinterface_db->{"\U$thorn FUNCTIONS\E"}))) + foreach $function (split(" ",($rhinterface_db->{"\U$thorn USES FUNCTION\E"}))) { -# print " Dealing with $function\n"; - if ($function_db->{"FUNCTIONS"} =~ /$function/ && $function !~ /^\s*$/) + $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*$/) { -# print " Found $function in database\n"; + 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 { - $inargs = $rhinterface_db->{"\U$thorn FUNCTION\E $function ARGS"}; - $inret = $rhinterface_db->{"\U$thorn FUNCTION\E $function RET"}; if ($inret =~ m:^\s*void\s*$:) { $function_db->{"$function CARGS"} = "SUB"; @@ -635,22 +1137,39 @@ sub FunctionDatabase $function_db->{"$function CARGS"} = "FUNC"; } - ($nstrings,$fortran,$wrappercall,$wrapperargs,$cargs) = &ParseArguments($inret,$inargs); + 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 ($fortran) + if ($rhinterface_db->{"\U$thorn FUNCTION\E $function RET"} eq "void") { - $function_db->{"$function LANG"} = "FC"; + $function_db->{"$function TYPE"} = "SUB"; } else { - $message = "Fortran wrapper not created for alias $function"; - &CST_error(1,$message,__LINE__,__FILE__); - $function_db->{"$function LANG"} = "C"; + $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"}; @@ -658,6 +1177,43 @@ sub FunctionDatabase } } + # 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; } @@ -681,50 +1237,76 @@ sub ParseArguments my($ret,$args) = @_; my($number_args); - print "\n\nInput args is $args\n\n"; +# print "\nParsing Arguments\n"; +# print "=================\n"; +# print "All args: $args\n"; - $fwrapperargs = ""; + $fwrapperargs = ""; $fwrappercallargs = ""; - $ccallargs = ""; - + $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"; + +# 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/char/) + if ($type =~ m/CCTK_STRING/) { $number_strings++; $ccallargs .= "$type $name, "; } - else + elsif ($type =~ m/CCTK_INT/ || $type =~ m/CCTK_REAL/) { if ($number_strings) { $fortran = 0; } # look for an array - if ($type =~ m/(.*)(:ARRAY|:\*)\s*/ && $type !~ /const char/i) - { - $ccallargs .= "$1 *$name, "; - $fwrapperargs .= "$1 *$name, "; - $fwrappercallargs .= "$name, "; - } + if ($type =~ m/^\s*(CCTK_INT??|CCTK_REAL??):ARRAY\s*$/) + { + $ccallargs .= "$1 *$name, "; + $fwrapperargs .= "$1 *$name, "; + $fwrappercallargs .= "$name, "; + } else - { - $ccallargs .= "$type $name, "; - $fwrapperargs .= "$type *$name, "; - $fwrappercallargs .= "*$name, "; - } + { + $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__); } } @@ -739,7 +1321,7 @@ sub ParseArguments $fortran = 0; } - return ($number_strings,$fortran,$fwrappercallargs,$fwrapperargs,$ccallargs); + return ($number_strings,$types,$c,$fortran,$fwrappercallargs,$fwrapperargs,$ccallargs); } 1; diff --git a/lib/sbin/interface_parser.pl b/lib/sbin/interface_parser.pl index fcb72696..cc83eeb5 100644 --- a/lib/sbin/interface_parser.pl +++ b/lib/sbin/interface_parser.pl @@ -605,7 +605,7 @@ sub parse_interface_ccl $interface_db{"\U$thorn PRIVATE GROUPS\E"} = ""; $interface_db{"\U$thorn USES HEADER\E"} = ""; $interface_db{"\U$thorn FUNCTIONS\E"} = ""; - $interface_db{"\U$thorn PROVIDES FUNCTION\E"} = ""; + $interface_db{"\U$thorn PROVIDES FUNCTION\E"} = ""; $interface_db{"\U$thorn USES FUNCTION\E"} = ""; $interface_db{"\U$thorn ARRANGEMENT\E"} = "$arrangement"; @@ -645,6 +645,68 @@ sub parse_interface_ccl { $block = "\U$1\E"; } + elsif ($line =~ m/^\s*PROVIDES\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*WITH\s*(.+)\s*$/i) + { + $funcname = $1; + $provided_by = $2; + + if($provided_by =~ m/(.*)\s*LANGUAGE\s*(.+)/i) + { + $provided_by = $1; + $provided_by_language = $2; + } + else + { + $provided_by_language = "Fortran"; + } + + $interface_db{"\U$thorn PROVIDES FUNCTION\E"} .= "$funcname "; + $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname WITH"} .= "$provided_by "; + $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname LANG"} .= "$provided_by_language "; + + } + elsif ($line =~ m/^\s*USES\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*$/i) + { + $funcname = $1; + $interface_db{"\U$thorn USES FUNCTION\E"} .= "$funcname "; + } + elsif ($line =~ m/^\s*([a-zA-Z_0-9]+)\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*(.*)\s*$/i) + { + $rettype = $1; + $funcname = $2; + $rest = $3; + if($rest =~ m/(.*)\s*PROVIDED-BY\s*(.+)/i) + { + $funcargs = $1; + $provided_by = $2; + + if($provided_by =~ m/(.*)\s*LANGUAGE\s*(.+)/i) + { + $provided_by = $1; + $provided_by_language = $2; + } + else + { + $provided_by_language = "Fortran"; + } + } + else + { + $funcargs = $rest; + $provided_by = ""; + } + + $interface_db{"\U$thorn FUNCTIONS\E"} .= "$funcname "; + $interface_db{"\U$thorn FUNCTION\E $funcname ARGS"} .= "$funcargs"; + $interface_db{"\U$thorn FUNCTION\E $funcname RET"} .= "$rettype"; + + if($provided_by ne "") + { + $interface_db{"\U$thorn PROVIDES FUNCTION\E"} .= "$funcname"; + $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname WITH"} .= "$provided_by"; + $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname LANG"} .= "$provided_by_language"; + } + } elsif ($line =~ m/^\s*(CCTK_)?(INT|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|CHAR|COMPLEX)\s*([a-zA-Z]+[a-zA-Z_0-9]*)\s*(.*)\s*$/i) { $current_group = "$3"; @@ -849,68 +911,6 @@ sub parse_interface_ccl # print "Adding $header to $4\n"; $interface_db{"\U$thorn ADD HEADER $header TO\E"} = $4; } - elsif ($line =~ m/^\s*PROVIDE\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*WITH\s*(.+)\s*$/i) - { - $funcname = $1; - $provided_by = $2; - - if($provided_by =~ m/(.*)\s*LANGUAGE\s*(.+)/i) - { - $provided_by = $1; - $provided_by_language = $2; - } - else - { - $provided_by_language = "Fortran"; - } - - $interface_db{"\U$thorn PROVIDES FUNCTION\E"} .= "$funcname"; - $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname WITH"} .= "$provided_by"; - $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname LANG"} .= "$provided_by_language"; - - } - elsif ($line =~ m/^\s*USES\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*$/i) - { - $funcname = $1; - $interface_db{"\U$thorn USES FUNCTION\E"} .= "$funcname"; - } - elsif ($line =~ m/^\s*([a-zA-Z_0-9]+)\s*FUNCTION\s*([a-zA-Z_0-9]+)\s*(.*)\s*$/i) - { - $rettype = $1; - $funcname = $2; - $rest = $3; - if($rest =~ m/(.*)\s*PROVIDED-BY\s*(.+)/i) - { - $funcargs = $1; - $provided_by = $2; - - if($provided_by =~ m/(.*)\s*LANGUAGE\s*(.+)/i) - { - $provided_by = $1; - $provided_by_language = $2; - } - else - { - $provided_by_language = "Fortran"; - } - } - else - { - $funcargs = $rest; - $provided_by = ""; - } - - $interface_db{"\U$thorn FUNCTIONS\E"} .= "$funcname"; - $interface_db{"\U$thorn FUNCTION\E $funcname ARGS"} .= "$funcargs"; - $interface_db{"\U$thorn FUNCTION\E $funcname RET"} .= "$rettype"; - - if($provided_by ne "") - { - $interface_db{"\U$thorn PROVIDES FUNCTION\E"} .= "$funcname"; - $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname WITH"} .= "$provided_by"; - $interface_db{"\U$thorn PROVIDES FUNCTION\E $funcname LANG"} .= "$provided_by_language"; - } - } else { if($line =~ m:\{:) diff --git a/src/include/cctk.h b/src/include/cctk.h index abda254f..9d119ee2 100644 --- a/src/include/cctk.h +++ b/src/include/cctk.h @@ -86,6 +86,7 @@ #include "cctk_Complex.h" #include "cctk_File.h" #include "cctk_Flesh.h" +#include "cctk_FunctionAliases.h" #include "cctk_GHExtensions.h" #include "cctk_Groups.h" #include "cctk_GroupsOnGH.h" diff --git a/src/main/InitialiseCactus.c b/src/main/InitialiseCactus.c index eff9d19a..efad6a52 100644 --- a/src/main/InitialiseCactus.c +++ b/src/main/InitialiseCactus.c @@ -117,6 +117,8 @@ int CCTKi_InitialiseCactus(int *argc, char ***argv, tFleshConfig *ConfigData) CCTKi_BindingsVariablesInitialise(); + CCTKBindings_RegisterThornFunctions(); + CCTKi_InitialiseScheduler(ConfigData); CCTKi_CallStartupFunctions(ConfigData); diff --git a/src/main/Subsystems.c b/src/main/Subsystems.c index 691b5620..4400dc01 100644 --- a/src/main/Subsystems.c +++ b/src/main/Subsystems.c @@ -60,10 +60,10 @@ int CCTKi_InitialiseSubsystemDefaults(void) CCTKi_SetupMainFunctions(); CCTKi_SetupCommFunctions(); CCTKi_SetupIOFunctions(); - + CCTKBindings_SetupThornFunctions(); CCTKi_BindingsImplementationsInitialise(); CCTKi_BindingsParametersInitialise(); - + return 0; } |