summaryrefslogtreecommitdiffstats
path: root/usr.bin/f2c/sysdep.c
diff options
context:
space:
mode:
Diffstat (limited to 'usr.bin/f2c/sysdep.c')
-rw-r--r--usr.bin/f2c/sysdep.c442
1 files changed, 442 insertions, 0 deletions
diff --git a/usr.bin/f2c/sysdep.c b/usr.bin/f2c/sysdep.c
new file mode 100644
index 0000000..81bc5af
--- /dev/null
+++ b/usr.bin/f2c/sysdep.c
@@ -0,0 +1,442 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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 *proto_fname = "proto_file";
+
+char link_msg[] = "-lf2c -lm"; /* was "-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(sig)
+{
+ 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)
+{
+ if (signal(sig, SIG_IGN) != SIG_IGN)
+ signal(sig, killed);
+ }
+
+ static void
+flovflo(sig)
+{
+ 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(sig)
+{
+ 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
OpenPOWER on IntegriCloud