Assume alice.inp in local directory.
[u/mrichter/AliRoot.git] / 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