src/smpi/smpif2c.in

   1 #! /usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5 use File::Temp;
   6 use File::Copy;
   7
   8 my $include="@includeflag@@f2cflags@";
   9
  10 foreach my $fortran (@ARGV) {
  11    my $output = $fortran;
  12    $output =~ s/.f$/.c/;
  13
  14    #print "F2C INPUT : ".$fortran."\n";
  15    #print "F2C OUTPUT: ".$output."\n";
  16
  17    my$outputdir = $output;
  18    $outputdir=~s/[^\/]*\.c$//g;
  19    #print "F2C DIR   : ".$outputdir."\n";
  20
  21    my $tmp = new File::Temp;
  22    $tmp->autoflush(1);
  23    #print "f2c -d$outputdir $include -w -a $fortran\n";
  24    `f2c -d$outputdir $include -w -a $fortran`;
  25    die "F2C failed\n" if $?;
  26    open F2C,"<$output" or die "Unable to open file $output";
  27    my $started = 0;
  28    my $cutext = 0;
  29    print $tmp "#ifndef INTEGER_STAR_8\n";
  30    print $tmp "#define INTEGER_STAR_8\n";
  31    print $tmp "#endif\n";
  32    print $tmp "#include <stdlib.h>\n";
  33    print $tmp "#include <smpif.h>\n";
  34    while(<F2C>) {
  35       chomp;
  36       if(/\/\* Common Block Declarations \*\//) {
  37          $started = 1;
  38       }
  39       if($started) {
  40          if(/^} (.*?);/) {
  41             $_ = "}* __attribute__((weak)) $1 = NULL;\n";
  42          } elsif(/^#define\s*(\S*)\s*\(?([^.]*)(\..*?)?\)?$/) {
  43             $_ = "#define $1 $2\[smpi_current_rank\]";
  44             if(defined $3) {
  45                $_ .= $3;
  46             }
  47             $_ .= "\n";
  48             $_ .= "\nvoid __attribute__((weak,constructor)) __preinit_$1(void) {\n  if(!$2) $2 = malloc(smpi_global_size() * sizeof(*$2));\n}\n";
  49             $_ .= "\nvoid __attribute__((weak,destructor)) __postfini_$1(void) {\n  free($2);\n  $2 = NULL;\n}\n";
  50          }
  51       }
  52       if(/\/\* Table of constant values \*\// || /MAIN__/) {
  53          $started = 0;
  54       }
  55       if(/extern \/\* Subroutine \*\//) {
  56          $cutext = 1;
  57       }
  58       if($cutext) {
  59          if(/;$/) {
  60             $cutext = 0;
  61          }
  62          next;
  63       }
  64       if(/\/* Main program alias \*\/\s*int\s+.*\s*\(\s*\)\s*{(.*)}/) {
  65          $_ = "int smpi_simulated_main__(int argc, char** argv) { smpi_process_init(&argc, &argv); $1 }\n";
  66       }
  67       print $tmp "$_\n";
  68    }
  69    close F2C;
  70    copy($tmp->filename,$output) or die "Copy failed: $!\n";
  71 }