1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
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 or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
24 extern char F2C_version[];
29 int complex_seen, dcomplex_seen;
31 LOCAL int Max_ftn_files;
34 int current_ftn_file = 0;
39 flag no66flag = NO; /* Must also set noextflag to this
41 flag zflag = YES; /* recognize double complex intrinsics */
43 flag onetripflag = NO;
49 extern void r8fix(), read_Pfiles();
51 int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */
52 int maxequiv = MAXEQUIV;
54 int maxstno = MAXSTNO;
56 int maxhash = MAXHASH;
57 int extcomm, ext1comm, useauto;
58 int can_include = YES; /* so we can disable includes for netlib */
60 static char *def_i2 = "";
62 static int useshortints = NO; /* YES => tyint = TYSHORT */
63 static int uselongints = NO; /* YES => tyint = TYLONG */
64 int addftnsrc = NO; /* Include ftn source in output */
65 int usedefsforcommon = NO; /* Use #defines for common reference */
66 int forcedouble = YES; /* force real functions to double */
71 int inqmask = M(TYLONG)|M(TYLOGICAL);
73 static int skipC, skipversion;
74 char *filename0, *parens;
76 static int typedefs = 0;
77 int chars_per_wd, gflag, protostatus;
79 char used_rets[TYSUBR+1];
82 #define f2c_entry(swit,count,type,store,size) \
83 p_entry ("-", swit, 0, count, type, store, size)
85 static arg_info table[] = {
86 f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
87 f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
88 f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
89 f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
90 f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
91 f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
92 f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
93 f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
94 f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
95 f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
96 f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
97 f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
98 f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
99 f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
100 f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
101 f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
102 f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
103 f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
104 f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
105 f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
106 f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
107 f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
108 f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
109 f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
110 f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
111 f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
112 f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
113 f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
114 f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
115 f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
116 f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
117 f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
118 f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
119 f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
120 f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
121 f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
122 f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
123 f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
124 f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
125 f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
126 f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
128 /* options omitted from man pages */
130 /* -ev ==> implement equivalence with initialized pointers */
131 f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
133 /* -!it used to be the default when -it was more agressive */
135 f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
137 /* -Pd is similar to -P, but omits :ref: lines */
138 f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
140 /* -t ==> emit typedefs (under -A or -C++) for procedure
141 argument types used. This is meant for netlib's
142 f2c service, so -A and -C++ will work with older
145 f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
147 /* -!V ==> omit version msg (to facilitate using diff in
150 f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
154 extern char *c_functions; /* "c_functions" */
155 extern char *coutput; /* "c_output" */
156 extern char *initfname; /* "raw_data" */
157 extern char *blkdfname; /* "block_data" */
158 extern char *p1_file; /* "p1_file" */
159 extern char *p1_bakfile; /* "p1_file.BAK" */
160 extern char *sortfname; /* "init_file" */
161 static char *proto_fname; /* "proto_file" */
164 extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
165 extern char *c_name();
170 /* Adjust the global flags according to the command line parameters */
172 if (chars_per_wd > 0) {
173 typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
174 typesize[TYLOGICAL] = chars_per_wd;
175 typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
176 typesize[TYDCOMPLEX] = chars_per_wd << 2;
177 typesize[TYSHORT] = chars_per_wd >> 1;
178 typesize[TYCILIST] = 5*chars_per_wd;
179 typesize[TYICILIST] = 6*chars_per_wd;
180 typesize[TYOLIST] = 9*chars_per_wd;
181 typesize[TYCLLIST] = 3*chars_per_wd;
182 typesize[TYALIST] = 2*chars_per_wd;
183 typesize[TYINLIST] = 26*chars_per_wd;
187 typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
190 szleng = typesize[TYSHORT];
191 def_i2 = "#define f2c_i2 1\n";
192 inqmask = M(TYSHORT)|M(TYLOGICAL);
196 szleng = typesize[TYLONG];
200 protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
201 typesize[TYLOGICAL] = typesize[TYSHORT];
202 casttypes[TYLOGICAL] = "K_fp";
204 err ("Can't use both long and short ints");
206 tyint = tylogical = TYSHORT;
208 else if (uselongints)
212 noextflag = no66flag;
221 protorettypes[TYREAL] = "E_f";
222 casttypes[TYREAL] = "E_fp";
225 if (maxregvar > MAXREGVAR) {
226 warni("-O%d: too many register variables", maxregvar);
227 maxregvar = MAXREGVAR;
228 } /* if maxregvar > MAXREGVAR */
230 /* Check the list of input files */
233 int bad, i, cur_max = Max_ftn_files;
235 for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
236 if (ftn_files[i][0] == '-') {
237 errstr ("Invalid flag '%s'", ftn_files[i]);
252 for(ext = extsymtab; ext < nextext; ext++)
253 if (ext->extstg == STGCOMMON && !ext->extinit)
259 write_typedefs(outfile)
263 register char *s, *p = 0;
264 static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
265 static char stl[4] = { 'E', 'C', 'Z', 'H' };
267 for(i = 0; i <= TYSUBR; i++)
268 if (s = usedcasts[i]) {
270 p = Ansi == 1 ? "()" : "(...)";
272 "/* Types for casting procedure arguments: */\
273 \n\n#ifndef F2C_proc_par_types\n");
276 "typedef int /* Unknown procedure type */ (*%s)%s;\n",
281 nice_printf(outfile, "typedef %s (*%s)%s;\n",
282 c_type_decl(i,1), s, p);
284 for(i = !forcedouble; i < 4; i++)
285 if (used_rets[st[i]])
287 "typedef %s %c_f; /* %s function */\n",
288 p = i ? "VOID" : "doublereal",
289 stl[i], ftn_types[st[i]]);
291 nice_printf(outfile, "#endif\n\n");
295 commonprotos(outfile)
296 register FILE *outfile;
298 register Extsym *e, *ee;
299 register Argtypes *at;
302 extern int proc_protochanges;
306 for (e = extsymtab, ee = nextext; e < ee; e++)
307 if (e->extstg == STGCOMMON && e->allextp)
308 nice_printf(outfile, "/* comlen %s %ld */\n",
309 e->cextname, e->maxleng);
313 /* -Pr: special comments conveying current knowledge
314 of external references */
316 k = proc_protochanges;
317 for (e = extsymtab, ee = nextext; e < ee; e++)
318 if (e->extstg == STGEXT
319 && e->cextname != e->fextname) /* not a library function */
320 if (at = e->arginfo) {
321 if ((!e->extinit || at->changes & 1)
322 /* not defined here or
323 changed since definition */
325 nice_printf(outfile, "/*:ref: %s %d %d",
326 e->cextname, e->extype, at->nargs);
328 for(ae = a + at->nargs; a < ae; a++)
329 nice_printf(outfile, " %d", a->type);
330 nice_printf(outfile, " */\n");
336 /* typyed external, never invoked */
337 nice_printf(outfile, "/*:ref: %s %d :*/\n",
338 e->cextname, e->extype);
341 "/* Rerunning f2c -P may change prototypes or declarations. */\n");
346 if (protofile != stdout) {
348 "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
349 filename0, proto_fname);
363 char *filename, *cdfilename;
364 static char stderrbuf[BUFSIZ];
365 extern void def_commons();
366 extern char **dfltproc, *dflt1proc[];
369 setbuf(stderr, stderrbuf); /* arrange for fast error msgs */
371 Max_ftn_files = argc - 1;
372 ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
374 parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
375 ftn_files, Max_ftn_files);
376 if (!can_include && ext1comm == 2)
378 if (ext1comm && !extcomm)
382 else if (Castargs == 1 && !Ansi)
384 if (Castargs >= 2 && !Ansi)
390 parens = Ansi == 1 ? "()" : "(...)";
392 dfltproc = dflt1proc;
396 read_Pfiles(ftn_files);
398 for(k = 1; ftn_files[k]; k++)
401 filename0 = filename = ftn_files[current_ftn_file = k - 1];
406 c_file = opf(c_functions, textwrite);
407 pass1_file=opf(p1_file, binwrite);
409 if (filename && *filename) {
410 if (debugflag != 1) {
411 coutput = c_name(filename,'c');
413 proto_fname = c_name(filename,'P');
415 cdfilename = coutput;
417 && !(protofile = fopen(proto_fname, textwrite)))
418 fatalstr("Can't open %.84s\n", proto_fname);
422 cdfilename = "f2c_out.c";
428 printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
432 if(inilex( copys(filename) ))
435 fprintf(diagfile, "%s:\n", filename);
442 fprintf(diagfile, "Bad parse, return code %d\n", k);
446 commonprotos(protofile);
447 if (protofile == stdout && !skipC)
448 printf("#endif\n\n");
457 && (c_output = fopen (coutput, textwrite)) == (FILE *) NULL)
458 fatalstr("can't open %.86s", coutput);
461 /* Write out the declarations which are global to this file */
463 if ((c2d = comm2dcl()) == 1)
464 nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
465 /* Split this into several files by piping it through\n\n\
466 sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
468 /*<<</dev/null>>>*/\n\
469 /*>>>'%s'<<<*/\n", cdfilename);
471 nice_printf (c_output, "/* %s -- translated by f2c ", filename);
472 nice_printf (c_output, "(version of %s).\n", F2C_version);
473 nice_printf (c_output,
474 " You must link the resulting object file with the libraries:\n\
475 -lF77 -lI77 -lm -lc (in that order)\n*/\n\n");
478 nice_printf(c_output,
479 "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
480 nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
481 if (Castargs && typedefs)
482 write_typedefs(c_output);
483 nice_printf (c_file, "\n");
485 c_file = c_output; /* HACK to get the next indenting
487 wr_common_decls (c_output);
489 list_init_data(&blkdfile, blkdfname, c_output);
490 wr_globals (c_output);
491 if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
492 Fatal("main - couldn't reopen c_functions");
493 ffilecopy (c_file, c_output);
495 nice_printf (c_output, "/* Main program alias */ ");
496 nice_printf (c_output, "int %s () { MAIN__ (); }\n",
500 nice_printf(c_output,
501 "#ifdef __cplusplus\n\t}\n#endif\n");
504 fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
507 def_commons(c_output);
513 if(parstate != OUTSIDE)
515 warn("missing END statement");
526 if( fp = fopen(fn, mode) )
529 fatalstr("cannot open intermediate file %s", fn);
530 /* NOT REACHED */ return 0;
539 if(p!=NULL && *p!=NULL && *p!=stdout)
542 fprintf(stderr, "I/O error on %s\n", what);
556 clf(&initfile, "initfile", 0);
557 clf(&c_file, "c_file", 0);
558 clf(&pass1_file, "pass1_file", 0);