"Fossies" - the Fresh Open Source Software Archive 
Member "fort77-1.18/fort77" (19 Apr 1999, 8722 Bytes) of package /linux/misc/old/fort77-1.18.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 #! /usr/bin/perl -w
2
3 # $Header: /usr/local/cvs/tools/prog/fort77,v 1.6 1999/04/19 12:19:11 abel Exp $
4
5 # fort77 (compiler driver) script for f2c
6 # For use with gcc under Linux
7 # This code is in the public domain; use at your own risk.
8 # Parse options
9
10 $version = "1.18";
11 $nnflag = '-Nn802';
12 $tmpdir = $ENV{'TMPDIR'} || '/tmp';
13 $cpp = 0;
14 $fast_math = 1;
15 $debug = 0;
16 $cc = $ENV{'CC'} || 'cc';
17
18 # Loop over all options; pull all options from @ARGV and put all
19 # arguments into @argv. This is needed because, apparently, UNIX
20 # compilers acceppt options anywhere on the command line.
21
22 while ($_ = $ARGV[0]) {
23 shift;
24
25 if (!/^-/) {
26 if (/\.P$/) {
27 push(@pfiles, $_);
28 }
29 else {
30 push(@argv, $_);
31 }
32 next;
33 }
34 # First, the f2c options.
35
36 if (/^-[CUuaEhRrz]$/ || /^-I[24]$/ || /^-onetrip$/ || /^-![clPR]$/ ||
37 /^-ext$/ || /^-!bs$/ || /^-W[1-9][0-9]*$/ || /^-w8$/ || /^-w66$/ ||
38 /^-r8$/ || /^-N[^n][0-9]+$/) {
39 push (@fopts, $_);
40 }
41 elsif (/^-Nn[0-9]+$/) {
42 $nnflag = $_;
43 }
44
45 # Prototype flags for f2c
46
47 elsif (/^-Ps?/) {
48 $extract_prototypes ++;
49 push (@fopts, $_);
50 }
51
52 # Does somebody want to run the preprocessor?
53
54 elsif (/^-cpp$/) {
55 $cpp++;
56 }
57
58 # These are common to both f2c and gcc
59 elsif (/^-w$/) {
60 push(@fopts, $_);
61 push(@copts, $_);
62 }
63
64 # This is for the linker, too...
65 elsif (/^-g$/) {
66 push(@fopts, $_);
67 push(@copts, $_);
68 push(@lopts, $_);
69 $debug ++;
70 }
71
72 # Special options for the different subprocesses: f for f2c step,
73 # p for (separate) preprocessing, c for C compiler, l for linker.
74 # a is also passed to the C compiler.
75
76 elsif (/^-Wf,/) {
77 push(@fopts, &parsewx($_));
78 }
79 elsif (/-Wp,/) {
80 push(@cppopts, &parsewx($_));
81 }
82 elsif (/-W[ca],/) {
83 push(@copts, &parsewx($_));
84 }
85 elsif (/-Wl,/) {
86 push(@lopts,&parsewx($_));
87 }
88
89 # gcc only options
90
91 # too many -f and -W options to list them all...
92
93 # First, let's see wether somebody wants to adhere to the C standard
94 # in Fortran.
95
96 elsif (/^-fnofast-math$/) {
97 $fast_math = 0;
98 }
99
100 # The '-f' option to f2c...
101
102 elsif (/^-f$/) {
103 push(@fopts, $_);
104 }
105 elsif (/^-[fWUAm]/ || /^-[Ex]$/ || /^-pipe$/ ) {
106 push(@copts, $_);
107 }
108
109 # Includes and outputs...
110
111 elsif (/^-I$/) {
112 (@ARGV > 0) || die "$0: Missing argument to \"$_\"\n";
113 push(@includes, "-I".shift);
114 }
115 elsif (/^-I./) {
116 push(@includes, $_);
117 }
118 elsif (/^-o$/) {
119 (@ARGV > 0) || die "$0: Missing argument to \"$_\"\n";
120 $output = shift;
121 }
122 elsif (/^-o(.*)/) {
123 $output = $1;
124 }
125
126 # Optimization
127 elsif (/^-O/) {
128 push(@copts, $_);
129 push(@lopts, $_);
130 $optimize ++;
131 }
132
133 # Options for both C compiler and linker
134
135 elsif (/^-[Og]/ || /^-p$/ || /^-pg$/) {
136 push(@copts, $_);
137 push(@lopts, $_);
138 }
139 elsif (/^-[bV]$/ ) {
140 (@ARGV > 0) || die "$0 : Missing argument to \"$_\"\n";
141 $arg = shift;
142 push(@copts, $_, $arg);
143 push(@lopts, $_, $arg);
144 }
145 elsif (/^-[bV]./ ) {
146 push(@copts, $_);
147 push(@lopts, $_);
148 }
149
150 # Linker only options
151
152 elsif (/^-[lL]$/) {
153 push(@lopts, $_);
154 (@ARGV > 0) || die "$0: Missing argument to \"$_\"\n";
155 $_ = shift;
156 push(@lopts, $_);
157 }
158 elsif (/^-[lL]./ || /^-nostartfiles$/ || /^-static$/ || /^-shared$/ ||
159 /^-symbolic$/) {
160 push(@lopts, $_);
161 }
162 elsif (/^-[cS]$/) {
163 $compile_only = $_;
164 }
165 elsif (/^-D/) {
166 push(@cppopts, $_);
167 }
168 # Are we verbose?
169
170 elsif (/^-v$/) {
171 $verbose ++;
172 }
173
174 # Does somebody want to keep the C files around?
175
176 elsif (/^-k$/) {
177 $keep_c ++;
178 }
179
180 # Assume any unknown options are for the C compiler. This is still a
181 # kludge, since this script doesn't use anything like getopts to parse
182 # the command line as it should. So "-unknown-opt" will get passed,
183 # but "-unknown-opt-with-other-stuff other-stuff" will cause an error
184 # even if it's valid. --AG
185
186 else {
187 push(@copts, $_);
188 }
189
190 }
191
192 push(@fopts,$nnflag);
193 push(@copts,'-ffast-math') if $optimize && $fast_math;
194 push(@cppopts,@includes);
195 push(@fopts,@includes,"-I.");
196 push(@fopts, @pfiles);
197
198 if ($verbose) {
199 print STDERR "$0: fort77 Version $version\n";
200 if ($verbose > 1) {
201 push(@copts,"-v");
202 push(@lopts,"-v");
203 push(@cppopts,"-v");
204 }
205 }
206
207
208 @ARGV = @argv;
209
210 if ($compile_only && $output && (@ARGV>1)) {
211 warn "$0: Warning: $compile_only and -o with mutiple files, ignoring -o\n";
212 $output = "";
213 }
214
215 die "$0: No input files specified\n" unless @ARGV;
216
217 while ($_ = $ARGV[0]) {
218 shift;
219 $ffile = "";
220 $cfile = "";
221 $lfile = "";
222 $basefile = "";
223 $debugcmd = "";
224
225 if (/\.[fF]$/) {
226 $ffile = $_;
227 $basefile = $ffile;
228 }
229 elsif (/\.[cCisSm]$/ || /\.cc$/ || /\.cxx$/) {
230 $cfile = $_;
231 $basefile = $_;
232 }
233 else {
234 push(@lfiles, $_);
235 }
236
237 $seq ++;
238
239 if ($ffile) {
240 &check_file_read($ffile);
241 if ($keep_c) {
242 $cfile = ($ffile =~ /([^\/]*\.).$/)[0] . "c";
243 }
244 else {
245 $cfile = "$tmpdir/fort77-$$-$seq.c";
246 }
247 if ($debug) {
248 $debugcmd = ' | /usr/bin/perl -p -e \'s!^(#line.*)""!$1"'
249 . $ffile . '"!\' '
250 }
251
252 $xtmperrout = "/tmp/fort77-xtmp-err-$$.$seq";
253
254 if ($cpp || ($ffile =~ /\.F$/)) {
255 # Backslashes at the end of comment lines confuse cpp...
256 $pipe = "| /lib/cpp -traditional " .
257 join(' ',@cppopts) . " | f2c " .
258 join(' ',@fopts) . $debugcmd . "2>$xtmperrout > $cfile ";
259 print STDERR "$0: Running \"$pipe\"" if $verbose;
260 open(F2C,$pipe);
261
262 open (FFILE, "$ffile") || die ("$0: Cannot open $ffile: $_\n");
263 while (defined($_ = <FFILE>)) {
264 s/([cC*].*)\\$/$1/;
265 print F2C $_;
266 }
267 close(FFILE);
268 close(F2C);
269 $retcode = $? / 256;
270 $retcode1 = 0;
271 }
272 else {
273 print "$ffile:\n";
274
275 if ($debugcmd eq "") {
276 $xtmpfile = $cfile;
277 } else {
278 $xtmpfile = "/tmp/fort77-xtmp-$$.$seq";
279 }
280
281 $retcode = &mysystem("f2c ".
282 join (" ",@fopts). " < ". $ffile . " >$xtmpfile 2>$xtmperrout")/256;
283 if ($debugcmd ne "") {
284 &mysystem("cat $xtmpfile $debugcmd > $cfile");
285 unlink $xtmpfile;
286 } else {
287 $retcode1 = 0;
288 }
289
290 }
291 # Fix error messages.
292 @sedfilenamepieces = split(/\//, $ffile);
293 $sedfilename = "";
294 foreach $piece (@sedfilenamepieces) {
295 $sedfilename = "$sedfilename\\$piece";
296 }
297
298 &mysystem("sed 's/^\\(Error\\|Warning\\) \\(on\\|processing entries before\\) line \\([0-9]*\\):/\\1 \\2 line \\3 of $sedfilename:/' <$xtmperrout 1>&2");
299 unlink $xtmperrout;
300
301 if (($retcode || $retcode1) && !$keep_c) {
302 print STDERR "$0: unlinking $cfile\n" if $verbose;
303 unlink $cfile;
304 die "$0: aborting compilation\n";
305 }
306
307 # Separate the prototypes out from the C files.
308
309 if ($extract_prototypes) {
310 $pfile = ($basefile =~ /([^\/]*\.).$/)[0] . "P";
311 open(CFILE, "$cfile") || die ("$0: Cannot open $cfile\n");
312 while (defined(($line = <CFILE>)) &&
313 ($line !~ '#ifdef P_R_O_T_O_T_Y_P_E_S\n')) {
314 print $line;
315 }
316 if ($_) {
317 open(PFILE, ">$pfile") || die ("$0: Cannot open $pfile\n");
318 while (defined(($line = <CFILE>)) &&
319 ($line !~ '#endif')) {
320 print PFILE $line;
321 }
322 close(PFILE);
323 }
324 close(CFILE);
325 }
326 }
327
328 # C compilation step.
329
330 if ($cfile) {
331 @command = ($cc,@cppopts,@copts);
332 if ($compile_only && $output) {
333 push(@command,'-o',$output,$compile_only);
334 }
335 elsif ((!$compile_only) || ($compile_only eq '-c')) {
336 $lfile = ($basefile =~ /([^\/]*\.).$/)[0] . "o";
337 push(@command, '-c', '-o', $lfile);
338 }
339 elsif ($compile_only eq '-S') {
340 $sfile = ($basefile =~ /([^\/]*\.).$/)[0] . "s";
341 push(@command, '-S', '-o', $sfile);
342 }
343
344 push(@command,$cfile);
345 $retcode = &mysystem(@command)/256;
346
347 if ($retcode) {
348 die "$0: aborting compilation\n";
349 }
350 if ($ffile && !$keep_c) {
351 print STDERR "$0: unlinking $cfile\n" if $verbose;
352 unlink $cfile;
353 }
354 if ($lfile) {
355 push (@gener_lfiles, $lfile); push(@lfiles, $lfile);
356 $lfile = "";
357 }
358 }
359 push (@lfiles, $lfile) if $lfile;
360 }
361
362
363 exit if $compile_only;
364
365 push (@output, "-o", $output) if $output;
366
367 $retcode = &mysystem($cc, @output, @lfiles, @lopts, "-lf2c", "-lm" );
368 if (@gener_lfiles) {
369 print STDERR "$0: unlinking ",join(',',@gener_lfiles),"\n" if $verbose;
370 unlink (@gener_lfiles);
371 }
372 exit $retcode;
373
374 # Basically a system call, except that we want to be verbose if
375 # necessary.
376
377 sub mysystem
378 {
379 local (@args) = @_;
380 if (@args == 1) {
381 print STDERR "$0: Running \"$args[0]\"\n" if $verbose;
382 system($args[0]);
383 }
384 else {
385 print STDERR "$0: Running \"",join('" "',@args),"\"\n" if $verbose;
386 system(@args);
387 }
388 }
389
390 sub parsewx
391 {
392 local ($str) = @_;
393 local(@tmp) = split(/,/,$str);
394 shift(@tmp);
395 return @tmp;
396 }
397
398 sub check_file_read
399 {
400 local ($name) = @_;
401 open (TESTFILE,"$name") || die "Cannot open $name: $!\n";
402 close(TESTFILE);
403 }