3 # Written by Endre Futo
6 # read the filename from the command argument
7 $inputfn = shift @ARGV;
8 $len = length($inputfn);
10 die "\nUsage: perl c2h \\(commonname\\)\n";
12 open(in, $inputfn) || die "\nCannot open the input file\n";
14 # construct the output file name
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'
25 # append '.h' to the output file name and prefix it by '>'
26 $outputfn = join("",">",$outputfn,".h");
28 print out "#ifndef ",$commonname,"\n";
29 print out "#define ",$commonname," 1 \n";
30 $newline = join("","#include \"cfortran.h\"\n");
32 $newline = join("","#include \"Rtypes.h\" \n");
34 $newline = join("","#include \"Fdimpar.h\" \n");
36 $newline = join("","extern \"C\" {\n");
41 $newline = join ("","\nCheck in the input file",$inputfn,":\n");
43 print "1. At the end of the input file must be at least one blank line\n";
47 $newline = join("","\nIn the C++ header file",$newline," created from the FORTRAN common file ",$inputfn," always check: \n");
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";
62 # Loop over lines read from the input file
63 # ========================================
66 # Translate everything to lower case
67 # ==================================
70 #---------------------------------------------------------------------------
76 $newline = join("","\/\/",$line);
79 #---------------------------------------------------------------------------
81 # Treat equivalence (became unions)
82 # ================================
84 elsif ($line =~ /equivalence/) {
85 # chop last two characters
86 $rightpar = chop($line);
87 $rightpar = chop($line);
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 '['
98 # translate ')' to ']'
100 # split the rest of the line according to comma
101 ($var1,$var2) = split(",",$newline1);
102 # here may come handling of variables
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");
110 $newline = join("","union { int ",$var1,";"," double ",$var2,";};\n");
113 # first variable is a double precision
115 if ($var2 =~ /^[i-n]/) {
116 $newline = join("","union { double ",$var1,";"," int ",$var2,";};\n");
119 $newline = join("","union { double ",$var1,";"," double ",$var2,";};\n");
124 #---------------------------------------------------------------------------
126 # Treat parameters (became constants)
127 # ===================================
129 elsif ($line =~ /parameter/) {
130 # chop last two characters
131 $rightpar = chop($line);
132 $rightpar = chop($line);
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);
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);
152 # parameter is an integer
153 if ($var =~ /^[i-n]/) {
154 $newline = join("","const int ",$var," = ",$newline1,";\n");
157 # parameter is real in double precision
159 $newline = join("","const double ",$var," = ",,$newline1,";\n");
163 #---------------------------------------------------------------------------
165 # Treat commons (became struct)
166 # =============================
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");
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");
180 $newline = join("","COMMON_BLOCK_DEF(",$comname,"Common",",",$comnamebig,");\n");
183 # from now on the first common is over
185 $newline = join("","\ntypedef struct {","\n");
187 # we are inside a common
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
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");
223 $newline = join(""," double ",$vars[$i],";\n");
229 # continuation line of the common
230 # -------------------------------
231 elsif (($line =~ /&/) && ($oncommon eq 1)) {
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
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");
257 $newline = join(""," double ",$vars[$i],";\n");
263 # the line does not belong to the common (end of common)
264 # ------------------------------------------------------
265 elsif ($oncommon eq 1) {
266 $newline = join("","} ",$comname,"Common;","\n");
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");
273 $newline = join("","COMMON_BLOCK_DEF(",$comname,"Common",",",$comnamebig,");\n");
277 #---------------------------------------------------------------------------
279 # all other lines are just repeated as comments
280 # ---------------------------------------------
282 # prefix line with '//'
283 $newline = join("","\/\/",$line);
284 # translate common name back to capitals
285 $newline =~ tr/a-z/A-Z/;
291 # closing curly parenthesis od the extern "C" { statement
293 print out "#endif\n";