#!/usr/local/bin/perl

# -------------------------------------------
# tapeppf: the Tape preprocessor for Fortran

# Author: Eric Maillet
# Date  : january 1995
# lang. : perl 4.0
# -------------------------------------------

sub groupmask {
$textmask=$_[0];
$mask=0;

foreach $c (split(//,$textmask)) {
  $r=ord($c)-ord("A");
  return -1 if($r<0||$r>25);
  $mask |= 1<<$r;
}

return $mask;
}

# Default tapepp file table
$TAPEDB = "$ENV{HOME}/pvm3/tapelib/tapepp.tab";

# Default source module mask
$MASK = -1;

# Default buffer size (in bytes)
$DBS = 10000;

# Default max. number of phases
$DPH = 20;

# Default delay (secs) between successive exchanges for clock synchro
$DDY = 2;

# Default number of message exchanges (per phase) for clock synchro
$DXC = 15;

# Check command line: supported options -f,-m,-o,-T,-P,-A,-E

if( $#ARGV==-1 ) {
 print "tapeppf: missing command line arguments\n\n";
 print "usage: tapeppf [options] file\n\n";
 print "file    : fortran source file\n";
 print "options : -f<file>, use <file> as source code data base\n";
 print "          -m<mask>, use <mask> as source module mask (decimal)\n";
 print "          -o<file>, use <file> as output file (default is '_t.f')\n";
 print "          -T<size>, fix buffer size\n";
 print "          -P<size>, fix number of phaes\n";
 print "          -A<delay>, wait for <delay> between ping-pongs\n";
 print "          -E<nbxch>, fix number of ping-pongs\n";
 exit;
}

foreach $i (0..$#ARGV-1) {
  
    if    ( $ARGV[$i]=~/^-f(\w+)$/ ) {
	$TAPEDB = $1;
    }
    elsif ( $ARGV[$i]=~/^-m(\w+)$/ ) {
	$MASK = &groupmask($1);
	if($MASK==-1) {
	    print STDERR "warning: wrong groupmask, using A-Z\n";
	}
    }
    elsif ( $ARGV[$i]=~/^-o(\w+)$/ ) {
	$DOTFOR_T = $1;
    }
    elsif ( $ARGV[$i]=~/^-T(\w+)$/ ) {
	$DBS = $1;
    }
    elsif ( $ARGV[$i]=~/^-P(\w+)$/ ) {
	$DPH = $1;
    }
    elsif ( $ARGV[$i]=~/^-A(\w+)$/ ) {
	$DDY = $1;
    }
    elsif ( $ARGV[$i]=~/^-E(\w+)$/ ) {
	$DXC = $1;
    }
    else {
	die "tapeppf: unknown command line option\n";
    }
    
}

$DOTFOR = $ARGV[$#ARGV];  # name of fortran source file

if( (! ($DOTFOR =~ /\.for$/) ) &&
    (! ($DOTFOR =~ /\.f$/) ) ) {
  die "tapeppf: illegal source file $DOTFOR, aborting";
}

if(! -T $DOTFOR) {
  die "tapeppf: couldn't find $DOTFOR, aborting";
}

# search file id in tapepp database

$newentry=0;

if(! -T $TAPEDB ) {
  print "tapeppf: couldn't find $TAPEDB, created it for you\n";
  open( TDB, ">$TAPEDB" );
  $DOTFORID=1;
  $newentry=1;
}
else {
  open( TDB, "$TAPEDB" );
  $nextid=1;
  while( $line=<TDB> ) {
    ($id, $src, $src_t) = split( '\s+',$line );
    $nextid=$id if $nextif<$id;
    last if( $src eq $ENV{PWD}."/".$DOTFOR );
  }
  if( $line ) {
    $DOTFORID=$id;
    $DOTFOR_T=$src_t;
    close( TDB );
  }
  else {
    $DOTFORID=$nextid+1;
    close( TDB );
    $newentry=1;
    open( TDB, ">> $TAPEDB" );
  }
}

# add a new entry to the database

if( $newentry == 1 ) {
    if(! $DOTFOR_T ) {
	@f = split(/\./,$DOTFOR);
	$ext = pop(@f);
	$DOTFOR_T = join('.',@f)."_t.".$ext;
    }
    print TDB $DOTFORID." ".$ENV{PWD}."/".$DOTFOR." ".$DOTFOR_T."\n";
    close( TDB ); 
}

# Assert:
#
# $DOTFORID      :   file id of fortran source (from tape data base)
# $DOTFOR        :   name of fortran source
# $DOTFOR_T      :   name of instrumented fortran source

# open source file and create instrumented source file

open( SRC, $DOTFOR ) || die "tapeppf: can't open $DOTFOR, $!\n";

if( ! open( SRC_T, "> $DOTFOR_T" ) ) {
  close SRC;
  die "tapeppf: can't open $DOTFOR_T, $!\n";
}

# main loop inserting instrumentation points

$maindecl = 0;   # flag - main decl section after program
$ti = 0;         # flag - tape init already inserted
$lineno = 0;     # current line number

$tapeinitstr = "C --- start tapeppf insert\n".
               "      call tapefstart($DBS,$DPH,$DDY,$DXC)\n".
               "C --- end tapeppf insert\n";

while( <SRC> ) {

  chop;
  $add = "";
  $lineno++;

  # detect end of declarations for main PROGRAM

  if( $maindecl                           	&&
      ! (length($_)==0 || /^[C|c|\*|!]/)  	&&
      ! /^\s+USE/i       			&&
      ! /^\s+DATA/i      			&&
      ! /^\s+FORMAT/i    			&&
      ! /^\s+ENTRY/i     			&&
      ! /^\s+BYTE/i      			&&
      ! /^\s+CHARACTER/i 			&&
      ! /^\s+COMPLEX/i   			&&
      ! /^\s+DOUBLE/i    			&&
      ! /^\s+INTEGER/i   			&&
      ! /^\s+LOGICAL/i   			&&
      ! /^\s+REAL/i      			&&
      ! /^\s+TYPE/i      			&&
      ! /^\s+IMPLICIT/i  			&&
      ! /^\s+PARAMETER/i 			&&
      ! /^\s+COMMON/i    			&&
      ! /^\s+EXTERNAL/i  			&&
      ! /^\s+DIMENSION/i			&&
      ! /^\s+INCLUDE/i                          &&
      ! /^     [^ ]/ )
       {
          if( $ti ) {
             close(SRC);
             close(SRC_T);
             print "tapeppf: panic, cannot insert tapefstart\n"; exit;
          }
          $add="\n".$tapeinitstr;
          $maindecl=0;
          $ti=1;
       } 

  # instrument non comment lines, non decl lines

  if( (! /^[C|c|\*|!]/) && (! $maindecl) ) {

   # instrument all pvm library calls
   s/pvmf([^\(]*)\(/tpvmf\1($DOTFORID,$lineno,$MASK,/i;
			    
   # instrument pvm utility functions
   s/tapefopenphase\(/tapefopenphase($DOTFORID,$lineno,$MASK,/i;
   s/tapefclosephase\(/tapefclosephase($DOTFORID,$lineno,$MASK,/i;
   s/tapefsetmask\(/tapefsetmask($DOTFORID,$lineno,$MASK,/i;

  }

  # detect start of main PROGRAM
  
  if( /^\s+PROGRAM/i ) {
    $maindecl=1;
  }

  print SRC_T "$add$_\n";
}

close SRC;
close SRC_T;



