00001 /****************************************************************
00002 Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 extern char F2C_version[];
00025 
00026 #include "defs.h"
00027 #include "parse.h"
00028 
00029 int complex_seen, dcomplex_seen;
00030 
00031 LOCAL int Max_ftn_files;
00032 
00033 int badargs;
00034 char **ftn_files;
00035 int current_ftn_file = 0;
00036 
00037 flag ftn66flag = NO;
00038 flag nowarnflag = NO;
00039 flag noextflag = NO;
00040 flag  no66flag = NO;            /* Must also set noextflag to this
00041                                            same value */
00042 flag zflag = YES;               /* recognize double complex intrinsics */
00043 flag debugflag = NO;
00044 flag onetripflag = NO;
00045 flag shiftcase = YES;
00046 flag undeftype = NO;
00047 flag checksubs = NO;
00048 flag r8flag = NO;
00049 flag use_bs = YES;
00050 flag keepsubs = NO;
00051 flag byterev = NO;
00052 int intr_omit;
00053 static int no_cd, no_i90;
00054 #ifdef TYQUAD
00055 flag use_tyquad = YES;
00056 #endif
00057 int tyreal = TYREAL;
00058 int tycomplex = TYCOMPLEX;
00059 
00060 int maxregvar = MAXREGVAR;      /* if maxregvar > MAXREGVAR, error */
00061 int maxequiv = MAXEQUIV;
00062 int maxext = MAXEXT;
00063 int maxstno = MAXSTNO;
00064 int maxctl = MAXCTL;
00065 int maxhash = MAXHASH;
00066 int maxliterals = MAXLITERALS;
00067 int maxcontin = MAXCONTIN;
00068 int maxlablist = MAXLABLIST;
00069 int extcomm, ext1comm, useauto;
00070 int can_include = YES;  /* so we can disable includes for netlib */
00071 
00072 static char *def_i2 = "";
00073 
00074 static int useshortints = NO;   /* YES => tyint = TYSHORT */
00075 static int uselongints = NO;    /* YES => tyint = TYLONG */
00076 int addftnsrc = NO;             /* Include ftn source in output */
00077 int usedefsforcommon = NO;      /* Use #defines for common reference */
00078 int forcedouble = YES;          /* force real functions to double */
00079 int dneg = NO;                  /* f77 treatment of unary minus */
00080 int Ansi = NO;
00081 int def_equivs = YES;
00082 int tyioint = TYLONG;
00083 int szleng = SZLENG;
00084 int inqmask = M(TYLONG)|M(TYLOGICAL);
00085 int wordalign = NO;
00086 int forcereal = NO;
00087 int warn72 = NO;
00088 static int skipC, skipversion;
00089 char *file_name, *filename0, *parens;
00090 int Castargs = 1;
00091 static int Castargs1;
00092 static int typedefs = 0;
00093 int chars_per_wd, gflag, protostatus;
00094 int infertypes = 1;
00095 char used_rets[TYSUBR+1];
00096 extern char *tmpdir;
00097 static int h0align = 0;
00098 char *halign, *ohalign;
00099 int krparens = NO;
00100 int hsize;      /* for padding under -h */
00101 int htype;      /* for wr_equiv_init under -h */
00102 chainp Iargs;
00103 
00104 #define f2c_entry(swit,count,type,store,size) \
00105         p_entry ("-", swit, 0, count, type, store, size)
00106 
00107 static arg_info table[] = {
00108     f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
00109     f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
00110     f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
00111     f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
00112     f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
00113     f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
00114     f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
00115     f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
00116     f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
00117     f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
00118     f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
00119     f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
00120     f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
00121     f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
00122     f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
00123     f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
00124     f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
00125     f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0),
00126     f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0),
00127     f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
00128     f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
00129     f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
00130     f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
00131     f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
00132     f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
00133     f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
00134     f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
00135     f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
00136     f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
00137     f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
00138     f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
00139     f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
00140     f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
00141     f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
00142     f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
00143     f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
00144     f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
00145     f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
00146     f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
00147     f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
00148     f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
00149     f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
00150     f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
00151     f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
00152     f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
00153     f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
00154     f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
00155     f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
00156     f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
00157     f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1),
00158     f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2),
00159     f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1),
00160     f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0),
00161     f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1),
00162     f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2),
00163 #ifdef TYQUAD
00164     f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
00165 #endif
00166 
00167         /* options omitted from man pages */
00168 
00169         /* -b ==> for unformatted I/O, call do_unio (for noncharacter  */
00170         /* data of length > 1 byte) and do_ucio (for the rest) rather  */
00171         /* than do_uio.  This permits modifying libI77 to byte-reverse */
00172         /* numeric data. */
00173 
00174     f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES),
00175 
00176         /* -ev ==> implement equivalence with initialized pointers */
00177     f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
00178 
00179         /* -!it used to be the default when -it was more agressive */
00180 
00181     f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
00182 
00183         /* -Pd is similar to -P, but omits :ref: lines */
00184     f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
00185 
00186         /* -t ==> emit typedefs (under -A or -C++) for procedure
00187                 argument types used.  This is meant for netlib's
00188                 f2c service, so -A and -C++ will work with older
00189                 versions of f2c.h
00190                 */
00191     f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
00192 
00193         /* -!V ==> omit version msg (to facilitate using diff in
00194                 regression testing)
00195                 */
00196     f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1),
00197 
00198         /* -Dnnn = debug level nnn */
00199 
00200     f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES),
00201 
00202         /* -dneg ==> under (default) -!R, imitate f77's bizarre */
00203         /* treatment of unary minus of REAL expressions by      */
00204         /* promoting them to DOUBLE PRECISION . */
00205 
00206     f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES)
00207 }; /* table */
00208 
00209 extern char *c_functions;       /* "c_functions"        */
00210 extern char *coutput;           /* "c_output"           */
00211 extern char *initfname;         /* "raw_data"           */
00212 extern char *blkdfname;         /* "block_data"         */
00213 extern char *p1_file;           /* "p1_file"            */
00214 extern char *p1_bakfile;        /* "p1_file.BAK"        */
00215 extern char *sortfname;         /* "init_file"          */
00216 extern char *proto_fname;       /* "proto_file"         */
00217 FILE *protofile;
00218 
00219  void
00220 set_externs(Void)
00221 {
00222     static char *hset[3] = { 0, "integer", "doublereal" };
00223 
00224 /* Adjust the global flags according to the command line parameters */
00225 
00226     if (chars_per_wd > 0) {
00227         typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
00228                 typesize[TYLOGICAL] = chars_per_wd;
00229         typesize[TYINT1] = typesize[TYLOGICAL1] = 1;
00230         typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
00231         typesize[TYDCOMPLEX] = chars_per_wd << 2;
00232         typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1;
00233         typesize[TYCILIST] = 5*chars_per_wd;
00234         typesize[TYICILIST] = 6*chars_per_wd;
00235         typesize[TYOLIST] = 9*chars_per_wd;
00236         typesize[TYCLLIST] = 3*chars_per_wd;
00237         typesize[TYALIST] = 2*chars_per_wd;
00238         typesize[TYINLIST] = 26*chars_per_wd;
00239         }
00240 
00241     if (wordalign)
00242         typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
00243     if (!tyioint) {
00244         tyioint = TYSHORT;
00245         szleng = typesize[TYSHORT];
00246         def_i2 = "#define f2c_i2 1\n";
00247         inqmask = M(TYSHORT)|M(TYLOGICAL2);
00248         goto checklong;
00249         }
00250     else
00251         szleng = typesize[TYLONG];
00252     if (useshortints) {
00253         /* inqmask = M(TYLONG); */
00254         /* used to disallow LOGICAL in INQUIRE under -I2 */
00255  checklong:
00256         protorettypes[TYLOGICAL] = "shortlogical";
00257         casttypes[TYLOGICAL] = "K_fp";
00258         if (uselongints)
00259                 err ("Can't use both long and short ints");
00260         else {
00261                 tyint = tylogical = TYSHORT;
00262                 tylog = TYLOGICAL2;
00263                 }
00264         }
00265     else if (uselongints)
00266         tyint = TYLONG;
00267 
00268     if (h0align) {
00269         if (tyint == TYLONG && wordalign)
00270                 h0align = 1;
00271         ohalign = halign = hset[h0align];
00272         htype = h0align == 1 ? tyint : TYDREAL;
00273         hsize = typesize[htype];
00274         }
00275 
00276     if (no66flag)
00277         noextflag = no66flag;
00278     if (noextflag)
00279         zflag = 0;
00280 
00281     if (r8flag) {
00282         tyreal = TYDREAL;
00283         tycomplex = TYDCOMPLEX;
00284         r8fix();
00285         }
00286     if (forcedouble) {
00287         protorettypes[TYREAL] = "E_f";
00288         casttypes[TYREAL] = "E_fp";
00289         }
00290     else
00291         dneg = 0;
00292 
00293     if (maxregvar > MAXREGVAR) {
00294         warni("-O%d: too many register variables", maxregvar);
00295         maxregvar = MAXREGVAR;
00296     } /* if maxregvar > MAXREGVAR */
00297 
00298 /* Check the list of input files */
00299 
00300     {
00301         int bad, i, cur_max = Max_ftn_files;
00302 
00303         for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
00304             if (ftn_files[i][0] == '-') {
00305                 errstr ("Invalid flag '%s'", ftn_files[i]);
00306                 bad++;
00307                 }
00308         if (bad)
00309                 exit(1);
00310 
00311     } /* block */
00312 } /* set_externs */
00313 
00314 
00315  static int
00316 comm2dcl(Void)
00317 {
00318         Extsym *ext;
00319         if (ext1comm)
00320                 for(ext = extsymtab; ext < nextext; ext++)
00321                         if (ext->extstg == STGCOMMON && !ext->extinit)
00322                                 return ext1comm;
00323         return 0;
00324         }
00325 
00326  static void
00327 #ifdef KR_headers
00328 write_typedefs(outfile)
00329         FILE *outfile;
00330 #else
00331 write_typedefs(FILE *outfile)
00332 #endif
00333 {
00334         register int i;
00335         register char *s, *p = 0;
00336         static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
00337         static char stl[4] = { 'E', 'C', 'Z', 'H' };
00338 
00339         for(i = 0; i <= TYSUBR; i++)
00340                 if (s = usedcasts[i]) {
00341                         if (!p) {
00342                                 p = Ansi == 1 ? "()" : "(...)";
00343                                 nice_printf(outfile,
00344                                 "/* Types for casting procedure arguments: */\
00345 \n\n#ifndef F2C_proc_par_types\n");
00346                                 if (i == 0) {
00347                                         nice_printf(outfile,
00348                         "typedef int /* Unknown procedure type */ (*%s)%s;\n",
00349                                                  s, p);
00350                                         continue;
00351                                         }
00352                                 }
00353                         nice_printf(outfile, "typedef %s (*%s)%s;\n",
00354                                         c_type_decl(i,1), s, p);
00355                         }
00356         for(i = !forcedouble; i < 4; i++)
00357                 if (used_rets[st[i]])
00358                         nice_printf(outfile,
00359                                 "typedef %s %c_f; /* %s function */\n",
00360                                 p = i ? "VOID" : "doublereal",
00361                                 stl[i], ftn_types[st[i]]);
00362         if (p)
00363                 nice_printf(outfile, "#endif\n\n");
00364         }
00365 
00366  static void
00367 #ifdef KR_headers
00368 commonprotos(outfile)
00369         register FILE *outfile;
00370 #else
00371 commonprotos(register FILE *outfile)
00372 #endif
00373 {
00374         register Extsym *e, *ee;
00375         register Argtypes *at;
00376         Atype *a, *ae;
00377         int k;
00378         extern int proc_protochanges;
00379 
00380         if (!outfile)
00381                 return;
00382         for (e = extsymtab, ee = nextext; e < ee; e++)
00383                 if (e->extstg == STGCOMMON && e->allextp)
00384                         nice_printf(outfile, "/* comlen %s %ld */\n",
00385                                 e->cextname, e->maxleng);
00386         if (Castargs1 < 3)
00387                 return;
00388 
00389         /* -Pr: special comments conveying current knowledge
00390             of external references */
00391 
00392         k = proc_protochanges;
00393         for (e = extsymtab, ee = nextext; e < ee; e++)
00394                 if (e->extstg == STGEXT
00395                 && e->cextname != e->fextname)  /* not a library function */
00396                     if (at = e->arginfo) {
00397                         if ((!e->extinit || at->changes & 1)
00398                                 /* not defined here or
00399                                         changed since definition */
00400                         && at->nargs >= 0) {
00401                                 nice_printf(outfile, "/*:ref: %s %d %d",
00402                                         e->cextname, e->extype, at->nargs);
00403                                 a = at->atypes;
00404                                 for(ae = a + at->nargs; a < ae; a++)
00405                                         nice_printf(outfile, " %d", a->type);
00406                                 nice_printf(outfile, " */\n");
00407                                 if (at->changes & 1)
00408                                         k++;
00409                                 }
00410                         }
00411                     else if (e->extype)
00412                         /* typed external, never invoked */
00413                         nice_printf(outfile, "/*:ref: %s %d :*/\n",
00414                                 e->cextname, e->extype);
00415         if (k) {
00416                 nice_printf(outfile,
00417         "/* Rerunning f2c -P may change prototypes or declarations. */\n");
00418                 if (nerr)
00419                         return;
00420                 if (protostatus)
00421                         done(4);
00422                 if (protofile != stdout) {
00423                         fprintf(diagfile,
00424         "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
00425                                 filename0, proto_fname);
00426                         fflush(diagfile);
00427                         }
00428                 }
00429         }
00430 
00431  static int
00432 #ifdef KR_headers
00433 I_args(argc, a)
00434         int argc;
00435         char **a;
00436 #else
00437 I_args(int argc, char **a)
00438 #endif
00439 {
00440         char **a0, **a1, **ae, *s;
00441 
00442         ae = a + argc;
00443         a0 = a;
00444         for(a1 = ++a; a < ae; a++) {
00445                 if (!(s = *a))
00446                         break;
00447                 if (*s == '-' && s[1] == 'I' && s[2]
00448                   && (s[3] || s[2] != '2' && s[2] != '4'))
00449                         Iargs = mkchain(s+2, Iargs);
00450                 else
00451                         *a1++ = s;
00452                 }
00453         Iargs = revchain(Iargs);
00454         *a1 = 0;
00455         return a1 - a0;
00456         }
00457 
00458  int retcode = 0;
00459 
00460  int
00461 #ifdef KR_headers
00462 main(argc, argv)
00463         int argc;
00464         char **argv;
00465 #else
00466 main(int argc, char **argv)
00467 #endif
00468 {
00469         int c2d, k;
00470         FILE *c_output;
00471         char *cdfilename;
00472         static char stderrbuf[BUFSIZ];
00473         extern char **dfltproc, *dflt1proc[];
00474         extern char link_msg[];
00475 
00476         diagfile = stderr;
00477         setbuf(stderr, stderrbuf);      /* arrange for fast error msgs */
00478 
00479         argc = I_args(argc, argv);      /* extract -I args */
00480         Max_ftn_files = argc - 1;
00481         ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
00482 
00483         parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
00484                 ftn_files, Max_ftn_files);
00485         if (badargs)
00486                 return 1;
00487         intr_omit = no_cd | no_i90;
00488         if (keepsubs && checksubs) {
00489                 warn("-C suppresses -s\n");
00490                 keepsubs = 0;
00491                 }
00492         if (!can_include && ext1comm == 2)
00493                 ext1comm = 1;
00494         if (ext1comm && !extcomm)
00495                 extcomm = 2;
00496         if (protostatus)
00497                 Castargs = 3;
00498         Castargs1 = Castargs;
00499         if (!Ansi) {
00500                 Castargs = 0;
00501                 parens = "()";
00502                 }
00503         else if (!Castargs)
00504                 parens = Ansi == 1 ? "()" : "(...)";
00505         else
00506                 dfltproc = dflt1proc;
00507 
00508         outbuf_adjust();
00509         set_externs();
00510         fileinit();
00511         read_Pfiles(ftn_files);
00512 
00513         for(k = 1; ftn_files[k]; k++)
00514                 if (dofork())
00515                         break;
00516         filename0 = file_name = ftn_files[current_ftn_file = k - 1];
00517 
00518         set_tmp_names();
00519         sigcatch(0);
00520 
00521         c_file   = opf(c_functions, textwrite);
00522         pass1_file=opf(p1_file, binwrite);
00523         initkey();
00524         if (file_name && *file_name) {
00525                 cdfilename = coutput;
00526                 if (debugflag != 1) {
00527                         coutput = c_name(file_name,'c');
00528                         cdfilename = copys(outbtail);
00529                         if (Castargs1 >= 2)
00530                                 proto_fname = c_name(file_name,'P');
00531                         }
00532                 if (skipC)
00533                         coutput = 0;
00534                 else if (!(c_output = fopen(coutput, textwrite))) {
00535                         file_name = coutput;
00536                         coutput = 0;    /* don't delete read-only .c file */
00537                         fatalstr("can't open %.86s", file_name);
00538                         }
00539 
00540                 if (Castargs1 >= 2
00541                 && !(protofile = fopen(proto_fname, textwrite)))
00542                         fatalstr("Can't open %.84s\n", proto_fname);
00543                 }
00544         else {
00545                 file_name = "";
00546                 cdfilename = "f2c_out.c";
00547                 c_output = stdout;
00548                 coutput = 0;
00549                 if (Castargs1 >= 2) {
00550                         protofile = stdout;
00551                         if (!skipC)
00552                                 printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
00553                         }
00554                 }
00555 
00556         if(inilex( copys(file_name) ))
00557                 done(1);
00558         if (filename0) {
00559                 fprintf(diagfile, "%s:\n", file_name);
00560                 fflush(diagfile);
00561                 }
00562 
00563         procinit();
00564         if(k = yyparse())
00565         {
00566                 fprintf(diagfile, "Bad parse, return code %d\n", k);
00567                 done(1);
00568         }
00569 
00570         commonprotos(protofile);
00571         if (protofile == stdout && !skipC)
00572                 printf("#endif\n\n");
00573 
00574         if (nerr || skipC)
00575                 goto C_skipped;
00576 
00577 
00578 /* Write out the declarations which are global to this file */
00579 
00580         if ((c2d = comm2dcl()) == 1)
00581                 nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
00582 /* Split this into several files by piping it through\n\n\
00583 sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
00584  */\n\
00585 /*<<</dev/null>>>*/\n\
00586 /*>>>'%s'<<<*/\n", cdfilename);
00587         if (gflag)
00588                 nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
00589         if (!skipversion) {
00590                 nice_printf (c_output, "/* %s -- translated by f2c ", file_name);
00591                 nice_printf (c_output, "(version %s).\n", F2C_version);
00592                 nice_printf (c_output,
00593         "   You must link the resulting object file with the libraries:\n\
00594         %s   (in that order)\n*/\n\n", link_msg);
00595                 }
00596         if (Ansi == 2)
00597                 nice_printf(c_output,
00598                         "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
00599         nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
00600         if (gflag)
00601                 nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
00602         if (Castargs && typedefs)
00603                 write_typedefs(c_output);
00604         nice_printf (c_file, "\n");
00605         fclose (c_file);
00606         c_file = c_output;              /* HACK to get the next indenting
00607                                            to work */
00608         wr_common_decls (c_output);
00609         if (blkdfile)
00610                 list_init_data(&blkdfile, blkdfname, c_output);
00611         wr_globals (c_output);
00612         if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
00613             Fatal("main - couldn't reopen c_functions");
00614         ffilecopy (c_file, c_output);
00615         if (*main_alias) {
00616             nice_printf (c_output, "/* Main program alias */ ");
00617             nice_printf (c_output, "int %s () { MAIN__ ();%s }\n",
00618                     main_alias, Ansi ? " return 0;" : "");
00619             }
00620         if (Ansi == 2)
00621                 nice_printf(c_output,
00622                         "#ifdef __cplusplus\n\t}\n#endif\n");
00623         if (c2d) {
00624                 if (c2d == 1)
00625                         fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
00626                 else
00627                         fclose(c_output);
00628                 def_commons(c_output);
00629                 }
00630         if (c2d != 2)
00631                 fclose (c_output);
00632 
00633  C_skipped:
00634         if(parstate != OUTSIDE)
00635                 {
00636                 warn("missing final end statement");
00637                 endproc();
00638                 nerr = 1;
00639                 }
00640         done(nerr ? 1 : 0);
00641         /* NOT REACHED */ return 0;
00642 }
00643 
00644 
00645  FILEP
00646 #ifdef KR_headers
00647 opf(fn, mode)
00648         char *fn;
00649         char *mode;
00650 #else
00651 opf(char *fn, char *mode)
00652 #endif
00653 {
00654         FILEP fp;
00655         if( fp = fopen(fn, mode) )
00656                 return(fp);
00657 
00658         fatalstr("cannot open intermediate file %s", fn);
00659         /* NOT REACHED */ return 0;
00660 }
00661 
00662 
00663  void
00664 #ifdef KR_headers
00665 clf(p, what, quit)
00666         FILEP *p;
00667         char *what;
00668         int quit;
00669 #else
00670 clf(FILEP *p, char *what, int quit)
00671 #endif
00672 {
00673         if(p!=NULL && *p!=NULL && *p!=stdout)
00674         {
00675                 if(ferror(*p)) {
00676                         fprintf(stderr, "I/O error on %s\n", what);
00677                         if (quit)
00678                                 done(3);
00679                         retcode = 3;
00680                         }
00681                 fclose(*p);
00682         }
00683         *p = NULL;
00684 }
00685 
00686 
00687  void
00688 #ifdef KR_headers
00689 done(k)
00690         int k;
00691 #else
00692 done(int k)
00693 #endif
00694 {
00695         clf(&initfile, "initfile", 0);
00696         clf(&c_file, "c_file", 0);
00697         clf(&pass1_file, "pass1_file", 0);
00698         Un_link_all(k);
00699         exit(k|retcode);
00700 }