#!/usr/local/bin/perl
# $Id: genfinterface.pl,v 1.1 1997/02/23 13:41:07 haupt Exp $
# Author Tomasz Haupt  (haupt@npac.syr.edu) 1996
#===========================================================================

#====================== GENERATE F90 INTERFACES =============
sub gen_iface {
local ($sub,$file)=@_;
local $ifile=$sub."_i.f90";
$ilist=$ilist.$sub."_i.o  ";
$ifile=">".$ifile;
if(!$file) {
    die "error 600: no file assosciated with $sub\n";
}
open (FILE,$file)   || die "cannot open $file  $! \n";

$amp = "&";
local $switch=2;
local $cont=0;
local $sline="";
local $cline="";
local $interface="module ".$sub."_i\n\n interface\n";

print "SUBROUTINE $sub FILE $file\n";

LOOP: while (($sline=<FILE>) && $switch>0) {

    $sline =~ tr/A-Z/a-z/;
    next LOOP if !($sline =~ /\S/);
    next LOOP if $sline =~ /^!/;

      if($cont) {
          $sline=$cline.$sline;
      }
      $truecont=0;
      if($sline =~ /$amp/) {
          $tline=$sline;
          $tline =~ s/\s*//g;
          if($tline =~ /$amp$/) {
	      $truecont=1;
	  }
      }
      if($truecont) {
          $cline = $sline;         
          $cline =~ s/$amp/A/g;
          $cont = 1;
      }
      else {
	  $cont = 0;
          if($sline =~ /subroutine\s*$sub\(./ && $switch == 2) {
	      $switch=3;
	  };
          if($sline =~ /end\s*interface/) {
	      $switch++;
	  }
	  elsif($sline =~ /interface/ && !($sline =~ /use/)) {
	      $switch--;
	  }
	  if($switch == 3) {    #the interface
	      if($sline =~ /subroutine/) {
		      $interface=$interface.$sline;
              }
	      elsif($sline =~ /integer|real|logical|use|type/) {
		      $interface=$interface.$sline;
	      }
              elsif(!($sline =~ /implicit|end\s*interface/))  {
		      $switch=0;
	      }
          } # $switch==3
      } # else (i.e. no continuations)
} #while

close (FILE);

open (IFACE,$ifile) || die "cannot open $ifile $! \n";
$interface =~ s/A/$amp/g;
$interface=$interface."\n end subroutine \n end interface \n\n end module\n";
print IFACE $interface;
close (IFILE);
} # sub gen_iface


# ----------------------------------------------------
# generate interfaces 
# ----------------------------------------------------

# build an associative array to keep the location of subroutines

# look at lines that matches "subroutine"
# catches:  exclude body of interface block
#               - module_interfaces, diffinterface exists!
#            skip lines that contain "end subroutine" 

#print "SCANNING *.f90 FILES IN THE CURRENT DIRECTORY\n";

$afile="appfiles";
open(INFH,$afile) || die "cannot open $afile $! \n";  

while(<INFH>) {
    $appfiles=$_;
}
close INFH;

$appfiles =~ s/\s//g;
$appfiles =~ s/\.o/\.f90 /g;
@files=split(" ",$appfiles);

     foreach $file (@files) {
	 print "processing file $file\n";
         @flines=();
         $switch=1;
	 open(FILE,$file) || die "cannot open $file $! \n";
LINE:        while ($aline=<FILE>) {
             next LINE if $aline =~ /^!/;
             $aline =~ tr/A-Z/a-z/;
             if($aline =~ /interface/) {
                if($aline =~ /end/ ) {
                   $switch=1;
                }
                elsif(!($aline =~ /use/)) {
                   $switch=0;
                }
             }
             elsif($switch && $aline =~ /subroutine/) {
		 if(!($aline =~ /end/)) {

                     $aline =~ s/^\s*//;    #leading blanks
                     $aline =~ /subroutine\s*(.*)\(./;
                     $subr_name=$1;
                     if(!$subr_name) {
                       $aline =~ /subroutine(.*)/;
                       $subr_name=$1;
                       print "Warning: no parameters to subroutine";
                       print  "$subr_name\n";
                       $subr_name || die "error parsing $aline\n";
                     } 


                     if($subr_list{$subr_name}) {
                        print "Error 101: subroutine $subr_name was previously
                                      found in file $subr_list{$subr_name}\n"; 
                        die "the current file is $file\n";
		     }
                     else {
                        $subr_list{$subr_name}=$file;
                    }
                 }
             }   
         }   
         close(FILE);
    }

print "\n subroutines to be found\n";

open(FH,"ifiles") || die "cannot open ifiles: $! \n";
while(<FH>){
    $ifce_list=$_;
}
close FH;

@subr_list=split(" ",$ifce_list);

foreach $subroutine (@subr_list) {

   &gen_iface($subroutine,$subr_list{$subroutine});
}

$finterfaces=">finterfaces";
open(FH,$finterfaces) || die "cannot open $finterfaces: $! \n";
print FH $ilist;
close FH;
