diff options
Diffstat (limited to 'usr.bin/f2c/main.c')
| -rw-r--r-- | usr.bin/f2c/main.c | 710 |
1 files changed, 0 insertions, 710 deletions
diff --git a/usr.bin/f2c/main.c b/usr.bin/f2c/main.c deleted file mode 100644 index 7237905..0000000 --- a/usr.bin/f2c/main.c +++ /dev/null @@ -1,710 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -extern char F2C_version[]; - -#include "defs.h" -#include "parse.h" - -int complex_seen, dcomplex_seen; - -LOCAL int Max_ftn_files; - -int badargs; -char **ftn_files; -int current_ftn_file = 0; - -flag ftn66flag = NO; -flag nowarnflag = NO; -flag noextflag = NO; -flag no66flag = NO; /* Must also set noextflag to this - same value */ -flag zflag = YES; /* recognize double complex intrinsics */ -flag debugflag = NO; -flag onetripflag = NO; -flag shiftcase = YES; -flag undeftype = NO; -flag checksubs = NO; -flag r8flag = NO; -flag use_bs = YES; -flag keepsubs = NO; -flag byterev = NO; -flag echo = NO; -int intr_omit; -static int no_cd, no_i90; -#ifdef TYQUAD -flag use_tyquad = YES; -#endif -int tyreal = TYREAL; -int tycomplex = TYCOMPLEX; - -int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */ -int maxequiv = MAXEQUIV; -int maxext = MAXEXT; -int maxstno = MAXSTNO; -int maxctl = MAXCTL; -int maxhash = MAXHASH; -int maxliterals = MAXLITERALS; -int maxcontin = MAXCONTIN; -int maxlablist = MAXLABLIST; -int extcomm, ext1comm, useauto; -int can_include = YES; /* so we can disable includes for netlib */ - -static char *def_i2 = ""; - -static int useshortints = NO; /* YES => tyint = TYSHORT */ -static int uselongints = NO; /* YES => tyint = TYLONG */ -int addftnsrc = NO; /* Include ftn source in output */ -int usedefsforcommon = NO; /* Use #defines for common reference */ -int forcedouble = YES; /* force real functions to double */ -int dneg = NO; /* f77 treatment of unary minus */ -int Ansi = NO; -int def_equivs = YES; -int tyioint = TYLONG; -int szleng = SZLENG; -int inqmask = M(TYLONG)|M(TYLOGICAL); -int wordalign = NO; -int forcereal = NO; -int warn72 = NO; -static int skipC, skipversion; -char *file_name, *filename0, *parens; -int Castargs = 1; -static int Castargs1; -static int typedefs = 0; -int chars_per_wd, gflag, protostatus; -int infertypes = 1; -char used_rets[TYSUBR+1]; -extern char *tmpdir; -static int h0align = 0; -char *halign, *ohalign; -int krparens = NO; -int hsize; /* for padding under -h */ -int htype; /* for wr_equiv_init under -h */ -chainp Iargs; -char *o_coutput = 0; - -#define f2c_entry(swit,count,type,store,size) \ - p_entry ("-", swit, 0, count, type, store, size) - -static arg_info table[] = { - f2c_entry ("o", P_ONE_ARG, P_STRING, &o_coutput, YES), - f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES), - f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES), - f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES), - f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES), - f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES), - f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES), - f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES), - f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO), - f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES), - f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0), - f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES), - f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0), - f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0), - f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0), - f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0), - f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0), - f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0), - f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0), - f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0), - f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES), - f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES), - f2c_entry ("v", P_NO_ARGS, P_INT, &echo, YES), - f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO), - f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES), - f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES), - f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES), - f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO), - f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES), - f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES), - f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO), - f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES), - f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO), - f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0), - f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES), - f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0), - f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1), - f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1), - f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2), - f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2), - f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3), - f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1), - f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0), - f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1), - f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0), - f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1), - f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2), - f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1), - f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2), - f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO), - f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES), - f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1), - f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2), - f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1), - f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0), - f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1), - f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2), -#ifdef TYQUAD - f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO), -#endif - - /* options omitted from man pages */ - - /* -b ==> for unformatted I/O, call do_unio (for noncharacter */ - /* data of length > 1 byte) and do_ucio (for the rest) rather */ - /* than do_uio. This permits modifying libI77 to byte-reverse */ - /* numeric data. */ - - f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES), - - /* -ev ==> implement equivalence with initialized pointers */ - f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO), - - /* -!it used to be the default when -it was more agressive */ - - f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1), - - /* -Pd is similar to -P, but omits :ref: lines */ - f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2), - - /* -t ==> emit typedefs (under -A or -C++) for procedure - argument types used. This is meant for netlib's - f2c service, so -A and -C++ will work with older - versions of f2c.h - */ - f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1), - - /* -!V ==> omit version msg (to facilitate using diff in - regression testing) - */ - f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1), - - /* -Dnnn = debug level nnn */ - - f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES), - - /* -dneg ==> under (default) -!R, imitate f77's bizarre */ - /* treatment of unary minus of REAL expressions by */ - /* promoting them to DOUBLE PRECISION . */ - - f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES) -}; /* table */ - -extern char *c_functions; /* "c_functions" */ -extern char *coutput; /* "c_output" */ -extern char *initfname; /* "raw_data" */ -extern char *blkdfname; /* "block_data" */ -extern char *p1_file; /* "p1_file" */ -extern char *p1_bakfile; /* "p1_file.BAK" */ -extern char *sortfname; /* "init_file" */ -extern char *proto_fname; /* "proto_file" */ -FILE *protofile; - - void -set_externs(Void) -{ - static char *hset[3] = { 0, "integer", "doublereal" }; - -/* Adjust the global flags according to the command line parameters */ - - if (chars_per_wd > 0) { - typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] = - typesize[TYLOGICAL] = chars_per_wd; - typesize[TYINT1] = typesize[TYLOGICAL1] = 1; - typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1; - typesize[TYDCOMPLEX] = chars_per_wd << 2; - typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1; - typesize[TYCILIST] = 5*chars_per_wd; - typesize[TYICILIST] = 6*chars_per_wd; - typesize[TYOLIST] = 9*chars_per_wd; - typesize[TYCLLIST] = 3*chars_per_wd; - typesize[TYALIST] = 2*chars_per_wd; - typesize[TYINLIST] = 26*chars_per_wd; - } - - if (wordalign) - typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL]; - if (!tyioint) { - tyioint = TYSHORT; - szleng = typesize[TYSHORT]; - def_i2 = "#define f2c_i2 1\n"; - inqmask = M(TYSHORT)|M(TYLOGICAL2); - goto checklong; - } - else - szleng = typesize[TYLONG]; - if (useshortints) { - /* inqmask = M(TYLONG); */ - /* used to disallow LOGICAL in INQUIRE under -I2 */ - checklong: - protorettypes[TYLOGICAL] = "shortlogical"; - casttypes[TYLOGICAL] = "K_fp"; - if (uselongints) - err ("Can't use both long and short ints"); - else { - tyint = tylogical = TYSHORT; - tylog = TYLOGICAL2; - } - } - else if (uselongints) - tyint = TYLONG; - - if (h0align) { - if (tyint == TYLONG && wordalign) - h0align = 1; - ohalign = halign = hset[h0align]; - htype = h0align == 1 ? tyint : TYDREAL; - hsize = typesize[htype]; - } - - if (no66flag) - noextflag = no66flag; - if (noextflag) - zflag = 0; - - if (r8flag) { - tyreal = TYDREAL; - tycomplex = TYDCOMPLEX; - r8fix(); - } - if (forcedouble) { - protorettypes[TYREAL] = "E_f"; - casttypes[TYREAL] = "E_fp"; - } - else - dneg = 0; - - if (maxregvar > MAXREGVAR) { - warni("-O%d: too many register variables", maxregvar); - maxregvar = MAXREGVAR; - } /* if maxregvar > MAXREGVAR */ - -/* Check the list of input files */ - - { - int bad, i, cur_max = Max_ftn_files; - - for (i = bad = 0; i < cur_max && ftn_files[i]; i++) - if (ftn_files[i][0] == '-') { - errstr ("Invalid flag '%s'", ftn_files[i]); - bad++; - } - if (bad) - exit(1); - - } /* block */ -} /* set_externs */ - - - static int -comm2dcl(Void) -{ - Extsym *ext; - if (ext1comm) - for(ext = extsymtab; ext < nextext; ext++) - if (ext->extstg == STGCOMMON && !ext->extinit) - return ext1comm; - return 0; - } - - static void -#ifdef KR_headers -write_typedefs(outfile) - FILE *outfile; -#else -write_typedefs(FILE *outfile) -#endif -{ - register int i; - register char *s, *p = 0; - static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR }; - static char stl[4] = { 'E', 'C', 'Z', 'H' }; - - for(i = 0; i <= TYSUBR; i++) - if (s = usedcasts[i]) { - if (!p) { - p = Ansi == 1 ? "()" : "(...)"; - nice_printf(outfile, - "/* Types for casting procedure arguments: */\ -\n\n#ifndef F2C_proc_par_types\n"); - if (i == 0) { - nice_printf(outfile, - "typedef int /* Unknown procedure type */ (*%s)%s;\n", - s, p); - continue; - } - } - nice_printf(outfile, "typedef %s (*%s)%s;\n", - c_type_decl(i,1), s, p); - } - for(i = !forcedouble; i < 4; i++) - if (used_rets[st[i]]) - nice_printf(outfile, - "typedef %s %c_f; /* %s function */\n", - p = i ? "VOID" : "doublereal", - stl[i], ftn_types[st[i]]); - if (p) - nice_printf(outfile, "#endif\n\n"); - } - - static void -#ifdef KR_headers -commonprotos(outfile) - register FILE *outfile; -#else -commonprotos(register FILE *outfile) -#endif -{ - register Extsym *e, *ee; - register Argtypes *at; - Atype *a, *ae; - int k; - extern int proc_protochanges; - - if (!outfile) - return; - for (e = extsymtab, ee = nextext; e < ee; e++) - if (e->extstg == STGCOMMON && e->allextp) - nice_printf(outfile, "/* comlen %s %ld */\n", - e->cextname, e->maxleng); - if (Castargs1 < 3) - return; - - /* -Pr: special comments conveying current knowledge - of external references */ - - k = proc_protochanges; - for (e = extsymtab, ee = nextext; e < ee; e++) - if (e->extstg == STGEXT - && e->cextname != e->fextname) /* not a library function */ - if (at = e->arginfo) { - if ((!e->extinit || at->changes & 1) - /* not defined here or - changed since definition */ - && at->nargs >= 0) { - nice_printf(outfile, "/*:ref: %s %d %d", - e->cextname, e->extype, at->nargs); - a = at->atypes; - for(ae = a + at->nargs; a < ae; a++) - nice_printf(outfile, " %d", a->type); - nice_printf(outfile, " */\n"); - if (at->changes & 1) - k++; - } - } - else if (e->extype) - /* typed external, never invoked */ - nice_printf(outfile, "/*:ref: %s %d :*/\n", - e->cextname, e->extype); - if (k) { - nice_printf(outfile, - "/* Rerunning f2c -P may change prototypes or declarations. */\n"); - if (nerr) - return; - if (protostatus) - done(4); - if (protofile != stdout) { - fprintf(diagfile, - "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n", - filename0, proto_fname); - fflush(diagfile); - } - } - } - - static int -#ifdef KR_headers -I_args(argc, a) - int argc; - char **a; -#else -I_args(int argc, char **a) -#endif -{ - char **a0, **a1, **ae, *s; - - ae = a + argc; - a0 = a; - for(a1 = ++a; a < ae; a++) { - if (!(s = *a)) - break; - if (*s == '-' && s[1] == 'I' && s[2] - && (s[3] || s[2] != '2' && s[2] != '4')) - Iargs = mkchain(s+2, Iargs); - else - *a1++ = s; - } - Iargs = revchain(Iargs); - *a1 = 0; - return a1 - a0; - } - - int retcode = 0; - - int -#ifdef KR_headers -main(argc, argv) - int argc; - char **argv; -#else -main(int argc, char **argv) -#endif -{ - int c2d, k; - FILE *c_output; - char *cdfilename; - static char stderrbuf[BUFSIZ]; - extern char **dfltproc, *dflt1proc[]; - extern char link_msg[]; - - diagfile = stderr; - setbuf(stderr, stderrbuf); /* arrange for fast error msgs */ - - argc = I_args(argc, argv); /* extract -I args */ - Max_ftn_files = argc - 1; - ftn_files = (char **)ckalloc((argc+1)*sizeof(char *)); - - parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info), - ftn_files, Max_ftn_files); - if (badargs) - return 1; - intr_omit = no_cd | no_i90; - if (keepsubs && checksubs) { - warn("-C suppresses -s\n"); - keepsubs = 0; - } - if (!can_include && ext1comm == 2) - ext1comm = 1; - if (ext1comm && !extcomm) - extcomm = 2; - if (protostatus) - Castargs = 3; - Castargs1 = Castargs; - if (!Ansi) { - Castargs = 0; - parens = "()"; - } - else if (!Castargs) - parens = Ansi == 1 ? "()" : "(...)"; - else - dfltproc = dflt1proc; - - outbuf_adjust(); - set_externs(); - fileinit(); - read_Pfiles(ftn_files); - - for(k = 1; ftn_files[k]; k++) - if (dofork()) - break; - filename0 = file_name = ftn_files[current_ftn_file = k - 1]; - - set_tmp_names(); - sigcatch(0); - - c_file = opf(c_functions, textwrite); - pass1_file=opf(p1_file, binwrite); - initkey(); - if (file_name && *file_name) { - if (debugflag != 1) { - if (!o_coutput) - coutput = c_name(file_name,'c'); - else - coutput = o_coutput; - if (Castargs1 >= 2) - proto_fname = c_name(file_name,'P'); - } - cdfilename = coutput; - if (skipC) - coutput = 0; - if (coutput[0] == '-'){ - c_output = stdout; - coutput = 0; - } - else if (!(c_output = fopen(coutput, textwrite))) { - file_name = coutput; - coutput = 0; /* don't delete read-only .c file */ - fatalstr("can't open %.86s", file_name); - } - - if (Castargs1 >= 2 - && !(protofile = fopen(proto_fname, textwrite))) - fatalstr("Can't open %.84s\n", proto_fname); - } - else { - file_name = ""; - cdfilename = "f2c_out.c"; - c_output = stdout; - coutput = 0; - if (Castargs1 >= 2) { - protofile = stdout; - if (!skipC) - printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n"); - } - } - - if(inilex( copys(file_name) )) - done(1); - if (filename0 && echo) { - fprintf(diagfile, "%s:\n", file_name); - fflush(diagfile); - } - - procinit(); - if(k = yyparse()) - { - fprintf(diagfile, "Bad parse, return code %d\n", k); - done(1); - } - - commonprotos(protofile); - if (protofile == stdout && !skipC) - printf("#endif\n\n"); - - if (nerr || skipC) - goto C_skipped; - - -/* Write out the declarations which are global to this file */ - - if ((c2d = comm2dcl()) == 1) - nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\ -/* Split this into several files by piping it through\n\n\ -sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\ - */\n\ -/*<<</dev/null>>>*/\n\ -/*>>>'%s'<<<*/\n", cdfilename); - if (gflag) - nice_printf (c_output, "#line 1 \"%s\"\n", file_name); - if (!skipversion) { - nice_printf (c_output, "/* %s -- translated by f2c ", file_name); - nice_printf (c_output, "(version %s).\n", F2C_version); - nice_printf (c_output, - " You must link the resulting object file with the libraries:\n\ - %s (in that order)\n*/\n\n", link_msg); - } - if (Ansi == 2) - nice_printf(c_output, - "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); - nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2); - if (gflag) - nice_printf (c_output, "#line 1 \"%s\"\n", file_name); - if (Castargs && typedefs) - write_typedefs(c_output); - nice_printf (c_file, "\n"); - fclose (c_file); - c_file = c_output; /* HACK to get the next indenting - to work */ - wr_common_decls (c_output); - if (blkdfile) - list_init_data(&blkdfile, blkdfname, c_output); - wr_globals (c_output); - if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL) - Fatal("main - couldn't reopen c_functions"); - ffilecopy (c_file, c_output); - if (*main_alias) { - nice_printf (c_output, "/* Main program alias */ "); - nice_printf (c_output, "int %s () { MAIN__ ();%s }\n", - main_alias, Ansi ? " return 0;" : ""); - } - if (Ansi == 2) - nice_printf(c_output, - "#ifdef __cplusplus\n\t}\n#endif\n"); - if (c2d) { - if (c2d == 1) - fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename); - else - fclose(c_output); - def_commons(c_output); - } - if (c2d != 2) - fclose (c_output); - - C_skipped: - if(parstate != OUTSIDE) - { - warn("missing final end statement"); - endproc(); - nerr = 1; - } - done(nerr ? 1 : 0); - /* NOT REACHED */ return 0; -} - - - FILEP -#ifdef KR_headers -opf(fn, mode) - char *fn; - char *mode; -#else -opf(char *fn, char *mode) -#endif -{ - FILEP fp; - if( fp = fopen(fn, mode) ) - return(fp); - - fatalstr("cannot open intermediate file %s", fn); - /* NOT REACHED */ return 0; -} - - - void -#ifdef KR_headers -clf(p, what, quit) - FILEP *p; - char *what; - int quit; -#else -clf(FILEP *p, char *what, int quit) -#endif -{ - if(p!=NULL && *p!=NULL && *p!=stdout) - { - if(ferror(*p)) { - fprintf(stderr, "I/O error on %s\n", what); - if (quit) - done(3); - retcode = 3; - } - fclose(*p); - } - *p = NULL; -} - - - void -#ifdef KR_headers -done(k) - int k; -#else -done(int k) -#endif -{ - clf(&initfile, "initfile", 0); - clf(&c_file, "c_file", 0); - clf(&pass1_file, "pass1_file", 0); - Un_link_all(k); - exit(k|retcode); -} |
