]>
Commit | Line | Data |
---|---|---|
b9d0a01d | 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 |