mirror of https://github.com/abinit/abinit.git
1212 lines
44 KiB
Perl
Executable File
1212 lines
44 KiB
Perl
Executable File
# This script enforces some coding rules on a single Fortran module or a collection of modules from a
|
|
# specific subdirectory or, from current directory and all src/* subdirectories.
|
|
|
|
# Copyright (C) 2001-2025 ABINIT group (LSi)
|
|
# This file is distributed under the terms of the
|
|
# GNU General Public License, see ~abinit/COPYING
|
|
# or http://www.gnu.org/copyleft/gpl.txt .
|
|
# For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
|
|
|
|
# NOTE : under Unix, an abirules script will be automatically generated by
|
|
# the command make perl in the ~abinit directory.
|
|
#
|
|
# USAGE :
|
|
# unix shell: abirules [-l] [-p] [-r] [-v] [-d subdirectory | sourcefile]
|
|
# Windows DOS box: [perl] abirules.pl [-l] [-p] [-r] [-v] [-d subdirectory | sourcefile]
|
|
# Options:
|
|
# -l reorder variables declarations line by line (dcl on different lines won't be merged, nor reordered)
|
|
# -p original source files will be preserved; new files with .abirules
|
|
# suffix will be written into same subdirectory
|
|
# -r don't reorder variables declarations
|
|
# -v verbose mode
|
|
# -d handle files in subdirectory instead of all files in src/*
|
|
#
|
|
$, = ' '; # set output field separator
|
|
$\ = "\n"; # set output record separator
|
|
|
|
# list of supported file types and corresponding file suffixes:
|
|
%Fsufix = ('Fortran','.F90'
|
|
# ,'C','.c' # a future enhancement might include C files
|
|
);
|
|
@Ftypes = keys(%Fsufix); # list of file types only
|
|
#
|
|
@Modules = values(%Fsufix); # modules list defaults to suffixes list
|
|
@SourceDirs = <. src/*>; # directories list defaults to all source subdirs
|
|
$FirstLine = "!{\\src2tex{textfont=tt}}\n"; # very first line of each source file
|
|
# Robodoc definitions
|
|
$RobodocBegin = '!!****'; # Robodoc begin marker
|
|
$RobodocModule = 'm*'; # header type for module
|
|
$RobodocProgram = 'p*'; # header type for module
|
|
$RobodocFunction = 'f*'; # header type for function
|
|
$RobodocInterFun = 'if*'; # header type for internal function
|
|
$ProjectABI = 'ABINIT/'; # project identifier in first line
|
|
# required items in the specified order:
|
|
@RobodocRequ = ('NAME','FUNCTION','COPYRIGHT','INPUTS','OUTPUT','SOURCE');
|
|
@RobodocOpts = ('SIDE','NOTES','WARNINGS','TODO','BUGS','PARENTS','CHILDREN'); # optional items
|
|
$RobodocLast = '!!***'; # should be last line of each source file
|
|
# required items at the begininning of the SOURCE section:
|
|
# statements name and options
|
|
@SourceBegin1 = ('#if','#include','#endif','ProgModSubFuncType','use','implicit');
|
|
@SourceBegin2 = ('defined','"config.h"','','*','defs_basis','none');
|
|
@SourceBegin3 = ('HAVE_CONFIG_H','','','','','');
|
|
$SourceProgIx = 3; # ProgModSubFuncType index in above arrays
|
|
$SourceUseIx = 4; # use index in above arrays
|
|
$SourceImplIx = 5; # implicit index in above arrays
|
|
$NoRules = '!no_abirules'; # directive to suspend variables lists processing
|
|
# The following string is used for sorting variables types in the order:
|
|
# Integer,Real,Complex,Logical,Character,Type()
|
|
# ans restoring the original type after sort.
|
|
$typeSort = 'irclct';
|
|
# Having the same initial as complex, character deserves a special treatment:
|
|
$charSort = 4;
|
|
$debug = 0; # verbose mode defaults to off
|
|
$byLine = 0; # default is merge and reorder all similar declarations
|
|
$reorder = 1; # default is reorder variables declarations
|
|
$preserve = 0; # default is modify source files
|
|
# analyze options and parameters
|
|
$CurARG = 0;
|
|
while (1) {
|
|
if ($ARGV[$CurARG] eq '-l') {
|
|
$byLine = 1; # reorder declarations one line at a time, without merging/reordering lines
|
|
$CurARG++;
|
|
next;
|
|
}
|
|
if ($ARGV[$CurARG] eq '-v') {
|
|
$debug = 1; # verbose mode on
|
|
# $debug = 2; # intensive debugging mode
|
|
$CurARG++;
|
|
next;
|
|
}
|
|
if ($ARGV[$CurARG] eq '-r') {
|
|
$reorder = 0; # don't reorder variables
|
|
$CurARG++;
|
|
next;
|
|
}
|
|
if ($ARGV[$CurARG] eq '-p') {
|
|
$preserve = 1; # leave original source files unchanged
|
|
print 'Source files will be kept unchanged' if ($debug > 0);
|
|
$CurARG ++;
|
|
next;
|
|
}
|
|
last;
|
|
}
|
|
if ($ARGV[$CurARG] eq '-d') { # check if -d subdir
|
|
if (! -d $ARGV[$CurARG+1]) {
|
|
print "Error, directory $ARGV[$CurARG+1] not found";
|
|
exit 16;
|
|
}
|
|
@SourceDirs = ($ARGV[$CurARG+1]); # sources subdirectory
|
|
$CurARG += 2;
|
|
}
|
|
elsif ($ARGV[$CurARG] ne '') {
|
|
$fname = $ARGV[$CurARG];
|
|
$dotx = index($fname,'.');
|
|
$suffix = substr($fname,$dotx); # get file suffix
|
|
while (($ftyp,$fsfx) = each(%Fsufix)) {
|
|
$filetyp = $ftyp if ($suffix eq $fsfx);
|
|
}
|
|
if ($filetyp eq '') {
|
|
print "Unrecognized suffix for file $fname";
|
|
exit 12;
|
|
}
|
|
if (! -e $fname) {
|
|
print "Error, file $fname not found";
|
|
exit 16;
|
|
}
|
|
@Modules = ($fname); # single module file
|
|
%ModTypes = ($fname,$filetyp);
|
|
@SourceDirs = (); # empty directories list
|
|
$CurARG ++;
|
|
}
|
|
if ($ARGV[$CurARG] ne '') {
|
|
print "Unexpected argument: $ARGV[$CurARG]";
|
|
exit 8;
|
|
}
|
|
#
|
|
print "Analyzing modules @Modules in directories @SourceDirs";
|
|
# build modules list
|
|
foreach $dir (@SourceDirs) {
|
|
foreach $ftyp (@Ftypes) {
|
|
if (! -d $dir) {
|
|
print "Skipping $dir, not a directory" if ($debug > 0);
|
|
next;
|
|
}
|
|
print "Searching $dir for $ftyp modules" if ($debug > 0);
|
|
@Files = (<${dir}/*${Fsufix{$ftyp}}> );
|
|
foreach $fname (@Files) {
|
|
%ModTypes = (%ModTypes,
|
|
$fname,$ftyp);
|
|
}
|
|
}
|
|
}
|
|
#
|
|
if ($debug > 0) { # print modules list
|
|
foreach $filetyp (@Ftypes) {
|
|
@Files = ();
|
|
while (($fname,$ftype) = each (%ModTypes)) {
|
|
@Files = (@Files,$fname) if ($ftype eq $filetyp);
|
|
}
|
|
print "$filetyp modules:",@Files;
|
|
}
|
|
}
|
|
# get current year for copyright
|
|
($sec,$min,$hour,$mday,$ymon,$yyear,$wday,$yday,$isdst)=localtime(time);
|
|
$yyear +=1900; # yyear was relative to 1900
|
|
$ymon ++; # was in range 0-11
|
|
# for each module, read the source file and find the Robodoc section
|
|
foreach $fname (keys(%ModTypes)) {
|
|
$rc = open(FILEIN,"<$fname");
|
|
if ($rc eq '') {
|
|
print "Unable to open file $fname, error $rc";
|
|
exit 64;
|
|
}
|
|
print "\nChecking rules in module $fname" if ($debug > 0);
|
|
#
|
|
open(FILEOUT,">$fname.abirules") || die "Unable to open FILEOUT";
|
|
# pick file name in path
|
|
$ix = index($fname,'/');
|
|
$modname = $ix >= 0 ? substr($fname,$ix+1) : $fname;
|
|
$dotx = index($modname,'.');
|
|
$modname = substr($modname,0,$dotx); # suppress suffix
|
|
$added = ' '; # list of added items
|
|
$replc = ''; # replaced item(s)
|
|
$repchar = ''; # replaced character
|
|
$repcont = ''; # replaced continue
|
|
$repend = ''; # replaced end
|
|
# read the source file
|
|
$linect = 0; # line counter
|
|
$phase = 0; # phase number 0 to 6
|
|
$ProgLvl = 0; # program/subroutine level
|
|
$cppif = 0; # flag for preprocessor if block
|
|
$cppincl = 0; # flag for include-config.h block
|
|
$suspend = 0; # flag for suspending variables lists processing
|
|
$DEBUGblk = 0; # flag for DEBUG block
|
|
$CopyR = 0; # flag for single copyright
|
|
$ModIntFc = 0; # flag for interface within a Fortran module
|
|
$assumeFun = 0; # function assumed if first line of header is missing
|
|
$RelTime = 0; # flags for herald Release Time
|
|
READLOOP:
|
|
while ($line = <FILEIN>) {
|
|
# Phase 0: make sure src2tex directive is ahead
|
|
$len = length($line);
|
|
$linect ++;
|
|
if ($phase == 0) {
|
|
$len1 = length($FirstLine);
|
|
&WriteLine($FirstLine,$len1); # always write src2tex directive
|
|
$phase = 1;
|
|
next if ($line eq $FirstLine); # read next line if expected directive
|
|
print 'Inserting src2tex directive ahead' if ($debug > 1);
|
|
$added = ' src2tex ';
|
|
}
|
|
($wd1,$wd2,$wd3,$wd4,$wd5,$wd6,$wd7,$wd8,$wd9,$wd10,$wd11,$wd12,$wd13,$wd14,$wd15) = split(' ',$line);
|
|
# Phase 1: make sure Robodoc module header follows
|
|
if ($phase == 1) {
|
|
if ($EndRobodoc >= 1 && $wd1 eq '') {
|
|
&WriteLine($line,$len); # write null or blank line
|
|
next READLOOP;
|
|
}
|
|
$wd1head = substr($wd1,0,6);
|
|
$phase = 2;
|
|
$itemNum = 0;
|
|
$section = '';
|
|
$saveline = '';
|
|
$EndRobodoc = 0; # flag for end of Robodoc header
|
|
if ($wd1head eq $RobodocBegin) {
|
|
$hdrtyp = substr($wd1,6);
|
|
# check project
|
|
$ix = index($wd2,'/');
|
|
if($ix > 0) {
|
|
$pjct = substr($wd2,0,$ix+1); # get what should be the project name
|
|
$sub = substr($wd2,$ix+1); # get what should be the subroutine/module name
|
|
print "Robodoc header $hdrtyp $pjct $sub begins at line $linect" if ($debug > 1);
|
|
}
|
|
else {
|
|
$pjct = '';
|
|
$sub = '';
|
|
}
|
|
if ($hdrtyp eq $RobodocModule || $hdrtyp eq $RobodocProgram || $hdrtyp eq $RobodocFunction) {
|
|
# starting header for program, module or stand-alone function, check name
|
|
if ( $sub ne $modname ) {
|
|
print "Warning: found \'$sub\' instead of module name in first header line" if ($debug > 0);
|
|
}
|
|
$subname = $sub ne '' ? $sub : $modname; # use module or sub name
|
|
if ($pjct ne $ProjectABI ) {
|
|
print "Warning: found \'$pjct\' as project name in first header line" if ($debug > 0);
|
|
$line1 = "$RobodocBegin$hdrtyp $ProjectABI$subname\n"; # correct...
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # ...first line of header and write it
|
|
$replc .= 'Project ';
|
|
next; # ignore wrong line
|
|
}
|
|
}
|
|
if ($hdrtyp eq $RobodocInterFun) {
|
|
if ($sub eq $modname) {
|
|
print "Warning: found \'$sub\' as internal subroutine name same as module " if ($debug > 0);
|
|
}
|
|
$subname = $sub; # use name from first header line
|
|
}
|
|
}
|
|
else {
|
|
if ($ModIntFc == 0) {
|
|
if ($wd1 eq 'subroutine' || $wd1 eq 'function') {
|
|
# subroutine found instead of header outside an interface; drop subroutine (arguments
|
|
$ix = index($wd2,'(');
|
|
$subname = $ix > 0 ? substr($wd2,0,$ix) : $wd2;
|
|
$hdrtyp = $RobodocInterFun;
|
|
$FunType = ' internal';
|
|
}
|
|
else {
|
|
$subname = $modname;
|
|
$assumeFun = 1;
|
|
$hdrtyp = $RobodocFunction;
|
|
$FunType = '';
|
|
}
|
|
$line1 = "$RobodocBegin$hdrtyp $ProjectABI$subname\n"; # build first line of header
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write first header line if missing, function assumed
|
|
print "Missing first line of header has been inserted assuming:$FunType function $subname" if ($debug > 0);
|
|
$added .= $hdrtyp;
|
|
}
|
|
}
|
|
}
|
|
# Phase 2: check the presence of defined Robodoc sections
|
|
$wd1char1 = substr($wd1,0,1);
|
|
if ($phase == 2) {
|
|
if ($wd1 ne '' && $wd1char1 ne '!') {
|
|
# save current line and insert SOURCE
|
|
print "Found \'$wd1 $wd2\' at line $linect while expecting $RobodocRequ[$itemNum]; SOURCE inserted" if ($debug > 0);
|
|
$saveline = $line;
|
|
$savelen = $len;
|
|
$line = "!! SOURCE\n";
|
|
$len = length($line);
|
|
$wd1 = '!!';
|
|
$wd2 = 'SOURCE';
|
|
}
|
|
if ($wd1 eq '!!') {
|
|
if ($section eq 'NAME') { # check subroutine name
|
|
$line1 = "!! $wd2\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write subroutine name
|
|
$section = '';
|
|
next if ($wd2 eq $subname); # skip if expected name
|
|
print "Warning: \'$wd2\' was found in subroutine NAME section instead of $subname and will be used from now on" if ($debug > 0);
|
|
$subname = $wd2;
|
|
$replc .= 'Name ';
|
|
($item = $wd2) =~ tr/a-z/A-Z/; # copy, then translate lowercase to uppercase
|
|
next if ($item ne $wd2); # ignore line if no Robodoc section name
|
|
}
|
|
if ($section eq 'COPYRIGHT' && $wd2 eq 'Copyright' && $wd3 eq '(C)') { # check current year
|
|
$len2 = length($wd4);
|
|
$wd4tail = substr($wd4,-4,4); # $wd4 should be yyyy or yyy1-yyy2
|
|
$wd4ix = index($line,$wd4);
|
|
$line1 = $line;
|
|
if ($wd4tail ne $yyear) {
|
|
if ($len2 == 4) {
|
|
substr($line1,$wd4ix,4) = $wd4.'-'.$yyear;
|
|
}
|
|
elsif ($len2 == 9) {
|
|
substr($line1,$wd4ix+4,5) = '-'.$yyear;
|
|
}
|
|
else {
|
|
print "Copyright year format error: $wd4";
|
|
}
|
|
}
|
|
$section = '';
|
|
if ($line1 ne $line) {
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write Copyright line
|
|
print "Copyright year $wd4 has been corrected" if ($debug > 1);
|
|
$replc .= 'CopyYear ';
|
|
next; # ignore wrong line
|
|
}
|
|
$CopyR = 1; # set Copyrignt found
|
|
}
|
|
($item = $wd2) =~ tr/a-z/A-Z/; # copy, then translate lowercase to uppercase
|
|
if ($item eq $wd2) { # was already uppercased ?
|
|
if ($wd2 eq $RobodocRequ[$itemNum]) { # expected section ?
|
|
print "Found $wd2 item at line $linect" if ($debug > 1);
|
|
if ($wd2 eq 'SOURCE') {
|
|
$phase = 3; # phase 3: read source
|
|
$itemNum = 0;
|
|
}
|
|
else {
|
|
$section = $wd2;
|
|
$itemNum ++;
|
|
}
|
|
}
|
|
elsif ($RobodocRequ[$itemNum] eq 'SOURCE') { # check for optional section preceding SOURCE
|
|
for ($ix = 0; $ix <= $#RobodocOpts; $ix ++) {
|
|
if ($wd2 eq $RobodocOpts[$ix]) {
|
|
print "Found optional item $wd2 at line $linect" if ($debug > 1);
|
|
$section = $wd2;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
else { # check for misplaced required section
|
|
for ($ix = 0; $ix <= $#RobodocRequ; $ix ++) {
|
|
last if ($wd2 eq $RobodocRequ[$ix]);
|
|
}
|
|
if ($ix <= $#RobodocRequ) {
|
|
print "Warning, expecting item $RobodocRequ[$itemNum], found $wd2 at line $linect" if ($debug > 1);
|
|
if ($ix < $itemNum) {
|
|
print "Duplicate section $wd2 skipped" if ($debug > 0);
|
|
next;
|
|
}
|
|
else {
|
|
# write missing sections
|
|
for ($iy = $itemNum ; $iy < $ix; $iy ++) {
|
|
$sectype = 'dummy';
|
|
$line1 = "!! $RobodocRequ[$iy]\n"; # Robodoc section name
|
|
$len1 = length($line1);
|
|
if ($RobodocRequ[$iy] eq 'COPYRIGHT') {
|
|
if ($CopyR == 0) {
|
|
&WriteLine($line1,$len1); # write section name
|
|
$line1 = "!! Copyright (C) $yyear ABINIT group ( ).\n"; # initials left blank
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write copyright line 1
|
|
$line1 = "!! This file is distributed under the terms of the\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write copyright line 2
|
|
$line1 = "!! GNU General Public License, see ~abinit/COPYING\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write copyright line 3
|
|
$line1 = "!! or http://www.gnu.org/copyleft/gpl.txt .\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write copyright line 4
|
|
$line1 = "!! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write copyright line 5
|
|
$sectype = '';
|
|
$CopyR = 1;
|
|
}
|
|
else {
|
|
$sectype = 'skip';
|
|
print 'COPYRIGHT item will only be written once' if ($debug >= 2);
|
|
}
|
|
}
|
|
else {
|
|
&WriteLine($line1,$len1); # write section name
|
|
if ($RobodocRequ[$iy] eq 'NAME') {
|
|
$line1 = "!! $subname\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write subroutine name
|
|
$sectype = '';
|
|
}
|
|
}
|
|
if ($sectype ne 'skip') {
|
|
$line1 = "!!\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write robodoc empty line
|
|
print "Wrote $sectype $RobodocRequ[$iy] section" if ($debug > 0);
|
|
$added .= $RobodocRequ[$iy].' ';
|
|
}
|
|
} # end for $iy
|
|
if ($wd2 eq 'SOURCE') {
|
|
if ($saveline ne '') {
|
|
&WriteLine($line,$len) ; # write SOURCE
|
|
$line = $saveline; # restore saved line
|
|
$len = $savelen;
|
|
($wd1,$wd2,$wd3,$wd4,$wd5,$wd6,$wd7,$wd8,$wd9,$wd10,$wd11,$wd12,$wd13,$wd14,$wd15) = split(' ',$line);
|
|
$saveline = '';
|
|
}
|
|
$phase = 3; # phase 3: read source
|
|
$itemNum = 0;
|
|
}
|
|
else {
|
|
$section = $wd2;
|
|
$itemNum = $ix + 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
# end of phase 2 processing
|
|
# phases 3 and subsequent: check Robodoc last line
|
|
if ($phase >= 3) {
|
|
if ($wd1 eq "$RobodocBegin$RobodocInterFun" || $wd1 eq "$RobodocBegin$RobodocFunction") {
|
|
# internal function header type has been found, prepare to process it
|
|
# check project
|
|
$ix = index($wd2,'/');
|
|
$pjct = substr($wd2,0,$ix+1) if($ix > 0); # get what should be the project name
|
|
$subname = substr($wd2,$ix+1); # get the subroutine/module name
|
|
if ($pjct ne $ProjectABI) {
|
|
print "Warning: project name \'$pjct\' found in header" if ($debug > 0);
|
|
}
|
|
print "Header with (internal) function type found at line $linect, sub= $subname" if ($debug >= 2);
|
|
print "Warning ! Function header begins in the middle of an interface section" if ($ModIntFc == 1 && $debug > 0);
|
|
if ($EndRobodoc == 0) {
|
|
print "Writing Robodoc fence before header, line $linect" if ($debug > 1);
|
|
&WriteLine("$RobodocLast\n",6); # insert Robodoc fence if missing
|
|
$added .= '*** ';
|
|
}
|
|
$phase = 2;
|
|
$EndRobodoc = 0;
|
|
$ProgLvl = 0; # reset program/subroutine level
|
|
$cppif = 0; # flag for preprocessor if block
|
|
$cppincl = 0; # flag for include-config.h block
|
|
$suspend = 0; # flag for suspending variables lists processing
|
|
$DEBUGblk = 0; # flag for DEBUG block
|
|
$itemNum = 0;
|
|
$section = '';
|
|
}
|
|
elsif ($EndRobodoc == 1) {
|
|
print "Warning: unexpected source line follows Robodoc fence in file $fname, line $linect";
|
|
$EndRobodoc = 2; # to print above error message only once
|
|
}
|
|
# turn flag on if Robodoc last line was found
|
|
if ($EndRobodoc == 0 && $wd1 eq $RobodocLast) {
|
|
print "Robodoc fence encountered at line $linect" if ($debug > 1);
|
|
$EndRobodoc = 1;
|
|
$phase = 1; # search for a possible following robodoc header if
|
|
}
|
|
}
|
|
$char1 = substr($line,0,1);
|
|
$wd1hd9 = substr($wd1,0,9);
|
|
$wd2head = substr($wd2,0,9);
|
|
if ($phase == 3) {
|
|
# phase 3: process SOURCE section
|
|
# handle cpp directives - identify #if - #endif blocks
|
|
if ($char1 eq '#') {
|
|
if ($wd1 eq '#if' || $wd1 eq '#ifdef' || $wd1 eq '#ifndef' || ($wd1 eq '#' && $wd2 eq 'if')) {
|
|
if (($wd1 eq '#if' && $wd2 eq $SourceBegin2[0] && $wd3 eq $SourceBegin3[0]) || ($wd2 eq 'if' && $wd3 eq $SourceBegin2[0] && $wd4 eq $SourceBegin3[0]) ) {
|
|
# remember #if defined CONFIG, count and drop
|
|
print "Found $SourceBegin2[0] $SourceBegin3[0] at line $linect" if ($debug > 1);
|
|
$cppincl ++;
|
|
next READLOOP;
|
|
}
|
|
$cppif ++; # remember cpp if-block
|
|
if ($cppif == 1) {
|
|
$saveif = $line;
|
|
$savetell = tell(FILEOUT); # save for possible backing up
|
|
}
|
|
}
|
|
elsif ($wd1 eq '#endif' || ($wd1 eq '#' && $wd2 eq 'endif')) {
|
|
if ($cppincl > 0) {
|
|
$cppincl --;
|
|
next READLOOP; # drop #endif corresponding to #if defined CONFIG
|
|
}
|
|
$cppif --; # end of cpp if-block
|
|
$saveif = '' if ($cppif == 0);
|
|
}
|
|
elsif ($wd1 eq $SourceBegin1[1] && $wd2 eq $SourceBegin2[1]) {
|
|
print "Found $SourceBegin1[1] $SourceBegin2[1] at line $linect" if ($debug > 1);
|
|
# drop [duplicate] #include config
|
|
next READLOOP;
|
|
}
|
|
}
|
|
# check for neither comment, nor cpp directive, nor continuation, nor null line
|
|
elsif ($char1 ne '!' && $char1 ne '&' && $char1 ne "\n" && $wd1 ne '') { # ignore line otherwise
|
|
# following SOURCE we should have 1st the #if defined config-#endif block
|
|
if ($itemNum == 0) {
|
|
for ($ii = 0; $ii < $SourceProgIx; $ii ++) {
|
|
$line1 = $ii == 0 ? "\n$SourceBegin1[$ii]" : "$SourceBegin1[$ii]";
|
|
$line1 .= " $SourceBegin2[$ii]" if ($SourceBegin2[$ii] ne '');
|
|
$line1 .= " $SourceBegin3[$ii]" if ($SourceBegin3[$ii] ne '');
|
|
$line1 .= "\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write #if defined config line 1
|
|
}
|
|
print "Wrote $SourceBegin2[0] $SourceBegin3[0] block" if ($debug > 1);
|
|
$itemNum = $SourceProgIx;
|
|
}
|
|
# ... and 2nd the program or subroutine definition
|
|
if ($SourceBegin1[$itemNum] eq 'ProgModSubFuncType') {
|
|
if ($wd1 eq 'program' || $wd1 eq 'module' || $wd1 eq 'MODULE' || $wd1 eq 'interface' || $wd1 eq 'subroutine' || $wd1 eq 'function' || $wd1 eq 'type' ) {
|
|
&HndlProg($wd1,$wd2);
|
|
}
|
|
elsif ( ($wd2 eq 'function') && ($wd1 eq 'integer' || $wd1 eq 'complex' || $wd1 eq 'logical' || $wd1hd9 eq 'character') ){
|
|
&HndlProg($wd2,$wd3);
|
|
}
|
|
elsif ( ($wd3 eq 'function') && $wd1 eq 'double' && $wd2 eq 'precision') {
|
|
&HndlProg($wd3,$wd4);
|
|
}
|
|
elsif ( $wd1 eq 'end') {
|
|
$ProgLvl --;
|
|
$ModIntFc = 0 if ( $wd2 eq 'interface' || ( $wd2 eq '' && $ProgType[$ProgLvl] eq 'interface' ) );
|
|
}
|
|
else {
|
|
print "Error: found $wd1 at line $linect while expecting program/subroutine";
|
|
last;
|
|
}
|
|
}
|
|
else {
|
|
for ($ii = $SourceProgIx + 1; $ii <= $#SourceBegin1; $ii ++) {
|
|
if ($wd1 eq $SourceBegin1[$ii] && $wd2 eq $SourceBegin2[$ii]) {
|
|
print "Found $wd1 $wd2 at line $linect - skipped" if ($debug > 1);
|
|
next READLOOP;
|
|
}
|
|
} # end for $ii
|
|
if ($SourceBegin1[$itemNum] eq 'use' && $wd1 ne 'use') {
|
|
if ($wd1 eq 'include' && $cppif >= 1 && $saveif ne '') {
|
|
die "Perl ERROR: 0 returned by tell" if ($savetell == 0);
|
|
seek(FILEOUT,$savetell,0);
|
|
print "Backing up to $savetell before #if block" if ($debug > 1);
|
|
}
|
|
else {
|
|
$saveif = '';
|
|
}
|
|
# implicit MUST be inserted AFTER ALL use and BEFORE the first include EVEN IF THE LATTER IS
|
|
# IN A #if-#endif BLOCK
|
|
# insert implicit before 1st line that is neither blank, nor use
|
|
print "implicit statement inserted before $wd1" if ($debug > 1);
|
|
$line2 = "\n implicit $SourceBegin2[$SourceImplIx]\n\n";
|
|
$len2 = length($line2);
|
|
&WriteLine($line2,$len2); # write implicit here
|
|
if ($cppif >= 1 && $saveif ne '') {
|
|
$len2 = length($saveif);
|
|
&WriteLine($saveif,$len2); # rewrite #if
|
|
$saveif = '';
|
|
}
|
|
$replc .= 'implicit ';
|
|
$itemNum ++;
|
|
}
|
|
} # end if $SourceBegin1[$itemNum]
|
|
} # end if $char1
|
|
elsif ($wd1 eq '') {
|
|
next READLOOP;
|
|
}
|
|
else {
|
|
# SOURCE subsections: arguments, local variables, executable
|
|
$wd1hd20 = substr($wd1,0,20);
|
|
if (($wd1 eq '!Arguments' && $wd2head eq '---------') || $wd1hd20 eq '!Arguments----------') {
|
|
if ($SourceBegin1[$itemNum] eq 'use') {
|
|
# insert implicit before arguments subsection
|
|
print "implicit statement inserted before $wd1hd20" if ($debug > 1);
|
|
$line2 = "\n implicit $SourceBegin2[$SourceImplIx]\n\n";
|
|
$len2 = length($line2);
|
|
&WriteLine($line2,$len2);
|
|
$replc .= 'implicit ';
|
|
}
|
|
print "Arguments subsection encountered at line $linect" if ($debug > 1);
|
|
$phase = 4;
|
|
$nodeclar = 0; # counter for unrecognized declarations
|
|
}
|
|
}
|
|
} # end of phase 3 processing
|
|
if ($phase == 4) {
|
|
# Phase 4: record arguments
|
|
if ($wd1 eq $NoRules) {
|
|
$suspend = 1; # turn on flag to suspend variables lists processing
|
|
&WriteDefs('arguments') if($byLine == 0); # write all arguments
|
|
}
|
|
$wd1ch1 = substr($wd1,0,1);
|
|
if ($wd1 eq '!Local' && $wd2head eq 'variables') {
|
|
print "Local variables subsection encountered at line $linect" if ($debug > 1);
|
|
&WriteDefs('arguments') if($byLine == 0); # write all arguments
|
|
$line2 = "\n";
|
|
&WriteLine($line2,1);
|
|
$phase = 5;
|
|
$suspend = 0; # make sure flag is off to resume variables lists processing
|
|
$nodeclar = 0; # counter for unrecognized declarations
|
|
}
|
|
elsif ($char1 ne '!' && $wd1 ne '' && $wd1ch1 ne '!') { # ignore comments and null lines
|
|
&BuildVarList; # build list of associated arrays for arguments
|
|
&WriteDefs('arguments') if($byLine == 1); # write arguments declared in this line
|
|
next; # skip copy to FILEOUT
|
|
}
|
|
elsif ($wd1 eq '' || $wd1 eq '!scalars' || $wd1 eq '!arrays') {
|
|
next READLOOP; # skip copy to FILEOUT
|
|
}
|
|
}
|
|
# Phase 5: record local variables
|
|
if ($phase == 5) {
|
|
if ($wd1 eq $NoRules) {
|
|
$suspend = 1; # turn on flag to suspend variables lists processing
|
|
&WriteDefs('local vars') if($byLine == 0); # write all local variables
|
|
}
|
|
$wd1ch1 = substr($wd1,0,1);
|
|
$wd1head = substr($wd1,0,10);
|
|
if ($wd1head eq '!*********' || $wd1head eq '!Interface' || ($wd1 eq '!' && $wd2head eq '*********')) {
|
|
print "Executable subsection encountered at line $linect" if ($debug > 1);
|
|
&WriteDefs('local vars') if($byLine == 0); # write all local variables
|
|
$line2 = "\n";
|
|
&WriteLine($line2,1);
|
|
$phase = 6;
|
|
}
|
|
elsif ($char1 ne '!' && $wd1 ne '' && $wd1ch1 ne '!') { # ignore comments and null lines
|
|
&BuildVarList; # build list of associated arrays for local variables
|
|
&WriteDefs('local vars') if($byLine == 1); # write local variables declared in this line
|
|
next; # skip copy to FILEOUT
|
|
}
|
|
elsif ($wd1 eq '' || $wd1 eq '!scalars' || $wd1 eq '!arrays') {
|
|
next READLOOP; # skip copy to FILEOUT
|
|
}
|
|
}
|
|
# Phase 6:
|
|
# a) check DEBUG blocks
|
|
$wd1char1 = substr($wd1,0,1);
|
|
if ($phase == 6) {
|
|
if ($wd1 eq '!DEBUG' || ($wd1 eq '!' && $wd2 eq 'DEBUG') ) { # test begin of DEBUG block
|
|
$DEBUGblk = $linect;
|
|
}
|
|
elsif ($wd1 eq '!ENDDEBUG' || $wd1 eq '!ENDEBUG' || ($wd1 eq '!' && $wd2 eq 'ENDDEBUG') || ($wd1 eq '!END' && $wd2 eq 'DEBUG') ) { # test end of DEBUG block
|
|
$DEBUGblk = 0;
|
|
}
|
|
elsif ($DEBUGblk > 0 && $wd1char1 ne '!' && $wd1 ne '') { # non commented line within DEBUG block ?
|
|
print "Warning ! Uncommented line found at line $linect within DEBUG block";
|
|
$DEBUGblk = 0; # reset flag to print above message only once
|
|
}
|
|
# b) reformat enddo, endif
|
|
if ($char1 ne '!') {
|
|
$line =~ s/enddo/end do/i;
|
|
$line =~ s/endif/end if/i if ($char1 ne "#");
|
|
$len = length($line);
|
|
# c) check for goto
|
|
$ix = index ($line,'goto');
|
|
print "Warning ! goto statement found at line $linect" if ($ix >= 0);
|
|
}
|
|
# d) record subprogram type and name to check subsequent end statement
|
|
if ($wd1 eq 'subroutine' || $wd1 eq 'interface' || $wd1 eq 'function') {
|
|
&HndlProg($wd1,$wd2);
|
|
}
|
|
elsif (($wd2 eq 'function') && ($wd1 eq 'integer' || $wd1 eq 'complex' || $wd1 eq 'logical' || $wd1hd9 eq 'character') ){
|
|
&HndlProg($wd2,$wd3);
|
|
}
|
|
elsif ($wd3 eq 'function' && $wd1 eq 'double' && $wd2 eq 'precision') {
|
|
&HndlProg($wd3,$wd4);
|
|
}
|
|
# e) check end statements
|
|
if ($wd1 eq 'end' && ($wd2 eq 'subroutine' || $wd2 eq 'module' || $wd2 eq 'interface' || $wd2 eq 'function' || $wd2 eq '') ) {
|
|
$ProgLvl --;
|
|
if ($ProgType[$ProgLvl] ne $wd2 || $ProgName[$ProgLvl] ne $wd3) {
|
|
$line = "end $ProgType[$ProgLvl] $ProgName[$ProgLvl]\n";
|
|
$len = length($line);
|
|
$repend = 'end ';
|
|
}
|
|
print "End $ProgType[$ProgLvl] $ProgName[$ProgLvl] level $ProgLvl encountered at line $linect" if ($debug > 1);
|
|
if ($ModIntFc == 1) { # reset for next subroutine if any
|
|
$itemNum = 0;
|
|
$phase = 3;
|
|
}
|
|
$ModIntFc = 0 if ($ProgType[$ProgLvl] eq 'interface');
|
|
print "ERROR: RELEASE TIME section incomplete in $wd3" if ($subname eq 'herald' && $RelTime > 0);
|
|
}
|
|
# f) record do labels to replace subsequent continue by end do[s]
|
|
if ($wd1 eq 'do' && ($wd2 =~ m/^[0-9]+/) ) {
|
|
if ($LabCnt{$wd2} eq '') {
|
|
$LabCnt{$wd2} = 1;
|
|
}
|
|
else {
|
|
$LabCnt{$wd2} ++;
|
|
}
|
|
$line =~ s/ $wd2 / /;
|
|
$len = length($line);
|
|
}
|
|
# g) replace continue statements that terminate a do loop
|
|
if (($wd1 =~ m/[0-9]+/) && $wd2 eq 'continue') {
|
|
if ($LabCnt{$wd1} ne '') {
|
|
for ($ix =0; $ix < $LabCnt{$wd1};$ix ++) {
|
|
&WriteLine("end do\n",7);
|
|
}
|
|
delete $LabCnt{$wd1};
|
|
$repcont = 'continue ';
|
|
next;
|
|
}
|
|
}
|
|
# h) handle year+month in herald RELEASE TIME section
|
|
if ($subname eq 'herald'){
|
|
if ($wd1 eq '!END' && $wd3 eq 'RELEASE' && $wd4 eq 'TIME') {
|
|
if (($RelTime & 2) != 2) { # check RELEASE TIME section full
|
|
$line1 = " yyyy_rel=$yyear\n"; # set current year as value
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write missing assignment
|
|
$added .= 'RelTyy ';
|
|
}
|
|
if ($RelTime < 4) { # check RELEASE TIME section full
|
|
$line1 = " mm_rel=$ymon\n"; # set current month# as value
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write missing assignment
|
|
$added .= 'RelTmm ';
|
|
}
|
|
print "Release Time processing completed in herald" if ($debug > 1);
|
|
$RelTime = 0;
|
|
}
|
|
elsif ($RelTime >= 1) {
|
|
if ($line =~ m/yyyy_rel\s*=.*/ ) {
|
|
$line = " yyyy_rel=$yyear\n"; # set current year as value
|
|
$len = length($line);
|
|
$RelTime = $RelTime | 2; # turn on next to last bit
|
|
$replc .= 'RelTyy ';
|
|
}
|
|
if ($line =~ m/mm_rel\s*=.*/) {
|
|
$line = " mm_rel=$ymon\n"; # set current month# as value
|
|
$len = length($line);
|
|
$RelTime = $RelTime | 4; # turn on previous bit
|
|
$replc .= 'RelTmm ';
|
|
}
|
|
}
|
|
elsif ($wd1 eq '!RELEASE' && $wd2 eq 'TIME' && $wd4 eq 'ABIRULES') {
|
|
print "Release Time encountered in herald at line $linect" if ($debug > 1);
|
|
$RelTime = 1; # turn on one bit
|
|
}
|
|
}
|
|
}
|
|
# Phases 2 and subsequent: copy line from input file to FILEOUT
|
|
&WriteLine($line,$len);
|
|
} # end while <FILEIN
|
|
# end of file has been hit
|
|
# Phase 6: make sure Robodoc last line is present
|
|
if ($phase == 6 && $EndRobodoc == 0) {
|
|
print "Writing Robodoc fence after line $linect" if ($debug > 1);
|
|
&WriteLine("$RobodocLast\n",6); # insert Robodoc fence at end of file
|
|
$added .= '*** ';
|
|
}
|
|
close (FILEOUT);
|
|
close (FILEIN);
|
|
# were all sections and statements encountered ?
|
|
if ($phase < 6 && $phase > 1) {
|
|
print "ERROR: end of file $fname hit before SOURCE section - $RobodocRequ[$itemNum] was expected" if ($phase == 2);
|
|
if ($phase == 3) {
|
|
if ($itemNum < $#SourceBegin1) {
|
|
print "ERROR: end of file $fname hit before encountering $SourceBegin1[$itemNum]";
|
|
}
|
|
else {
|
|
print "ERROR: end of file $fname hit before encountering Arguments section";
|
|
}
|
|
}
|
|
print "ERROR: end of file $fname hit before encountering Local variables section" if ($phase == 4);
|
|
print "ERROR: delimitor for executable section missing in $fname" if ($phase == 5);
|
|
%definitions = (); # clear associative array
|
|
next; # process next subroutine
|
|
}
|
|
# rename files if preserve option (-p) has not been specified
|
|
if ($preserve == 0) {
|
|
unlink ("$fname.old"); # suppress .old file
|
|
$rc = rename($fname,"$fname.old");
|
|
if ($rc != 1) {
|
|
print "Error $! renaming $fname to $fname.old";
|
|
exit 120;
|
|
}
|
|
$rc = rename("$fname.abirules","$fname");
|
|
if ($rc != 1) {
|
|
print "Error $! renaming $fname.abirules to $fname";
|
|
exit 140;
|
|
}
|
|
}
|
|
$replc .= $repchar.$repcont.$repend;
|
|
print "Added:$added; Replaced: $replc" if ($debug >= 1);
|
|
print "Module $fname processing completed";
|
|
print " phase $phase item $itemNum " if($debug > 1);
|
|
}
|
|
|
|
exit;
|
|
# ***************************
|
|
sub BuildVarList {
|
|
# Purpose: build definition lists for arguments (phase 4) or local variables (phase 5)
|
|
# Common variables: $line,$char1,$wd1,$len,$linect
|
|
if ($reorder == 0 || $suspend == 1) {
|
|
&WriteLine($line,$len); # copy declaration without processing (no reorder)
|
|
return;
|
|
}
|
|
$linect1 = $linect;
|
|
# handle declarations within cpp #if-#endif block
|
|
# handle cpp directives - identify #if - #endif blocks
|
|
if ($char1 eq '#') {
|
|
if ($wd1 eq '#if' || $wd1 eq '#ifdef' || $wd1 eq '#ifndef' || ($wd1 eq '#' && $wd2 eq 'if')) {
|
|
$cppif ++; # remember cpp if-block
|
|
}
|
|
elsif ($wd1 eq '#endif' || ($wd1 eq '#' && $wd2 eq 'endif')) {
|
|
$cppif --; # end of cpp if-block
|
|
}
|
|
&WriteLine($line,$len); # copy cpp directive without processing
|
|
return;
|
|
}
|
|
# handle declarations within cpp #if-#endif block
|
|
if ($cppif > 0 && $byLine == 0) {
|
|
&WriteLine($line,$len); # copy declaration without processing (no reorder)
|
|
return;
|
|
}
|
|
# handle in-line comments
|
|
$ix = index ($line,'!');
|
|
if ($ix >= 0) {
|
|
$line2 = substr($line,$ix); # copy comment
|
|
$len2 = length($line2);
|
|
&WriteLine($line2,$len2); # write comment here as a separate line
|
|
$line = substr($line,0,$ix)."\n"; # drop comment, append newline
|
|
$len = $ix + 1;
|
|
}
|
|
# handle continuations
|
|
while (1) {
|
|
$_ = $line;
|
|
$hit = m/(.*)(&\s*$)/; # search trailing &
|
|
last if (! $hit);
|
|
$line = $1; # drop &
|
|
while (1) {
|
|
$line2 = <FILEIN>;
|
|
$linect ++;
|
|
$char2 = substr($line2,0,1);
|
|
last if ($char2 ne '!');
|
|
$len2 = length($line2);
|
|
&WriteLine($line2,$len2); # write comment line here
|
|
}
|
|
$_ = $line2;
|
|
$hit = m/(^\s*&)(.*$)/; # search leading &
|
|
$line .= $hit ? $2."\n" : $line2; # drop &
|
|
# handle in-line comments in continuations
|
|
$ix = index ($line,'!');
|
|
if ($ix >= 0) {
|
|
$line2 = substr($line,$ix); # copy comment
|
|
$len2 = length($line2);
|
|
&WriteLine($line2,$len2); # write comment here as a separate line
|
|
$line = substr($line,0,$ix)."\n"; # drop comment, append newline
|
|
}
|
|
$len = length($line);
|
|
}
|
|
#
|
|
$_ = $line;
|
|
y/ //d; # strip blanks off $_
|
|
# Replace character(*) statements
|
|
$ix = s/character\(\*\)/character(len=\*)/;
|
|
$iy = $ix;
|
|
# Replace character* statements
|
|
if ( /character\*/ ) {
|
|
if ( /character\*\(/ ) {
|
|
$ix = s/character\*\(([^\)]*)\)(.*)/character(len=$1)$2/;
|
|
$iy = $iy +$ix;
|
|
}
|
|
else {
|
|
$ix = s/character\*([0-9]+)(.*)/character(len=$1)$2/;
|
|
$iy = $iy +$ix;
|
|
}
|
|
}
|
|
$repchar = 'character ' if ($iy > 0);
|
|
print "character statement at line $linect1 changed to:$_" if ($iy > 0 && $debug > 1);
|
|
$hit = m/(.*)(::)(.*)/; # check for general form declaration statement
|
|
if ($hit) {
|
|
# general form declaration
|
|
# WARNING ! attributes containing commas are not yet supported
|
|
($_,@attrib) = split(',',$1); # separate type from attributes list
|
|
# sort attributes list - declarations with attributes in different order will be merged
|
|
@Attr = sort(@attrib);
|
|
# attrSort is a character used for sorting declarations: 1-6 for priority attribute,
|
|
# 7 for no attribute, 8-9 for low-priority attribute
|
|
$attrSort = '7'; # no attribute
|
|
foreach $atrb (@Attr) { # set digit for sorting declarations according to some attribute
|
|
$atr19 = substr($atrb,0,9);
|
|
if ($atr19 eq 'dimension') { # dimension attribute is not allowed (comma, parenthesis)
|
|
print "Warning ! Dimension attribute found - line $linect1 not processed";
|
|
&WriteLine($line,$len); # copy declaration without processing (no reorder)
|
|
return;
|
|
}
|
|
if ($atrb eq 'parameter') {
|
|
$attrSort = '1' ;
|
|
last;
|
|
}
|
|
elsif ($atrb eq 'save') {
|
|
$attrSort = '2' ;
|
|
last;
|
|
}
|
|
elsif ($atrb eq 'allocatable') {
|
|
$attrSort = '8' ;
|
|
}
|
|
else { # non-priority attribute
|
|
$attrSort = '9' if ($attrSort eq '7');
|
|
}
|
|
}
|
|
$attributes = $attrSort.join(',',@Attr);
|
|
$VarList = $3;
|
|
}
|
|
else { # old fashion declaration
|
|
$attributes = '7'; # no attribute
|
|
$VarList = ''; # remember old fashion
|
|
}
|
|
# check type against some patterns
|
|
$hitparam = m/(parameter\()(.*)/i;
|
|
if ($hitparam) {
|
|
print "Warning ! Parameter statement found - line $linect1 not processed";
|
|
&WriteLine($line,$len); # copy attribute without merging with declaration
|
|
return;
|
|
}
|
|
$TypeAttr = '';
|
|
$hitchar = m/(character\*?)(.*)/i if ($2 eq '::'); # general form character
|
|
$TypeAttr = $1.$2 if ($hitchar);
|
|
if ($VarList eq '') { # old fashion character
|
|
$hitchar = m/(character\()(len=.*\))(.*)/i;
|
|
if ($hitchar) {
|
|
# WARNING ! $1,$2,$3 are LOCAL to the block
|
|
if ( $3 ne '') {
|
|
$VarList = $3;
|
|
$TypeAttr = $1.$2;
|
|
}
|
|
else {
|
|
print "Warning ! Unable to decode character statement - line $linect1 not processed";
|
|
&WriteLine($line,$len); # copy statement without processing (no reorder)
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
$hitint = m/(integer)(\*[24])?(.*)/i;
|
|
$hitdouble = m/(double)(precision)(.*)/i;
|
|
$hitdblcplx = m/(double)(complex)(.*)/i;
|
|
$hitreal4 = m/(real)(\*4)(.*)/i;
|
|
$hitreal8 = $hitreal4 ? 0 : m/(real)(\*8)?(.*)/i;
|
|
$hitrealk = m/(real)(kind\(.*\))(.*)/i;
|
|
$hitrealdp = m/(real)(\(dp\))(.*)/i;
|
|
$hitcplxdp = m/(complex)(\(dp[c]?\))?(.*)/i;
|
|
$hitcplgwpc = m/(complex)(\(gwpc\))(.*)/i;
|
|
$hitcplxk = m/(complex)(\(kind=.*\))(.*)/i;
|
|
$hitlogi = m/(logical)(\*[14])?(.*)/i;
|
|
$hittype = m/(type)(\(.*\))(.*)/i;
|
|
if ($hitdouble || $hitreal8) {
|
|
$TypeAttr = 'real(dp)';
|
|
}
|
|
elsif ($hitdblcplx || ($hitcplxdp && $2 ne '' && ! $hitcplgwpc) || $hitcplxk) {
|
|
$TypeAttr = 'complex(dpc)';
|
|
}
|
|
elsif ($TypeAttr eq '') {
|
|
$TypeAttr = $1.$2;
|
|
}
|
|
$type1 = substr($TypeAttr,0,1); # first letter of type will be replaced ...
|
|
substr($TypeAttr,0,1) = $hitchar ? $charSort : index($typeSort,$type1); # ... by digit for non-alphabetic sort
|
|
$VarList = $3 if ($VarList eq ''); # old fashion
|
|
if (! ($hitint || $hitreal4 || $hitreal8 || $hitrealk|| $hitdouble || $hitdblcplx || $hitrealdp || $hitcplxdp || $hitcplxk || $hitcplgwpc || $hitchar || $hitlogi || $hittype)) {
|
|
# if the lines is longer than 80, try to split it after commas
|
|
if ($len > 80) {
|
|
while (1) {
|
|
$ix = rindex($line,',',80);
|
|
last if ($ix <= 0);
|
|
$line1 = substr($line,0,$ix+1)."&\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1);
|
|
$line = '& '.substr($line,$ix+1);
|
|
$len = length($line);
|
|
}
|
|
}
|
|
&WriteLine($line,$len);
|
|
$nodeclar ++;
|
|
return if ($nodeclar > 10);
|
|
print "Error, at least 10 declarations could not be identified" if ($nodeclar == 10);
|
|
print "Warning ! Unrecognized declaration at line $linect1 around $_" if ($debug >= 1 && $nodeclar < 10);
|
|
return;
|
|
}
|
|
# WARNING ! If some variable receives an initial value and the declaration type is character,
|
|
# the initial value may have been corrupted when the blanks were stripped off. So, this
|
|
# declaration line will be written now to the output as it is, i.e. without continuations
|
|
$ix = index($VarList,'=');
|
|
if ($hitchar && $ix >= 0) {
|
|
print "Warning ! Character string with initial value found at line $linect1" if ($debug >= 1);
|
|
&WriteLine($line,$len);
|
|
return;
|
|
}
|
|
# split variables list; pay attention to the comma since it is simultanously variable name
|
|
# separator & indices separator in arrays !
|
|
$_ = $VarList;
|
|
$ScalarList = '';
|
|
$ArrayList = '';
|
|
Parse:
|
|
while (1) {
|
|
$hit = m/(.+)([=])(.+)/; # search for initialization value
|
|
if ($hit) {
|
|
# WARNING ! multiple parameter arrays declarations in a single statement not yet supported
|
|
$P3char12=substr($3,0,2);
|
|
$P3charnd=substr($3,-2,2);
|
|
if ($P3char12 eq '(/' || $P3charnd eq '/)' ){ # array initialization value
|
|
if (length($_) > 80) {
|
|
print "Warning ! Array declaration with value longer than 80 chars was found - line $linect1 may be mishandled";
|
|
}
|
|
$ArrayList .= $_;
|
|
last; # end of processing
|
|
}
|
|
$hit = m/(.*)([,])(.+)/; # search for first comma FROM RIGHT TO LEFT
|
|
if ($hit) {
|
|
$ScalarList .= $3.' '; # comma separator found - change it to blank
|
|
$_ = $1;
|
|
next; # continue processing with left part
|
|
}
|
|
else {
|
|
$ScalarList .= $_;
|
|
last; # end of processing
|
|
}
|
|
}
|
|
$hit = m/(.*)([)])(.*)/; # search for right parenthesis FROM RIGHT TO LEFT
|
|
if (! $hit) {
|
|
$hit = m/(.*)([,])(.+)/; # no parenthesis - search for first comma FROM RIGHT TO LEFT
|
|
if ($hit) {
|
|
$ScalarList .= $3.' '; # comma separator found - change it to blank
|
|
$_ = $1;
|
|
next; # continue processing with left part
|
|
}
|
|
else {
|
|
$ScalarList .= $_;
|
|
last; # end of processing
|
|
}
|
|
}
|
|
if ($3 ne '') { # right parenthesis followed by something
|
|
$save = $1;
|
|
$_ = $3;
|
|
$hit = m/(.*)([,])(.+)/; # search for first comma
|
|
if ($hit) {
|
|
$ScalarList .= $3.' '; # change comma separator to blank
|
|
$_ = $save.')'.$1;
|
|
next; # continue processing with string left of comma
|
|
}
|
|
}
|
|
# WARNING ! The following algorithm needs further checkings
|
|
# scan the string backward from the right
|
|
$ParLvl = 0; # parenthesis level
|
|
for ($ix = length($_) - 1;$ix >= 0;$ix --) {
|
|
$charx = substr($_,$ix,1);
|
|
if ($charx eq ')' ) {
|
|
$ParLvl ++;
|
|
next;
|
|
}
|
|
if ($charx eq '(' ) {
|
|
$ParLvl --;
|
|
next;
|
|
}
|
|
if ($charx eq ',' && $ParLvl == 0) { # comma found outside parentheses
|
|
$ArrayList .= substr($_,$ix+1).' ';
|
|
$_ = substr($_,0,$ix);
|
|
next Parse;
|
|
}
|
|
}
|
|
$ArrayList .= $_;
|
|
last; # end of processing
|
|
}
|
|
# build type-attributes lists as an associative array
|
|
# declarations will be sorted with scalars first, put a 0 ahead type,attributes
|
|
if ($ScalarList ne '') {
|
|
$TypeSattr = '0'.$TypeAttr.','.$attributes;
|
|
print "$TypeSattr declaration at line $linect1" if ($debug >= 2);
|
|
print "Scalar List= $ScalarList" if ($debug >= 2);
|
|
if ($definitions{$TypeSattr} eq '') {
|
|
%definitions = (%definitions,
|
|
$TypeSattr,$ScalarList); # define new entry in assoc array
|
|
}
|
|
else { # append new variables to list
|
|
$definitions{$TypeSattr} .= ' '.$ScalarList;
|
|
}
|
|
}
|
|
if ($ArrayList ne '') {
|
|
# declarations will be sorted with arrays next, put a 1 ahead type,attributes
|
|
$TypeAattr = '1'.$TypeAttr.','.$attributes;
|
|
print "$TypeAattr declaration at line $linect1" if ($debug >= 2);
|
|
print "Array List= $ArrayList" if ($debug >= 2);
|
|
if ($definitions{$TypeAattr} eq '') {
|
|
%definitions = (%definitions,
|
|
$TypeAattr,$ArrayList); # define new entry in assoc array
|
|
}
|
|
else { # append new variables to list
|
|
$definitions{$TypeAattr} .= ' '.$ArrayList;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
# ***************************
|
|
sub WriteDefs {
|
|
local ($list) = @_;
|
|
# Purpose: write definitions sorted lists for arguments (phase 4) or local variables (phase 5)
|
|
print "Writing $list list before line $linect" if ($debug >= 2);
|
|
print " types encountered:",keys(%definitions) if ($debug >= 2);
|
|
$ScalArr = '-'; # scalar/array flag undefined for now
|
|
foreach $TypeAttr (sort (keys %definitions)) {
|
|
$type0 = substr($TypeAttr,0,1); # scalar/array for sorting
|
|
if ($type0 ne $ScalArr) {
|
|
$line1 = $type0 eq '0' ? "!scalars\n" : "!arrays\n";
|
|
$len1 = length($line1);
|
|
&WriteLine($line1,$len1); # write comment before declarations
|
|
$ScalArr = $type0; # remember current scalar/array flag
|
|
}
|
|
$type1 = substr($TypeAttr,1,1); # character at offset 1 of type (early changed into digit for sorting) ...
|
|
@VarsList = split(' ',$definitions{$TypeAttr});
|
|
@SortedList = sort(@VarsList);
|
|
substr($TypeAttr,1,1) = substr($typeSort,$type1,1); # is restored with the corresponding letter
|
|
$ix = index($TypeAttr,',');
|
|
$attrSort = substr($TypeAttr,$ix+1,1); # digit for sorting according to some attribute
|
|
# drop the 2 characters used for sorting (0/1 at offset 0 for scalar/array & next to comma for attributes sorting)
|
|
$TypeAttr = $attrSort eq '7' ? substr($TypeAttr,1,$ix-1) : substr($TypeAttr,1,$ix).substr($TypeAttr,$ix+2); # remove attrSort
|
|
$line1 = ' '.$TypeAttr.' :: ';
|
|
$lenh = length($line1);
|
|
$len1 = $lenh;
|
|
foreach $var(@SortedList) {
|
|
$len2 = $len1+length($var)+1; # estimate length of output line, NL-terminated
|
|
if ($len2 > 80 && $len1 > $lenh) {
|
|
substr($line1,-1,1)="\n"; # replace separator by NL
|
|
&WriteLine($line1,$len1);
|
|
$line1 = ' '.$TypeAttr.' :: '.$var.',';
|
|
$len1 = $lenh+length($var)+1;
|
|
}
|
|
else {
|
|
$line1 = $line1.$var.',';
|
|
$len1 = $len2;
|
|
}
|
|
}
|
|
if ($len1 > $lenh) { # non empty line left ?
|
|
substr($line1,-1,1)="\n"; # replace separator by NL
|
|
&WriteLine($line1,$len1); # write last row
|
|
}
|
|
}
|
|
%definitions = (); # clear associative array
|
|
return;
|
|
}
|
|
# ***************************
|
|
sub HndlProg { local ($type,$name) = @_;
|
|
local ($ix);
|
|
# Purpose: build a stack of program/subroutine/function definitions
|
|
# apply rules if first Program/Module/Subroutine/Function
|
|
# Arguments: program/module/interface/subroutine/function type and name
|
|
# Common variables: $ProgLvl, $itemNum
|
|
# drop subroutine/function (parameters
|
|
$ix = index($name,'(');
|
|
$name = substr($name,0,$ix) if ($ix > 0);
|
|
# stack (sub)program type and name to check subsequent end statement
|
|
$ProgType[$ProgLvl] = $type;
|
|
$ProgName[$ProgLvl] = $name;
|
|
# check for interface within module
|
|
if ($SourceBegin1[$itemNum] eq 'ProgModSubFuncType') {
|
|
# handle first Program/Module/Subroutine
|
|
print "$type $name statement encountered at line $linect" if ($debug > 0);
|
|
if ($assumeFun == 1 && $type ne 'subroutine' && $type ne 'interface') {
|
|
print "WARNING, assumption of function for $subname in first line of header defeated for $type $name" if ( $debug > 0);
|
|
$assumeFun = 0;
|
|
}
|
|
&WriteLine("\n",1); # write 1 blank line before Program/Module/Subroutine
|
|
while (1) {
|
|
# handle in-line comments
|
|
$ix = rindex ($line,'!');
|
|
$_ = $ix < 0 ? $line : substr($line,0,$ix);
|
|
$hit = m/(.*)(&\s*$)/; # search trailing &
|
|
last if (! $hit);
|
|
&WriteLine($line,$len); # write this line
|
|
$line = <FILEIN>; # and read the next one
|
|
$len = length($line);
|
|
$linect ++;
|
|
}
|
|
if ($ProgType[0] eq 'module' && $type eq 'interface') {
|
|
$ModIntFc = 1;
|
|
# leaving itemNum unchanged will search for next subroutine/function...
|
|
}
|
|
else {
|
|
&WriteLine($line,$len);
|
|
# following statement should be use
|
|
print "use statement inserted after $wd1" if ($debug > 1);
|
|
$line = "\n use $SourceBegin2[$SourceUseIx]\n";
|
|
$len = length($line);
|
|
$replc .= 'use ';
|
|
$itemNum ++; # continue with other use statements
|
|
}
|
|
}
|
|
else {
|
|
print "Sub/Func $ProgName[$ProgLvl] level $ProgLvl encountered at line $linect" if ($debug > 1);
|
|
}
|
|
print "Warning $type name found is $name instead of $subname" if ($name ne $subname && $debug > 0);
|
|
$ProgLvl ++; # bump stack pointer
|
|
return;
|
|
}
|
|
# ***************************
|
|
sub WriteLine { local ($line,$llen) = @_;
|
|
local ($rc);
|
|
# Purpose: write one line to FILEOUT and check return code
|
|
# Arguments: $line, $llen = line to be written and length
|
|
# Common variable: $fname
|
|
$rc = syswrite(FILEOUT,$line,$llen);
|
|
if ($rc != $llen) {
|
|
print "Error $rc writing to $fname.abirules";
|
|
exit 100;
|
|
}
|
|
return;
|
|
}
|