#!/usr/sbin/perl -i.bak

#
# xlatepragma - VADS Ada83 to GNAT Ada95 pragma translator
#
# Usage:
#
#   xlatepragma [filename...]
#
# Summary:
#
#   xlatepragma scans Ada source code looking for pragmas.  If one or more
#   files are specified on the command line, they will be processed in-place.
#   If no files are specified, the command acts as a filter between standard
#   input and standard output.
#
#   By default, a copy of the original file is saved with a suffix of .bak.
#   to disable this, replace the first line of this file with the line:
#
#      #!/usr/sbin/perl -i
#
#   i.e. get rid of the ".bac" argument to the -i switch.
#

#
# Author:
#
#    Tom Quiggle,
#    Silicon Graphics
#
# Version: 0.1
#
# Modification Log:
#
#    09Oct95	Initial version covering only those pragmas used by MDHC
#
# Report bugs/enhancements/suggestions to:
#
#    quiggle@sgi.com
#

$FALSE = 0;
$TRUE  = 1;

#
# An associateive array listing the pragmas we may need to modify
#

%Pragmas_To_Modify = (
  'built_in',       $TRUE,
  'c_callable',     $TRUE,
  'export',         $TRUE,
  'external_name',  $TRUE,
  'implicit_code',  $TRUE,
  'initialize',     $TRUE,
  'inline_only',    $TRUE,
  'interface',      $TRUE,
  'interface_name', $TRUE,
  'optimize_code',  $TRUE,
  );


#
# When scanning a pragma declaration, we tokenize each input line and
# place it into the following:
#

@Tokens = ();		# Array of the tokens comprising current line
$Index  = 0;            # Index of current token
$Current_Token = "";    # text of current token

@Arguments = ();        # Arguments to current pragma under consideration
@Pragma_Lines = ();	# Source lines for current pragma

$VADS_COMMENT_PREFIX="--(vads)";  # comment token for VADS-specific code
$GNAT_COMMENT_PREFIX="--(gnat)";  # comment token for GNAT-specific code

while (<>) {

   if ( /^\s*[Pp][Rr][Aa][Gg][Mm][Aa]\s/ || /^\s*[Pp][Rr][Aa][Gg][Mm][Aa]$/) {
      #
      # We have a non-comment line beginning with the reserved word "pragma"
      # (in any case) followed by either whitespace or an end-of-line.
      # We analyze the pragma and look for the ';' that completes it.
      #

      &tokenize_current_line;

      #
      # Scan past the 'pragma' token
      #
      while (&lc ($Current_Token) ne "pragma") {
	 &next_token;
      }

      #
      # Find the pragma identifier and store it in $Identifier
      #
      while ( ($_ = &next_token), /\W/ ) {
	 ;
      }

      $Identifier = &lc ($_);

      if ( ! $Pragmas_To_Modify {$Identifier} ) {
	 foreach $line (@Pragma_Lines) {
	    print "$line";
	 };
	 next;
      }

      #
      # Build the pragma argument list
      #
      @Arguments = ();
      $Current_Argument = "";
      $paren_nesting = 0;

      while ( ($_ = &next_token), ! /;/ ) {
	 if ( /\(/ ) {
	    if ($paren_nesting++ > 1) {
	       $Current_Argument .= $_;
	    }
	 } elsif ( /\)/ ) {
            if (--$paren_nesting == 0) {
	       @Arguments = (@Arguments, $Current_Argument);
	       $Current_Argument = "";
	    } else {
	       $Current_Argument .= $_;
	    }
	 } elsif (/,/) {
	    @Arguments = (@Arguments, $Current_Argument);
	    $Current_Argument = "";
	 } elsif (/--/) {
	    ; # for now, ignore comments in the middle of pragma argument lists
	 } else {
	   $Current_Argument .= $_;
         }
      }

      $_ = $Identifier;
      switch: {
	 &do_built_in ($line),       last switch if /built_in/;
	 &do_c_callable ($line),     last switch if /c_callable/;
	 &do_export ($line),         last switch if /export/;
	 &do_external_name ($line),  last switch if /external_name/;
	 &do_implicit_code ($line),  last switch if /implicit_code/;
	 &do_initialize ($line),     last switch if /initialize/;
	 &do_inline_only ($line),    last switch if /inline_only/;
	 &do_interface ($line),      last switch if /interface/;
	 &do_interface_name ($line), last switch if /interface_name/;
	 &do_optimize_code ($line),  last switch if /optimize_code/;
      }


   } else {
      #
      # Not a pragma line.  Pass it through unchanged.
      #
      print "$_";

   }

}

#
# General purpose subroutines
#

sub lc { local($x); $x = $_[0]; $x  =~ tr/A-Z/a-z/; return "$x"; };

sub next_token {

   if ( $Index++ > $#Tokens ) {
      &tokenize_next_line;
   } else {
      $_ = $Tokens[$Index];

      if ( (/-/) && ($Tokens[$Index+1] eq "-") ) {
         $Current_Token = "--";
         $Index = $#Tokens;    # Don't tokenize remainder of comment
      } else {
	 $Current_Token = $_;
      }
   }
}

sub tokenize_current_line {
   @Pragma_Lines = ($_);    # Add this line to the buffer for the pragma
   @Tokens = grep(/./, split(/(\W)/, $_));
   $Index = $[ - 1;
   &next_token;
}

sub tokenize_next_line {
   $_ = <ARGV>;
   @Pragma_Lines = (@Pragma_Lines, $_);
   @Tokens = grep(/./, split(/(\W)/, $_));
   $Index = $[ - 1;
   &next_token;
}



#
# pragma replacement routines.  For each pragma that we wish to modify
# there is a routine of the name do_<pragma_name>.  On entry, the pragma
# has NOT been printed to the output file. The global variables
#

sub do_built_in {
   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }
}

sub do_c_callable {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

   print ' ' x $old_indentation;
   print "pragma Export (C,",  $Arguments[0], "); --(gnat)\n";

}

sub do_export {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   $_ = &lc ($Arguments[0]);
   if ( /assembly/ ) {

      foreach $line (@Pragma_Lines) {
	 print "--(vads)$line";
      }

      print ' ' x $old_indentation;
      print "pragma Export (Assembler";
      foreach $arg (@Arguments[1 .. $#Arguments]) {
	 $arg =~s/^\s+//;
	 $arg =~s/\n/--(gnat)\n/;
	 print ", ", $arg;
      }
      print "); --(gnat)\n";

   } else {
      foreach $line (@Pragma_Lines) {
	 print "$line";
      }
   }

}

sub do_external_name {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

   print ' ' x $old_indentation;
   print "pragma Export (Ada, ";

   print $Arguments[1];
   print ", ";
   print $Arguments[0];
   print ");--(gnat)\n";

}

sub do_inline_only {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

   print ' ' x $old_indentation;
   print "pragma Inline (";
   foreach $arg (@Arguments[0 .. $#Arguments-1]) {
      $arg =~s/^\s+//;
      print "$arg, ";
   }
   @Arguments[$#Arguments] =~s/^\s+//;
   print "@Arguments[$#Arguments]);--(gnat)\n";

}

sub do_implicit_code {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

}

sub do_initialize {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

   $_ = &lc ($Arguments[0]);

   if ( /static/) {
      print ' ' x $old_indentation;
      print "pragma Preelaborate;--(gnat)\n";
   }
}

sub do_interface {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   $_ = &lc ($Arguments[0]);
   if ( /assembly/ ) {

      foreach $line (@Pragma_Lines) {
	 print "--(vads)$line";
      }

      print ' ' x $old_indentation;
      print "pragma Interface (Assembler";
      foreach $arg (@Arguments[1 .. $#Arguments]) {
	 $arg =~s/^\s+//;
	 $arg =~s/\n/--(gnat)\n/;
	 print ", ", $arg;
      }
      print ");--(gnat)\n";

   } else {
      foreach $line (@Pragma_Lines) {
	 print "$line";
      }
   }

}

sub do_interface_name {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");

   foreach $line (@Pragma_Lines) {
      print "$line";
   }

}

sub do_optimize_code {
   local ($line0)  = &lc($Pragma_Lines[0]);
   local ($old_indentation) = index($line0,  "pragma");


   foreach $line (@Pragma_Lines) {
      print "--(vads)$line";
   }

   $_ = &lc ($Arguments[0]);
   if ( /on/ ) {
      print ' ' x $old_indentation;
      print "pragma Optimize (Code);--(gnat)\n";
   }

}