#!/usr/bin/perl -w

use Getopt::Long;

# Format in a standard way free syntax Fortran sources.
#   Usage:
#     gag-format-f90.pl < in.f > out.f
#   (type gag-format-f90.pl -h for details)
#
# Last modified on 13-sep-2007, by Sebastien Bardeau

our($progname) = "gag-format-f90.pl";

# Retrieve options
GetOptions("h",         \$help,
           "help",      \$help,
           "v",         \$version,
           "version",   \$version);

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

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

our($textwidth) = 72;
our(@globfuncs) = ();
&known_funcs(\@globfuncs);  # Add known functions to this list

# First quick loop to detect functions
open (OUT,">copy.txt");
while (defined($oneline = <STDIN>)) {

   print OUT $oneline;  # Save it for 2nd parsing

   $c2 = ($oneline =~ /^\s*\w*\s*function\s+(\w+)/i);

   if ($c2) { push(@globfuncs,$1) }

}
close(OUT);

# And now do the real job
%buffers  = (); reset_buffers(\%buffers);
%lines    = ();
$pp       = 0;
$usefound = 0;
$type     = "";
$inproto  = 0;
$inbody   = 0;
$asuivre  = 0;

open(IN,"copy.txt");
while (defined($oneline = <IN>)) {

   # Remove spaces at end of line:
   $oneline =~ s/\s*$/\n/;

   $c0 = ($oneline =~ /^\s*program\s+/i);
   $c1 = ($oneline =~ /^\s*(recursive)?\s*subroutine/i);
   $c2 = ($oneline =~ /^\s*\w*\s*function\s+/i);
   $c3 = ($oneline =~ /^\s*end\s*function\s+/i);
   $c31 = ($oneline =~ /^\s*blockdata\s+/i);

   if ($c0 or $c1 or ($c2 and not $c3) or $c31) {
      # A new routine/function begins: flush previous buffer.
      flush_buffer(\%buffers);

      # And start new buffers:
      $inproto = 1;
      $inbody  = 0;
      reset_buffers(\%buffers);
      $buffers{'proto'} -> {'lines'} = $oneline;

      $asuivre = ($oneline =~ /&\s*(!.*)?$/); # Detect continuation line
      next; # Line has been stored, next one.
   }

   $c4  = ($oneline =~ /^\s*module\s+/i);
   $c5  = ($oneline =~ /^\s*\w*\s*block\sdata\s+/i);

   if ($c4 or $c5) {
      # A new block begins: flush previous buffer.
      flush_buffer(\%buffers);

      # And start new buffers:
      $inproto = 1;
      $inbody  = 0;
      reset_buffers(\%buffers);
      $buffers{'proto'} -> {'lines'} = $oneline;

      $asuivre = ($oneline =~ /&\s*(!.*)?$/); # Detect continuation line
      next; # Line has been stored, next one.
   }

   # Line is continuation of prototype:
   if ($asuivre and $inproto) {
      $buffers{'proto'} -> {'lines'} .= $oneline;

      $asuivre = ($oneline =~ /&\s*(!.*)?$/); # Detect continuation line
      # print STDERR $oneline;
      next; # Line has been stored, next one.
   }

   # Remove lines "! Global variables:"
   if (($oneline =~ /^\s*!\s*(global|dummy|local)\s+(variable)?/i) and not $inbody) {
      next;  # Delete line
   }

   # Line is a comment found just after the prototype:
   if ($oneline =~ /^\s*!/ and $inproto) {
      push(@{$buffers{'header'}}, $oneline);

      $asuivre = 0;
      next; # Line has been stored, next one.
   }

   $c6  = ($oneline =~ /^\s*use\s+\w+/i);
   # $oneline is a use, store it in special buffer
   if ($c6) {
      $buffers{'use'} .= $oneline;
      $usefound = 1;

      $asuivre = ($oneline =~ /&\s*(!.*)?$/); # Detect continuation line
      next; # Line has been stored, next one.
   }

   # Ended with prototype and header.
   if ($inproto) {
      # Switch flag to 0, and construct args list
      $inproto = 0;
      find_args(\%{$buffers{'proto'}});
   }

   # Starting a preprocessing block
   if ($oneline =~ /^#(if|ifdef|ifndef)\s+\w+/ ) {
      $pp = 1;
      $buffers{'body'} .= $oneline;
      next; # Line has been stored, next one.
   }

   # Ending preprocessing block
   if ($oneline =~ /^#endif/) {
      $pp = 0;
      $buffers{'body'} .= $oneline;
      next; # Line has been stored, next one.
   }

   # Currently in a preprocessing block. $oneline can not be moved.
   if ($pp == 1) {
      # ZZZ but should be formatted!
      # ZZZ and checked first, no?
      $buffers{'body'} .= $oneline;
      next; # Line has been stored, next one.
   }

   # Something else

   $c7 = ($oneline =~ /^\s*implicit\s+none/i);
   # Implicit none?
   if ($c7) {
      $buffers{'impnone'} = $oneline;
      next; # Line has been stored, next one.
   }

   # Declarations? (previous line must NOT be continued)
   $c8 = ( ($oneline =~ /^\s*(integer|real|(double\s+)?complex|logical|external|type)\W/i) and not $asuivre and not $inbody);
   $c9 = ( ($oneline =~ /^\s*character\W/i) and not $asuivre and not $inbody);

   # $oneline is a declaration. $type ne "" ensure continued declarations
   if ( $c8 or $c9 or $type ne "" ) {
      if ($c9 or ($type =~ /character/i) ) {
         # print STDERR "\nComputing $oneline";
         ($type2,%lines) = fmt_char($oneline,$type);
         $type = "";  # Empty type here because fmt_char has already added type
         foreach (values %lines) {
            $type = fmt_decl($_,\%buffers,$type);
         }
         $type = $type2;  # Get back $type2 returned by fmt_Char to handle continued character declarations
         # print STDERR "Type is $type\n";
      } else {
         $type = fmt_decl($oneline,\%buffers,$type);
      }
      $usefound = 0;

      next; # Line has been stored (in $buffers{'dummies/globals/body'}), next one.

   }

   # INCLUDE statements?
   $c10 = ($oneline =~ /^\s*include\s+/i);
   if ($c10) {
      $buffers{'globals'} -> {'includes'} .= $oneline;
      next; # Line has been stored, next one.
   }

   # PARAMETER statements?
   if (($oneline =~ /^\s*parameter\s+/i) and not $inbody) {
      $buffers{'body'} .= $oneline;
      next; # Line has been stored, next one.
   }


   $c11 = ($oneline =~ /^\s*!\s*$/);               # Empty comment line
   $c12 = ($buffers{'body'} eq "");                # Body is not yet started
   $c13 = ($buffers{'proto'} -> {'lines'} eq "");  # Proto is empty
   $c14 = ($buffers{'body'} =~ /\n\s*!\s*$/s);     # Last body line is already an empty comment

   # "$c11" means line is an empty comment
   # "$c12" means we just leaved proto/header/use/dummies section
   # "$c13" means inside a subroutine/function block
   # "$c14" means that we already have an empty comment line finishing the body
   if ($c11 and ( ($c12 and not $c13) or $c14 )) {
      next; # Delete line (do nothing). This avoids duplicate empty comment lines.

   }

   # Something else: $oneline is added at the end of $buffer
   if ($oneline =~ /=/) { $inbody = 1 }
   $buffers{'body'} .= $oneline;
   $usefound = 0;
   $asuivre = ($oneline =~ /&$/); # Detect continuation line

} # EndWhile
close(IN);

unlink("copy.txt");

flush_buffer(\%buffers);

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

    print STDERR "  This utility reads free-syntax-formatted Fortran sources from standard input\n";
    print STDERR "(STDIN) and prints to standard output (STDOUT) reformatted sources in a standard\n";
    print STDERR "way. In particular dummy variables are extracted from all the declared variables\n";
    print STDERR "and put at the beginning of the routines. Character variables are also declared\n";
    print STDERR "(len=<len>) since *<len> form is obsolescent.\n";
    print STDERR "\n";
    print STDERR "  Usage:\n";
    print STDERR "     $progname < in.f90   Rewrite in.f90 to STDOUT\n";
    print STDERR "\n";
    print STDERR "     $progname -h         Display this help\n";
    print STDERR "     $progname --help     Display this help\n";
    print STDERR "     $progname -v         Show version number\n";
    print STDERR "     $progname --version  Show version number\n";
    print STDERR "\n";

    exit;

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

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

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

    exit;

}
#=======================================================================
sub reset_buffers {

   my($ptr) = @_;

   # Structure is:
   # %buffers -> 'proto' -> 'lines'          : prototype line(s)     (scalar string)
   #                     -> 'args'           : prototype argument(s) (array of strings)
   #                     -> 'nbargs'         : # of arguments        (scalar integer)
   #          -> 'header'                    : header line(s)        (array of strings)
   #          -> 'use'                       : use stmts line(s)     (scalar string)
   #          -> 'impnone'                   : implicit none line    (scalar string)
   #          -> 'dummies' -> $var -> 'pos'  : position              (scalar integer)
   #                                  'line' : declaration           (scalar string)
   #                                  'deps' : dependencies          (array of strings)
   #          -> 'globals' -> 'funcs' -> $type : functions per type  (array of string)
   #                       -> 'includes'     : list of include lines (scalar string)
   #          -> 'locals'                    : are there local decls? (scalar integer)
   #          -> 'body'                      : all other lines       (scalar string)

   $ptr -> {'proto'}   = ();
   $ptr -> {'proto'} -> {'lines'}  = "";
   $ptr -> {'header'}  = ();
   $ptr -> {'use'}     = "";
   $ptr -> {'impnone'} = "";
   $ptr -> {'dummies'} = ();
   $ptr -> {'globals'} = ();
   $ptr -> {'globals'} -> {'includes'} = "";
   $ptr -> {'locals'}  = 0;
   $ptr -> {'body'}    = "";

}
#========================================================================
sub display_dummies { # For debugging purpose

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

   foreach $key ( sort { $ptr->{$a}->{'pos'} <=> $ptr->{$b}->{'pos'} } keys %{$ptr}) {

      print STDERR $ptr -> {$key} -> {'pos'} ." : ";
      print STDERR $key;
      if ( $#{$ptr -> {$key} -> {'deps'}} >= 0) {
         print STDERR " ( @{$ptr -> {$key} -> {'deps'}} )";
      }
      print STDERR " -> ". $ptr -> {$key} -> {'line'};

   }

   print STDERR "\n";

}
#========================================================================
sub flush_buffer {

   my($bufptr) = @_;

   my($proto,$use,$header,$impnone,$dummies,$body);

   # Can display dummies for debugging purpose:
   # display_dummies($bufptr->{'dummies'});

   # Empty buffer?
   if ($bufptr->{'body'} eq "") { return; }

   $proto   = $bufptr->{'proto'}->{'lines'};
   $use     = $bufptr->{'use'};
   $header  = fmt_header($bufptr->{'header'});
   $impnone = $bufptr->{'impnone'};
   $dummies = declare_dummies($bufptr);
   $globals = declare_globals($bufptr->{'globals'});
   $body    = $bufptr->{'body'};

   if ( ($dummies.$globals ne "") and ($bufptr->{'locals'}) ) {
      $body =~ /^\s*/s;
      $body = $&."! Local\n".$body;
   }

   print $proto.$use.$header.$impnone.$dummies.$globals.$body;

}
#========================================================================
sub fmt_header {

   my($arrptr) = @_;
   my($line);

   # Header is empty
   if ( $#{$arrptr} == -1 ) { return ""; }

   # Construct line
   $arrptr->[0] =~ /^\s*!/;
   $line = $&."-"x($textwidth-length($&))."\n";

   # Else
   while ( $arrptr->[0]  =~ /^\s*!\s*-*$/ ) {
      shift(@{$arrptr});
      if ($#{$arrptr} == -1) { return ""; }
   }
   while ( $arrptr->[-1] =~ /^\s*!\s*-*$/ ) {
      pop(@{$arrptr});
      if ($#{$arrptr} == -1) { return ""; }
   }

   return $line.join('',@{$arrptr}).$line;

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

   my($protoptr) = @_;
   my($i,$declline);

   # print STDERR "Entering find_args\n";

   @{$protoptr->{'args'}} = ();

   # Handle function as a dummy
   if ($protoptr->{'lines'} =~ /^\s*\w*\s*function\s+(\w+)/i) {
      push(@{$protoptr->{'args'}},$1);
   }

   # Search for dummies
   $declline = $protoptr->{'lines'};  # Just a local copy to detect dummies
   $declline =~ s/\s*!.*\n/\n/g ;     # Suppress comments in prototype
   # print STDERR $declline;
   if ($declline =~ /\(\s*(.*)\s*\)/s) {
      push(@{$protoptr->{'args'}},split(/[\s\n&]*,[\s\n&]*/s,$1));
   }

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

   # Compute number if args
   $protoptr -> {'nbargs'} = $#{$protoptr->{'args'}}+1;

}
#========================================================================
sub find_deps {

   my($type,$fullvar) = @_;
   my($i,$var);
   my(@deps1,@deps2) = ();

   # print STDERR "Searching dependencies for $fullvar\n";

   # 1) Split deps for declarations like a(x,y,3)
   if ($fullvar =~ /\((.+)\)/) {
      # Valid words separator are coma and operators:
      @deps1 = split(/[,\*\s]*[,\+\-\*\/][,\*\s]*/,$1);
   }

   # 2) Split deps for declarations like a=x+y+1
   if ($fullvar =~ /=\s*([\s\w\.\+\-\*\/]+)/) {
      push(@deps1, split(/\s*[\+\-\*\/]\s*/,$1));
   }

   # 3) Split deps for declaration like "real, dimension(x,y,3) :: a"
   if ($type =~ /dimension\((.+?)\)/i) { # ".+?" = minimal match
      # Valid word separators are coma and operators:
      @deps1 = split(/[,\*\s]*[,\+\-\*\/][,\*\s]*/,$1);
   }

   # 4) Finally, eliminate non-variable objects
   foreach $var (@deps1) {
      $var =~ s/%[\w%]+//;     # Structure.
      if ($var =~ /^[A-Za-z]\w/) { # Variable mixing letters and digits, first is a letter
         push(@deps2, $var);
      } elsif (not ($var =~ /[\*:\d+]/) ) { # Forbidden chars
         push(@deps2, $var);
      }
   }

   return @deps2;

}
#========================================================================
sub fmt_decl {

   my($line,$bufptr,$type) = @_;
   my($c,$i,$comment,$vars,$var,$fullvar,$cont);

   # print STDERR "Fmt_decl1: $line";

   # Remove leading "   &" and add previous type:
   if ($type ne "") {
      $line =~ s/^\s*&\s*,?//;
      $line =~ s/^\s*/$type/;
   }

   # Detect continuation and remove trailing "&"
   if ( $line =~ s/,?\s*&$// ) {
      $cont = 1;
   } else {
      $cont = 0;
   }

   ($line,$comment) = split_comment($line);
   ($type,$vars) = split_decl($line);

   # print STDERR "Fmt_decl2: $type<<\n";
   # print STDERR "\nFmt_decl2: vars = $vars\n";

   # Extract from declaration lines the dummy arguments:
   for ($i=0; $i<$bufptr->{'proto'}->{'nbargs'}; $i++) {

      $var = $bufptr -> {'proto'} -> {'args'} -> [$i];
      # print STDERR "Searching dummy $var\n";
      ($fullvar,$vars) = split_vars($var,$vars);

      # Found one of the dummies?
      if ($fullvar ne "") {
         # print STDERR "Found $var\n";
         $bufptr -> {'dummies'} -> {$var} -> {'pos'}  = $i;
         if (exists($bufptr -> {'dummies'} -> {$var} -> {'line'})) {
            $bufptr -> {'dummies'} -> {$var} -> {'line'} .= $type.$fullvar.$comment;
         } else {
            $bufptr -> {'dummies'} -> {$var} -> {'line'} = $type.$fullvar.$comment;
         }
         @deps = find_deps($type,$fullvar);
         @{$bufptr -> {'dummies'} -> {$var} -> {'deps'}} = @deps;
      }

      # Are all variables in declaration identified?
      if ($vars eq "") { last; }
   }

   # Extract from declaration lines the global functions:
   for ($i=0; $i<=$#globfuncs; $i++) {

      $var = $globfuncs[$i];
      ($fullvar,$vars) = split_vars($var,$vars);

      # Found one of the global functions?
      if ($fullvar ne "") {
         push(@{$bufptr -> {'globals'} -> {'funcs'} -> {$type}}, $fullvar);
         # Drop of $comment (no use for global functions?)
      }

      # Are all variables in declaration identified?
      if ($vars eq "") { last; }
   }

   if ($vars ne "") {
      $bufptr->{'locals'} = 1;  # There are local definitions
      $bufptr->{'body'} .= $type.$vars.$comment;
   }

   if (not $cont) {
      $type = "";
   }

   return $type;  # Returning a non-empty type means that it will be
                  # reused with the next continued line

}
#========================================================================
sub fmt_char { # Changes declaration line like "character*123",
               # "character(123)", "character*(*)" to
               # "character(len=123)"
               # Original case of word "character" is kept

   my($line,$type) = @_;
   my($comment,$var,$deflen,$len,$rawvars,$cont,$parameter,$isparam);
   my(%vars);
   my(%lines) = ();

   # print STDERR "Fmt_char1: $line";

   # Remove leading "   &" and add previous type:
   if ($type ne "") {
      $line =~ s/^\s*&\s*,?//;
      $line =~ s/^\s*/$type/;
   }

   ($line,$comment) = split_comment($line);

   # Detect continuation and remove trailing "&"
   if ( $line =~ s/,?\s*&$// ) {
      $cont = 1;
   } else {
      $cont = 0;
   }

   $isparam  = "";
   $isalloc  = "";
   $isintent = "";
   $parameter   = ',\s*parameter';
   $allocatable = ',\s*allocatable';
   $intent      = ',\s*intent\(\w+\)';

   # Find which (default) length apply:
   if      ($line =~ /(character)\s*\(len\s*=\s*([\w\+\-]+|\*)?\)\s* ($intent)? ($parameter)? ($allocatable)? \s* (::)?\s*/ix) { # character(len=123) foo
      $char    = $`.$1;  # Keep spaces and case
      $deflen  = $2;
      if (defined($3)) { $isintent = $3; }
      if (defined($4)) { $isparam  = $4; }
      if (defined($5)) { $isalloc  = $5; }
      $rawvars = $';

   } elsif ($line =~ /(character)\*(\d+)                         \s* ($intent)? ($parameter)? ($allocatable)? \s* (::)?\s*/ix) { # character*123 foo
      $char    = $`.$1;
      $deflen  = $2;
      if (defined($3)) { $isintent = $3; }
      if (defined($4)) { $isparam  = $4; }
      if (defined($5)) { $isalloc  = $5; }
      $rawvars = $';

   } elsif ($line =~ /(character)\*?\((\d+|\w+)\)                \s* ($intent)? ($parameter)? ($allocatable)? \s* (::)?\s*/ix) { # character(123) foo
      $char    = $`.$1;
      $deflen  = $2;
      if (defined($3)) { $isintent = $3; }
      if (defined($4)) { $isparam  = $4; }
      if (defined($5)) { $isalloc  = $5; }
      $rawvars = $';

   } elsif ($line =~ /(character)\s*\*?\(\*\)                    \s* ($intent)? ($parameter)? ($allocatable)? \s* (::)?\s*/ix) { # character*(*) foo
      $char    = $`.$1;
      $deflen  = "*";
      if (defined($2)) { $isintent = $2; }
      if (defined($3)) { $isparam  = $3; }
      if (defined($4)) { $isalloc  = $4; }
      $rawvars = $';

   } elsif ($line =~ /(character)                                \s* ($intent)? ($parameter)? ($allocatable)? \s* (::)?\s*/ix) { # characte foo*123
      $char    = $`.$1;
      $deflen  = "";
      if (defined($2)) { $isintent = $2; }
      if (defined($3)) { $isparam  = $3; }
      if (defined($4)) { $isalloc  = $4; }
      $rawvars = $';

   } else {
      print STDERR "fmt_char error1: character line $line\n";
   }

   # Type of the current declaration was...
   if ($deflen ne "") {
      $type = $char."(len=$deflen)";
   } else {
      $type = $char;
   }
   $type .= $isintent.$isparam.$isalloc;
#    print STDERR "Fmt_char3: type    = >>$type<<\n";
#    print STDERR "Fmt_char4: rawvars = >>$rawvars<<\n";

   if ($rawvars =~ /\*/)   { # foo*123, bar*456

      # Got to split variables...
      %vars = parse_vars($rawvars);

      foreach $var (keys %vars) {
         $len = $vars{$var}->{'len'};
         # Length?
         if ($len eq "") {
            $len = $deflen;  # None found, apply default
         }
         if ($len eq "") {
            print STDERR "fmt_char error2: character line $line\n";
         }
         # (Re)build line(s)
         if (exists $lines{$len}) {
            $lines{$len} .= ",".$var.($vars{$var}->{'dims'}).($vars{$var}->{'value'});
         } else {
            $lines{$len} = $char."(len=$len)".$isparam.$isalloc." ".$var.($vars{$var}->{'dims'}).($vars{$var}->{'value'});
         }
      }

   } else {
      $lines{$deflen} = $type." ".$rawvars;
   }

   # Add comments
   foreach $len (keys %lines) {
      $lines{$len} .= $comment;
   }

   # Return a non-empty $type if line is continued
   if (not $cont) { $type = "" }

   # print STDERR "Fmt_char2: returning type = $type\n";

   return ($type,%lines);

}
#========================================================================
sub parse_vars {

   my($inline) = @_;
   my($line,$len,$dims,$value);
   my(@vars);
   my(%hvars) = ();

   # First stage: suppress dimensions, string lengths, continuation lines
   ($line = $inline) =~ s/\([\w%,:\s\+\-\*\/]+\)//g;
   $line =~ s/\*\d*//g;  # "\d*" and not "\d+" since toto*(*) became toto*
   # $line =~ s/\s*,?\s*&\s*$//;  # There should be no continuation at this stage
   $line =~ s/\s*=\s*.*?(,|$)//g;  # Suppress initial value

   # print STDERR ">>> Stripped line=\"$line\"\n";

   # Store variable names:
   @vars = split(/\s*,\s*/,$line);

   # Then, reanalyze to find dimensions and string lengths:
   foreach $var (@vars) {

      if (not ($inline =~ /^  \b$var\b  (\*(\d+|\(\*\)))?  (\([\w%,:\s\+\-\*\/]+\))?  (\*(\d+|\(\*\)))?  (\s*=[\s\w\.\+\-\*\/\(\)'"]+)?  \s*  ([,\s]+|$)  /x )) {
         die "parse_vars error: Could not find back \"$var\" in \"$inline\"!\n";
      }
      # $1 =  *123       (star + string length, before dimensions)
      # $2 =  123        (string length -subpart of $1-)
      # $3 =  (123,foo)  (dimensions)
      # $4 =  *123       (star + string length, after dimensions)
      # $5 =  123        (string length -subpart of $4-)
      # $6 =  =2*3+bar   (initial value)

      # Store string length
      $len = "";
      if (defined($2)) { $len = $2 };
      if (defined($5)) { $len = $5 };
      if ($len eq "(*)") { $len = "*" }
      $hvars{$var} -> {'len'} = $len;

      # Store dimensions
      $dims = "";
      if (defined($3)) { $dims = $3 };
      $hvars{$var} -> {'dims'} = $dims;

      # Store value
      $value = "";
      if (defined($6)) { $value = $6 };
      $hvars{$var} -> {'value'} = $value;

      # Remaining variables
      $inline = $';

   }

   return %hvars;

}
#========================================================================
sub split_vars { # Input is a string list of declared variables (which
                 # may contain parenthesis, dimensions, ...) separated by
                 # comas.
                 # Output is the variable (if found), and the list
                 # without the variable which has been extracted.

   my($onevar,$line) = @_;
   my($copy) = $line;

   $copy =~ s/\([^\(]*?\)//;  # Suppress deep parenthesis blocks
   $copy =~ s/\([^\(]*?\)//;  # Again

   if ( $copy =~ /\b$onevar\b/ ) {
      # print STDERR ">>> $onevar is declared in $copy = $line\n";
   }

   if ( not ($copy =~ /\b$onevar\b/ ) ) {
      $onevar = "";

   } elsif ($line =~ /^          \b$onevar\b  ( \s* (\*\d+)? (\([\w%,:\s\+\-\*\/]+\))? (=[\s\w\.\+\-\*\/]+)? )  $       /x ) {
      # $onevar is single var declared
      $line = "";
      if ($1 ne "") { $onevar .= $1; }

   } elsif ($line =~ /^          \b$onevar\b  ( \s* (\*\d+)? (\([\w%,:\s\+\-\*\/]+\))? (=[\s\w\.\+\-\*\/]+)? )  [,\s]+  /x ) {
      # $onevar is first var declared
      $line = $';
      if ($1 ne "") { $onevar .= $1; }

   } elsif ($line =~ /\s*,\s*    \b$onevar\b  ( \s* (\*\d+)? (\([\w%,:\s\+\-\*\/]+\))? (=[\s\w\.\+\-\*\/]+)? )  $       /x ) {
      # $onevar is last var declared
      $line = $`;
      if ($1 ne "") { $onevar .= $1; }

   } elsif ($line =~ /(\s*,\s*)  \b$onevar\b  ( \s* (\*\d+)? (\([\w%,:\s\+\-\*\/]+\))? (=[\s\w\.\+\-\*\/]+)? )  \s*,\s* /x ) {
      # $onevar is neither first nor last var declared
      $line = $`.$1.$';
      if ($2 ne "") { $onevar .= $2; }

   } else {
      # $onevar is not declared here
      $onevar = "";

   }

   return ($onevar,$line);

}
#========================================================================
sub split_comment {

   my($line) = @_;
   my($comment) = "\n";

   # Split line (remove spaces and comments before analyze):
   if ($line =~ /\s*!.*/) {
      $line = $`;
      $comment = $&.$';
   } else {
      chomp($line);
   }

   return ($line,$comment);

}
#========================================================================
sub split_decl {

   my($line) = @_;
   my($type) = $line;
   my($variables) = "";

   if ($line =~ /\s*::\s*/) {
      # Nothing to be done
      $type = $`.$&;
      $variables = $';

   } elsif ($line =~ /(double\s+complex)(\s+)/i ) {
      $type = $`.$1." ::".$2;
      $variables = $';

   } elsif ($line =~ /\b\s+\b/) {
      # This means: "end-of-word, followed by one or more spaces, beginning of word
      # Because "::" should be placed where there is no comma!
      $type = $`." ::".$&;
      $variables = $';
      # Concatenates: string before the match, " ::", the match (ie spaces),
      # and string after the match.

   } elsif ($line =~ /\)(\s+)\b/) {
      # This means: "a closing paranthesis, followed by one or more spaces, beginning
      # of word. Because left part may end by a closing paranthesis (eg (kind=...) )
      $type = $`.") ::".$1;
      $variables = $';
      # Concatenates: string before the match, ") ::" (because the closing paranthesis
      # was captured by the match), the spaces (captured by the enclosing "()" into $1 ),
      # and string after the match.

   } elsif ($line =~ /^\s*\S+$/) {
      # This means: "optional spaces at beginning, and a single word (non-space
      # chars) at EOL. e.g. nothing declared here (might happen on continued lines)
      $type = $&." :: ";
      $variables = "";

   } else {
      print STDERR "Error in split_decl! Unexpected declaration:\n";
      print STDERR $line."\n";
      print STDERR "(nothing processed on this line)\n";

   }

   return ($type,$variables);

}
#========================================================================
sub declare_dummies {

   my($bufptr) = @_;
   my($i,$buffer,$key,$nbargs,$dumptr);
   my(@array);

   $dumptr = $bufptr -> {'dummies'};
   $nbargs = $bufptr -> {'proto'} -> {'nbargs'};

   # Protect against empty dummies:
   if (scalar keys %$dumptr == 0) { return ""; }

   # Sorting, but by taking into account dependencies:
   @array = ();
   foreach $key ( sort { $dumptr->{$a}->{'pos'} <=> $dumptr->{$b}->{'pos'} } keys %{$dumptr}) {
      push(@array, @{$dumptr -> {$key} -> {'deps'}}); # First, add prerequisites
      push(@array, $key);                             # Then, add current var
   }

   # Update positions:
   for ($i=0; $i<=$#array; $i++) {
      $key = $array[$i];
      if (not exists($dumptr->{$key})) {
         next;  # A dependency variable might not be declared here (e.g. in a module instead)
      }
      if ($dumptr->{$key}->{'pos'} < $nbargs) {
         $dumptr->{$key}->{'pos'} = $nbargs + $i;
      }
   }

   # And make buffer:
   $buffer = "";
   foreach $key ( sort { $dumptr->{$a}->{'pos'} <=> $dumptr->{$b}->{'pos'} } keys %{$dumptr}) {
      $buffer .= $dumptr -> {$key} -> {'line'};
   }

   $buffer = add_comment($buffer);
   $buffer = add_dummies($buffer);

   return $buffer;

}
#========================================================================
sub declare_globals {

   my($gblptr) = @_;
   my($i,$buffer,$funcs,$type);
   my(@array);

   # print STDERR "Keys = ",(keys %{$gblptr}),"\n";
   # print STDERR "Includes = \n";
   # print STDERR $gblptr -> {'includes'};

   # Protect against empty globals:
   if ((scalar keys %{$gblptr -> {'funcs'}} == 0)
       and ($gblptr -> {'includes'} eq "")) { return "" }

   # And make buffer:
   $buffer = "";
   foreach $type ( keys %{$gblptr -> {'funcs'}}) {
      $funcs = "";
      foreach $func (@{$gblptr -> {'funcs'} -> {$type}}) {
         if ($funcs ne "") { $funcs .= "," }
         $funcs .= $func;
      }
      $buffer .= $type.$funcs."\n";
   }

   # Add 'include' lines
   $buffer .= $gblptr -> {'includes'};

   # print STDERR "Globals buffer is:\n";
   # print STDERR $buffer;

   $buffer = add_globals($buffer);  # Add "  ! Global"

   return $buffer;

}
#========================================================================
sub add_comment {

   my($buffer) = @_;
   my($lc,$decl,$line,$newbuf);
   my(@text);

   @text = split(/\n/,$buffer);

   # 1) Search for position where comments will be aligned:
   $lc = $textwidth/2;
   foreach $line (@text) {

      $decl = $line;
      if ( $line =~ /\s*!.*/) { $decl = $`; }
      $lc = mymax($lc,length($decl)+2); # +2 spaces

   }

   # 2) Realign/add comments
   $newbuf = "";
   foreach $line (@text) {

      # if (! ($line =~ s/\s*!/sprintf("%".($lc-length($`))."s","!")/e) ) {
      #    $line .= sprintf("%".($lc-length($line))."s","!");
      # }
      if (! ($line =~ s/\s*!/" "x($lc-length($`))."!"/e) ) {
         $line .= " "x($lc-length($line))."!";
      }
      $newbuf .= $line."\n";
   }

   return $newbuf;

}
#========================================================================
sub add_dummies {

   my($buffer) = @_;
   my($line,$newbuf);
   my(@text);

   @text = split(/\n/,$buffer);
   $line = shift(@text);

   $line =~ /^\s*/;
# Commented out since Jerome do not want we had the "Dummies" keyword
#    $newbuf  = $&."!\n";
#    $newbuf .= $&."! Dummies\n";
   $newbuf .= $buffer;

   return $newbuf;

}
#========================================================================
sub add_globals {  # Add comment "  ! Global"
                   # But parse buffer to find number of spaces

   my($buffer) = @_;
   my($line,$newbuf);
   my(@text);

   @text = split(/\n/,$buffer);
   $line = shift(@text);

   $line =~ /^\s*/;
   # $newbuf  = $&."!\n";
   $newbuf .= $&."! Global\n";
   $newbuf .= $buffer;

   return $newbuf;

}
#========================================================================
sub mymax {

    my($max) = shift;
    foreach (@_) { $max = $_ if $max < $_ }

    return $max;

}
#========================================================================
sub known_funcs {
   my($ptr) = @_;

   push(@{$ptr}, "gr8_in");
   # gsys
   push(@{$ptr}, "bytpnt");
   push(@{$ptr}, "gag_filwrite");
   push(@{$ptr}, "gag_filread");
   push(@{$ptr}, "gag_filseek");
   push(@{$ptr}, "gag_inquire");
   push(@{$ptr}, "gag_pointer");
   push(@{$ptr}, "gag_random");
   push(@{$ptr}, "gag_system");
   push(@{$ptr}, "gag_which");
   push(@{$ptr}, "locwrd");
   push(@{$ptr}, "locstr");
   push(@{$ptr}, "lenc");
   push(@{$ptr}, "r4tor4");
   push(@{$ptr}, "r8tor8");
   push(@{$ptr}, "sic_findfile");
   push(@{$ptr}, "sic_getvm");
   push(@{$ptr}, "sic_getlog");
   push(@{$ptr}, "sic_getlun");
   push(@{$ptr}, "sic_hasfin");
   push(@{$ptr}, "sic_hasins");
   push(@{$ptr}, "sic_open");
   push(@{$ptr}, "sic_query_file");
   # gcont
   push(@{$ptr}, "conxch");
   # gio
#    push(@{$ptr}, "gag_isreal");
#    push(@{$ptr}, "gag_isdble");
   push(@{$ptr}, "gdf_conv");
#    push(@{$ptr}, "fiseof");
   push(@{$ptr}, "gdf_riox");
   push(@{$ptr}, "gdf_wiox");
   push(@{$ptr}, "gdf_block");
   push(@{$ptr}, "gdf_rih");
   push(@{$ptr}, "gdf_eih");
#    push(@{$ptr}, "gildas_error");
   push(@{$ptr}, "gdf_word_length");
   push(@{$ptr}, "gdf_stis");
   push(@{$ptr}, "gdf_chis");
#    push(@{$ptr}, "gdf_sris");
#    push(@{$ptr}, "intprt");
   # gtv
   push(@{$ptr}, "cree_genv_array");
   push(@{$ptr}, "get_next_env");
   push(@{$ptr}, "gtchkt");
   push(@{$ptr}, "gterrtst");
   push(@{$ptr}, "gtg_curs");
   push(@{$ptr}, "gtstat");
   push(@{$ptr}, "open_x");
   push(@{$ptr}, "ps_hard");
   push(@{$ptr}, "x_exist_saved");
   push(@{$ptr}, "x_test_event");
   # sic
   push(@{$ptr}, "sic_ctrlc");
   push(@{$ptr}, "sic_eqchain");
   push(@{$ptr}, "sic_hasdel");
   push(@{$ptr}, "sic_level");
   push(@{$ptr}, "sic_len");
   push(@{$ptr}, "sic_lire");
   push(@{$ptr}, "sic_narg");
   push(@{$ptr}, "sic_notsamedesc");
   push(@{$ptr}, "sic_present");
   push(@{$ptr}, "sic_start");
   push(@{$ptr}, "var_type");
   # greg
   push(@{$ptr}, "gr_error");
   # clic
   push(@{$ptr}, "gr8_random");
   push(@{$ptr}, "mth_bessj1");
   push(@{$ptr}, "mth_bessj0");
   push(@{$ptr}, "mingauss");
   push(@{$ptr}, "progauss");
   push(@{$ptr}, "run_clic");
   push(@{$ptr}, "run_tifits");
   push(@{$ptr}, "run_sdm");
   push(@{$ptr}, "fcheb");
   push(@{$ptr}, "dummyconvert");

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