1 /****************************************************************
2 Copyright 1990 - 1994, 2000 by AT&T, Lucent Technologies 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,
10 Lucent or Bellcore or any of their entities not be used in
11 advertising or publicity pertaining to distribution of the
12 software without specific, written prior permission.
13
14 AT&T, Lucent and Bellcore disclaim all warranties with regard to
15 this software, including all implied warranties of
16 merchantability and fitness. In no event shall AT&T, Lucent or
17 Bellcore be liable for any special, indirect or consequential
18 damages or any damages whatsoever resulting from loss of use,
19 data or profits, whether in an action of contract, negligence or
20 other tortious action, arising out of or in connection with the
21 use or performance of 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[] = "on Microsoft Windows system, link with libf2c.lib;\n\
39 on Linux or Unix systems, link with .../path/to/libf2c.a -lm\n\
40 or, if you install libf2c.a in a standard place, with -lf2c -lm\n\
41 -- in that order, at the end of the command line, as in\n\
42 cc *.o -lf2c -lm\n\
43 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,\n\n\
44 http://www.netlib.org/f2c/libf2c.zip";
45
46 char *outbuf = "", *outbtail;
47
48 #undef WANT_spawnvp
49 #ifdef MSDOS
50 #ifndef NO_spawnvp
51 #define WANT_spawnvp
52 #endif
53 #endif
54
55 #ifdef _WIN32
56 #include <windows.h> /* for GetVolumeInformation */
57 #undef WANT_spawnvp
58 #define WANT_spawnvp
59 #undef MSDOS
60 #define MSDOS
61 #endif
62
63 #ifdef WANT_spawnvp
64 #include <process.h>
65 #ifndef _P_WAIT
66 #define _P_WAIT P_WAIT /* Symantec C/C++ */
67 #endif
68 static char **spargv, **pfname;
69 #endif
70
71 char *tmpdir = "";
72
73 #ifdef __cplusplus
74 #define Cextern extern "C"
75 extern "C" {
76 static void flovflo(int), killed(int);
77 static int compare(const void *a, const void *b);
78 }
79 #else
80 #define Cextern extern
81 #endif
82
83 Cextern int unlink Argdcl((const char *));
84 Cextern int fork Argdcl((void)), getpid Argdcl((void)), wait Argdcl((int*));
85
86 void
87 #ifdef KR_headers
Un_link_all(cdelete)88 Un_link_all(cdelete)
89 int cdelete;
90 #else
91 Un_link_all(int cdelete)
92 #endif
93 {
94 if (!debugflag) {
95 unlink(c_functions);
96 unlink(initfname);
97 unlink(p1_file);
98 unlink(sortfname);
99 unlink(blkdfname);
100 if (cdelete && coutput)
101 unlink(coutput);
102 }
103 }
104
105 #ifndef MSDOS
106 #include "sysdep.hd"
107 #include <unistd.h> /* for mkdtemp and rmdir */
108 #endif
109
110 #ifndef NO_TEMPDIR
111 static void
rmtdir(Void)112 rmtdir(Void)
113 {
114 char *s;
115 if (*(s = tmpdir)) {
116 tmpdir = "";
117 rmdir(s);
118 }
119 }
120 #endif /*NO_TEMPDIR*/
121
122 static void
alloc_names(Void)123 alloc_names(Void)
124 {
125 int k = strlen(tmpdir) + 24;
126 c_functions = (char *)ckalloc(7*k);
127 initfname = c_functions + k;
128 initbname = initfname + k;
129 blkdfname = initbname + k;
130 p1_file = blkdfname + k;
131 p1_bakfile = p1_file + k;
132 sortfname = p1_bakfile + k;
133 }
134
135 void
set_tmp_names(Void)136 set_tmp_names(Void)
137 {
138 #ifdef MSDOS
139 char buf[64], *s, *t;
140 #ifdef _WIN32
141 DWORD flags, maxlen, volser;
142 char volname[512], f2c[24], fsname[512], *name1;
143 int i;
144
145 if (debugflag == 1)
146 return;
147 i = sprintf(f2c, "%x", _getpid());
148 if (!GetVolumeInformation(NULL, volname, sizeof(volname), &volser, &maxlen,
149 &flags, fsname, sizeof(fsname))
150 || maxlen < i+8) /* FAT16 */
151 strcpy(f2c, "f2c_");
152 #else
153 static char f2c[] = "f2c_";
154 if (debugflag == 1)
155 return;
156 #endif
157
158 if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
159 t = "";
160 else {
161 /* substitute \ for / to avoid confusion with a
162 * switch indicator in the system("sort ...")
163 * call in formatdata.c
164 */
165 for(s = tmpdir, t = buf; *s; s++, t++)
166 if ((*t = *s) == '/')
167 *t = '\\';
168 if (t[-1] != '\\')
169 *t++ = '\\';
170 *t = 0;
171 t = buf;
172 }
173 alloc_names();
174 sprintf(c_functions, "%s%sfunc", t, f2c);
175 sprintf(initfname, "%s%srd", t, f2c);
176 sprintf(blkdfname, "%s%sblkd", t, f2c);
177 sprintf(p1_file, "%s%sp1f", t, f2c);
178 sprintf(p1_bakfile, "%s%sp1fb", t, f2c);
179 sprintf(sortfname, "%s%ssort", t, f2c);
180 #else /*!MSDOS*/
181 long pid;
182
183 #define L_TDNAME 20
184 #ifdef NO_MKDTEMP
185 #ifdef NO_MKSTEMP
186 #undef L_TDNAME
187 #define L_TDNAME L_tmpnam
188 #endif
189 #endif
190 static char tdbuf[L_TDNAME];
191
192 if (debugflag == 1)
193 return;
194 pid = getpid();
195 if (!*tmpdir) {
196 #ifdef NO_TEMPDIR
197 tmpdir = "/tmp";
198 #else
199 #ifdef NO_MKDTEMP
200 #ifdef NO_MKSTEMP
201 if (!(tmpdir = tmpnam(tdbuf))) {
202 fprintf(stderr, "tmpnam failed (for -T)\n");
203 exit(1);
204 }
205 #else
206 int f;
207 strcpy(tdbuf, "/tmp/f2ctd_XXXXXX");
208 f = mkstemp(tdbuf);
209 if (f >= 0) {
210 close(f);
211 remove(tmpdir = tdbuf);
212 }
213 else {
214 fprintf(stderr, "mkstemp failed (for -T)\n");
215 exit(1);
216 }
217 #endif /*NO_MKSTEMP*/
218 if (mkdir(tdbuf,0700)) {
219 fprintf(stderr, "mkdir failed (for -T)\n");
220 exit(1);
221 }
222 #else /*!NO_MKDTEMP*/
223 strcpy(tdbuf, "/tmp/f2ctd_XXXXXX");
224 if (!(tmpdir = mkdtemp(tdbuf))) {
225 fprintf(stderr, "mkdtemp failed (for -T)\n");
226 exit(1);
227 }
228 #endif /*NO_MKDTEMP*/
229 if (!debugflag)
230 atexit(rmtdir);
231 #endif /*NO_TEMPDIR*/
232 }
233 alloc_names();
234 sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid);
235 sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid);
236 sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid);
237 sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid);
238 sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid);
239 sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid);
240 #endif /*MSDOS*/
241 sprintf(initbname, "%s.b", initfname);
242 if (debugflag)
243 fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
244 initfname, blkdfname, p1_file, p1_bakfile, sortfname);
245 }
246
247 char *
248 #ifdef KR_headers
c_name(s,ft)249 c_name(s, ft)
250 char *s;
251 int ft;
252 #else
253 c_name(char *s, int ft)
254 #endif
255 {
256 char *b, *s0;
257 int c;
258
259 b = s0 = s;
260 while(c = *s++)
261 if (c == '/')
262 b = s;
263 if (--s < s0 + 3 || s[-2] != '.'
264 || ((c = *--s) != 'f' && c != 'F')) {
265 infname = s0;
266 Fatal("file name must end in .f or .F");
267 }
268 strcpy(outbtail, b);
269 outbtail[s-b] = ft;
270 b = copys(outbuf);
271 return b;
272 }
273
274 static void
275 #ifdef KR_headers
killed(sig)276 killed(sig)
277 int sig;
278 #else
279 killed(int sig)
280 #endif
281 {
282 sig = sig; /* shut up warning */
283 signal(SIGINT, SIG_IGN);
284 #ifdef SIGQUIT
285 signal(SIGQUIT, SIG_IGN);
286 #endif
287 #ifdef SIGHUP
288 signal(SIGHUP, SIG_IGN);
289 #endif
290 signal(SIGTERM, SIG_IGN);
291 Un_link_all(1);
292 exit(126);
293 }
294
295 static void
296 #ifdef KR_headers
sig1catch(sig)297 sig1catch(sig)
298 int sig;
299 #else
300 sig1catch(int sig)
301 #endif
302 {
303 sig = sig; /* shut up warning */
304 if (signal(sig, SIG_IGN) != SIG_IGN)
305 signal(sig, killed);
306 }
307
308 static void
309 #ifdef KR_headers
flovflo(sig)310 flovflo(sig)
311 int sig;
312 #else
313 flovflo(int sig)
314 #endif
315 {
316 sig = sig; /* shut up warning */
317 Fatal("floating exception during constant evaluation; cannot recover");
318 /* vax returns a reserved operand that generates
319 an illegal operand fault on next instruction,
320 which if ignored causes an infinite loop.
321 */
322 signal(SIGFPE, flovflo);
323 }
324
325 void
326 #ifdef KR_headers
sigcatch(sig)327 sigcatch(sig)
328 int sig;
329 #else
330 sigcatch(int sig)
331 #endif
332 {
333 sig = sig; /* shut up warning */
334 sig1catch(SIGINT);
335 #ifdef SIGQUIT
336 sig1catch(SIGQUIT);
337 #endif
338 #ifdef SIGHUP
339 sig1catch(SIGHUP);
340 #endif
341 sig1catch(SIGTERM);
342 signal(SIGFPE, flovflo); /* catch overflows */
343 }
344
345 /* argkludge permits wild-card expansion and caching of the original or expanded */
346 /* argv to kludge around the lack of fork() and exec() when necessary. */
347
348 void
349 #ifdef KR_headers
argkludge(pargc,pargv)350 argkludge(pargc, pargv) int *pargc; char ***pargv;
351 #else
352 argkludge(int *pargc, char ***pargv)
353 #endif
354 {
355 #ifdef WANT_spawnvp
356 size_t L, L1;
357 int argc, i, nf;
358 char **a, **argv, *s, *t, *t0;
359
360 /* Assume wild-card expansion has been done by Microsoft's setargv.obj */
361
362 /* Count Fortran input files. */
363
364 L = argc = *pargc;
365 argv = *pargv;
366 for(i = nf = 0; i < argc; i++) {
367 L += L1 = strlen(s = argv[i]);
368 if (L1 > 2 && s[L1-2] == '.')
369 switch(s[L1-1]) {
370 case 'f':
371 case 'F':
372 nf++;
373 }
374 }
375 if (nf <= 1)
376 return;
377
378 /* Cache inputs */
379
380 i = argc - nf + 2;
381 a = spargv = (char**)Alloc(i*sizeof(char*) + L);
382 t = (char*)(a + i);
383 for(i = 0; i < argc; i++) {
384 *a++ = t0 = t;
385 for(s = argv[i]; *t++ = *s; s++);
386 if (t-t0 > 3 && s[-2] == '.')
387 switch(s[-1]) {
388 case 'f':
389 case 'F':
390 --a;
391 t = t0;
392 }
393 }
394 pfname = a++;
395 *a = 0;
396 #endif
397 }
398
399 int
400 #ifdef KR_headers
dofork(fname)401 dofork(fname) char *fname;
402 #else
403 dofork(char *fname)
404 #endif
405 {
406 extern int retcode;
407 #ifdef MSDOS
408 #ifdef WANT_spawnvp
409 *pfname = fname;
410 retcode |= _spawnvp(_P_WAIT, spargv[0], (char const*const*)spargv);
411 #else /*_WIN32*/
412 Fatal("Only one Fortran input file allowed under MS-DOS");
413 #endif /*_WIN32*/
414 #else
415 int pid, status, w;
416
417 if (!(pid = fork()))
418 return 1;
419 if (pid == -1)
420 Fatal("bad fork");
421 while((w = wait(&status)) != pid)
422 if (w == -1)
423 Fatal("bad wait code");
424 retcode |= status >> 8;
425 #endif
426 return 0;
427 }
428
429 /* Initialization of tables that change with the character set... */
430
431 char escapes[Table_size];
432
433 #ifdef non_ASCII
434 char *str_fmt[Table_size];
435 static char *str0fmt[127] = { /*}*/
436 #else
437 char *str_fmt[Table_size] = {
438 #endif
439 "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
440 "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017",
441 "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
442 "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
443 " ", "!", "\\\"", "#", "$", "%%", "&", "'",
444 "(", ")", "*", "+", ",", "-", ".", "/",
445 "0", "1", "2", "3", "4", "5", "6", "7",
446 "8", "9", ":", ";", "<", "=", ">", "?",
447 "@", "A", "B", "C", "D", "E", "F", "G",
448 "H", "I", "J", "K", "L", "M", "N", "O",
449 "P", "Q", "R", "S", "T", "U", "V", "W",
450 "X", "Y", "Z", "[", "\\\\", "]", "^", "_",
451 "`", "a", "b", "c", "d", "e", "f", "g",
452 "h", "i", "j", "k", "l", "m", "n", "o",
453 "p", "q", "r", "s", "t", "u", "v", "w",
454 "x", "y", "z", "{", "|", "}", "~"
455 };
456
457 #ifdef non_ASCII
458 char *chr_fmt[Table_size];
459 static char *chr0fmt[127] = { /*}*/
460 #else
461 char *chr_fmt[Table_size] = {
462 #endif
463 "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7",
464 "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17",
465 "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27",
466 "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37",
467 " ", "!", "\"", "#", "$", "%%", "&", "\\'",
468 "(", ")", "*", "+", ",", "-", ".", "/",
469 "0", "1", "2", "3", "4", "5", "6", "7",
470 "8", "9", ":", ";", "<", "=", ">", "?",
471 "@", "A", "B", "C", "D", "E", "F", "G",
472 "H", "I", "J", "K", "L", "M", "N", "O",
473 "P", "Q", "R", "S", "T", "U", "V", "W",
474 "X", "Y", "Z", "[", "\\\\", "]", "^", "_",
475 "`", "a", "b", "c", "d", "e", "f", "g",
476 "h", "i", "j", "k", "l", "m", "n", "o",
477 "p", "q", "r", "s", "t", "u", "v", "w",
478 "x", "y", "z", "{", "|", "}", "~"
479 };
480
481 void
fmt_init(Void)482 fmt_init(Void)
483 {
484 static char *str1fmt[6] =
485 { "\\b", "\\t", "\\n", "\\f", "\\r", "\\013" };
486 register int i, j;
487 register char *s;
488
489 /* str_fmt */
490
491 #ifdef non_ASCII
492 i = 0;
493 #else
494 i = 127;
495 #endif
496 s = Alloc(5*(Table_size - i));
497 for(; i < Table_size; i++) {
498 sprintf(str_fmt[i] = s, "\\%03o", i);
499 s += 5;
500 }
501 #ifdef non_ASCII
502 for(i = 32; i < 127; i++) {
503 s = str0fmt[i];
504 str_fmt[*(unsigned char *)s] = s;
505 }
506 str_fmt['"'] = "\\\"";
507 #else
508 if (Ansi == 1)
509 str_fmt[7] = chr_fmt[7] = "\\a";
510 #endif
511
512 /* chr_fmt */
513
514 #ifdef non_ASCII
515 for(i = 0; i < 32; i++)
516 chr_fmt[i] = chr0fmt[i];
517 #else
518 i = 127;
519 #endif
520 for(; i < Table_size; i++)
521 chr_fmt[i] = "\\%o";
522 #ifdef non_ASCII
523 for(i = 32; i < 127; i++) {
524 s = chr0fmt[i];
525 j = *(unsigned char *)s;
526 if (j == '\\')
527 j = *(unsigned char *)(s+1);
528 chr_fmt[j] = s;
529 }
530 #endif
531
532 /* escapes (used in lex.c) */
533
534 for(i = 0; i < Table_size; i++)
535 escapes[i] = i;
536 for(s = "btnfr0", i = 0; i < 6; i++)
537 escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
538 /* finish str_fmt and chr_fmt */
539
540 if (Ansi)
541 str1fmt[5] = "\\v";
542 if ('\v' == 'v') { /* ancient C compiler */
543 str1fmt[5] = "v";
544 #ifndef non_ASCII
545 escapes['v'] = 11;
546 #endif
547 }
548 else
549 escapes['v'] = '\v';
550 for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
551 str_fmt[j] = chr_fmt[j] = str1fmt[i++];
552 /* '\v' = 11 for both EBCDIC and ASCII... */
553 chr_fmt[11] = (char*)(Ansi ? "\\v" : "\\13");
554 }
555
556 void
outbuf_adjust(Void)557 outbuf_adjust(Void)
558 {
559 int n, n1;
560 char *s;
561
562 n = n1 = strlen(outbuf);
563 if (*outbuf && outbuf[n-1] != '/')
564 n1++;
565 s = Alloc(n+64);
566 outbtail = s + n1;
567 strcpy(s, outbuf);
568 if (n != n1)
569 strcpy(s+n, "/");
570 outbuf = s;
571 }
572
573
574 /* Unless SYSTEM_SORT is defined, the following gives a simple
575 * in-core version of dsort(). On Fortran source with huge DATA
576 * statements, the in-core version may exhaust the available memory,
577 * in which case you might either recompile this source file with
578 * SYSTEM_SORT defined (if that's reasonable on your system), or
579 * replace the dsort below with a more elaborate version that
580 * does a merging sort with the help of auxiliary files.
581 */
582
583 #ifdef SYSTEM_SORT
584
585 int
586 #ifdef KR_headers
dsort(from,to)587 dsort(from, to)
588 char *from;
589 char *to;
590 #else
591 dsort(char *from, char *to)
592 #endif
593 {
594 char buf[200];
595 sprintf(buf, "sort <%s >%s", from, to);
596 return system(buf) >> 8;
597 }
598 #else
599
600 static int
601 #ifdef KR_headers
compare(a,b)602 compare(a,b)
603 char *a, *b;
604 #else
605 compare(const void *a, const void *b)
606 #endif
607 { return strcmp(*(char **)a, *(char **)b); }
608
609 int
610 #ifdef KR_headers
dsort(from,to)611 dsort(from, to)
612 char *from;
613 char *to;
614 #else
615 dsort(char *from, char *to)
616 #endif
617 {
618 struct Memb {
619 struct Memb *next;
620 int n;
621 char buf[32000];
622 };
623 typedef struct Memb memb;
624 memb *mb, *mb1;
625 register char *x, *x0, *xe;
626 register int c, n;
627 FILE *f;
628 char **z, **z0;
629 int nn = 0;
630
631 f = opf(from, textread);
632 mb = (memb *)Alloc(sizeof(memb));
633 mb->next = 0;
634 x0 = x = mb->buf;
635 xe = x + sizeof(mb->buf);
636 n = 0;
637 for(;;) {
638 c = getc(f);
639 if (x >= xe && (c != EOF || x != x0)) {
640 if (!n)
641 return 126;
642 nn += n;
643 mb->n = n;
644 mb1 = (memb *)Alloc(sizeof(memb));
645 mb1->next = mb;
646 mb = mb1;
647 memcpy(mb->buf, x0, n = x-x0);
648 x0 = mb->buf;
649 x = x0 + n;
650 xe = x0 + sizeof(mb->buf);
651 n = 0;
652 }
653 if (c == EOF)
654 break;
655 if (c == '\n') {
656 ++n;
657 *x++ = 0;
658 x0 = x;
659 }
660 else
661 *x++ = c;
662 }
663 clf(&f, from, 1);
664 f = opf(to, textwrite);
665 if (x > x0) { /* shouldn't happen */
666 *x = 0;
667 ++n;
668 }
669 mb->n = n;
670 nn += n;
671 if (!nn) /* shouldn't happen */
672 goto done;
673 z = z0 = (char **)Alloc(nn*sizeof(char *));
674 for(mb1 = mb; mb1; mb1 = mb1->next) {
675 x = mb1->buf;
676 n = mb1->n;
677 for(;;) {
678 *z++ = x;
679 if (--n <= 0)
680 break;
681 while(*x++);
682 }
683 }
684 qsort((char *)z0, nn, sizeof(char *), compare);
685 for(n = nn, z = z0; n > 0; n--)
686 fprintf(f, "%s\n", *z++);
687 free((char *)z0);
688 done:
689 clf(&f, to, 1);
690 do {
691 mb1 = mb->next;
692 free((char *)mb);
693 }
694 while(mb = mb1);
695 return 0;
696 }
697 #endif
698