TFluka/scripts/c2h.pl

   1 #!/usr/bin/perl
   2
   3 # Written by Endre Futo
   4 # 21-May-2002
   5
   6 # read the filename from the command argument
   7 $inputfn = shift @ARGV;
   8 $len = length($inputfn);
   9 if ($len == 0) {
  10    die "\nUsage: perl c2h \\(commonname\\)\n";
  11 }
  12 open(in, $inputfn) || die "\nCannot open the input file\n";
  13
  14 # construct the output file name
  15 $outputfn = $inputfn;
  16 # chop last character
  17 $rightpar = chop($outputfn);
  18 # translate to lower case
  19 $commonname = $outputfn;
  20 $commonname =~ tr/(/F/;
  21 $commonname = join("",$commonname,"_H");
  22 $outputfn =~ tr/A-Z/a-z/;
  23 # translate '(' to 'F'
  24 $outputfn =~ tr/(/F/;
  25 # append '.h' to the output file name and prefix it by '>'
  26 $outputfn = join("",">",$outputfn,".h");
  27 open(out,$outputfn);
  28 print out "#ifndef ",$commonname,"\n";
  29 print out "#define ",$commonname," 1 \n";
  30 $newline = join("","#include \"cfortran.h\"\n");
  31 print out $newline;
  32 $newline = join("","#include \"Rtypes.h\" \n");
  33 print out $newline;
  34 $newline = join("","#include \"Fdimpar.h\" \n");
  35 print out $newline;
  36 $newline = join("","extern \"C\" {\n");
  37 print out $newline;
  38
  39 # Print the hints
  40 # ===============
  41 $newline = join ("","\nCheck in the input file",$inputfn,":\n");
  42 print $newline;
  43 print "1. At the end of the input file must be at least one blank line\n";
  44
  45 $newline = $outputfn;
  46 $newline =~ tr/>/ /;
  47 $newline = join("","\nIn the C++ header file",$newline," created from the FORTRAN common file ",$inputfn," always check: \n");
  48 print $newline;
  49 print "1. Mutidimensional arrays - swap the dimensions\n";
  50 print "2. Arrays dimensioned as X(x:y) - should became X[x-y+1]\n";
  51 print "3. CHARACTER* variables - swap the dimension and CHARACTER* size\n";
  52 print "4. LOGICAL variables - all should be integers\n";
  53 print "5. All comment lines\n";
  54 print "6. All continuation lines\n";
  55 print "7. All unions created from EQUIVALENCEs\n";
  56 print "8. All double constants - exponent should be e not d\n";
  57 print "9. All constants with exponent- exponent should not start with 0\n";
  58
  59 $oncommon = 0;
  60 $firstcom = 0;
  61
  62 # Loop over lines read from the input file
  63 # ========================================
  64 while($line = <in>) {
  65
  66 # Translate everything to lower case
  67 # ==================================
  68
  69    $line =~ tr/A-Z/a-z/;
  70 #---------------------------------------------------------------------------
  71
  72 # Treat comments
  73 # ==============
  74
  75    if ($line =~ /^\*/) {
  76       $newline = join("","\/\/",$line);
  77       print out $newline;
  78    }
  79 #---------------------------------------------------------------------------
  80
  81 # Treat equivalence (became unions)
  82 # ================================
  83
  84    elsif ($line =~ /equivalence/) {
  85 # chop last two characters
  86       $rightpar = chop($line);
  87       $rightpar = chop($line);
  88 # search for '('
  89       $pos = index($line,'(');
  90 # shift out everything before '(' inclusive
  91       $newline1 = substr($line,$pos+1);
  92 # split the rest of the line according to blank
  93       @vars = split(" ",$newline1);
  94 # join the line again - the line will now be without blanks
  95       $newline1 = join("",@vars);
  96 # translate '(' to '['
  97       $newline1 =~ tr/(/[/;
  98 # translate ')' to ']'
  99       $newline1 =~ tr/)/]/;
 100 # split the rest of the line according to comma
 101       ($var1,$var2) = split(",",$newline1);
 102 # here may come handling of variables
 103 #
 104 # first variable is an integer
 105       if ($var1 =~ /^[i-n]/) {
 106          if ($var2 =~ /^[i-n]/) {
 107             $newline = join("","union { int    ",$var1,";"," int    ",$var2,";};\n");
 108          }
 109          else {
 110             $newline = join("","union { int    ",$var1,";"," double ",$var2,";};\n");
 111          }
 112       }
 113 # first variable is a double precision
 114       else {
 115          if ($var2 =~ /^[i-n]/) {
 116             $newline = join("","union { double ",$var1,";"," int    ",$var2,";};\n");
 117          }
 118          else {
 119             $newline = join("","union { double ",$var1,";"," double ",$var2,";};\n");
 120          }
 121       }
 122       print out $newline;
 123    }
 124 #---------------------------------------------------------------------------
 125
 126 # Treat parameters (became constants)
 127 # ===================================
 128
 129    elsif ($line =~ /parameter/) {
 130 # chop last two characters
 131       $rightpar = chop($line);
 132       $rightpar = chop($line);
 133 # search for '('
 134       $pos = index($line,'(');
 135 # shift out everything before '(' inclusive
 136       $newline1 = substr($line,$pos+1);
 137 # store the variable name
 138       ($var) = split("=",$newline1);
 139 # split the variable name according to blank
 140       @vars = split(" ",$var);
 141 # join the line again - the variable name will now be without blanks
 142       $var = join("",@vars);
 143 # search for '='
 144       $pos = index($line,'=');
 145 # shift out everything before '=' inclusive
 146       $newline1 = substr($line,$pos+1);
 147 # split the rest of the line according to blank
 148       @vars = split(" ",$newline1);
 149 # join the line again - the line will now be without blanks
 150       $newline1 = join("",@vars);
 151
 152 # parameter is an integer
 153       if ($var =~ /^[i-n]/) {
 154          $newline = join("","const int ",$var," = ",$newline1,";\n");
 155          print out $newline;
 156       }
 157 # parameter is real in double precision
 158       else {
 159          $newline = join("","const double ",$var," = ",,$newline1,";\n");
 160          print out $newline;
 161       }
 162    }
 163 #---------------------------------------------------------------------------
 164
 165 # Treat commons (became struct)
 166 # =============================
 167
 168 # first line of the common
 169 # ------------------------
 170    elsif ($line =~ /common/) {
 171 # finish the previous common - for the first one there is nothing to finish
 172       if ($firstcom eq 1) {
 173          $newline = join("","} ",$comname,"Common;","\n");
 174          print out $newline;
 175          $comnamebig = $comname;
 176 # translate common name back to capitals
 177          $comnamebig =~ tr/a-z/A-Z/;
 178          $newline = join("","#define ",$comnamebig," COMMON_BLOCK(",$comnamebig,",",$comname,")\n");
 179          print out $newline;
 180          $newline = join("","COMMON_BLOCK_DEF(",$comname,"Common",",",$comnamebig,");\n");
 181          print out $newline;
 182       }
 183 # from now on the first common is over
 184       $firstcom = 1;
 185       $newline = join("","\ntypedef struct {","\n");
 186       print out $newline;
 187 # we are inside a common
 188       $oncommon = 1;
 189 # look for the first '/'
 190       $pos = index($line,'/');
 191 # shift out everything before first '/' inclusive
 192       $newline1 = substr($line,$pos+1);
 193       $newline2 = $newline1;
 194 # eliminate the second '/'
 195       $newline2 =~ tr/\// /;
 196 # determine the common name
 197       ($comname) = split(" ",$newline2);
 198 # look for the second '/'
 199       $pos = index($newline1,'/');
 200 # shift out everything before second '/' inclusive
 201       $newline2 = substr($newline1,$pos+1);
 202 # split the rest of the line according to blank
 203       @vars = split(" ",$newline2);
 204 # join the line again - the line will now be without blanks
 205       $newline2 = join("",@vars);
 206 # here may come handling of multidimensional arrays
 207 #
 208 # translate comma to blank
 209       $newline2 =~ tr/,/ /;
 210 # translate '(' to '['
 211       $newline2 =~ tr/(/[/;
 212 # translate ')' to ']'
 213       $newline2 =~ tr/)/]/;
 214 # split the rest of the line according to blank
 215       @vars = split(" ",$newline2);
 216 # loop over common variables
 217       for ($i=0; $i < @vars; $i++) {
 218          if ($vars[$i] =~ /^[i-n]/) {
 219             $newline = join("","   int    ",$vars[$i],";\n");
 220             print out $newline;
 221          }
 222          else {
 223             $newline = join("","   double ",$vars[$i],";\n");
 224             print out $newline;
 225          }
 226       }
 227    }
 228
 229 # continuation line of the common
 230 # -------------------------------
 231    elsif (($line =~ /&/) && ($oncommon eq 1)) {
 232 # look for '&'
 233       $pos = index($line,'&');
 234 # shift out everything before '&' inclusive
 235       $newline1 = substr($line,$pos+1);
 236 # split the rest of the line according to blank
 237       @vars = split(" ",$newline1);
 238 # join the line again - the line will now be without blanks
 239       $newline2 = join("",@vars);
 240 # here may come handling of multidimensional arrays
 241 #
 242 # translate comma to blank
 243       $newline2 =~ tr/,/ /;
 244 # translate '(' to '['
 245       $newline2 =~ tr/(/[/;
 246 # translate ')' to ']'
 247       $newline2 =~ tr/)/]/;
 248 # split the rest of the line according to blank
 249       @vars = split(" ",$newline2);
 250 # loop over common variables
 251       for ($i=0; $i < @vars; $i++) {
 252          if ($vars[$i] =~ /^[i-n]/) {
 253             $newline = join("","   int    ",$vars[$i],";\n");
 254             print out $newline;
 255          }
 256          else {
 257             $newline = join("","   double ",$vars[$i],";\n");
 258             print out $newline;
 259          }
 260       }
 261    }
 262
 263 # the line does not belong to the common (end of common)
 264 # ------------------------------------------------------
 265    elsif ($oncommon eq 1) {
 266       $newline = join("","} ",$comname,"Common;","\n");
 267       print out $newline;
 268       $comnamebig = $comname;
 269 # translate common name back to capital
 270       $comnamebig =~ tr/a-z/A-Z/;
 271       $newline = join("","#define ",$comnamebig," COMMON_BLOCK(",$comnamebig,",",$comname,")\n");
 272       print out $newline;
 273       $newline = join("","COMMON_BLOCK_DEF(",$comname,"Common",",",$comnamebig,");\n");
 274       print out $newline;
 275       $oncommon = 0;
 276    }
 277 #---------------------------------------------------------------------------
 278
 279 # all other lines are just repeated as comments
 280 # ---------------------------------------------
 281    else {
 282 # prefix line with '//'
 283       $newline = join("","\/\/",$line);
 284 # translate common name back to capitals
 285       $newline =~ tr/a-z/A-Z/;
 286       print out $newline;
 287    }
 288
 289
 290 }
 291 # closing curly parenthesis od the extern "C" { statement
 292 print out "}\n";
 293 print out "#endif\n";
 294
 295 close(in);
 296 close(out);
 297
 298