From 74d7c47ce7558cd8b0276aa18a8340c0aa633930 Mon Sep 17 00:00:00 2001 From: Ed Hartnett Date: Fri, 17 May 2019 10:16:55 -0600 Subject: [PATCH] added genf90.pl --- scripts/genf90.pl | 387 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 387 insertions(+) create mode 100755 scripts/genf90.pl diff --git a/scripts/genf90.pl b/scripts/genf90.pl new file mode 100755 index 00000000000..ec7d0dba28b --- /dev/null +++ b/scripts/genf90.pl @@ -0,0 +1,387 @@ +#!/usr/bin/env perl +use strict; +my $outfile; +# Beginning with F90, Fortran has strict typing of variables based on "TKR" +# (type, kind, and rank). In many cases we want to write subroutines that +# provide the same functionality for different variable types and ranks. In +# order to do this without cut-and-paste duplication of code, we create a +# template file with the extension ".F90.in", which can be parsed by this script +# to generate F90 code for all of the desired specific types. +# +# Keywords are delimited by curly brackets: {} +# +# {TYPE} and {DIMS} are used to generate the specific subroutine names from the +# generic template +# {TYPE} : Variable type name; implemented types are character, 4 or 8 byte real, +# and 4 or 8 byte integer. +# allowed values: text, real, double, int, long, logical +# default values: text, real, double, int +# {VTYPE} : Used to generate variable declarations to match the specific type. +# if {TYPE}=double then {VTYPE} is "real(r8)" +# {ITYPE}, {ITYPENAME} : Used to generate CPP statements for the specific type. +# {MPITYPE} : Used to generate MPI types corresponding to the specific type. +# +# {DIMS} : Rank of arrays, "0" for scalar. +# allowed values: 0-7 +# default values : 0-5 +# {DIMSTR} : Generates the parenthesis and colons used for a variable +# declaration of {DIMS} dimensions. +# if {DIMS}=3 then {DIMSTR} is (:,:,:) +# {REPEAT} : Repeats an expression for each number from 1 to {DIMS}, with each +# iteration separated by commas. +# {REPEAT: foo(#, bar)} +# expands to this: +# foo(1, bar), foo(2, bar), foo(3, bar), ... + +# defaults +my @types = qw(text real double int); +my $vtype = {'text' => 'character(len=*)', + 'real' => 'real(r4)', + 'double' => 'real(r8)', + 'int' => 'integer(i4)', + 'long' => 'integer(i8)', + 'logical' => 'logical' }; +my $itype = {'text' => 100, + 'real' => 101, + 'double' => 102, + 'int' => 103, + 'long' => 104, + 'logical' => 105}; +my $itypename = {'text' => 'TYPETEXT', + 'real' => 'TYPEREAL', + 'double' => 'TYPEDOUBLE', + 'int' => 'TYPEINT', + 'long' => 'TYPELONG', + 'logical' => 'TYPELOGICAL'}; +my $mpitype = {'text' => 'MPI_CHARACTER', + 'real' => 'MPI_REAL4', + 'double' => 'MPI_REAL8', + 'int' => 'MPI_INTEGER'}; +# Netcdf C datatypes +my $nctype = {'text' => 'text', + 'real' => 'float', + 'double' => 'double', + 'int' => 'int'}; +# C interoperability types +my $ctype = {'text' => 'character(C_CHAR)', + 'real' => 'real(C_FLOAT)', + 'double' => 'real(C_DOUBLE)', + 'int' => 'integer(C_INT)'}; + + + +my @dims =(0..5); + +my $write_dtypes = "no"; +# begin + +foreach(@ARGV){ + my $infile = $_; + usage() unless($infile =~ /(.*.F90).in/); + $outfile = $1; + open(F,"$infile") || die "$0 Could not open $infile to read"; + my @parsetext; + my $cnt=0; + foreach(){ + $cnt++; + if(/^\s*contains/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^\s*interface/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^[^!]*subroutine/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^[^!]*function/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + + push(@parsetext,$_); + } + + close(F); + + my $end; + my $contains=0; + my $in_type_block=0; + my @unit; + my $unitcnt=0; + my $date = localtime(); + my $preamble = +"!=================================================== +! DO NOT EDIT THIS FILE, it was generated using $0 +! Any changes you make to this file may be lost +!===================================================\n"; + my @output ; + push(@output,$preamble); + + my $line; + my $dimmodifier; + my $typemodifier; + my $itypeflag; + my $block; + my $block_type; + my $cppunit; + foreach $line (@parsetext){ +# skip parser comments + next if($line =~ /\s*!pl/); + + $itypeflag=1 if($line =~ /{ITYPE}/); + $itypeflag=1 if($line =~ /TYPETEXT/); + $itypeflag=1 if($line =~ /TYPEREAL/); + $itypeflag=1 if($line =~ /TYPEDOUBLE/); + $itypeflag=1 if($line =~ /TYPEINT/); + $itypeflag=1 if($line =~ /TYPELONG/); + + + if($contains==0){ + if($line=~/\s*!\s*DIMS\s+[\d,]+!*/){ + $dimmodifier=$line; + next; + } + if($line=~/\s*!\s*TYPE\s+[^!]+!*$/){ + $typemodifier=$line; + next; + } + if ((defined $typemodifier or defined $dimmodifier) + and not defined $block and $line=~/^\s*#[^{]*$/) { + push(@output, $line); + next; + } + # Figure out the bounds of a type statement. + # Type blocks start with "type," "type foo" or "type::" but not + # "type(". + $in_type_block=1 if($line=~/^\s*type\s*[,:[:alpha:]]/i); + $in_type_block=0 if($line=~/^\s*end\s*type/i); + if(not defined $block) { + if ($line=~/^\s*type[^[:alnum:]_].*(\{TYPE\}|\{DIMS\})/i or + $line=~/^[^!]*(function|subroutine).*(\{TYPE\}|\{DIMS\})/i) { + $block=$line; + next; + } + if ($line=~/^\s*interface.*(\{TYPE\}|\{DIMS\})/i) { + $block_type="interface"; + $block=$line; + next; + } + } + if(not defined $block_type and + ($line=~/^\s*end\s+type\s+.*(\{TYPE\}|\{DIMS\})/i or + $line=~/^\s*end\s+(function|subroutine)\s+.*(\{TYPE\}|\{DIMS\})/i)){ + + $line = $block.$line; + undef $block; + } + if ($line=~/^\s*end\s*interface/i and + defined $block) { + $line = $block.$line; + undef $block; + undef $block_type; + } + if(defined $block){ + $block = $block.$line; + next; + } + if(defined $dimmodifier){ + $line = $dimmodifier.$line; + undef $dimmodifier; + } + if(defined $typemodifier){ + $line = $typemodifier.$line; + undef $typemodifier; + } + + push(@output, buildout($line)); + if(($line =~ /^\s*contains\s*!*/i && ! $in_type_block) or + ($line =~ /^\s*!\s*Not a module/i)){ + $contains=1; + next; + } + } + if($line=~/^\s*end module\s*/){ + $end = $line; + last; + } + + if($contains==1){ + # first parse into functions or subroutines + if($cppunit || !(defined($unit[$unitcnt]))){ + # Make cpp lines and blanks between routines units. + if($line =~ /^\s*\#(?!\s[[:digit:]]+)/ || $line =~/^\s*$/ || $line=~/^\s*!(?!\s*(TYPE|DIMS))/){ + push(@{$unit[$unitcnt]},$line); + $cppunit=1; + next; + } else { + $cppunit=0; + $unitcnt++; + } + } + + + push(@{$unit[$unitcnt]},$line); + if ($line=~/^\s*interface/i) { + $block_type="interface"; + $block=$line; + } + if ($line=~/^\s*end\s*interface/i) { + undef $block_type; + undef $block; + } + unless(defined $block){ + if($line =~ /\s*end function/i or $line =~ /\s*end subroutine/i){ + $unitcnt++; + } + } + } + } + my $i; + + + for($i=0;$i<$unitcnt;$i++){ + if(defined($unit[$i])){ + my $func = join('',@{$unit[$i]}); + push(@output, buildout($func)); + } + } + push(@output,@{$unit[$#unit]}) if($unitcnt==$#unit); + push(@output, $end); + if($itypeflag==1){ + my $str; + $str.="#include \"dtypes.h\"\n"; + $write_dtypes = "yes"; + print $str; + } + print @output; + writedtypes() if(!(-e "dtypes.h") && $write_dtypes == "yes"); + + +} + + +sub usage{ + die("$0 Expected input filename of the form .*.F90.in"); +} + +sub build_repeatstr{ + my($dims) = @_; + # Create regex to repeat expression DIMS times. + my $repeatstr; + for(my $i=1;$i<=$dims;$i++){ + $repeatstr .="\$\{1\}$i\$\{2\},&\n"; + } + if(defined $repeatstr){ + $repeatstr="\"$repeatstr"; + chop $repeatstr; + chop $repeatstr; + chop $repeatstr; + $repeatstr.="\""; + }else{ + $repeatstr=''; + } +} + +sub writedtypes{ + open(F,">dtypes.h"); + print F +"#define TYPETEXT 100 +#define TYPEREAL 101 +#define TYPEDOUBLE 102 +#define TYPEINT 103 +#define TYPELONG 104 +#define TYPELOGICAL 105 +"; + close(F); +} + +sub buildout{ + my ($func) = @_; + + my $outstr; + my(@ldims, @ltypes); + + if($func=~/\s*!\s*DIMS\s+([\d,]+)\s*/){ + @ldims = split(/,/,$1); + }else{ + @ldims = @dims; + } + if($func=~/\s*!\s*TYPE\s+([^!\s]+)\s*/){ + @ltypes = split(/,/,$1); +# print ">$func<>@ltypes<\n"; + }else{ + @ltypes = @types; + } + + + if(($func =~ /{TYPE}/ && $func =~ /{DIMS}/) ){ + my ($type, $dims); + foreach $type (@ltypes){ + foreach $dims (@ldims){ + my $dimstr; + for(my $i=1;$i<=$dims;$i++){ + $dimstr .=':,'; + } + if(defined $dimstr){ + $dimstr="($dimstr"; + chop $dimstr; + $dimstr.=')'; + }else{ + $dimstr=''; + } + + my $repeatstr = build_repeatstr($dims); + + my $str = $func; + $str =~ s/{TYPE}/$type/g; + $str =~ s/{VTYPE}/$vtype->{$type}/g; + $str =~ s/{ITYPE}/$itype->{$type}/g; + $str =~ s/{MPITYPE}/$mpitype->{$type}/g; + $str =~ s/{NCTYPE}/$nctype->{$type}/g; + $str =~ s/{CTYPE}/$ctype->{$type}/g; + $str =~ s/{DIMS}/$dims/g; + $str =~ s/{DIMSTR}/$dimstr/g; + $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; + $outstr .= $str; + } + } + }elsif($func =~ /{DIMS}/){ + my $dims; + foreach $dims (@ldims){ + my $dimstr; + for(my $i=1;$i<=$dims;$i++){ + $dimstr .=':,'; + } + if(defined $dimstr){ + $dimstr="($dimstr"; + chop $dimstr; + $dimstr.=')'; + }else{ + $dimstr=''; + } + + my $repeatstr = build_repeatstr($dims); + + my $str = $func; + $str =~ s/{DIMS}/$dims/g; + $str =~ s/{DIMSTR}/$dimstr/g; + $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; + $outstr .= $str; + } + }elsif($func =~ /{TYPE}/){ + my ($type); + foreach $type (@ltypes){ + my $str = $func; + $str =~ s/{TYPE}/$type/g; + $str =~ s/{VTYPE}/$vtype->{$type}/g; + $str =~ s/{ITYPE}/$itype->{$type}/g; + $str =~ s/{MPITYPE}/$mpitype->{$type}/g; + $str =~ s/{NCTYPE}/$nctype->{$type}/g; + $str =~ s/{CTYPE}/$ctype->{$type}/g; + $outstr.=$str; + } + }else{ + $outstr=$func; + } + + return $outstr; +}