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 }

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         }

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         }

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 }

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         }

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 }

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 }

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 */

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         }