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