lang/fortran/comp/sysdep.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 #include "defs.h"
  24 #include "usignal.h"
  25
  26 char binread[] = "rb", textread[] = "r";
  27 char binwrite[] = "wb", textwrite[] = "w";
  28 char *c_functions       = "c_functions";
  29 char *coutput           = "c_output";
  30 char *initfname         = "raw_data";
  31 char *initbname         = "raw_data.b";
  32 char *blkdfname         = "block_data";
  33 char *p1_file           = "p1_file";
  34 char *p1_bakfile        = "p1_file.BAK";
  35 char *sortfname         = "init_file";
  36
  37 char link_msg[]         = "-lF77 -lI77 -lm -lc";
  38
  39 #ifndef TMPDIR
  40 #ifdef MSDOS
  41 #define TMPDIR ""
  42 #else
  43 #define TMPDIR "/tmp"
  44 #endif
  45 #endif
  46
  47 char *tmpdir = TMPDIR;
  48
  49  void
  50 Un_link_all(cdelete)
  51 {
  52         if (!debugflag) {
  53                 unlink(c_functions);
  54                 unlink(initfname);
  55                 unlink(p1_file);
  56                 unlink(sortfname);
  57                 unlink(blkdfname);
  58                 if (cdelete && coutput)
  59                         unlink(coutput);
  60                 }
  61         }
  62
  63  void
  64 set_tmp_names()
  65 {
  66         int k;
  67         if (debugflag == 1)
  68                 return;
  69         k = strlen(tmpdir) + 16;
  70         c_functions = (char *)ckalloc(7*k);
  71         initfname = c_functions + k;
  72         initbname = initfname + k;
  73         blkdfname = initbname + k;
  74         p1_file = blkdfname + k;
  75         p1_bakfile = p1_file + k;
  76         sortfname = p1_bakfile + k;
  77         {
  78 #ifdef MSDOS
  79         char buf[64], *s, *t;
  80         if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
  81                 t = "";
  82         else {
  83                 /* substitute \ for / to avoid confusion with a
  84                  * switch indicator in the system("sort ...")
  85                  * call in formatdata.c
  86                  */
  87                 for(s = tmpdir, t = buf; *s; s++, t++)
  88                         if ((*t = *s) == '/')
  89                                 *t = '\\';
  90                 if (t[-1] != '\\')
  91                         *t++ = '\\';
  92                 *t = 0;
  93                 t = buf;
  94                 }
  95         sprintf(c_functions, "%sf2c_func", t);
  96         sprintf(initfname, "%sf2c_rd", t);
  97         sprintf(blkdfname, "%sf2c_blkd", t);
  98         sprintf(p1_file, "%sf2c_p1f", t);
  99         sprintf(p1_bakfile, "%sf2c_p1fb", t);
 100         sprintf(sortfname, "%sf2c_sort", t);
 101 #else
 102         int pid = getpid();
 103         sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
 104         sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
 105         sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
 106         sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
 107         sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
 108         sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
 109 #endif
 110         sprintf(initbname, "%s.b", initfname);
 111         }
 112         if (debugflag)
 113                 fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
 114                         initfname, blkdfname, p1_file, p1_bakfile, sortfname);
 115         }
 116
 117  char *
 118 c_name(s,ft)char *s;
 119 {
 120         char *b, *s0;
 121         int c;
 122
 123         b = s0 = s;
 124         while(c = *s++)
 125                 if (c == '/')
 126                         b = s;
 127         if (--s < s0 + 3 || s[-2] != '.'
 128                          || ((c = *--s) != 'f' && c != 'F')) {
 129                 infname = s0;
 130                 Fatal("file name must end in .f or .F");
 131                 }
 132         *s = ft;
 133         b = copys(b);
 134         *s = c;
 135         return b;
 136         }
 137
 138  static void
 139 killed()
 140 {
 141         signal(SIGINT, SIG_IGN);
 142 #ifdef SIGQUIT
 143         signal(SIGQUIT, SIG_IGN);
 144 #endif
 145 #ifdef SIGHUP
 146         signal(SIGHUP, SIG_IGN);
 147 #endif
 148         signal(SIGTERM, SIG_IGN);
 149         Un_link_all(1);
 150         exit(126);
 151         }
 152
 153  static void
 154 sig1catch(sig) int sig;
 155 {
 156         if (signal(sig, SIG_IGN) != SIG_IGN)
 157                 signal(sig, killed);
 158         }
 159
 160  static void
 161 flovflo()
 162 {
 163         Fatal("floating exception during constant evaluation; cannot recover");
 164         /* vax returns a reserved operand that generates
 165            an illegal operand fault on next instruction,
 166            which if ignored causes an infinite loop.
 167         */
 168         signal(SIGFPE, flovflo);
 169 }
 170
 171  void
 172 sigcatch()
 173 {
 174         sig1catch(SIGINT);
 175 #ifdef SIGQUIT
 176         sig1catch(SIGQUIT);
 177 #endif
 178 #ifdef SIGHUP
 179         sig1catch(SIGHUP);
 180 #endif
 181         sig1catch(SIGTERM);
 182         signal(SIGFPE, flovflo);  /* catch overflows */
 183         }
 184
 185
 186 dofork()
 187 {
 188 #ifdef MSDOS
 189         Fatal("Only one Fortran input file allowed under MS-DOS");
 190 #else
 191         int pid, status, w;
 192         extern int retcode;
 193
 194         if (!(pid = fork()))
 195                 return 1;
 196         if (pid == -1)
 197                 Fatal("bad fork");
 198         while((w = wait(&status)) != pid)
 199                 if (w == -1)
 200                         Fatal("bad wait code");
 201         retcode |= status >> 8;
 202 #endif
 203         return 0;
 204         }
 205
 206 /* Initialization of tables that change with the character set... */
 207
 208 char escapes[Table_size];
 209
 210 #ifdef non_ASCII
 211 char *str_fmt[Table_size];
 212 static char *str0fmt[127] = { /*}*/
 213 #else
 214 char *str_fmt[Table_size] = {
 215 #endif
 216  "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
 217    "\\b",   "\\t",   "\\n", "\\013",   "\\f",   "\\r", "\\016", "\\017",
 218  "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
 219  "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
 220      " ",     "!",  "\\\"",     "#",     "$",     "%%",    "&",     "'",
 221      "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
 222      "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
 223      "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
 224      "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
 225      "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
 226      "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
 227      "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
 228      "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
 229      "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
 230      "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
 231      "x",     "y",     "z",     "{",     "|",     "}",     "~"
 232      };
 233
 234 #ifdef non_ASCII
 235 char *chr_fmt[Table_size];
 236 static char *chr0fmt[127] = {   /*}*/
 237 #else
 238 char *chr_fmt[Table_size] = {
 239 #endif
 240    "\\0",   "\\1",   "\\2",   "\\3",   "\\4",   "\\5",   "\\6",   "\\7",
 241    "\\b",   "\\t",   "\\n",  "\\13",   "\\f",   "\\r",  "\\16",  "\\17",
 242   "\\20",  "\\21",  "\\22",  "\\23",  "\\24",  "\\25",  "\\26",  "\\27",
 243   "\\30",  "\\31",  "\\32",  "\\33",  "\\34",  "\\35",  "\\36",  "\\37",
 244      " ",     "!",    "\"",     "#",     "$",     "%%",    "&",   "\\'",
 245      "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
 246      "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
 247      "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
 248      "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
 249      "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
 250      "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
 251      "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
 252      "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
 253      "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
 254      "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
 255      "x",     "y",     "z",     "{",     "|",     "}",     "~"
 256      };
 257
 258  void
 259 fmt_init()
 260 {
 261         static char *str1fmt[6] =
 262                 { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
 263         register int i, j;
 264         register char *s;
 265
 266         /* str_fmt */
 267
 268 #ifdef non_ASCII
 269         i = 0;
 270 #else
 271         i = 127;
 272 #endif
 273         for(; i < Table_size; i++)
 274                 str_fmt[i] = "\\%03o";
 275 #ifdef non_ASCII
 276         for(i = 32; i < 127; i++) {
 277                 s = str0fmt[i];
 278                 str_fmt[*(unsigned char *)s] = s;
 279                 }
 280         str_fmt['"'] = "\\\"";
 281 #else
 282         if (Ansi == 1)
 283                 str_fmt[7] = chr_fmt[7] = "\\a";
 284 #endif
 285
 286         /* chr_fmt */
 287
 288 #ifdef non_ASCII
 289         for(i = 0; i < 32; i++)
 290                 chr_fmt[i] = chr0fmt[i];
 291 #else
 292         i = 127;
 293 #endif
 294         for(; i < Table_size; i++)
 295                 chr_fmt[i] = "\\%o";
 296 #ifdef non_ASCII
 297         for(i = 32; i < 127; i++) {
 298                 s = chr0fmt[i];
 299                 j = *(unsigned char *)s;
 300                 if (j == '\\')
 301                         j = *(unsigned char *)(s+1);
 302                 chr_fmt[j] = s;
 303                 }
 304 #endif
 305
 306         /* escapes (used in lex.c) */
 307
 308         for(i = 0; i < Table_size; i++)
 309                 escapes[i] = i;
 310         for(s = "btnfr0", i = 0; i < 6; i++)
 311                 escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
 312         /* finish str_fmt and chr_fmt */
 313
 314         if (Ansi)
 315                 str1fmt[5] = "\\v";
 316         if ('\v' == 'v') { /* ancient C compiler */
 317                 str1fmt[5] = "v";
 318 #ifndef non_ASCII
 319                 escapes['v'] = 11;
 320 #endif
 321                 }
 322         else
 323                 escapes['v'] = '\v';
 324         for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
 325                 str_fmt[j] = chr_fmt[j] = str1fmt[i++];
 326         /* '\v' = 11 for both EBCDIC and ASCII... */
 327         chr_fmt[11] = Ansi ? "\\v" : "\\13";
 328         }
 329
 330
 331
 332 /* Unless SYSTEM_SORT is defined, the following gives a simple
 333  * in-core version of dsort().  On Fortran source with huge DATA
 334  * statements, the in-core version may exhaust the available memory,
 335  * in which case you might either recompile this source file with
 336  * SYSTEM_SORT defined (if that's reasonable on your system), or
 337  * replace the dsort below with a more elaborate version that
 338  * does a merging sort with the help of auxiliary files.
 339  */
 340
 341 #ifdef SYSTEM_SORT
 342
 343 dsort(from, to)
 344  char *from, *to;
 345 {
 346         char buf[200];
 347         sprintf(buf, "sort <%s >%s", from, to);
 348         return system(buf) >> 8;
 349         }
 350 #else
 351
 352  static int
 353 #ifdef __STDC__
 354 compare(const void *a, const void *b)
 355 #else
 356 compare(a,b)
 357  char *a, *b;
 358 #endif
 359 { return strcmp(*(char **)a, *(char **)b); }
 360
 361 dsort(from, to)
 362  char *from, *to;
 363 {
 364         extern char *Alloc();
 365
 366         struct Memb {
 367                 struct Memb *next;
 368                 int n;
 369                 char buf[32000];
 370                 };
 371         typedef struct Memb memb;
 372         memb *mb, *mb1;
 373         register char *x, *x0, *xe;
 374         register int c, n;
 375         FILE *f;
 376         char **z, **z0;
 377         int nn = 0;
 378
 379         f = opf(from, textread);
 380         mb = (memb *)Alloc(sizeof(memb));
 381         mb->next = 0;
 382         x0 = x = mb->buf;
 383         xe = x + sizeof(mb->buf);
 384         n = 0;
 385         for(;;) {
 386                 c = getc(f);
 387                 if (x >= xe && (c != EOF || x != x0)) {
 388                         if (!n)
 389                                 return 126;
 390                         nn += n;
 391                         mb->n = n;
 392                         mb1 = (memb *)Alloc(sizeof(memb));
 393                         mb1->next = mb;
 394                         mb = mb1;
 395                         memcpy(mb->buf, x0, n = x-x0);
 396                         x0 = mb->buf;
 397                         x = x0 + n;
 398                         xe = x0 + sizeof(mb->buf);
 399                         n = 0;
 400                         }
 401                 if (c == EOF)
 402                         break;
 403                 if (c == '\n') {
 404                         ++n;
 405                         *x++ = 0;
 406                         x0 = x;
 407                         }
 408                 else
 409                         *x++ = c;
 410                 }
 411         clf(&f, from, 1);
 412         f = opf(to, textwrite);
 413         if (x > x0) { /* shouldn't happen */
 414                 *x = 0;
 415                 ++n;
 416                 }
 417         mb->n = n;
 418         nn += n;
 419         if (!nn) /* shouldn't happen */
 420                 goto done;
 421         z = z0 = (char **)Alloc(nn*sizeof(char *));
 422         for(mb1 = mb; mb1; mb1 = mb1->next) {
 423                 x = mb1->buf;
 424                 n = mb1->n;
 425                 for(;;) {
 426                         *z++ = x;
 427                         if (--n <= 0)
 428                                 break;
 429                         while(*x++);
 430                         }
 431                 }
 432         qsort((char *)z0, nn, sizeof(char *), compare);
 433         for(n = nn, z = z0; n > 0; n--)
 434                 fprintf(f, "%s\n", *z++);
 435         free((char *)z0);
 436  done:
 437         clf(&f, to, 1);
 438         do {
 439                 mb1 = mb->next;
 440                 free((char *)mb);
 441                 }
 442                 while(mb = mb1);
 443         return 0;
 444         }
 445 #endif