Commit | Line | Data |
---|---|---|
f1525c23 WH |
1 | /**************************************************************** |
2 | Copyright 1990, 1991, 1992, 1993 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[] = "-lf2c -lm"; /* was "-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 |