genf90.pl

#!/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(real double int short int64 text);
my $vtype = {'text' => 'character(len=*)',
	     'real' => 'real(r4)',
	     'double' => 'real(r8)',
	     'int'    => 'integer(i4)',
	     'short'  => 'integer(i2)',
	     'long'   => 'integer(i8)',
		 'int64'  => 'integer(i8)',
         'logical' => 'logical' };
my $itype = {'text' => 100,
	     'real' => 101,
	     'double' => 102,
	     'int'    => 103,
	     'long'   => 104,
             'logical' => 105,
             'short'  => 106,
			 'int64'  => 107};
my $itypename = {'text' => 'TYPETEXT',
	     'real' =>  'TYPEREAL',
	     'double' => 'TYPEDOUBLE',
	     'int'    => 'TYPEINT',
	     'short'  => 'TYPESHORT',
	     'long'   =>  'TYPELONG',
             'logical' => 'TYPELOGICAL'};
my $mpitype = {'text' => 'MPI_CHARACTER',
	       'real' => 'MPI_REAL4',
	       'short' => 'MPI_SHORT',
	       'double' => 'MPI_REAL8',
	       'int' => 'MPI_INTEGER',
		   'int64' => 'MPI_INTEGER64'};
# Netcdf C datatypes
my $nctype = {'text' => 'text',
	      'real' => 'float',
	      'short' => 'short',
	      'double' => 'double',
	      'int' => 'int',
		  'int64' => 'longlong'};
# C interoperability types
my $ctype = {'text' => 'character(C_CHAR)',
	     'real' => 'real(C_FLOAT)',
	     'double' => 'real(C_DOUBLE)',
	     'int' => 'integer(C_INT)',
         'short' => 'integer(C_SHORT)',
		 'int64' => 'integer(C_LONG_LONG)'};


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(<F>){
	$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;
}