|
|
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories 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 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.
13:
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
21: 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: char **ftn_files;
34: int current_ftn_file = 0;
35:
36: flag ftn66flag = NO;
37: flag nowarnflag = NO;
38: flag noextflag = NO;
39: flag no66flag = NO; /* Must also set noextflag to this
40: same value */
41: flag zflag = YES; /* recognize double complex intrinsics */
42: flag debugflag = NO;
43: flag onetripflag = NO;
44: flag shiftcase = YES;
45: flag undeftype = NO;
46: flag checksubs = NO;
47: flag r8flag = NO;
48: flag use_bs = YES;
49: flag keepsubs = NO;
50: #ifdef TYQUAD
51: flag use_tyquad = YES;
52: #endif
53: int tyreal = TYREAL;
54: int tycomplex = TYCOMPLEX;
55: extern void r8fix(), read_Pfiles();
56:
57: int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */
58: int maxequiv = MAXEQUIV;
59: int maxext = MAXEXT;
60: int maxstno = MAXSTNO;
61: int maxctl = MAXCTL;
62: int maxhash = MAXHASH;
63: int maxliterals = MAXLITERALS;
64: int maxcontin = MAXCONTIN;
65: int maxlablist = MAXLABLIST;
66: int extcomm, ext1comm, useauto;
67: int can_include = YES; /* so we can disable includes for netlib */
68:
69: static char *def_i2 = "";
70:
71: static int useshortints = NO; /* YES => tyint = TYSHORT */
72: static int uselongints = NO; /* YES => tyint = TYLONG */
73: int addftnsrc = NO; /* Include ftn source in output */
74: int usedefsforcommon = NO; /* Use #defines for common reference */
75: int forcedouble = YES; /* force real functions to double */
76: int Ansi = NO;
77: int def_equivs = YES;
78: int tyioint = TYLONG;
79: int szleng = SZLENG;
80: int inqmask = M(TYLONG)|M(TYLOGICAL);
81: int wordalign = NO;
82: int forcereal = NO;
83: int warn72 = NO;
84: static int skipC, skipversion;
85: char *file_name, *filename0, *parens;
86: int Castargs = 1;
87: static int Castargs1;
88: static int typedefs = 0;
89: int chars_per_wd, gflag, protostatus;
90: int infertypes = 1;
91: char used_rets[TYSUBR+1];
92: extern char *tmpdir;
93: static int h0align = 0;
94: char *halign, *ohalign;
95: int krparens = NO;
96: int hsize; /* for padding under -h */
97: int htype; /* for wr_equiv_init under -h */
98:
99: #define f2c_entry(swit,count,type,store,size) \
100: p_entry ("-", swit, 0, count, type, store, size)
101:
102: static arg_info table[] = {
103: f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
104: f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
105: f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
106: f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
107: f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
108: f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
109: f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
110: f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
111: f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
112: f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
113: f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
114: f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
115: f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
116: f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
117: f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
118: f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
119: f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
120: f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
121: f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0),
122: f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0),
123: f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
124: f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
125: f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
126: f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
127: f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
128: f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
129: f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
130: f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
131: f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
132: f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
133: f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
134: f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
135: f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
136: f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
137: f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
138: f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
139: f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
140: f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
141: f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
142: f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
143: f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
144: f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
145: f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
146: f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
147: f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
148: f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
149: f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
150: f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
151: f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
152: f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
153: f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1),
154: f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2),
155: f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1),
156: #ifdef TYQUAD
157: f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
158: #endif
159:
160: /* options omitted from man pages */
161:
162: /* -ev ==> implement equivalence with initialized pointers */
163: f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
164:
165: /* -!it used to be the default when -it was more agressive */
166:
167: f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
168:
169: /* -Pd is similar to -P, but omits :ref: lines */
170: f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
171:
172: /* -t ==> emit typedefs (under -A or -C++) for procedure
173: argument types used. This is meant for netlib's
174: f2c service, so -A and -C++ will work with older
175: versions of f2c.h
176: */
177: f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
178:
179: /* -!V ==> omit version msg (to facilitate using diff in
180: regression testing)
181: */
182: f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
183:
184: }; /* table */
185:
186: extern char *c_functions; /* "c_functions" */
187: extern char *coutput; /* "c_output" */
188: extern char *initfname; /* "raw_data" */
189: extern char *blkdfname; /* "block_data" */
190: extern char *p1_file; /* "p1_file" */
191: extern char *p1_bakfile; /* "p1_file.BAK" */
192: extern char *sortfname; /* "init_file" */
193: extern char *proto_fname; /* "proto_file" */
194: FILE *protofile;
195:
196: extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
197: extern char *c_name();
198:
199:
200: set_externs ()
201: {
202: static char *hset[3] = { 0, "integer", "doublereal" };
203:
204: /* Adjust the global flags according to the command line parameters */
205:
206: if (chars_per_wd > 0) {
207: typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
208: typesize[TYLOGICAL] = chars_per_wd;
209: typesize[TYINT1] = typesize[TYLOGICAL1] = 1;
210: typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
211: typesize[TYDCOMPLEX] = chars_per_wd << 2;
212: typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1;
213: typesize[TYCILIST] = 5*chars_per_wd;
214: typesize[TYICILIST] = 6*chars_per_wd;
215: typesize[TYOLIST] = 9*chars_per_wd;
216: typesize[TYCLLIST] = 3*chars_per_wd;
217: typesize[TYALIST] = 2*chars_per_wd;
218: typesize[TYINLIST] = 26*chars_per_wd;
219: }
220:
221: if (wordalign)
222: typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
223: if (!tyioint) {
224: tyioint = TYSHORT;
225: szleng = typesize[TYSHORT];
226: def_i2 = "#define f2c_i2 1\n";
227: inqmask = M(TYSHORT)|M(TYLOGICAL);
228: goto checklong;
229: }
230: else
231: szleng = typesize[TYLONG];
232: if (useshortints) {
233: inqmask = M(TYLONG);
234: checklong:
235: protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
236: typesize[TYLOGICAL] = typesize[TYSHORT];
237: casttypes[TYLOGICAL] = "K_fp";
238: if (uselongints)
239: err ("Can't use both long and short ints");
240: else {
241: tyint = tylogical = TYSHORT;
242: tylog = TYLOGICAL2;
243: }
244: }
245: else if (uselongints)
246: tyint = TYLONG;
247:
248: if (h0align) {
249: if (tyint == TYLONG && wordalign)
250: h0align = 1;
251: ohalign = halign = hset[h0align];
252: htype = h0align == 1 ? tyint : TYDREAL;
253: hsize = typesize[htype];
254: }
255:
256: if (no66flag)
257: noextflag = no66flag;
258: if (noextflag)
259: zflag = 0;
260:
261: if (r8flag) {
262: tyreal = TYDREAL;
263: tycomplex = TYDCOMPLEX;
264: r8fix();
265: }
266: if (forcedouble) {
267: protorettypes[TYREAL] = "E_f";
268: casttypes[TYREAL] = "E_fp";
269: }
270:
271: if (maxregvar > MAXREGVAR) {
272: warni("-O%d: too many register variables", maxregvar);
273: maxregvar = MAXREGVAR;
274: } /* if maxregvar > MAXREGVAR */
275:
276: /* Check the list of input files */
277:
278: {
279: int bad, i, cur_max = Max_ftn_files;
280:
281: for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
282: if (ftn_files[i][0] == '-') {
283: errstr ("Invalid flag '%s'", ftn_files[i]);
284: bad++;
285: }
286: if (bad)
287: exit(1);
288:
289: } /* block */
290: } /* set_externs */
291:
292:
293: static int
294: comm2dcl()
295: {
296: Extsym *ext;
297: if (ext1comm)
298: for(ext = extsymtab; ext < nextext; ext++)
299: if (ext->extstg == STGCOMMON && !ext->extinit)
300: return ext1comm;
301: return 0;
302: }
303:
304: static void
305: write_typedefs(outfile)
306: FILE *outfile;
307: {
308: register int i;
309: register char *s, *p = 0;
310: static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
311: static char stl[4] = { 'E', 'C', 'Z', 'H' };
312:
313: for(i = 0; i <= TYSUBR; i++)
314: if (s = usedcasts[i]) {
315: if (!p) {
316: p = Ansi == 1 ? "()" : "(...)";
317: nice_printf(outfile,
318: "/* Types for casting procedure arguments: */\
319: \n\n#ifndef F2C_proc_par_types\n");
320: if (i == 0) {
321: nice_printf(outfile,
322: "typedef int /* Unknown procedure type */ (*%s)%s;\n",
323: s, p);
324: continue;
325: }
326: }
327: nice_printf(outfile, "typedef %s (*%s)%s;\n",
328: c_type_decl(i,1), s, p);
329: }
330: for(i = !forcedouble; i < 4; i++)
331: if (used_rets[st[i]])
332: nice_printf(outfile,
333: "typedef %s %c_f; /* %s function */\n",
334: p = i ? "VOID" : "doublereal",
335: stl[i], ftn_types[st[i]]);
336: if (p)
337: nice_printf(outfile, "#endif\n\n");
338: }
339:
340: static void
341: commonprotos(outfile)
342: register FILE *outfile;
343: {
344: register Extsym *e, *ee;
345: register Argtypes *at;
346: Atype *a, *ae;
347: int k;
348: extern int proc_protochanges;
349:
350: if (!outfile)
351: return;
352: for (e = extsymtab, ee = nextext; e < ee; e++)
353: if (e->extstg == STGCOMMON && e->allextp)
354: nice_printf(outfile, "/* comlen %s %ld */\n",
355: e->cextname, e->maxleng);
356: if (Castargs1 < 3)
357: return;
358:
359: /* -Pr: special comments conveying current knowledge
360: of external references */
361:
362: k = proc_protochanges;
363: for (e = extsymtab, ee = nextext; e < ee; e++)
364: if (e->extstg == STGEXT
365: && e->cextname != e->fextname) /* not a library function */
366: if (at = e->arginfo) {
367: if ((!e->extinit || at->changes & 1)
368: /* not defined here or
369: changed since definition */
370: && at->nargs >= 0) {
371: nice_printf(outfile, "/*:ref: %s %d %d",
372: e->cextname, e->extype, at->nargs);
373: a = at->atypes;
374: for(ae = a + at->nargs; a < ae; a++)
375: nice_printf(outfile, " %d", a->type);
376: nice_printf(outfile, " */\n");
377: if (at->changes & 1)
378: k++;
379: }
380: }
381: else if (e->extype)
382: /* typed external, never invoked */
383: nice_printf(outfile, "/*:ref: %s %d :*/\n",
384: e->cextname, e->extype);
385: if (k) {
386: nice_printf(outfile,
387: "/* Rerunning f2c -P may change prototypes or declarations. */\n");
388: if (nerr)
389: return;
390: if (protostatus)
391: done(4);
392: if (protofile != stdout) {
393: fprintf(diagfile,
394: "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
395: filename0, proto_fname);
396: fflush(diagfile);
397: }
398: }
399: }
400:
401: int retcode = 0;
402:
403: main(argc, argv)
404: int argc;
405: char **argv;
406: {
407: int c2d, k;
408: FILE *c_output;
409: char *cdfilename;
410: static char stderrbuf[BUFSIZ];
411: extern void def_commons();
412: extern char **dfltproc, *dflt1proc[];
413: extern char link_msg[];
414:
415: diagfile = stderr;
416: setbuf(stderr, stderrbuf); /* arrange for fast error msgs */
417:
418: Max_ftn_files = argc - 1;
419: ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
420:
421: parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
422: ftn_files, Max_ftn_files);
423: if (!can_include && ext1comm == 2)
424: ext1comm = 1;
425: if (ext1comm && !extcomm)
426: extcomm = 2;
427: if (protostatus)
428: Castargs = 3;
429: Castargs1 = Castargs;
430: if (!Ansi) {
431: Castargs = 0;
432: parens = "()";
433: }
434: else if (!Castargs)
435: parens = Ansi == 1 ? "()" : "(...)";
436: else
437: dfltproc = dflt1proc;
438:
439: set_externs();
440: fileinit();
441: read_Pfiles(ftn_files);
442:
443: for(k = 1; ftn_files[k]; k++)
444: if (dofork())
445: break;
446: filename0 = file_name = ftn_files[current_ftn_file = k - 1];
447:
448: set_tmp_names();
449: sigcatch();
450:
451: c_file = opf(c_functions, textwrite);
452: pass1_file=opf(p1_file, binwrite);
453: initkey();
454: if (file_name && *file_name) {
455: if (debugflag != 1) {
456: coutput = c_name(file_name,'c');
457: if (Castargs1 >= 2)
458: proto_fname = c_name(file_name,'P');
459: }
460: cdfilename = coutput;
461: if (skipC)
462: coutput = 0;
463: else if (!(c_output = fopen(coutput, textwrite))) {
464: file_name = coutput;
465: coutput = 0; /* don't delete read-only .c file */
466: fatalstr("can't open %.86s", file_name);
467: }
468:
469: if (Castargs1 >= 2
470: && !(protofile = fopen(proto_fname, textwrite)))
471: fatalstr("Can't open %.84s\n", proto_fname);
472: }
473: else {
474: file_name = "";
475: cdfilename = "f2c_out.c";
476: c_output = stdout;
477: coutput = 0;
478: if (Castargs1 >= 2) {
479: protofile = stdout;
480: if (!skipC)
481: printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
482: }
483: }
484:
485: if(inilex( copys(file_name) ))
486: done(1);
487: if (filename0) {
488: fprintf(diagfile, "%s:\n", file_name);
489: fflush(diagfile);
490: }
491:
492: procinit();
493: if(k = yyparse())
494: {
495: fprintf(diagfile, "Bad parse, return code %d\n", k);
496: done(1);
497: }
498:
499: commonprotos(protofile);
500: if (protofile == stdout && !skipC)
501: printf("#endif\n\n");
502:
503: if (nerr || skipC)
504: goto C_skipped;
505:
506:
507: /* Write out the declarations which are global to this file */
508:
509: if ((c2d = comm2dcl()) == 1)
510: nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
511: /* Split this into several files by piping it through\n\n\
512: sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
513: */\n\
514: /*<<</dev/null>>>*/\n\
515: /*>>>'%s'<<<*/\n", cdfilename);
516: if (gflag)
517: nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
518: if (!skipversion) {
519: nice_printf (c_output, "/* %s -- translated by f2c ", file_name);
520: nice_printf (c_output, "(version of %s).\n", F2C_version);
521: nice_printf (c_output,
522: " You must link the resulting object file with the libraries:\n\
523: %s (in that order)\n*/\n\n", link_msg);
524: }
525: if (Ansi == 2)
526: nice_printf(c_output,
527: "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
528: nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
529: if (gflag)
530: nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
531: if (Castargs && typedefs)
532: write_typedefs(c_output);
533: nice_printf (c_file, "\n");
534: fclose (c_file);
535: c_file = c_output; /* HACK to get the next indenting
536: to work */
537: wr_common_decls (c_output);
538: if (blkdfile)
539: list_init_data(&blkdfile, blkdfname, c_output);
540: wr_globals (c_output);
541: if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
542: Fatal("main - couldn't reopen c_functions");
543: ffilecopy (c_file, c_output);
544: if (*main_alias) {
545: nice_printf (c_output, "/* Main program alias */ ");
546: nice_printf (c_output, "int %s () { MAIN__ ();%s }\n",
547: main_alias, Ansi ? " return 0;" : "");
548: }
549: if (Ansi == 2)
550: nice_printf(c_output,
551: "#ifdef __cplusplus\n\t}\n#endif\n");
552: if (c2d) {
553: if (c2d == 1)
554: fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
555: else
556: fclose(c_output);
557: def_commons(c_output);
558: }
559: if (c2d != 2)
560: fclose (c_output);
561:
562: C_skipped:
563: if(parstate != OUTSIDE)
564: {
565: warn("missing final end statement");
566: endproc();
567: }
568: done(nerr ? 1 : 0);
569: }
570:
571:
572: FILEP opf(fn, mode)
573: char *fn, *mode;
574: {
575: FILEP fp;
576: if( fp = fopen(fn, mode) )
577: return(fp);
578:
579: fatalstr("cannot open intermediate file %s", fn);
580: /* NOT REACHED */ return 0;
581: }
582:
583:
584: clf(p, what, quit)
585: FILEP *p;
586: char *what;
587: int quit;
588: {
589: if(p!=NULL && *p!=NULL && *p!=stdout)
590: {
591: if(ferror(*p)) {
592: fprintf(stderr, "I/O error on %s\n", what);
593: if (quit)
594: done(3);
595: retcode = 3;
596: }
597: fclose(*p);
598: }
599: *p = NULL;
600: }
601:
602:
603: done(k)
604: int k;
605: {
606: clf(&initfile, "initfile", 0);
607: clf(&c_file, "c_file", 0);
608: clf(&pass1_file, "pass1_file", 0);
609: Un_link_all(k);
610: exit(k|retcode);
611: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.