1 /****************************************************************
2 Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore.
3
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T, Bell Laboratories,
10 Lucent or Bellcore or any of their entities not be used in
11 advertising or publicity pertaining to distribution of the
12 software without specific, written prior permission.
13
14 AT&T, Lucent and Bellcore disclaim all warranties with regard to
15 this software, including all implied warranties of
16 merchantability and fitness. In no event shall AT&T, Lucent or
17 Bellcore be liable for any special, indirect or consequential
18 damages or any damages whatsoever resulting from loss of use,
19 data or profits, whether in an action of contract, negligence or
20 other tortious action, arising out of or in connection with the
21 use or performance of this software.
22 ****************************************************************/
23
24 extern char F2C_version[];
25
26 #include "defs.h"
27 #include "parse.h"
28
29 int complex_seen, dcomplex_seen;
30
31 LOCAL int Max_ftn_files;
32
33 int badargs;
34 char **ftn_files;
35 int current_ftn_file = 0;
36
37 flag ftn66flag = NO;
38 flag nowarnflag = NO;
39 flag noextflag = NO;
40 flag no66flag = NO; /* Must also set noextflag to this
41 same value */
42 flag zflag = YES; /* recognize double complex intrinsics */
43 flag debugflag = NO;
44 flag onetripflag = NO;
45 flag shiftcase = YES;
46 flag undeftype = NO;
47 flag checksubs = NO;
48 flag r8flag = NO;
49 flag use_bs = YES;
50 flag keepsubs = NO;
51 flag byterev = NO;
52 int intr_omit;
53 static int no_cd, no_i90;
54 #ifdef TYQUAD
55 flag use_tyquad = YES;
56 #ifndef NO_LONG_LONG
57 flag allow_i8c = YES;
58 #endif
59 #endif
60 int tyreal = TYREAL;
61 int tycomplex = TYCOMPLEX;
62
63 int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */
64 int maxequiv = MAXEQUIV;
65 int maxext = MAXEXT;
66 int maxstno = MAXSTNO;
67 int maxctl = MAXCTL;
68 int maxhash = MAXHASH;
69 int maxliterals = MAXLITERALS;
70 int maxcontin = MAXCONTIN;
71 int maxlablist = MAXLABLIST;
72 int extcomm, ext1comm, useauto;
73 int can_include = YES; /* so we can disable includes for netlib */
74
75 static char *def_i2 = "";
76
77 static int useshortints = NO; /* YES => tyint = TYSHORT */
78 static int uselongints = NO; /* YES => tyint = TYLONG */
79 int addftnsrc = NO; /* Include ftn source in output */
80 int usedefsforcommon = NO; /* Use #defines for common reference */
81 int forcedouble = YES; /* force real functions to double */
82 int dneg = NO; /* f77 treatment of unary minus */
83 int Ansi = YES;
84 int def_equivs = YES;
85 int tyioint = TYLONG;
86 int szleng = SZLENG;
87 int inqmask = M(TYLONG)|M(TYLOGICAL);
88 int wordalign = NO;
89 int forcereal = NO;
90 int warn72 = NO;
91 static int help, showver, skipC, skipversion;
92 char *file_name, *filename0, *parens;
93 int Castargs = 1;
94 static int Castargs1;
95 static int typedefs = 0;
96 int chars_per_wd, gflag, protostatus;
97 int infertypes = 1;
98 char used_rets[TYSUBR+1];
99 extern char *tmpdir;
100 static int h0align = 0;
101 char *halign, *ohalign;
102 int krparens = NO;
103 int hsize; /* for padding under -h */
104 int htype; /* for wr_equiv_init under -h */
105 int trapuv;
106 chainp Iargs;
107
108 #define f2c_entry(swit,count,type,store,size) \
109 p_entry ("-", swit, 0, count, type, store, size)
110
111 static arg_info table[] = {
112 f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
113 f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
114 f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
115 f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
116 f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
117 f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
118 f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
119 f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
120 f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
121 f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
122 f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
123 f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
124 f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
125 f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
126 f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
127 f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
128 f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
129 f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0),
130 f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0),
131 f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
132 f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
133 f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
134 f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
135 f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
136 f2c_entry ("K", P_NO_ARGS, P_INT, &Ansi, NO),
137 f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
138 f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
139 f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
140 f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
141 f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
142 f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
143 f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
144 f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
145 f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
146 f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
147 f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
148 f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
149 f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
150 f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
151 f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
152 f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
153 f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
154 f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
155 f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
156 f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
157 f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
158 f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
159 f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
160 f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
161 f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
162 f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1),
163 f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2),
164 f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1),
165 f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0),
166 f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1),
167 f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2),
168 f2c_entry ("trapuv", P_NO_ARGS, P_INT, &trapuv, 1),
169 #ifdef TYQUAD
170 #ifndef NO_LONG_LONG
171 f2c_entry ("!i8const", P_NO_ARGS, P_INT, &allow_i8c, NO),
172 #endif
173 f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
174 #endif
175
176 /* options omitted from man pages */
177
178 /* -b ==> for unformatted I/O, call do_unio (for noncharacter */
179 /* data of length > 1 byte) and do_ucio (for the rest) rather */
180 /* than do_uio. This permits modifying libI77 to byte-reverse */
181 /* numeric data. */
182
183 f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES),
184
185 /* -ev ==> implement equivalence with initialized pointers */
186 f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
187
188 /* -!it used to be the default when -it was more agressive */
189
190 f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
191
192 /* -Pd is similar to -P, but omits :ref: lines */
193 f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
194
195 /* -t ==> emit typedefs (under -A or -C++) for procedure
196 argument types used. This is meant for netlib's
197 f2c service, so -A and -C++ will work with older
198 versions of f2c.h
199 */
200 f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
201
202 /* -!V ==> omit version msg (to facilitate using diff in
203 regression testing)
204 */
205 f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1),
206
207 /* -Dnnn = debug level nnn */
208
209 f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES),
210
211 /* -dneg ==> under (default) -!R, imitate f77's bizarre */
212 /* treatment of unary minus of REAL expressions by */
213 /* promoting them to DOUBLE PRECISION . */
214
215 f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES),
216
217 /* -?, --help, -v, --version */
218
219 f2c_entry ("?", P_NO_ARGS, P_INT, &help, YES),
220 f2c_entry ("-help", P_NO_ARGS, P_INT, &help, YES),
221
222 f2c_entry ("v", P_NO_ARGS, P_INT, &showver, YES),
223 f2c_entry ("-version", P_NO_ARGS, P_INT, &showver, YES)
224
225 }; /* table */
226
227 extern char *c_functions; /* "c_functions" */
228 extern char *coutput; /* "c_output" */
229 extern char *initfname; /* "raw_data" */
230 extern char *blkdfname; /* "block_data" */
231 extern char *p1_file; /* "p1_file" */
232 extern char *p1_bakfile; /* "p1_file.BAK" */
233 extern char *sortfname; /* "init_file" */
234 extern char *proto_fname; /* "proto_file" */
235 FILE *protofile;
236
237 void
set_externs(Void)238 set_externs(Void)
239 {
240 static char *hset[3] = { 0, "integer", "doublereal" };
241
242 /* Adjust the global flags according to the command line parameters */
243
244 if (chars_per_wd > 0) {
245 typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
246 typesize[TYLOGICAL] = chars_per_wd;
247 typesize[TYINT1] = typesize[TYLOGICAL1] = 1;
248 typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
249 typesize[TYDCOMPLEX] = chars_per_wd << 2;
250 typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1;
251 typesize[TYCILIST] = 5*chars_per_wd;
252 typesize[TYICILIST] = 6*chars_per_wd;
253 typesize[TYOLIST] = 9*chars_per_wd;
254 typesize[TYCLLIST] = 3*chars_per_wd;
255 typesize[TYALIST] = 2*chars_per_wd;
256 typesize[TYINLIST] = 26*chars_per_wd;
257 }
258
259 if (wordalign)
260 typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
261 if (!tyioint) {
262 tyioint = TYSHORT;
263 szleng = typesize[TYSHORT];
264 def_i2 = "#define f2c_i2 1\n";
265 inqmask = M(TYSHORT)|M(TYLOGICAL2);
266 goto checklong;
267 }
268 else
269 szleng = typesize[TYLONG];
270 if (useshortints) {
271 /* inqmask = M(TYLONG); */
272 /* used to disallow LOGICAL in INQUIRE under -I2 */
273 checklong:
274 protorettypes[TYLOGICAL] = "shortlogical";
275 casttypes[TYLOGICAL] = "K_fp";
276 if (uselongints)
277 err ("Can't use both long and short ints");
278 else {
279 tyint = tylogical = TYSHORT;
280 tylog = TYLOGICAL2;
281 }
282 }
283 else if (uselongints)
284 tyint = TYLONG;
285
286 if (h0align) {
287 if (tyint == TYLONG && wordalign)
288 h0align = 1;
289 ohalign = halign = hset[h0align];
290 htype = h0align == 1 ? tyint : TYDREAL;
291 hsize = typesize[htype];
292 }
293
294 if (no66flag)
295 noextflag = no66flag;
296 if (noextflag)
297 zflag = 0;
298
299 if (r8flag) {
300 tyreal = TYDREAL;
301 tycomplex = TYDCOMPLEX;
302 r8fix();
303 }
304 if (forcedouble) {
305 protorettypes[TYREAL] = "E_f";
306 casttypes[TYREAL] = "E_fp";
307 }
308 else
309 dneg = 0;
310
311 #ifndef NO_LONG_LONG
312 if (!use_tyquad)
313 allow_i8c = 0;
314 #endif
315
316 if (maxregvar > MAXREGVAR) {
317 warni("-O%d: too many register variables", maxregvar);
318 maxregvar = MAXREGVAR;
319 } /* if maxregvar > MAXREGVAR */
320
321 /* Check the list of input files */
322
323 {
324 int bad, i, cur_max = Max_ftn_files;
325
326 for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
327 if (ftn_files[i][0] == '-') {
328 errstr ("Invalid flag '%s'", ftn_files[i]);
329 bad++;
330 }
331 if (bad)
332 exit(1);
333
334 } /* block */
335 } /* set_externs */
336
337
338 static int
comm2dcl(Void)339 comm2dcl(Void)
340 {
341 Extsym *ext;
342 if (ext1comm)
343 for(ext = extsymtab; ext < nextext; ext++)
344 if (ext->extstg == STGCOMMON && !ext->extinit)
345 return ext1comm;
346 return 0;
347 }
348
349 static void
350 #ifdef KR_headers
write_typedefs(outfile)351 write_typedefs(outfile)
352 FILE *outfile;
353 #else
354 write_typedefs(FILE *outfile)
355 #endif
356 {
357 register int i;
358 register char *s, *p = 0;
359 static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
360 static char stl[4] = { 'E', 'C', 'Z', 'H' };
361
362 for(i = 0; i <= TYSUBR; i++)
363 if (s = usedcasts[i]) {
364 if (!p) {
365 p = (char*)(Ansi == 1 ? "()" : "(...)");
366 nice_printf(outfile,
367 "/* Types for casting procedure arguments: */\
368 \n\n#ifndef F2C_proc_par_types\n");
369 if (i == 0) {
370 nice_printf(outfile,
371 "typedef int /* Unknown procedure type */ (*%s)%s;\n",
372 s, p);
373 continue;
374 }
375 }
376 nice_printf(outfile, "typedef %s (*%s)%s;\n",
377 c_type_decl(i,1), s, p);
378 }
379 for(i = !forcedouble; i < 4; i++)
380 if (used_rets[st[i]])
381 nice_printf(outfile,
382 "typedef %s %c_f; /* %s function */\n",
383 p = (char*)(i ? "VOID" : "doublereal"),
384 stl[i], ftn_types[st[i]]);
385 if (p)
386 nice_printf(outfile, "#endif\n\n");
387 }
388
389 static void
390 #ifdef KR_headers
commonprotos(outfile)391 commonprotos(outfile)
392 register FILE *outfile;
393 #else
394 commonprotos(register FILE *outfile)
395 #endif
396 {
397 register Extsym *e, *ee;
398 register Argtypes *at;
399 Atype *a, *ae;
400 int k;
401 extern int proc_protochanges;
402
403 if (!outfile)
404 return;
405 for (e = extsymtab, ee = nextext; e < ee; e++)
406 if (e->extstg == STGCOMMON && e->allextp)
407 nice_printf(outfile, "/* comlen %s %ld */\n",
408 e->cextname, e->maxleng);
409 if (Castargs1 < 3)
410 return;
411
412 /* -Pr: special comments conveying current knowledge
413 of external references */
414
415 k = proc_protochanges;
416 for (e = extsymtab, ee = nextext; e < ee; e++)
417 if (e->extstg == STGEXT
418 && e->cextname != e->fextname) /* not a library function */
419 if (at = e->arginfo) {
420 if ((!e->extinit || at->changes & 1)
421 /* not defined here or
422 changed since definition */
423 && at->nargs >= 0) {
424 nice_printf(outfile, "/*:ref: %s %d %d",
425 e->cextname, e->extype, at->nargs);
426 a = at->atypes;
427 for(ae = a + at->nargs; a < ae; a++)
428 nice_printf(outfile, " %d", a->type);
429 nice_printf(outfile, " */\n");
430 if (at->changes & 1)
431 k++;
432 }
433 }
434 else if (e->extype)
435 /* typed external, never invoked */
436 nice_printf(outfile, "/*:ref: %s %d :*/\n",
437 e->cextname, e->extype);
438 if (k) {
439 nice_printf(outfile,
440 "/* Rerunning f2c -P may change prototypes or declarations. */\n");
441 if (nerr)
442 return;
443 if (protostatus)
444 done(4);
445 if (protofile != stdout) {
446 fprintf(diagfile,
447 "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
448 filename0, proto_fname);
449 fflush(diagfile);
450 }
451 }
452 }
453
454 static int
455 #ifdef KR_headers
I_args(argc,a)456 I_args(argc, a)
457 int argc;
458 char **a;
459 #else
460 I_args(int argc, char **a)
461 #endif
462 {
463 char **a0, **a1, **ae, *s;
464
465 ae = a + argc;
466 a0 = a;
467 for(a1 = ++a; a < ae; a++) {
468 if (!(s = *a))
469 break;
470 if (*s == '-' && s[1] == 'I' && s[2]
471 && (s[3] || s[2] != '2' && s[2] != '4'))
472 Iargs = mkchain(s+2, Iargs);
473 else
474 *a1++ = s;
475 }
476 Iargs = revchain(Iargs);
477 *a1 = 0;
478 return a1 - a0;
479 }
480
481 static void
omit_non_f(Void)482 omit_non_f(Void)
483 {
484 /* complain about ftn_files that do not end in .f or .F */
485
486 char *s, *s1;
487 int i, k;
488
489 for(i = k = 0; s = ftn_files[k]; k++) {
490 s1 = s + strlen(s);
491 if (s1 - s >= 3) {
492 s1 -= 2;
493 if (*s1 == '.') switch(s1[1]) {
494 case 'f':
495 case 'F':
496 ftn_files[i++] = s;
497 continue;
498 }
499 }
500 fprintf(diagfile, "\"%s\" does not end in .f or .F\n", s);
501 }
502 if (i != k) {
503 fflush(diagfile);
504 if (!i)
505 exit(1);
506 ftn_files[i] = 0;
507 }
508 }
509
510 static void
show_version(Void)511 show_version(Void)
512 {
513 printf("f2c (Fortran to C Translator) version %s.\n", F2C_version);
514 }
515
516 static void
517 #ifdef KR_headers
show_help(progname)518 show_help(progname) char *progname;
519 #else
520 show_help(char *progname)
521 #endif
522 {
523 show_version();
524 if (!progname)
525 progname = "f2c";
526 printf("Usage: %s [ option ... ] [file ...]\n%s%s%s%s%s%s%s",
527 progname,
528 "For usage details, see the man page, f2c.1.\n",
529 "For technical details, see the f2c report.\n",
530 "Both are available from netlib, e.g.,\n",
531 "\thttps://www.netlib.org/f2c/f2c.1\n",
532 "\thttps://www.netlib.org/f2c/f2c.pdf\nor\n",
533 "\thttps://ampl.com/netlib/f2c/f2c.1\n",
534 "\thttps://ampl.com/netlib/f2c/f2c.pdf\n");
535 }
536
537 int retcode = 0;
538
539 int
540 #ifdef KR_headers
main(argc,argv)541 main(argc, argv)
542 int argc;
543 char **argv;
544 #else
545 main(int argc, char **argv)
546 #endif
547 {
548 int c2d, k;
549 FILE *c_output;
550 char *cdfilename;
551 static char stderrbuf[BUFSIZ];
552 extern char **dfltproc, *dflt1proc[];
553 extern char link_msg[];
554
555 diagfile = stderr;
556 setbuf(stderr, stderrbuf); /* arrange for fast error msgs */
557
558 argkludge(&argc, &argv); /* for _WIN32 */
559 argc = I_args(argc, argv); /* extract -I args */
560 Max_ftn_files = argc - 1;
561 ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
562
563 parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
564 ftn_files, Max_ftn_files);
565 if (badargs)
566 return 1;
567 if (help) {
568 show_help(argv[0]);
569 return 0;
570 }
571 if (showver && !ftn_files[0]) {
572 show_version();
573 return 0;
574 }
575 intr_omit = no_cd | no_i90;
576 if (keepsubs && checksubs) {
577 warn("-C suppresses -s\n");
578 keepsubs = 0;
579 }
580 if (!can_include && ext1comm == 2)
581 ext1comm = 1;
582 if (ext1comm && !extcomm)
583 extcomm = 2;
584 if (protostatus)
585 Castargs = 3;
586 Castargs1 = Castargs;
587 if (!Ansi) {
588 Castargs = 0;
589 parens = "()";
590 }
591 else if (!Castargs)
592 parens = (char*)(Ansi == 1 ? "()" : "(...)");
593 else
594 dfltproc = dflt1proc;
595
596 outbuf_adjust();
597 set_externs();
598 fileinit();
599 read_Pfiles(ftn_files);
600 omit_non_f();
601
602 for(k = 0; ftn_files[k+1]; k++)
603 if (dofork(ftn_files[k]))
604 break;
605 filename0 = file_name = ftn_files[current_ftn_file = k];
606
607 set_tmp_names();
608 sigcatch(0);
609
610 c_file = opf(c_functions, textwrite);
611 pass1_file=opf(p1_file, binwrite);
612 initkey();
613 if (file_name && *file_name) {
614 cdfilename = coutput;
615 if (debugflag != 1) {
616 coutput = c_name(file_name,'c');
617 cdfilename = copys(outbtail);
618 if (Castargs1 >= 2)
619 proto_fname = c_name(file_name,'P');
620 }
621 if (skipC)
622 coutput = 0;
623 else if (!(c_output = fopen(coutput, textwrite))) {
624 file_name = coutput;
625 coutput = 0; /* don't delete read-only .c file */
626 fatalstr("can't open %.86s", file_name);
627 }
628
629 if (Castargs1 >= 2
630 && !(protofile = fopen(proto_fname, textwrite)))
631 fatalstr("Can't open %.84s\n", proto_fname);
632 }
633 else {
634 file_name = "";
635 cdfilename = "f2c_out.c";
636 c_output = stdout;
637 coutput = 0;
638 if (Castargs1 >= 2) {
639 protofile = stdout;
640 if (!skipC)
641 printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
642 }
643 }
644
645 if(inilex( copys(file_name) ))
646 done(1);
647 if (filename0) {
648 fprintf(diagfile, "%s:\n", file_name);
649 fflush(diagfile);
650 }
651
652 procinit();
653 if(k = yyparse())
654 {
655 fprintf(diagfile, "Bad parse, return code %d\n", k);
656 done(1);
657 }
658
659 commonprotos(protofile);
660 if (protofile == stdout && !skipC)
661 printf("#endif\n\n");
662
663 if (nerr || skipC)
664 goto C_skipped;
665
666
667 /* Write out the declarations which are global to this file */
668
669 if ((c2d = comm2dcl()) == 1)
670 nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
671 /* Split this into several files by piping it through\n\n\
672 sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
673 */\n\
674 /*<<</dev/null>>>*/\n\
675 /*>>>'%s'<<<*/\n", cdfilename);
676 if (gflag)
677 nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
678 if (!skipversion) {
679 nice_printf (c_output, "/* %s -- translated by f2c ", file_name);
680 nice_printf (c_output, "(version %s).\n", F2C_version);
681 nice_printf (c_output,
682 " You must link the resulting object file with libf2c:\n\
683 %s\n*/\n\n", link_msg);
684 }
685 if (Ansi == 2)
686 nice_printf(c_output,
687 "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
688 nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
689 if (trapuv)
690 nice_printf(c_output, "extern void _uninit_f2c(%s);\n%s\n\n",
691 Ansi ? "void*,int,long" : "", "extern double _0;");
692 if (gflag)
693 nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
694 if (Castargs && typedefs)
695 write_typedefs(c_output);
696 nice_printf (c_file, "\n");
697 fclose (c_file);
698 c_file = c_output; /* HACK to get the next indenting
699 to work */
700 wr_common_decls (c_output);
701 if (blkdfile)
702 list_init_data(&blkdfile, blkdfname, c_output);
703 wr_globals (c_output);
704 if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
705 Fatal("main - couldn't reopen c_functions");
706 ffilecopy (c_file, c_output);
707 if (*main_alias) {
708 nice_printf (c_output, "/* Main program alias */ ");
709 nice_printf (c_output, "int %s () { MAIN__ ();%s }\n",
710 main_alias, Ansi ? " return 0;" : "");
711 }
712 if (Ansi == 2)
713 nice_printf(c_output,
714 "#ifdef __cplusplus\n\t}\n#endif\n");
715 if (c2d) {
716 if (c2d == 1)
717 fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
718 else
719 fclose(c_output);
720 def_commons(c_output);
721 }
722 if (c2d != 2)
723 fclose (c_output);
724
725 C_skipped:
726 if(parstate != OUTSIDE)
727 {
728 warn("missing final end statement");
729 endproc();
730 nerr = 1;
731 }
732 done(nerr ? 1 : 0);
733 /* NOT REACHED */ return 0;
734 }
735
736
737 FILEP
738 #ifdef KR_headers
opf(fn,mode)739 opf(fn, mode)
740 char *fn;
741 char *mode;
742 #else
743 opf(char *fn, char *mode)
744 #endif
745 {
746 FILEP fp;
747 if( fp = fopen(fn, mode) )
748 return(fp);
749
750 fatalstr("cannot open intermediate file %s", fn);
751 /* NOT REACHED */ return 0;
752 }
753
754
755 void
756 #ifdef KR_headers
clf(p,what,quit)757 clf(p, what, quit)
758 FILEP *p;
759 char *what;
760 int quit;
761 #else
762 clf(FILEP *p, char *what, int quit)
763 #endif
764 {
765 if(p!=NULL && *p!=NULL && *p!=stdout)
766 {
767 if(ferror(*p)) {
768 fprintf(stderr, "I/O error on %s\n", what);
769 if (quit)
770 done(3);
771 retcode = 3;
772 }
773 fclose(*p);
774 }
775 *p = NULL;
776 }
777
778
779 void
780 #ifdef KR_headers
done(k)781 done(k)
782 int k;
783 #else
784 done(int k)
785 #endif
786 {
787 clf(&initfile, "initfile", 0);
788 clf(&c_file, "c_file", 0);
789 clf(&pass1_file, "pass1_file", 0);
790 Un_link_all(k);
791 exit(k|retcode);
792 }
793