#!/usr/bin/perl -w

use Getopt::Long;

our($progname) = "gag-get-interfaces.pl";

# Retrieve options
GetOptions("public:s",  \$public,
           "private:s", \$private,
           "obsolete:s",\$obsolete,
           "all:s",     \$all,
           "none:s",    \$none,
           "keyword=s", \$keyword,
           "short",     \$short,
           "mandatory", \$mandatory,
           "source:s",  \$source,
           "h",         \$help,
           "help",      \$help,
           "v",         \$version,
           "version",   \$version);

# Need help?
if (defined($help)) { &usage }

# Want version?
if (defined($version)) { &show_version }

# Which analysis?
%parsing = ();
$parsing{'keys'} = ();  # Dictionary of keywords + file handler associated to each
$parsing{'short'} = 0;
$parsing{'mandatory'} = 0;
if (defined($public))    { $parsing{'keys'}->{'public'}->{'file'}   = $public;    }
if (defined($private))   { $parsing{'keys'}->{'private'}->{'file'}  = $private;   }
if (defined($obsolete))  { $parsing{'keys'}->{'obsolete'}->{'file'} = $obsolete;  }
if (defined($all))       { $parsing{'all'}->{'file'}                = $all;       }
if (defined($none))      { $parsing{'none'}->{'file'}               = $none;      }
if (defined($keyword))   { $parsing{'keys'}->{$keyword}->{'file'}   = "";         }
if (defined($short))     { $parsing{'short'} = 1;                                 }
if (defined($mandatory)) { $parsing{'mandatory'} = 1;                             }
if (defined($source))    { $parsing{'source'}->{'file'} = $source;                }
if (keys %{$parsing{'keys'}} eq -1) { $parsing{'keys'}->{'public'}->{'file'} = ""; }  # Default

&open_all_fh;  # Open all File Handlers

&init_prepros;
$curr_prepro_before = "";

$curr_kind = 0;  # 0: out of block,
                 # 1: subroutine,
                 # 2: program,
                 # 3: function,
                 # 4: block data,
                 # 5: module
$buffer_full = "";
$buffer_source = "";
$protocont = 0;
$linecont = 0;
$prevcont = 0;
$interfacecont = 0;
$nomore = 0;
$curr_mandatory = 0;          # Is current procedure mandatory?
$curr_mandatory_reason = "";  # If current procedure is mandatory, reason
$log_it = -1;
$indent = "  ";
$curr_key = "";
$curr_name = "";
@modules = ();  # List of modules defined locally
%generics = ();  # Dictionary of generic interfaces

MAIN: while (defined($oneline = <STDIN>)) {

   if ($oneline =~ /^\s*$/) { next MAIN; }  # Ignore blank lines

   $prevcont = $linecont;                    # Previous line was continued
   $linecont = ($oneline =~ /&\s*(!.*)?$/);  # Current line is continued

   $p01 = ($oneline =~ /^#if/);    #
   $p02 = ($oneline =~ /^#else/);  # "else" or "elseif"
   $p03 = ($oneline =~ /^#end/);   # "end" or "endif"

   if ($prevcont and not $nomore and $p01|$p02|$p03) {
     print STDERR "$progname: mixing continuation line and preprocessing is not supported.\n";
     print STDERR $oneline;
     exit(1);
   }

   if (not $curr_kind) {

     if ($p01) {
       &open_prepros($oneline);
       $curr_prepro_before = $oneline;
     } elsif ($p02) {
       &append_prepros($oneline);
       $curr_prepro_before .= $oneline;
     } elsif ($p03) {
       &close_prepros($oneline);
       $curr_prepro_before = "";
     }

     $curr_genericname = "";

     if ($p01|$p02|$p03) {
       $buffer_source .= $oneline;
       next MAIN;
     }

     # Search for a new block:
     $c01 = ($oneline =~ /^\s*(recursive\s+)?subroutine\s+(\w+)/i);  # A new subroutine begins
     $c02 = ($oneline =~ /^\s*program\s+(\w+)/i);                    # A new program begins
     $c03 = ($oneline =~ /^\s*(\w+\s+)?function\s+(\w+)/i);          # A new function begins
     $c04 = ($oneline =~ /^\s*\w*\s*block\sdata\s+/i);               # A new block data begins
     $c05 = ($oneline =~ /^\s*module\s+(\w+)/i);                     # A new module begins

     if ($c03 and defined($1)) {
       if ($1 eq "end") { $c03 = 0; }
     }

     if ($c01|$c02|$c03|$c04|$c05) {
       # A new block begins
          if ($c01) { $curr_kind = 1; $curr_name = $2; }
       elsif ($c02) { $curr_kind = 2; $curr_name = $1; }
       elsif ($c03) { $curr_kind = 3; $curr_name = $2; }
       elsif ($c04) { $curr_kind = 4; $curr_name = ""; }
       elsif ($c05) { $curr_kind = 5; $curr_name = $1; }

       # Start a new buffer:
       if ($c01|$c03) { # Subroutine or function
         $curr_key = "";
         $log_it = 0;   # Log if and where required
         $parsing{'none'}->{'log_it'} = 1;
         if ($c03) {
           # Functions have mandatory interfaces
           $curr_mandatory = 1;
           $curr_mandatory_reason = "function";
         } else {
           $curr_mandatory = 0;
           $curr_mandatory_reason = "";
         }
       } else {
         $log_it = -1;  # Never log
       }
       $nomore = 0;

       # Store prototype (calling sequence) in current buffer
       if ($log_it ne -1) {
         @args = ();
         $protocont = $linecont;
         $buffer_full = $indent.$indent.$oneline;
         if (not $protocont) { find_args($buffer_full,\@args); }
       }

       if ($c05) {
         $oneline =~ /^\s*module\s+(\w+)/i;
         push(@modules,$1);
       }
     }

     $buffer_source .= $oneline;
     next MAIN;

   } else {

     # Search for end of current block.
          if ($curr_kind eq 1) {
       $end = ($oneline =~ /^\s*end\s+subroutine\s+$curr_name\b/i);
     } elsif ($curr_kind eq 2) {
       $end = ($oneline =~ /^\s*end\s+program\s+$curr_name\b/i);
     } elsif ($curr_kind eq 3) {
       $end = ($oneline =~ /^\s*end\s+function\s+$curr_name\b/i);
     } elsif ($curr_kind eq 4) {
       $end = ($oneline =~ /^\s*end\s+block\sdata\s+/i);
     } elsif ($curr_kind eq 5) {
       $end = ($oneline =~ /^\s*end\s+module\s+$curr_name\b/i);
     }

     if ($end) {
       # The current block ends
       $curr_kind = 0;
       $buffer_source .= $oneline;
       print  {$parsing{'source'}->{'fh'}}  $buffer_source;
       $buffer_source = "";

       if ($log_it eq -1) { next MAIN; }

       $buffer_full .= $indent.$indent.$oneline;

       # Flush buffer
       if ($curr_genericname eq "") {
          # Interface is standalone

          # Add this interface to the $curr_key members
          if ($log_it) {
            &write_buffers($parsing{'keys'}->{$curr_key},$curr_mandatory);
          }

          # Add this interface to the ALL members
          &write_buffers($parsing{'all'},$curr_mandatory);

          # Add this interface to the $curr_key members
          if ($parsing{'none'}->{'log_it'}) {
            &write_buffers($parsing{'none'},$curr_mandatory);
          }

       } else {
          # Interface is member of a generic interface
          if (not defined($generics{$curr_genericname})) {
            # Define a new buffer
            $generics{$curr_genericname}= "";
          }
          if ($curr_prepro_before eq "") {
            $generics{$curr_genericname} .= $buffer_full;
          } else {
            $generics{$curr_genericname} .= $curr_prepro_before;
            $generics{$curr_genericname} .= $buffer_full;
            $generics{$curr_genericname} .= "#endif\n";
          }

          # Add this generic interface to the $curr_key members
          if ($log_it) {
            $parsing{'keys'}->{$curr_key}->{'generics'}->{$curr_genericname} = 1;
          }

          # Add this generic interface to the ALL members
          $parsing{'all'}->{'generics'}->{$curr_genericname} = 1;

          # Add this generic interface to the NONE members
          if ($parsing{'none'}->{'log_it'}) {
            $parsing{'none'}->{'generics'}->{$curr_genericname} = 1;
          }

       }

       next MAIN;

     }

     # If we are in a module or block data, nothing to parse
     if ($curr_kind eq 4 or $curr_kind eq 5) {
       $buffer_source .= $oneline;
       next MAIN;
     }

     # Can it be the interface of an EXTERNAL procedure? e.g.
     # subroutine foo(sub)
     #   interface
     #     subroutine sub
     #     end subroutine sub
     #   end interface
     #   call sub()
     # end subroutine foo
     if ($interfacecont) {
       # We are currently in an interface block
       #
       if ($oneline =~ /^\s*end\s+interface\s*$/i) {
         $interfacecont = 0;
       } else {
         # Check if we declare one the dummy procedures
         $myc01 = ($oneline =~ /^\s*(recursive\s+)?subroutine\s+(\w+)/i);
         $myc03 = ($oneline =~ /^\s*(\w+\s+)?function\s+(\w+)/i);
         if ($myc01 or $myc03) {
           $proc_name = $2;
           $i = 0;
           while ($i <= $#args) {
             if ($args[$i] =~ /\b$proc_name\b/i) {
               splice(@args,$i,1);
             } else {
               $i++;
             }
           }
           if ($#args eq -1) {
             $nomore = 1;  # All dummies found: stop.
             &non_mandatory($curr_mandatory,$curr_mandatory_reason,$curr_name);
           }
         }
       }
       $buffer_full .= $indent.$indent.$oneline;
       $buffer_source .= $oneline;
       next MAIN;
     } elsif ($oneline =~ /^\s*interface\s*$/i) {
       # An interface begins
       $interfacecont = 1;
       $buffer_full .= $indent.$indent.$oneline;
       $buffer_source .= $oneline;
       next MAIN;
     }

     # Any comment:
     $c11 = ($oneline =~ /^\s*!/i);  # A comment line

     if ($curr_key ne "") {
       # Avoid random comments starting with "@" (the Sic command)
       $c12 = 0;

     } else {

       if ($oneline =~ /^\s*!\s*\@\s*(\w+)-generic\s+(\w+)/i) {
         # @ foo-generic bar
         $c12 = 1;
         $curr_key = $1;
         $curr_genericname = $2;
         $curr_mandatory = 1;
         $curr_mandatory_reason = "generic interface";
       } elsif ($oneline =~ /^\s*!\s*\@\s*(\w+)-mandatory/i) {
         # @ foo-mandatory
         $c12 = 1;
         $curr_key = $1;
         $curr_genericname = "";
         $curr_mandatory = 1;
         $curr_mandatory_reason = "keyword \"mandatory\"";
       } elsif ($oneline =~ /^\s*!\s*\@\s*(\w+)/i) {
         # @ foo
         $c12 = 1;
         $curr_key = $1;
         $curr_genericname = "";
       }
     }

     # Statements:
     $c21 = ($oneline =~ /^\s*(use)\s+/i);  # A use statement
     $c22 = ($oneline =~ /^\s*(integer|real|complex|logical|character|external|type|class)\W(.*)/i);
     $c23 = ($oneline =~ /^\s*(include)\s+/i);  # An include statement

   }

   # Analyse
   if ($protocont) {
      if ($log_it ne -1) {
        # Prototype is continued
        $buffer_full .= $indent.$indent.$oneline;
        $protocont = ($oneline =~ /&\s*(!.*)?$/); # Detect continuation line
        if ($protocont) {
          $buffer_source .= $oneline;
          next MAIN;
        }
        find_args($buffer_full,\@args);
      }

   } elsif ($nomore) {
      $buffer_source .= $oneline;
      next MAIN;

   } elsif ($c12) { # "! @ foo" comment
      if ($log_it ne -1 and defined($parsing{'keys'}->{$curr_key})) {
        $log_it = 1;
      }
      $parsing{'none'}->{'log_it'} = 0;
      $buffer_full .= $indent.$indent.$oneline;

   } elsif ($c21) {  # Use / Include
      if ($oneline =~ /^\s*use\s+(\w+)/i) {
        # A "use" statement
        if ($1 =~ /_interfaces/i) {
          $buffer_source .= $oneline;
          next MAIN;  # A "use *_interfaces" statement, skip it in interfaces
        }
        foreach $name (@modules) {
          if ($name eq $1) {
            $buffer_source .= $oneline;
            next MAIN;  # A local module is used, skip it in interfaces
          }
        }
      }
      $buffer_full .= $indent.$indent.$oneline;

   } elsif ($c11) {  # A comment before the last dummy declaration
      $buffer_full .= $indent.$indent.$oneline;

   } elsif ($#args eq -1) {  # Not a begin of block, not a comment, not a use.
                             # Remains: includes, declarations and computations
      $nomore = 1;           # Subroutine has no dummies: stop.
      &non_mandatory($curr_mandatory,$curr_mandatory_reason,$curr_name);

   } elsif ($c23) {  # An include before the last dummy declaration. We keep
                     # it because some dummies requires parameters from include
                     # files...
      $buffer_full .= $indent.$indent.$oneline;

   } elsif ($c22) {          # Declarations: search for dummies
      $buffer_full .= $indent.$indent.$oneline;
      # Dummies?
      $locline = $oneline;
      $locline =~ s/\s*!.*// ;   # Suppress comments
      $locline =~ s/^(.*)::// ;  # Suppress all what is before "::"
      if (defined($1)) {
        $before = $1;
      } else {
        $before = $locline;
      }
      $i = 0;
      while ($i <= $#args) {
        $arg = $args[$i];
        if ($locline =~ /\b$arg\b/i) {
          splice(@args,$i,1);
          if ($locline =~ /\b$arg\s*\(\s*:/i) {
            # Found a dummy array with assumed-shape: Fortran requires
            # an explicit interface for this procedure
            $curr_mandatory = 1;
            $curr_mandatory_reason = "assumed-shape dummy array"
          } elsif ($before =~ /\bdimension\s*\(\s*:/i) {
            # Found a dummy argument with the DIMENSION(:) attribute: Fortran
            # requires an explicit interface for this procedure
            $curr_mandatory = 1;
            $curr_mandatory_reason = "assumed-shape dummy array";
          } elsif ($before =~ /\bpointer\b/i) {
            # Found a dummy argument with the POINTER attribute: Fortran
            # requires an explicit interface for this procedure
            $curr_mandatory = 1;
            $curr_mandatory_reason = "dummy pointer";
          } elsif ($before =~ /\btarget\b/i) {
            # Found a dummy argument with the TARGET attribute: Fortran
            # requires an explicit interface for this procedure
            $curr_mandatory = 1;
            $curr_mandatory_reason = "dummy target";
          } elsif ($before =~ /\boptional\b/i) {
            # Found a dummy argument with the OPTIONAL attribute: Fortran
            # requires an explicit interface for this procedure
            $curr_mandatory = 1;
            $curr_mandatory_reason = "optional dummy";
          }
        } else {
          $i++;
        }
      }
      if ($#args eq -1) {
        $nomore = 1;  # All dummies found: stop.
        &non_mandatory($curr_mandatory,$curr_mandatory_reason,$curr_name);
      }

   } elsif ($prevcont) {
      # Could not find what this line is, but it is a continuation line. Skip.
      $buffer_source .= $oneline;
      next MAIN;

   } elsif ($p01|$p02|$p03) {
      print STDERR "$progname: preprocessing in interfaces is not supported.\n";
      print STDERR $oneline;
      exit(1);

   } else {
      # Something else: throw away incoming lines
      $nomore = 1;
      &non_mandatory($curr_mandatory,$curr_mandatory_reason,$curr_name);

   } # EndIf $oneline match

   $buffer_source .= $oneline;

} # EndWhile

# Flush pending source buffer
print  {$parsing{'source'}->{'fh'}}  $buffer_source;

# Flush generic interfaces buffer. Sort alphabetically to avoid random output
# at each run.
&write_generics;

# Close all the file handlers
&close_all_fh;

if ($curr_kind != 0) { print STDERR "Warning: found no end for block $curr_name\n"; }

#=======================================================================
sub usage {

    print STDERR "  This utility reads Fortran-formatted sources from standard input\n";
    print STDERR "(STDIN) and prints APIs of its routines to the given file (or standard\n";
    print STDERR "output (STDOUT) if no file is provided), depending on the keyword present\n";
    print STDERR "in their header comments. Several options can be combined.\n";
    print STDERR "\n";
    print STDERR "  Usage:\n";
    print STDERR "     $progname                      < in.f90  Print APIs with \@public keyword\n";
    print STDERR "     $progname --public[=pubfile]   < in.f90  Print APIs with \@public keyword\n";
    print STDERR "     $progname --private[=privfile] < in.f90  Print APIs with \@private keyword\n";
    print STDERR "     $progname --obsolete[=obsfile] < in.f90  Print APIs with \@obsolete keyword\n";
    print STDERR "     $progname --all[=allfile]      < in.f90  Print all APIs (no keyword required)\n";
    print STDERR "     $progname --none[=nonefile]    < in.f90  Print APIs when no keyword is present\n";
    print STDERR "     $progname --keyword=foo        < in.f90  Print APIs with \@foo keyword\n";
    print STDERR "     $progname --public=pubfile --private=privfile --none < in.f90  Print APIs\n";
    print STDERR "               with \@public and \@private keyword to the given files, and the\n";
    print STDERR "               remaining ones (no keyword) to STDOUT.\n";
    print STDERR "     $progname --short              < in.f90  Build a shortened version of the\n";
    print STDERR "               interfaces in a file named with the '.short' extension\n";
    print STDERR "\n";
    print STDERR "\n";
    print STDERR "     $progname -h         Displays this help\n";
    print STDERR "     $progname --help     Displays this help\n";
    print STDERR "     $progname -v         Shows version number\n";
    print STDERR "     $progname --version  Shows version number\n";
    print STDERR "\n";

    exit;

}
#=======================================================================
sub show_version {

    my($version) = '$Revision: 1.4 $';

    print STDERR "$progname ".substr($version,1,length($version)-2);
    print STDERR "\n";

    exit;

}
#=======================================================================
sub find_args {

   my($line,$argsptr) = @_;
   my($i,$declline);

#    print STDERR "\n---\nEntering find_args\n";
#    print STDERR "$line";

   @{$argsptr} = ();

   # Search for dummies
   $declline = $line;  # Just a local copy to detect dummies
   $declline =~ s/\s*!.*\n/\n/g ;     # Suppress comments in prototype
   # print STDERR $declline;

   # Patch for functions
   if ($declline =~ /^\s*(\w*)\s*function\s+(\w+)/i) {
      $fdeclared = ($1 ne "");
      $fname = $2;
      if ($declline =~ /(.+)\s+result\s*\(\s*(\w+)\s*\)$/i) {
        # Handle RESULT field as a dummy
        push(@{$argsptr},$2);
        $declline = $1;
      } elsif (not $fdeclared) {
        # Function type is not declared: handle function name as a dummy
        push(@{$argsptr},$fname);
      }
   }

   # Split dummies
   if ($declline =~ /\(\s*(.*)\s*\)/s) {
      push(@{$argsptr},split(/[\s\n&]*,[\s\n&]*/s,$1));
   }

   # Remove '*' dummy
   for ($i=0; $i<=$#{$argsptr}; $i++) {
      if ($argsptr->[$i] eq "*") {
         splice(@{$argsptr},$i,1);
      }
   }

#    for ($i=0; $i<=$#{$argsptr}; $i++) {
#      print STDERR "'".$argsptr->[$i]."' ";
#    }
#    print STDERR "\n";

}

#========================================================================
sub open_all_fh {

    # For all requested keywords
    for my $key ( keys %{$parsing{'keys'}} ) {
      $parsing{'keys'}->{$key}->{'fhf'} = open_fh($parsing{'keys'}->{$key}->{'file'});
      if ((not $parsing{'short'}) or $parsing{'keys'}->{$key}->{'file'} eq "") {
        $parsing{'keys'}->{$key}->{'fhs'} = open_fh("/dev/null");
      } else {
        $parsing{'keys'}->{$key}->{'fhs'} = open_fh($parsing{'keys'}->{$key}->{'file'}.".short");
      }
    }

    # For the ALL mode:
    if (defined($parsing{'all'}->{'file'})) {
      $parsing{'all'}->{'fhf'} = open_fh($parsing{'all'}->{'file'});
      if ((not $parsing{'short'}) or $parsing{'all'}->{'file'} eq "") {
        $parsing{'all'}->{'fhs'} = open_fh("/dev/null");
      } else {
        $parsing{'all'}->{'fhs'} = open_fh($parsing{'all'}->{'file'}.".short");
      }
    } else {
      $parsing{'all'}->{'fhf'} = open_fh("/dev/null");
      $parsing{'all'}->{'fhs'} = open_fh("/dev/null");
    }

    # For the NONE mode:
    if (defined($parsing{'none'}->{'file'})) {
      $parsing{'none'}->{'fhf'} = open_fh($parsing{'none'}->{'file'});
      if ((not $parsing{'short'}) or $parsing{'none'}->{'file'} eq "") {
        $parsing{'none'}->{'fhs'} = open_fh("/dev/null");
      } else {
        $parsing{'none'}->{'fhs'} = open_fh($parsing{'none'}->{'file'}.".short");
      }
    } else {
      $parsing{'none'}->{'fhf'} = open_fh("/dev/null");
      $parsing{'none'}->{'fhs'} = open_fh("/dev/null");
    }

    # For the SOURCE itself:
    if (defined($parsing{'source'}->{'file'})) {
      $parsing{'source'}->{'fh'} = open_fh($parsing{'source'}->{'file'});
    } else {
      $parsing{'source'}->{'fh'} = open_fh("/dev/null");
    }

}
#========================================================================
sub open_fh {

   my($fname) = @_;
   my($fh);

   if ($fname eq "") {
     $fh = *STDOUT;
   } else {
     open($fh,">",$fname) || die "Cannot open output file: $!\n";
   }

   return $fh;

}
#========================================================================
sub close_all_fh {

    while ( my ($key,$val) = each(%{$parsing{'keys'}}) ) {
      close_fh($val->{'fhf'});
      close_fh($val->{'fhs'});
    }

    close_fh($parsing{'all'}->{'fhf'});
    close_fh($parsing{'all'}->{'fhs'});

    close_fh($parsing{'none'}->{'fhf'});
    close_fh($parsing{'none'}->{'fhs'});

    close_fh($parsing{'source'}->{'fh'});

}
#========================================================================
sub close_fh {

   my($fh) = @_;

   if ($fh ne *STDOUT) {
     close($fh) || die "Cannot close output file: $!\n";
   }

}
#========================================================================
sub init_prepros {

    my($key);

    # For all requested keywords
    for my $key ( keys %{$parsing{'keys'}} ) {
      $parsing{'keys'}->{$key}->{'inprepro'} = 0;
      $parsing{'keys'}->{$key}->{'prepro_before'} = "";
    }

    # For the ALL mode:
    $parsing{'all'}->{'inprepro'} = 0;
    $parsing{'all'}->{'prepro_before'} = "";

    # For the NONE mode:
    $parsing{'none'}->{'inprepro'} = 0;
    $parsing{'none'}->{'prepro_before'} = "";

}
#========================================================================
sub open_prepros {

    my($oneline) = @_;
    my($key);

    # For all requested keywords
    for my $key ( keys %{$parsing{'keys'}} ) {
      $parsing{'keys'}->{$key}->{'inprepro'} = -1;
      $parsing{'keys'}->{$key}->{'prepro_before'} = $oneline;
    }

    # For the ALL mode:
    $parsing{'all'}->{'inprepro'} = -1;
    $parsing{'all'}->{'prepro_before'} = $oneline;

    # For the NONE mode:
    $parsing{'none'}->{'inprepro'} = -1;
    $parsing{'none'}->{'prepro_before'} = $oneline;

}
#========================================================================
sub append_prepros {

    my($oneline) = @_;
    my($key);

    # For all requested keywords
    for my $key ( keys %{$parsing{'keys'}} ) {
      $parsing{'keys'}->{$key}->{'prepro_before'} .= $oneline;
      if ($parsing{'keys'}->{$key}->{'inprepro'} eq 1) {
        # Already written, just print current preprocessing
        print  {$parsing{'keys'}->{$key}->{'fhf'}}  $oneline;
      }
    }

    # For the ALL mode:
    $parsing{'all'}->{'prepro_before'} .= $oneline;
    if ($parsing{'all'}->{'inprepro'} eq 1) {
      # Already written, just print current preprocessing
      print  {$parsing{'all'}->{'fhf'}}  $oneline;
    }

    # For the NONE mode:
    $parsing{'none'}->{'prepro_before'} .= $oneline;
    if ($parsing{'none'}->{'inprepro'} eq 1) {
      # Already written, just print current preprocessing
      print  {$parsing{'none'}->{'fhf'}}  $oneline;
    }

}
#========================================================================
sub close_prepros {

    my($oneline) = @_;

    # For all requested keywords
    for my $key ( keys %{$parsing{'keys'}} ) {
      $parsing{'keys'}->{$key}->{'prepro_before'} = "";
      if ($parsing{'keys'}->{$key}->{'inprepro'} eq 1) {
        # Already written, must close it
        print  {$parsing{'keys'}->{$key}->{'fhf'}}  $oneline;
      }
      $parsing{'keys'}->{$key}->{'inprepro'} = 0;
    }

    # For the ALL mode:
    $parsing{'all'}->{'prepro_before'} = "";
    if ($parsing{'all'}->{'inprepro'} eq 1) {
      # Already written, must close it
      print  {$parsing{'all'}->{'fhf'}}  $oneline;
    }
    $parsing{'all'}->{'inprepro'} = 0;

    # For the NONE mode:
    $parsing{'none'}->{'prepro_before'} = "";
    if ($parsing{'none'}->{'inprepro'} eq 1) {
      # Already written, must close it
      print  {$parsing{'none'}->{'fhf'}}  $oneline;
    }
    $parsing{'none'}->{'inprepro'} = 0;

}
#========================================================================
sub write_buffers {

    my($desc,$mandatory) = @_;

    if ($parsing{'mandatory'} and not $mandatory) { return; }

    if ($desc->{'inprepro'} eq -1) {
      print  {$desc->{'fhf'}}  $desc->{'prepro_before'};
      $desc->{'inprepro'} = 1;  # >0 means directive written
    }

    # Full interfaces
    print  {$desc->{'fhf'}}  $indent."interface\n";
    print  {$desc->{'fhf'}}  $buffer_full;
    print  {$desc->{'fhf'}}  $indent."end interface\n";
    print  {$desc->{'fhf'}}  $indent."!\n";

    # Short interfaces
    &write_short($desc->{'fhs'},$buffer_full);

}
#========================================================================
sub write_generics {

    # For all requested keywords
    while ( my ($key,$desc) = each(%{$parsing{'keys'}}) ) {
      &write_generic($desc);
    }

    # For the ALL mode:
    &write_generic($parsing->{'all'});

    # For the NONE mode:
    &write_generic($parsing->{'none'});

}
#========================================================================
sub write_generic {  # NB: Generic interfaces are always mandatory:


    my($desc) = @_;

    for my $gname (sort keys %{$desc->{'generics'}}) {
      # Full interfaces
      print  {$desc->{'fhf'}}  $indent."interface $gname\n";
      print  {$desc->{'fhf'}}  $generics{$gname};
      print  {$desc->{'fhf'}}  $indent."end interface $gname\n";
      print  {$desc->{'fhf'}}  $indent."!\n";
      # Short interfaces
      &write_short($desc->{'fhs'},$generics{$gname});
    }

}
#========================================================================
sub write_short {

    my($fh,$buf) = @_;
    my($prevline) = "";

    foreach my $line (split('\n',$buf)) {

      $line =~ s/!.*//;          # Suppress comments

      if ($line =~ /\s*&\s*(!.*)?$/) {
        # Current line is continued
        $line =~ s/\s*&\s*(!.*)?$//;
        $prevline = $prevline.$line;
        next;
      } else {
        $line = $prevline.$line;
        $prevline = "";
      }

      $line =~ s/^\s*use\s+\w+//i;  # Suppress "use" lines
      $line =~ s/\s+//g;            # Suppress all spaces (a la fixed syntax, should not be a problem)

      if ($line =~ /^\s*$/) { next; }  # Skip blank lines

      print  {$fh}  lc($line)."\n";    # Write line, lowercased

    } # EndWhile

}
#========================================================================
sub non_mandatory {  # If procedure is not mandatory, remove the
                     # "except_this" procedure rename

    my($mandatory,$reason,$name) = @_;

    if ($parsing{'mandatory'}) {  # User wants only the mandatory interfaces
      if (not $mandatory) {       # Current interface is not mandatory
        # Edit global buffer:
        $buffer_source =~ s/_interfaces\s*,\s*\w+\s*=>\s*$name\b(.*)\n/_interfaces$1 ! Not mandatory\n/i;
      } else {
        # Debug:
        $buffer_source =~ s/(_interfaces\s*,\s*\w+\s*=>\s*$name\b.*)\n/$1 ! Mandatory ($reason)\n/i;
      }
    }

}
#========================================================================
