#!/usr/bin/perl 

#
# "Linkage verifier" for fortran - checks the *number* of arguments
# matches between call and subroutine (functions not checked)
#
# Use:
#   lv.pl filename > lv.out
#
# Bugs:
#   subs with 0 args are counted as having one!
#
# Author:
#   W. M. Connolley, Britsh Antarctic Survey, March 1998
#

$FUSSY=0;
$FANCY=1;
$Errors=0;
$NOISY=1;

eval "\$$1=\$2" while $ARGV[0] =~ /^(\w+)=(.*)/ && shift;

#
# Read in the whole file
#
$I=-1;
while ($_=<>) {
# Extract first 72 characters...
  $_=substr($_,0,72);
# Throw this line away if its a comment
  next if (/(^[C\!]|^\s*$)/i);
# Cray F90 at least seems to recognise "*" in first position as comment...
  next if (/^[*]/);
# Throw away bits that *are* comment
  s/\s*\!.*//;
# If its a continuation line, add it to our current line; otherwise add it as a new line.
  if (substr($_,5,1) ne " " and substr($_,0,1) ne "\t") { $LINES[$I].=substr($_,6,72-6) } else { $I++; $LINES[$I]=$_ } 
};

#
# Now loop through the lines of the file, searching for variable declarations, but 
# also looking for "SUBROUTINE" so we know where the declarations are
#
print "[---First pass---] ";
for ($J=0; $J<=$I; $J++) {

#
# Look for variable declarations
#
  if ($LINES[$J] =~ /^\s+(INTEGER|REAL|LOGICAL|CHARACTER\s*\(\n*\))\b/i) {
# Save the variable type
    $TYPE=uc substr($1,0,1);
# Remove () pairs
    $MORE=$'; $MORE=~s/\s*//g;
    $MORE1=$MORE;
    while ($MORE =~ s/(\([^,)]*),/$1|/g ) {};
    while ($MORE1 =~ s/\([^\(\)]*?\)//) {};
# Find variables
    @VARS=split(/,/,$MORE);
    @VARS1=split(/,/,$MORE1);
# Die if we're not in a subroutine
    if (!$NAME) { die "Variable declaration but no SUBROUTINE declared\n" };
# Record vars
    for (@VARS) { $VARS{$NAME.",".$_}=$TYPE; };
    for (@VARS1) { $VARS1{$NAME.",".$_}=$TYPE; };
    for ($i=0; $i< scalar(@VARS); $i++) { ${"cf_".$NAME}{$VARS1[$i]} = $VARS[$i]."-goat" };
  };

#
# Look for match to "SUBROUTINE"
#
  if ($LINES[$J] =~ /^\s+(SUBROUTINE)\s*(\w+)\s*\(/i) {
# Save the name in.... $NAME
    $NAME=uc $2;
    $VARS{$NAME.",".".TRUE."}="L"; $VARS{$NAME.",".".FALSE."}="L"; $VARS{$NAME.","."CHARACTER"}="C";
  };

};

# 
# Output vars
#
#for $k (sort keys %VARS) { print "$k $VARS{$k}\n" };
#for $k (sort keys %VARS1) { print "$k $VARS1{$k}\n" };

#
# Now loop again, now we have the variables declared, and look for "CALL" or "SUBROUTINE"
#
print "---Second pass--\n";
for ($J=0; $J<=$I; $J++) {

#
# Look for match to "CALL" or "SUBROUTINE"
#
  if ($LINES[$J] =~ /^\s+(CALL|SUBROUTINE)\s*(\w+)\s*\(/i) {
# Save whether it was a CALL or SUBROUTINE in $CS
    $CS=uc $1;
# Save the name in $NAMEs (if its "SUBROUTINE") or in NAMEc (for a "CALL")
# and anyway in $NAME
    if ($CS eq "CALL") { $NAMEc=uc $2 } else { $NAMEs=uc $2};
    $NAME=uc $2;
# $MORE now contains everything-on-the-line after the pattern-match
    $MORE=$';
# Remove (...) pairs and what they contain, so as to remove array references
# or function calls.
    while ($MORE =~ s/\([^\(\)]*?\)//) {};
# Swap '...' for "CHARACTER"
    while ($MORE =~ s/\s*'[^']*?'\s*/CHARACTER/) {};
# Now we can count the number of ","'s on the line...
    $COUNT=($MORE=~s/\,/\,/g);
# And add one, to get the number of arguments
    $COUNT++;
# Find the variables
    $MORE=~s/\).*//;
    @VARS=grep { s/\s*//g } split(/,/,$MORE);
# Diag
    $THISSIG=join(",",map { $VARS1{$NAMEs.",".$_} } @VARS);
#    print "Routine $NAMEc args are: $THISSIG\n"; 
    $THISSIG=~s/,\s*$/,\./; $THISSIG=~s/^,/\.,/; while ($THISSIG=~s/,,/,\.,/g) {}; $THISSIG=~s/,//g;
#    print "Routine $NAMEc args are: ",join(",",@VARS),"\n";
#    print "Routine $NAMEc args are: $THISSIG\n"; 
    if (! defined $SIGS{$NAME}) { $SIGS{$NAME}=$THISSIG; $SIGSv{$NAME}=join(",",@VARS) };

#
# Now look up "NAME" to see if we've met it before
#
    $ThisErr=0;
    if (defined $KNOWN{$NAME}) {
# If yes, check that the count then is the count now
      $TEXT = "";
      if ($KNOWN{$NAME} == $COUNT) {
# If counts match, we're happy
        if ($NOISY > 0) {
          $TEXT=" (seen before: OK: $KNOWN{$NAME} / $COUNT)";
          if ($NOISY > 1 and $FANCY) {
            @VARS2=split(/,/,$SIGSv{$NAME});
            $l=$KNOWN{$NAME}; if ($l < $COUNT) { $l = $COUNT };
            for $I (0..$l-1) {
              $TEXT.= ">  $I, $VARS2[$I],  <$VARS[$I]>\n"
            }
          }
        }
      } else {
# If not, complain
        $ThisErr=1;
        $TEXT=" (seen before: *** count then was $KNOWN{$NAME} ***)";
        if ($FANCY) {
          @VARS2=split(/,/,$SIGSv{$NAME});
          $l=$KNOWN{$NAME}; if ($l < $COUNT) { $l = $COUNT };
          for $I (0..$l-1) {
          #  $TEXT.= "  $I, $VARS2[$I],  (",${"cf_".$NAME}{$VARS[$I]},")\n"
          }
        };
        $Errors++;
      };
# Check argument signature
      $S1=$SIGS{$NAME}; $S2=$THISSIG;
      $L=length($S1); $l=length($S2); if ($l < $L) { $L=$l; $l=length($S1) };
# If we're not fussy, allow "don't knows" to combine
      if (!$FUSSY) { for ($K=0; $K<$L; $K++) { if (substr($S2,$K,1) eq ".") { substr($S1,$K,1)="." } } };
      if ($S2=~/^$S1$/) {
        if ($NOISY > 0) { $TEXT.="\n   Signatures match ($S1)" }
      } else {
        $ThisErr=1;
        $TEXT.="\n   ***$NAME Signatures don't match: $SIGS{$NAME} and $THISSIG";
        if ($FANCY) {
          $TEXT.="\n";
          @VARS1=split(/,/,$SIGSv{$NAME});
          for $I (0..$l-1) {
            $TEXT.= "  $I, <$VARS1[$I]>,  <$VARS[$I]>\n" 
          };
          $TEXT=~s/<([^>]+)>/$1/g;
          $TEXT=~s/<>/<missing>/g;
        };
        $Errors++;
      };

    } else {
# If this is new, then record it as such
      $KNOWN{$NAME}=$COUNT;
      $TEXT=" (a new one)"
    };
 
# Report what we've found
    if ($ThisErr or $NOISY>0) { print "Found $CS $NAME Which has $COUNT arguments ($THISSIG) $TEXT\n" };

  };
};

if ($Errors == 0) {
  print "\nAll appears to be OK\n"
} else {
  print "\nFound $Errors problem(s)\n"
};