/**************************************************************** Copyright 1990 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T Bell Laboratories or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "usignal.h" char binread[] = "rb", textread[] = "r"; char binwrite[] = "wb", textwrite[] = "w"; char *c_functions = "c_functions"; char *coutput = "c_output"; char *initfname = "raw_data"; char *initbname = "raw_data.b"; char *blkdfname = "block_data"; char *p1_file = "p1_file"; char *p1_bakfile = "p1_file.BAK"; char *sortfname = "init_file"; char link_msg[] = "-lF77 -lI77 -lm -lc"; #ifndef TMPDIR #ifdef MSDOS #define TMPDIR "" #else #define TMPDIR "/tmp" #endif #endif char *tmpdir = TMPDIR; void Un_link_all(cdelete) { if (!debugflag) { unlink(c_functions); unlink(initfname); unlink(p1_file); unlink(sortfname); unlink(blkdfname); if (cdelete && coutput) unlink(coutput); } } void set_tmp_names() { int k; if (debugflag == 1) return; k = strlen(tmpdir) + 16; c_functions = (char *)ckalloc(7*k); initfname = c_functions + k; initbname = initfname + k; blkdfname = initbname + k; p1_file = blkdfname + k; p1_bakfile = p1_file + k; sortfname = p1_bakfile + k; { #ifdef MSDOS char buf[64], *s, *t; if (!*tmpdir || *tmpdir == '.' && !tmpdir[1]) t = ""; else { /* substitute \ for / to avoid confusion with a * switch indicator in the system("sort ...") * call in formatdata.c */ for(s = tmpdir, t = buf; *s; s++, t++) if ((*t = *s) == '/') *t = '\\'; if (t[-1] != '\\') *t++ = '\\'; *t = 0; t = buf; } sprintf(c_functions, "%sf2c_func", t); sprintf(initfname, "%sf2c_rd", t); sprintf(blkdfname, "%sf2c_blkd", t); sprintf(p1_file, "%sf2c_p1f", t); sprintf(p1_bakfile, "%sf2c_p1fb", t); sprintf(sortfname, "%sf2c_sort", t); #else int pid = getpid(); sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid); sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid); sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid); sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid); sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid); sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid); #endif sprintf(initbname, "%s.b", initfname); } if (debugflag) fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions, initfname, blkdfname, p1_file, p1_bakfile, sortfname); } char * c_name(s,ft)char *s; { char *b, *s0; int c; b = s0 = s; while(c = *s++) if (c == '/') b = s; if (--s < s0 + 3 || s[-2] != '.' || ((c = *--s) != 'f' && c != 'F')) { infname = s0; Fatal("file name must end in .f or .F"); } *s = ft; b = copys(b); *s = c; return b; } static void killed() { signal(SIGINT, SIG_IGN); #ifdef SIGQUIT signal(SIGQUIT, SIG_IGN); #endif #ifdef SIGHUP signal(SIGHUP, SIG_IGN); #endif signal(SIGTERM, SIG_IGN); Un_link_all(1); exit(126); } static void sig1catch(sig) int sig; { if (signal(sig, SIG_IGN) != SIG_IGN) signal(sig, killed); } static void flovflo() { Fatal("floating exception during constant evaluation; cannot recover"); /* vax returns a reserved operand that generates an illegal operand fault on next instruction, which if ignored causes an infinite loop. */ signal(SIGFPE, flovflo); } void sigcatch() { sig1catch(SIGINT); #ifdef SIGQUIT sig1catch(SIGQUIT); #endif #ifdef SIGHUP sig1catch(SIGHUP); #endif sig1catch(SIGTERM); signal(SIGFPE, flovflo); /* catch overflows */ } dofork() { #ifdef MSDOS Fatal("Only one Fortran input file allowed under MS-DOS"); #else int pid, status, w; extern int retcode; if (!(pid = fork())) return 1; if (pid == -1) Fatal("bad fork"); while((w = wait(&status)) != pid) if (w == -1) Fatal("bad wait code"); retcode |= status >> 8; #endif return 0; } /* Initialization of tables that change with the character set... */ char escapes[Table_size]; #ifdef non_ASCII char *str_fmt[Table_size]; static char *str0fmt[127] = { /*}*/ #else char *str_fmt[Table_size] = { #endif "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007", "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017", "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027", "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037", " ", "!", "\\\"", "#", "$", "%%", "&", "'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", "\\\\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", "}", "~" }; #ifdef non_ASCII char *chr_fmt[Table_size]; static char *chr0fmt[127] = { /*}*/ #else char *chr_fmt[Table_size] = { #endif "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7", "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17", "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27", "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37", " ", "!", "\"", "#", "$", "%%", "&", "\\'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", "\\\\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", "}", "~" }; void fmt_init() { static char *str1fmt[6] = { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" }; register int i, j; register char *s; /* str_fmt */ #ifdef non_ASCII i = 0; #else i = 127; #endif for(; i < Table_size; i++) str_fmt[i] = "\\%03o"; #ifdef non_ASCII for(i = 32; i < 127; i++) { s = str0fmt[i]; str_fmt[*(unsigned char *)s] = s; } str_fmt['"'] = "\\\""; #else if (Ansi == 1) str_fmt[7] = chr_fmt[7] = "\\a"; #endif /* chr_fmt */ #ifdef non_ASCII for(i = 0; i < 32; i++) chr_fmt[i] = chr0fmt[i]; #else i = 127; #endif for(; i < Table_size; i++) chr_fmt[i] = "\\%o"; #ifdef non_ASCII for(i = 32; i < 127; i++) { s = chr0fmt[i]; j = *(unsigned char *)s; if (j == '\\') j = *(unsigned char *)(s+1); chr_fmt[j] = s; } #endif /* escapes (used in lex.c) */ for(i = 0; i < Table_size; i++) escapes[i] = i; for(s = "btnfr0", i = 0; i < 6; i++) escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i]; /* finish str_fmt and chr_fmt */ if (Ansi) str1fmt[5] = "\\v"; if ('\v' == 'v') { /* ancient C compiler */ str1fmt[5] = "v"; #ifndef non_ASCII escapes['v'] = 11; #endif } else escapes['v'] = '\v'; for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;) str_fmt[j] = chr_fmt[j] = str1fmt[i++]; /* '\v' = 11 for both EBCDIC and ASCII... */ chr_fmt[11] = Ansi ? "\\v" : "\\13"; } /* Unless SYSTEM_SORT is defined, the following gives a simple * in-core version of dsort(). On Fortran source with huge DATA * statements, the in-core version may exhaust the available memory, * in which case you might either recompile this source file with * SYSTEM_SORT defined (if that's reasonable on your system), or * replace the dsort below with a more elaborate version that * does a merging sort with the help of auxiliary files. */ #ifdef SYSTEM_SORT dsort(from, to) char *from, *to; { char buf[200]; sprintf(buf, "sort <%s >%s", from, to); return system(buf) >> 8; } #else static int compare(a,b) char *a, *b; { return strcmp(*(char **)a, *(char **)b); } dsort(from, to) char *from, *to; { extern char *Alloc(); struct Memb { struct Memb *next; int n; char buf[32000]; }; typedef struct Memb memb; memb *mb, *mb1; register char *x, *x0, *xe; register int c, n; FILE *f; char **z, **z0; int nn = 0; f = opf(from, textread); mb = (memb *)Alloc(sizeof(memb)); mb->next = 0; x0 = x = mb->buf; xe = x + sizeof(mb->buf); n = 0; for(;;) { c = getc(f); if (x >= xe && (c != EOF || x != x0)) { if (!n) return 126; nn += n; mb->n = n; mb1 = (memb *)Alloc(sizeof(memb)); mb1->next = mb; mb = mb1; memcpy(mb->buf, x0, n = x-x0); x0 = mb->buf; x = x0 + n; xe = x0 + sizeof(mb->buf); n = 0; } if (c == EOF) break; if (c == '\n') { ++n; *x++ = 0; x0 = x; } else *x++ = c; } clf(&f, from, 1); f = opf(to, textwrite); if (x > x0) { /* shouldn't happen */ *x = 0; ++n; } mb->n = n; nn += n; if (!nn) /* shouldn't happen */ goto done; z = z0 = (char **)Alloc(nn*sizeof(char *)); for(mb1 = mb; mb1; mb1 = mb1->next) { x = mb1->buf; n = mb1->n; for(;;) { *z++ = x; if (--n <= 0) break; while(*x++); } } qsort((char *)z0, nn, sizeof(char *), compare); for(n = nn, z = z0; n > 0; n--) fprintf(f, "%s\n", *z++); free((char *)z0); done: clf(&f, to, 1); do { mb1 = mb->next; free((char *)mb); } while(mb = mb1); return 0; } #endif