sources/f2c/main.c

   1 /****************************************************************
   2 Copyright 1990 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 int tyreal = TYREAL;
  49 extern void r8fix(), read_Pfiles();
  50
  51 int maxregvar = MAXREGVAR;      /* if maxregvar > MAXREGVAR, error */
  52 int maxequiv = MAXEQUIV;
  53 int maxext = MAXEXT;
  54 int maxstno = MAXSTNO;
  55 int maxctl = MAXCTL;
  56 int maxhash = MAXHASH;
  57 int extcomm, ext1comm, useauto;
  58 int can_include = YES;  /* so we can disable includes for netlib */
  59
  60 static char *def_i2 = "";
  61
  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 */
  67 int Ansi = NO;
  68 int def_equivs = YES;
  69 int tyioint = TYLONG;
  70 int szleng = SZLENG;
  71 int inqmask = M(TYLONG)|M(TYLOGICAL);
  72 int wordalign = NO;
  73 static int skipC, skipversion;
  74 char *filename0, *parens;
  75 int Castargs = 1;
  76 static int typedefs = 0;
  77 int chars_per_wd, gflag, protostatus;
  78 int infertypes = 1;
  79 char used_rets[TYSUBR+1];
  80 extern char *tmpdir;
  81
  82 #define f2c_entry(swit,count,type,store,size) \
  83         p_entry ("-", swit, 0, count, type, store, size)
  84
  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),
 127
 128         /* options omitted from man pages */
 129
 130         /* -ev ==> implement equivalence with initialized pointers */
 131     f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
 132
 133         /* -!it used to be the default when -it was more agressive */
 134
 135     f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
 136
 137         /* -Pd is similar to -P, but omits :ref: lines */
 138     f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
 139
 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
 143                 versions of f2c.h
 144                 */
 145     f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
 146
 147         /* -!V ==> omit version msg (to facilitate using diff in
 148                 regression testing)
 149                 */
 150     f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
 151
 152 }; /* table */
 153
 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"         */
 162 FILE *protofile;
 163
 164 extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
 165 extern char *c_name();
 166
 167
 168 set_externs ()
 169 {
 170 /* Adjust the global flags according to the command line parameters */
 171
 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;
 184         }
 185
 186     if (wordalign)
 187         typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
 188     if (!tyioint) {
 189         tyioint = TYSHORT;
 190         szleng = typesize[TYSHORT];
 191         def_i2 = "#define f2c_i2 1\n";
 192         inqmask = M(TYSHORT)|M(TYLOGICAL);
 193         goto checklong;
 194         }
 195     else
 196         szleng = typesize[TYLONG];
 197     if (useshortints) {
 198         inqmask = M(TYLONG);
 199  checklong:
 200         protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
 201         typesize[TYLOGICAL] = typesize[TYSHORT];
 202         casttypes[TYLOGICAL] = "K_fp";
 203         if (uselongints)
 204             err ("Can't use both long and short ints");
 205         else
 206             tyint = tylogical = TYSHORT;
 207         }
 208     else if (uselongints)
 209         tyint = TYLONG;
 210
 211     if (no66flag)
 212         noextflag = no66flag;
 213     if (noextflag)
 214         zflag = 0;
 215
 216     if (r8flag) {
 217         tyreal = TYDREAL;
 218         r8fix();
 219         }
 220     if (forcedouble) {
 221         protorettypes[TYREAL] = "E_f";
 222         casttypes[TYREAL] = "E_fp";
 223         }
 224
 225     if (maxregvar > MAXREGVAR) {
 226         warni("-O%d: too many register variables", maxregvar);
 227         maxregvar = MAXREGVAR;
 228     } /* if maxregvar > MAXREGVAR */
 229
 230 /* Check the list of input files */
 231
 232     {
 233         int bad, i, cur_max = Max_ftn_files;
 234
 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]);
 238                 bad++;
 239                 }
 240         if (bad)
 241                 exit(1);
 242
 243     } /* block */
 244 } /* set_externs */
 245
 246
 247  static int
 248 comm2dcl()
 249 {
 250         Extsym *ext;
 251         if (ext1comm)
 252                 for(ext = extsymtab; ext < nextext; ext++)
 253                         if (ext->extstg == STGCOMMON && !ext->extinit)
 254                                 return ext1comm;
 255         return 0;
 256         }
 257
 258  static void
 259 write_typedefs(outfile)
 260  FILE *outfile;
 261 {
 262         register int i;
 263         register char *s, *p = 0;
 264         static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
 265         static char stl[4] = { 'E', 'C', 'Z', 'H' };
 266
 267         for(i = 0; i <= TYSUBR; i++)
 268                 if (s = usedcasts[i]) {
 269                         if (!p) {
 270                                 p = Ansi == 1 ? "()" : "(...)";
 271                                 nice_printf(outfile,
 272                                 "/* Types for casting procedure arguments: */\
 273 \n\n#ifndef F2C_proc_par_types\n");
 274                                 if (i == 0) {
 275                                         nice_printf(outfile,
 276                         "typedef int /* Unknown procedure type */ (*%s)%s;\n",
 277                                                  s, p);
 278                                         continue;
 279                                         }
 280                                 }
 281                         nice_printf(outfile, "typedef %s (*%s)%s;\n",
 282                                         c_type_decl(i,1), s, p);
 283                         }
 284         for(i = !forcedouble; i < 4; i++)
 285                 if (used_rets[st[i]])
 286                         nice_printf(outfile,
 287                                 "typedef %s %c_f; /* %s function */\n",
 288                                 p = i ? "VOID" : "doublereal",
 289                                 stl[i], ftn_types[st[i]]);
 290         if (p)
 291                 nice_printf(outfile, "#endif\n\n");
 292         }
 293
 294  static void
 295 commonprotos(outfile)
 296  register FILE *outfile;
 297 {
 298         register Extsym *e, *ee;
 299         register Argtypes *at;
 300         Atype *a, *ae;
 301         int k;
 302         extern int proc_protochanges;
 303
 304         if (!outfile)
 305                 return;
 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);
 310         if (Castargs < 3)
 311                 return;
 312
 313         /* -Pr: special comments conveying current knowledge
 314             of external references */
 315
 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 */
 324                         && at->nargs >= 0) {
 325                                 nice_printf(outfile, "/*:ref: %s %d %d",
 326                                         e->cextname, e->extype, at->nargs);
 327                                 a = at->atypes;
 328                                 for(ae = a + at->nargs; a < ae; a++)
 329                                         nice_printf(outfile, " %d", a->type);
 330                                 nice_printf(outfile, " */\n");
 331                                 if (at->changes & 1)
 332                                         k++;
 333                                 }
 334                         }
 335                     else if (e->extype)
 336                         /* typyed external, never invoked */
 337                         nice_printf(outfile, "/*:ref: %s %d :*/\n",
 338                                 e->cextname, e->extype);
 339         if (k) {
 340                 nice_printf(outfile,
 341         "/* Rerunning f2c -P may change prototypes or declarations. */\n");
 342                 if (nerr)
 343                         return;
 344                 if (protostatus)
 345                         done(4);
 346                 if (protofile != stdout) {
 347                         fprintf(diagfile,
 348         "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
 349                                 filename0, proto_fname);
 350                         fflush(diagfile);
 351                         }
 352                 }
 353         }
 354
 355  int retcode = 0;
 356
 357 main(argc, argv)
 358 int argc;
 359 char **argv;
 360 {
 361         int c2d, k;
 362         FILE *c_output;
 363         char *filename, *cdfilename;
 364         static char stderrbuf[BUFSIZ];
 365         extern void def_commons();
 366         extern char **dfltproc, *dflt1proc[];
 367
 368         diagfile = stderr;
 369         setbuf(stderr, stderrbuf);      /* arrange for fast error msgs */
 370
 371         Max_ftn_files = argc - 1;
 372         ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
 373
 374         parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
 375                 ftn_files, Max_ftn_files);
 376         if (!can_include && ext1comm == 2)
 377                 ext1comm = 1;
 378         if (ext1comm && !extcomm)
 379                 extcomm = 2;
 380         if (protostatus)
 381                 Castargs = 3;
 382         else if (Castargs == 1 && !Ansi)
 383                 Castargs = 0;
 384         if (Castargs >= 2 && !Ansi)
 385                 Ansi = 1;
 386
 387         if (!Ansi)
 388                 parens = "()";
 389         else if (!Castargs)
 390                 parens = Ansi == 1 ? "()" : "(...)";
 391         else
 392                 dfltproc = dflt1proc;
 393
 394         set_externs();
 395         fileinit();
 396         read_Pfiles(ftn_files);
 397
 398         for(k = 1; ftn_files[k]; k++)
 399                 if (dofork())
 400                         break;
 401         filename0 = filename = ftn_files[current_ftn_file = k - 1];
 402
 403         set_tmp_names();
 404         sigcatch();
 405
 406         c_file   = opf(c_functions, textwrite);
 407         pass1_file=opf(p1_file, binwrite);
 408         initkey();
 409         if (filename && *filename) {
 410                 if (debugflag != 1) {
 411                         coutput = c_name(filename,'c');
 412                         if (Castargs >= 2)
 413                                 proto_fname = c_name(filename,'P');
 414                         }
 415                 cdfilename = coutput;
 416                 if (Castargs >= 2
 417                 && !(protofile = fopen(proto_fname, textwrite)))
 418                         fatalstr("Can't open %.84s\n", proto_fname);
 419                 }
 420         else {
 421                 filename = "";
 422                 cdfilename = "f2c_out.c";
 423                 c_output = stdout;
 424                 coutput = 0;
 425                 if (Castargs >= 2) {
 426                         protofile = stdout;
 427                         if (!skipC)
 428                                 printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
 429                         }
 430                 }
 431
 432         if(inilex( copys(filename) ))
 433                 done(1);
 434         if (filename0) {
 435                 fprintf(diagfile, "%s:\n", filename);
 436                 fflush(diagfile);
 437                 }
 438
 439         procinit();
 440         if(k = yyparse())
 441         {
 442                 fprintf(diagfile, "Bad parse, return code %d\n", k);
 443                 done(1);
 444         }
 445
 446         commonprotos(protofile);
 447         if (protofile == stdout && !skipC)
 448                 printf("#endif\n\n");
 449
 450         if(nerr)
 451                 done(1);
 452
 453         if (skipC)
 454                 goto C_skipped;
 455
 456         if (filename0
 457         && (c_output = fopen (coutput, textwrite)) == (FILE *) NULL)
 458                 fatalstr("can't open %.86s", coutput);
 459
 460
 461 /* Write out the declarations which are global to this file */
 462
 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\
 467  */\n\
 468 /*<<</dev/null>>>*/\n\
 469 /*>>>'%s'<<<*/\n", cdfilename);
 470         if (!skipversion) {
 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");
 476                 }
 477         if (Ansi == 2)
 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");
 484         fclose (c_file);
 485         c_file = c_output;              /* HACK to get the next indenting
 486                                            to work */
 487         wr_common_decls (c_output);
 488         if (blkdfile)
 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);
 494         if (*main_alias) {
 495             nice_printf (c_output, "/* Main program alias */ ");
 496             nice_printf (c_output, "int %s () { MAIN__ (); }\n",
 497                     main_alias);
 498             }
 499         if (Ansi == 2)
 500                 nice_printf(c_output,
 501                         "#ifdef __cplusplus\n\t}\n#endif\n");
 502         if (c2d) {
 503                 if (c2d == 1)
 504                         fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
 505                 else
 506                         fclose(c_output);
 507                 def_commons(c_output);
 508                 }
 509         if (c2d != 2)
 510                 fclose (c_output);
 511
 512  C_skipped:
 513         if(parstate != OUTSIDE)
 514                 {
 515                 warn("missing END statement");
 516                 endproc();
 517                 }
 518         done(nerr ? 1 : 0);
 519 }
 520
 521
 522 FILEP opf(fn, mode)
 523 char *fn, *mode;
 524 {
 525         FILEP fp;
 526         if( fp = fopen(fn, mode) )
 527                 return(fp);
 528
 529         fatalstr("cannot open intermediate file %s", fn);
 530         /* NOT REACHED */ return 0;
 531 }
 532
 533
 534 clf(p, what, quit)
 535  FILEP *p;
 536  char *what;
 537  int quit;
 538 {
 539         if(p!=NULL && *p!=NULL && *p!=stdout)
 540         {
 541                 if(ferror(*p)) {
 542                         fprintf(stderr, "I/O error on %s\n", what);
 543                         if (quit)
 544                                 done(3);
 545                         retcode = 3;
 546                         }
 547                 fclose(*p);
 548         }
 549         *p = NULL;
 550 }
 551
 552
 553 done(k)
 554 int k;
 555 {
 556         clf(&initfile, "initfile", 0);
 557         clf(&c_file, "c_file", 0);
 558         clf(&pass1_file, "pass1_file", 0);
 559         Un_link_all(k);
 560         exit(k|retcode);
 561 }