00001 /****************************************************************
00002 Copyright 1990 - 1994 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 #include "defs.h"
00024 #include "usignal.h"
00025 
00026 char binread[] = "rb", textread[] = "r";
00027 char binwrite[] = "wb", textwrite[] = "w";
00028 char *c_functions       = "c_functions";
00029 char *coutput           = "c_output";
00030 char *initfname         = "raw_data";
00031 char *initbname         = "raw_data.b";
00032 char *blkdfname         = "block_data";
00033 char *p1_file           = "p1_file";
00034 char *p1_bakfile        = "p1_file.BAK";
00035 char *sortfname         = "init_file";
00036 char *proto_fname       = "proto_file";
00037 
00038 char link_msg[]         = "-lf2c -lm"; /* was "-lF77 -lI77 -lm -lc"; */
00039 
00040 char *outbuf = "", *outbtail;
00041 
00042 #ifndef TMPDIR
00043 #ifdef MSDOS
00044 #define TMPDIR ""
00045 #else
00046 #define TMPDIR "/tmp"
00047 #endif
00048 #endif
00049 
00050 char *tmpdir = TMPDIR;
00051 #ifndef MSDOS
00052 #ifndef KR_headers
00053 extern int getpid(void);
00054 #endif
00055 #endif
00056 
00057  void
00058 #ifdef KR_headers
00059 Un_link_all(cdelete)
00060         int cdelete;
00061 #else
00062 Un_link_all(int cdelete)
00063 #endif
00064 {
00065 #ifndef KR_headers
00066         extern int unlink(const char *);
00067 #endif
00068         if (!debugflag) {
00069                 unlink(c_functions);
00070                 unlink(initfname);
00071                 unlink(p1_file);
00072                 unlink(sortfname);
00073                 unlink(blkdfname);
00074                 if (cdelete && coutput)
00075                         unlink(coutput);
00076                 }
00077         }
00078 
00079  void
00080 set_tmp_names(Void)
00081 {
00082         int k;
00083         if (debugflag == 1)
00084                 return;
00085         k = strlen(tmpdir) + 24;
00086         c_functions = (char *)ckalloc(7*k);
00087         initfname = c_functions + k;
00088         initbname = initfname + k;
00089         blkdfname = initbname + k;
00090         p1_file = blkdfname + k;
00091         p1_bakfile = p1_file + k;
00092         sortfname = p1_bakfile + k;
00093         {
00094 #ifdef MSDOS
00095         char buf[64], *s, *t;
00096         if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
00097                 t = "";
00098         else {
00099                 /* substitute \ for / to avoid confusion with a
00100                  * switch indicator in the system("sort ...")
00101                  * call in formatdata.c
00102                  */
00103                 for(s = tmpdir, t = buf; *s; s++, t++)
00104                         if ((*t = *s) == '/')
00105                                 *t = '\\';
00106                 if (t[-1] != '\\')
00107                         *t++ = '\\';
00108                 *t = 0;
00109                 t = buf;
00110                 }
00111         sprintf(c_functions, "%sf2c_func", t);
00112         sprintf(initfname, "%sf2c_rd", t);
00113         sprintf(blkdfname, "%sf2c_blkd", t);
00114         sprintf(p1_file, "%sf2c_p1f", t);
00115         sprintf(p1_bakfile, "%sf2c_p1fb", t);
00116         sprintf(sortfname, "%sf2c_sort", t);
00117 #else
00118         long pid = getpid();
00119         sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid);
00120         sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid);
00121         sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid);
00122         sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid);
00123         sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid);
00124         sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid);
00125 #endif
00126         sprintf(initbname, "%s.b", initfname);
00127         }
00128         if (debugflag)
00129                 fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
00130                         initfname, blkdfname, p1_file, p1_bakfile, sortfname);
00131         }
00132 
00133  char *
00134 #ifdef KR_headers
00135 c_name(s, ft)
00136         char *s;
00137         int ft;
00138 #else
00139 c_name(char *s, int ft)
00140 #endif
00141 {
00142         char *b, *s0;
00143         int c;
00144 
00145         b = s0 = s;
00146         while(c = *s++)
00147                 if (c == '/')
00148                         b = s;
00149         if (--s < s0 + 3 || s[-2] != '.'
00150                          || ((c = *--s) != 'f' && c != 'F')) {
00151                 infname = s0;
00152                 Fatal("file name must end in .f or .F");
00153                 }
00154         strcpy(outbtail, b);
00155         outbtail[s-b] = ft;
00156         b = copys(outbuf);
00157         return b;
00158         }
00159 
00160  static void
00161 #ifdef KR_headers
00162 killed(sig)
00163         int sig;
00164 #else
00165 killed(int sig)
00166 #endif
00167 {
00168         sig = sig;      /* shut up warning */
00169         signal(SIGINT, SIG_IGN);
00170 #ifdef SIGQUIT
00171         signal(SIGQUIT, SIG_IGN);
00172 #endif
00173 #ifdef SIGHUP
00174         signal(SIGHUP, SIG_IGN);
00175 #endif
00176         signal(SIGTERM, SIG_IGN);
00177         Un_link_all(1);
00178         exit(126);
00179         }
00180 
00181  static void
00182 #ifdef KR_headers
00183 sig1catch(sig)
00184         int sig;
00185 #else
00186 sig1catch(int sig)
00187 #endif
00188 {
00189         sig = sig;      /* shut up warning */
00190         if (signal(sig, SIG_IGN) != SIG_IGN)
00191                 signal(sig, killed);
00192         }
00193 
00194  static void
00195 #ifdef KR_headers
00196 flovflo(sig)
00197         int sig;
00198 #else
00199 flovflo(int sig)
00200 #endif
00201 {
00202         sig = sig;      /* shut up warning */
00203         Fatal("floating exception during constant evaluation; cannot recover");
00204         /* vax returns a reserved operand that generates
00205            an illegal operand fault on next instruction,
00206            which if ignored causes an infinite loop.
00207         */
00208         signal(SIGFPE, flovflo);
00209 }
00210 
00211  void
00212 #ifdef KR_headers
00213 sigcatch(sig)
00214         int sig;
00215 #else
00216 sigcatch(int sig)
00217 #endif
00218 {
00219         sig = sig;      /* shut up warning */
00220         sig1catch(SIGINT);
00221 #ifdef SIGQUIT
00222         sig1catch(SIGQUIT);
00223 #endif
00224 #ifdef SIGHUP
00225         sig1catch(SIGHUP);
00226 #endif
00227         sig1catch(SIGTERM);
00228         signal(SIGFPE, flovflo);  /* catch overflows */
00229         }
00230 
00231 
00232 dofork(Void)
00233 {
00234 #ifdef MSDOS
00235         Fatal("Only one Fortran input file allowed under MS-DOS");
00236 #else
00237 #ifndef KR_headers
00238         extern int fork(void), wait(int*);
00239 #endif
00240         int pid, status, w;
00241         extern int retcode;
00242 
00243         if (!(pid = fork()))
00244                 return 1;
00245         if (pid == -1)
00246                 Fatal("bad fork");
00247         while((w = wait(&status)) != pid)
00248                 if (w == -1)
00249                         Fatal("bad wait code");
00250         retcode |= status >> 8;
00251 #endif
00252         return 0;
00253         }
00254 
00255 /* Initialization of tables that change with the character set... */
00256 
00257 char escapes[Table_size];
00258 
00259 #ifdef non_ASCII
00260 char *str_fmt[Table_size];
00261 static char *str0fmt[127] = { /*}*/
00262 #else
00263 char *str_fmt[Table_size] = {
00264 #endif
00265  "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
00266    "\\b",   "\\t",   "\\n", "\\013",   "\\f",   "\\r", "\\016", "\\017",
00267  "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
00268  "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
00269      " ",     "!",  "\\\"",     "#",     "$",     "%%",    "&",     "'",
00270      "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
00271      "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
00272      "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
00273      "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
00274      "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
00275      "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
00276      "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
00277      "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
00278      "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
00279      "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
00280      "x",     "y",     "z",     "{",     "|",     "}",     "~"
00281      };
00282 
00283 #ifdef non_ASCII
00284 char *chr_fmt[Table_size];
00285 static char *chr0fmt[127] = {   /*}*/
00286 #else
00287 char *chr_fmt[Table_size] = {
00288 #endif
00289    "\\0",   "\\1",   "\\2",   "\\3",   "\\4",   "\\5",   "\\6",   "\\7",
00290    "\\b",   "\\t",   "\\n",  "\\13",   "\\f",   "\\r",  "\\16",  "\\17",
00291   "\\20",  "\\21",  "\\22",  "\\23",  "\\24",  "\\25",  "\\26",  "\\27",
00292   "\\30",  "\\31",  "\\32",  "\\33",  "\\34",  "\\35",  "\\36",  "\\37",
00293      " ",     "!",    "\"",     "#",     "$",     "%%",    "&",   "\\'",
00294      "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
00295      "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
00296      "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
00297      "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
00298      "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
00299      "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
00300      "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
00301      "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
00302      "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
00303      "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
00304      "x",     "y",     "z",     "{",     "|",     "}",     "~"
00305      };
00306 
00307  void
00308 fmt_init(Void)
00309 {
00310         static char *str1fmt[6] =
00311                 { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
00312         register int i, j;
00313         register char *s;
00314 
00315         /* str_fmt */
00316 
00317 #ifdef non_ASCII
00318         i = 0;
00319 #else
00320         i = 127;
00321 #endif
00322         for(; i < Table_size; i++)
00323                 str_fmt[i] = "\\%03o";
00324 #ifdef non_ASCII
00325         for(i = 32; i < 127; i++) {
00326                 s = str0fmt[i];
00327                 str_fmt[*(unsigned char *)s] = s;
00328                 }
00329         str_fmt['"'] = "\\\"";
00330 #else
00331         if (Ansi == 1)
00332                 str_fmt[7] = chr_fmt[7] = "\\a";
00333 #endif
00334 
00335         /* chr_fmt */
00336 
00337 #ifdef non_ASCII
00338         for(i = 0; i < 32; i++)
00339                 chr_fmt[i] = chr0fmt[i];
00340 #else
00341         i = 127;
00342 #endif
00343         for(; i < Table_size; i++)
00344                 chr_fmt[i] = "\\%o";
00345 #ifdef non_ASCII
00346         for(i = 32; i < 127; i++) {
00347                 s = chr0fmt[i];
00348                 j = *(unsigned char *)s;
00349                 if (j == '\\')
00350                         j = *(unsigned char *)(s+1);
00351                 chr_fmt[j] = s;
00352                 }
00353 #endif
00354 
00355         /* escapes (used in lex.c) */
00356 
00357         for(i = 0; i < Table_size; i++)
00358                 escapes[i] = i;
00359         for(s = "btnfr0", i = 0; i < 6; i++)
00360                 escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
00361         /* finish str_fmt and chr_fmt */
00362 
00363         if (Ansi)
00364                 str1fmt[5] = "\\v";
00365         if ('\v' == 'v') { /* ancient C compiler */
00366                 str1fmt[5] = "v";
00367 #ifndef non_ASCII
00368                 escapes['v'] = 11;
00369 #endif
00370                 }
00371         else
00372                 escapes['v'] = '\v';
00373         for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
00374                 str_fmt[j] = chr_fmt[j] = str1fmt[i++];
00375         /* '\v' = 11 for both EBCDIC and ASCII... */
00376         chr_fmt[11] = Ansi ? "\\v" : "\\13";
00377         }
00378 
00379  void
00380 outbuf_adjust(Void)
00381 {
00382         int n, n1;
00383         char *s;
00384 
00385         n = n1 = strlen(outbuf);
00386         if (*outbuf && outbuf[n-1] != '/')
00387                 n1++;
00388         s = Alloc(n+64);
00389         outbtail = s + n1;
00390         strcpy(s, outbuf);
00391         if (n != n1)
00392                 strcpy(s+n, "/");
00393         outbuf = s;
00394         }
00395 
00396 
00397 /* Unless SYSTEM_SORT is defined, the following gives a simple
00398  * in-core version of dsort().  On Fortran source with huge DATA
00399  * statements, the in-core version may exhaust the available memory,
00400  * in which case you might either recompile this source file with
00401  * SYSTEM_SORT defined (if that's reasonable on your system), or
00402  * replace the dsort below with a more elaborate version that
00403  * does a merging sort with the help of auxiliary files.
00404  */
00405 
00406 #ifdef SYSTEM_SORT
00407 
00408  int
00409 #ifdef KR_headers
00410 dsort(from, to)
00411         char *from;
00412         char *to;
00413 #else
00414 dsort(char *from, char *to)
00415 #endif
00416 {
00417         char buf[200];
00418         sprintf(buf, "sort <%s >%s", from, to);
00419         return system(buf) >> 8;
00420         }
00421 #else
00422 
00423  static int
00424 #ifdef KR_headers
00425  compare(a,b)
00426   char *a, *b;
00427 #else
00428  compare(const void *a, const void *b)
00429 #endif
00430 { return strcmp(*(char **)a, *(char **)b); }
00431 
00432 #ifdef KR_headers
00433 dsort(from, to)
00434         char *from;
00435         char *to;
00436 #else
00437 dsort(char *from, char *to)
00438 #endif
00439 {
00440         struct Memb {
00441                 struct Memb *next;
00442                 int n;
00443                 char buf[32000];
00444                 };
00445         typedef struct Memb memb;
00446         memb *mb, *mb1;
00447         register char *x, *x0, *xe;
00448         register int c, n;
00449         FILE *f;
00450         char **z, **z0;
00451         int nn = 0;
00452 
00453         f = opf(from, textread);
00454         mb = (memb *)Alloc(sizeof(memb));
00455         mb->next = 0;
00456         x0 = x = mb->buf;
00457         xe = x + sizeof(mb->buf);
00458         n = 0;
00459         for(;;) {
00460                 c = getc(f);
00461                 if (x >= xe && (c != EOF || x != x0)) {
00462                         if (!n)
00463                                 return 126;
00464                         nn += n;
00465                         mb->n = n;
00466                         mb1 = (memb *)Alloc(sizeof(memb));
00467                         mb1->next = mb;
00468                         mb = mb1;
00469                         memcpy(mb->buf, x0, n = x-x0);
00470                         x0 = mb->buf;
00471                         x = x0 + n;
00472                         xe = x0 + sizeof(mb->buf);
00473                         n = 0;
00474                         }
00475                 if (c == EOF)
00476                         break;
00477                 if (c == '\n') {
00478                         ++n;
00479                         *x++ = 0;
00480                         x0 = x;
00481                         }
00482                 else
00483                         *x++ = c;
00484                 }
00485         clf(&f, from, 1);
00486         f = opf(to, textwrite);
00487         if (x > x0) { /* shouldn't happen */
00488                 *x = 0;
00489                 ++n;
00490                 }
00491         mb->n = n;
00492         nn += n;
00493         if (!nn) /* shouldn't happen */
00494                 goto done;
00495         z = z0 = (char **)Alloc(nn*sizeof(char *));
00496         for(mb1 = mb; mb1; mb1 = mb1->next) {
00497                 x = mb1->buf;
00498                 n = mb1->n;
00499                 for(;;) {
00500                         *z++ = x;
00501                         if (--n <= 0)
00502                                 break;
00503                         while(*x++);
00504                         }
00505                 }
00506         qsort((char *)z0, nn, sizeof(char *), compare);
00507         for(n = nn, z = z0; n > 0; n--)
00508                 fprintf(f, "%s\n", *z++);
00509         free((char *)z0);
00510  done:
00511         clf(&f, to, 1);
00512         do {
00513                 mb1 = mb->next;
00514                 free((char *)mb);
00515                 }
00516                 while(mb = mb1);
00517         return 0;
00518         }
00519 #endif