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