Commit | Line | Data |
---|---|---|
0d57d6f5 TL |
1 | char *xxxvers[] = "\n FORTRAN 77 DRIVER, VERSION 1.11, 28 JULY 1978\n"; |
2 | #include <stdio.h> | |
3 | #include <ctype.h> | |
4 | #include "defines" | |
5 | #include "locdefs" | |
6 | #include "drivedefs" | |
7 | #include "ftypes" | |
8 | #include <signal.h> | |
9 | ||
10 | static FILEP diagfile = {stderr} ; | |
11 | static int pid; | |
12 | static int sigivalue = 0; | |
13 | static int sigqvalue = 0; | |
14 | ||
15 | static char *pass1name = PASS1NAME ; | |
16 | static char *pass2name = PASS2NAME ; | |
17 | static char *asmname = ASMNAME ; | |
18 | static char *ldname = LDNAME ; | |
19 | static char *footname = FOOTNAME; | |
20 | static char *proffoot = PROFFOOT; | |
21 | static char *macroname = "m4"; | |
22 | static char *shellname = "/bin/sh"; | |
23 | static char *aoutname = "a.out" ; | |
24 | ||
25 | static char *infname; | |
26 | static char textfname[15]; | |
27 | static char asmfname[15]; | |
28 | static char asmpass2[15]; | |
29 | static char initfname[15]; | |
30 | static char sortfname[15]; | |
31 | static char prepfname[15]; | |
32 | static char objfdefault[15]; | |
33 | static char optzfname[15]; | |
34 | static char setfname[15]; | |
35 | ||
36 | static char fflags[30] = "-"; | |
37 | static char cflags[20] = "-c"; | |
38 | static char eflags[30] = ""; | |
39 | static char rflags[30] = ""; | |
40 | static char lflag[3] = "-x"; | |
41 | static char *fflagp = fflags+1; | |
42 | static char *cflagp = cflags+2; | |
43 | static char *eflagp = eflags; | |
44 | static char *rflagp = rflags; | |
45 | static char **loadargs; | |
46 | static char **loadp; | |
47 | ||
48 | static flag loadflag = YES; | |
49 | static flag saveasmflag = NO; | |
50 | static flag profileflag = NO; | |
51 | static flag optimflag = NO; | |
52 | static flag debugflag = NO; | |
53 | static flag verbose = NO; | |
54 | static flag nofloating = NO; | |
55 | static flag fortonly = NO; | |
56 | static flag macroflag = NO; | |
57 | ||
58 | \f | |
59 | main(argc, argv) | |
60 | int argc; | |
61 | char **argv; | |
62 | { | |
63 | int i, c, status; | |
64 | char *setdoto(), *lastchar(), *lastfield(); | |
65 | ptr ckalloc(); | |
66 | register char *s; | |
67 | char fortfile[20], *t; | |
68 | char buff[100]; | |
69 | int intrupt(); | |
70 | ||
71 | sigivalue = (int) signal(SIGINT, 1) & 01; | |
72 | sigqvalue = (int) signal(SIGQUIT,1) & 01; | |
73 | enbint(intrupt); | |
74 | ||
75 | pid = getpid(); | |
76 | crfnames(); | |
77 | ||
78 | loadargs = (char **) ckalloc( (argc+20) * sizeof(*loadargs) ); | |
79 | loadargs[1] = "-X"; | |
80 | loadargs[2] = "-u"; | |
81 | #if HERE==PDP11 || HERE==VAX | |
82 | loadargs[3] = "_MAIN__"; | |
83 | #endif | |
84 | #if HERE == INTERDATA | |
85 | loadargs[3] = "main"; | |
86 | #endif | |
87 | loadp = loadargs + 4; | |
88 | ||
89 | --argc; | |
90 | ++argv; | |
91 | ||
92 | while(argc>0 && argv[0][0]=='-' && argv[0][1]!='\0') | |
93 | { | |
94 | for(s = argv[0]+1 ; *s ; ++s) switch(*s) | |
95 | { | |
96 | case 'T': /* use special passes */ | |
97 | switch(*++s) | |
98 | { | |
99 | case '1': | |
100 | pass1name = s+1; goto endfor; | |
101 | case '2': | |
102 | pass2name = s+1; goto endfor; | |
103 | case 'a': | |
104 | asmname = s+1; goto endfor; | |
105 | case 'l': | |
106 | ldname = s+1; goto endfor; | |
107 | case 'F': | |
108 | footname = s+1; goto endfor; | |
109 | case 'm': | |
110 | macroname = s+1; goto endfor; | |
111 | default: | |
112 | fatal1("bad option -T%c", *s); | |
113 | } | |
114 | break; | |
115 | ||
116 | case 'w': | |
117 | if(s[1]=='6' && s[2]=='6') | |
118 | { | |
119 | *fflagp++ = *s++; | |
120 | *fflagp++ = *s++; | |
121 | } | |
122 | ||
123 | copyfflag: | |
124 | case 'u': | |
125 | case 'U': | |
126 | case 'M': | |
127 | case '1': | |
128 | case 'C': | |
129 | *fflagp++ = *s; | |
130 | break; | |
131 | ||
132 | case 'O': | |
133 | optimflag = YES; | |
134 | #if TARGET == INTERDATA | |
135 | *loadp++ = "-r"; | |
136 | *loadp++ = "-d"; | |
137 | #endif | |
138 | *fflagp++ = 'O'; | |
139 | if( isdigit(s[1]) ) | |
140 | *fflagp++ = *++s; | |
141 | break; | |
142 | ||
143 | case 'm': | |
144 | if(s[1] == '4') | |
145 | ++s; | |
146 | macroflag = YES; | |
147 | break; | |
148 | ||
149 | case 'S': | |
150 | saveasmflag = YES; | |
151 | ||
152 | case 'c': | |
153 | loadflag = NO; | |
154 | break; | |
155 | ||
156 | case 'v': | |
157 | verbose = YES; | |
158 | break; | |
159 | ||
160 | case 'd': | |
161 | debugflag = YES; | |
162 | goto copyfflag; | |
163 | ||
164 | case 'p': | |
165 | profileflag = YES; | |
166 | *cflagp++ = 'p'; | |
167 | goto copyfflag; | |
168 | ||
169 | case 'o': | |
170 | if( ! strcmp(s, "onetrip") ) | |
171 | { | |
172 | *fflagp++ = '1'; | |
173 | goto endfor; | |
174 | } | |
175 | aoutname = *++argv; | |
176 | --argc; | |
177 | break; | |
178 | ||
179 | #if TARGET == PDP11 | |
180 | case 'f': | |
181 | nofloating = YES; | |
182 | pass2name = NOFLPASS2; | |
183 | break; | |
184 | #endif | |
185 | ||
186 | case 'F': | |
187 | fortonly = YES; | |
188 | loadflag = NO; | |
189 | break; | |
190 | ||
191 | case 'I': | |
192 | if(s[1]=='2' || s[1]=='4' || s[1]=='s') | |
193 | { | |
194 | *fflagp++ = *s++; | |
195 | goto copyfflag; | |
196 | } | |
197 | fprintf(diagfile, "invalid flag -I%c\n", s[1]); | |
198 | done(1); | |
199 | ||
200 | case 'l': /* letter ell--library */ | |
201 | s[-1] = '-'; | |
202 | *loadp++ = s-1; | |
203 | goto endfor; | |
204 | ||
205 | case 'E': /* EFL flag argument */ | |
206 | while( *eflagp++ = *++s) | |
207 | ; | |
208 | *eflagp++ = ' '; | |
209 | goto endfor; | |
210 | case 'R': | |
211 | while( *rflagp++ = *++s ) | |
212 | ; | |
213 | *rflagp++ = ' '; | |
214 | goto endfor; | |
215 | default: | |
216 | lflag[1] = *s; | |
217 | *loadp++ = copys(lflag); | |
218 | break; | |
219 | } | |
220 | endfor: | |
221 | --argc; | |
222 | ++argv; | |
223 | } | |
224 | ||
225 | loadargs[0] = ldname; | |
226 | #if TARGET == PDP11 | |
227 | if(nofloating) | |
228 | *loadp++ = (profileflag ? NOFLPROF : NOFLFOOT); | |
229 | else | |
230 | #endif | |
231 | *loadp++ = (profileflag ? proffoot : footname); | |
232 | ||
233 | for(i = 0 ; i<argc ; ++i) | |
234 | switch(c = dotchar(infname = argv[i]) ) | |
235 | { | |
236 | case 'r': /* Ratfor file */ | |
237 | case 'e': /* EFL file */ | |
238 | if( unreadable(argv[i]) ) | |
239 | break; | |
240 | s = fortfile; | |
241 | t = lastfield(argv[i]); | |
242 | while( *s++ = *t++) | |
243 | ; | |
244 | s[-2] = 'f'; | |
245 | ||
246 | if(macroflag) | |
247 | { | |
248 | if(sys(sprintf(buff, "%s %s >%s", macroname, infname, prepfname) )) | |
249 | { | |
250 | rmf(prepfname); | |
251 | break; | |
252 | } | |
253 | infname = prepfname; | |
254 | } | |
255 | ||
256 | if(c == 'e') | |
257 | sprintf(buff, "efl %s %s >%s", eflags, infname, fortfile); | |
258 | else | |
259 | sprintf(buff, "ratfor %s %s >%s", rflags, infname, fortfile); | |
260 | status = sys(buff); | |
261 | if(macroflag) | |
262 | rmf(infname); | |
263 | if(status) | |
264 | { | |
265 | loadflag = NO; | |
266 | rmf(fortfile); | |
267 | break; | |
268 | } | |
269 | ||
270 | if( ! fortonly ) | |
271 | { | |
272 | infname = argv[i] = lastfield(argv[i]); | |
273 | *lastchar(infname) = 'f'; | |
274 | ||
275 | if( dofort(argv[i]) ) | |
276 | loadflag = NO; | |
277 | else { | |
278 | if( nodup(t = setdoto(argv[i])) ) | |
279 | *loadp++ = t; | |
280 | rmf(fortfile); | |
281 | } | |
282 | } | |
283 | break; | |
284 | ||
285 | case 'f': /* Fortran file */ | |
286 | case 'F': | |
287 | if( unreadable(argv[i]) ) | |
288 | break; | |
289 | if( dofort(argv[i]) ) | |
290 | loadflag = NO; | |
291 | else if( nodup(t=setdoto(argv[i])) ) | |
292 | *loadp++ = t; | |
293 | break; | |
294 | ||
295 | case 'c': /* C file */ | |
296 | case 's': /* Assembler file */ | |
297 | if( unreadable(argv[i]) ) | |
298 | break; | |
299 | #if HERE==PDP11 || HERE==VAX | |
300 | fprintf(diagfile, "%s:\n", argv[i]); | |
301 | #endif | |
302 | sprintf(buff, "cc -c %s", argv[i] ); | |
303 | if( sys(buff) ) | |
304 | loadflag = NO; | |
305 | else | |
306 | if( nodup(t = setdoto(argv[i])) ) | |
307 | *loadp++ = t; | |
308 | break; | |
309 | ||
310 | case 'o': | |
311 | if( nodup(argv[i]) ) | |
312 | *loadp++ = argv[i]; | |
313 | break; | |
314 | ||
315 | default: | |
316 | if( ! strcmp(argv[i], "-o") ) | |
317 | aoutname = argv[++i]; | |
318 | else | |
319 | *loadp++ = argv[i]; | |
320 | break; | |
321 | } | |
322 | ||
323 | if(loadflag) | |
324 | doload(loadargs, loadp); | |
325 | done(0); | |
326 | } | |
327 | \f | |
328 | dofort(s) | |
329 | char *s; | |
330 | { | |
331 | int retcode; | |
332 | char buff[200]; | |
333 | ||
334 | infname = s; | |
335 | sprintf(buff, "%s %s %s %s %s %s", | |
336 | pass1name, fflags, s, asmfname, initfname, textfname); | |
337 | switch( sys(buff) ) | |
338 | { | |
339 | case 1: | |
340 | goto error; | |
341 | case 0: | |
342 | break; | |
343 | default: | |
344 | goto comperror; | |
345 | } | |
346 | ||
347 | if(content(initfname) > 0) | |
348 | if( dodata() ) | |
349 | goto error; | |
350 | if( dopass2() ) | |
351 | goto comperror; | |
352 | doasm(s); | |
353 | retcode = 0; | |
354 | ||
355 | ret: | |
356 | rmf(asmfname); | |
357 | rmf(initfname); | |
358 | rmf(textfname); | |
359 | return(retcode); | |
360 | ||
361 | error: | |
362 | fprintf(diagfile, "\nError. No assembly.\n"); | |
363 | retcode = 1; | |
364 | goto ret; | |
365 | ||
366 | comperror: | |
367 | fprintf(diagfile, "\ncompiler error.\n"); | |
368 | retcode = 2; | |
369 | goto ret; | |
370 | } | |
371 | ||
372 | ||
373 | ||
374 | ||
375 | dopass2() | |
376 | { | |
377 | char buff[100]; | |
378 | ||
379 | if(verbose) | |
380 | fprintf(diagfile, "PASS2."); | |
381 | ||
382 | #if FAMILY==DMR | |
383 | sprintf(buff, "%s %s - %s", pass2name, textfname, asmpass2); | |
384 | return( sys(buff) ); | |
385 | #endif | |
386 | ||
387 | #if FAMILY == SCJ | |
388 | # if TARGET==INTERDATA | |
389 | sprintf(buff, "%s -A%s <%s >%s", pass2name, setfname, textfname, asmpass2); | |
390 | # else | |
391 | sprintf(buff, "%s <%s >%s", pass2name, textfname, asmpass2); | |
392 | # endif | |
393 | return( sys(buff) ); | |
394 | #endif | |
395 | } | |
396 | ||
397 | ||
398 | ||
399 | ||
400 | doasm(s) | |
401 | char *s; | |
402 | { | |
403 | register char *lastc; | |
404 | char *obj; | |
405 | char buff[200]; | |
406 | ||
407 | if(*s == '\0') | |
408 | s = objfdefault; | |
409 | lastc = lastchar(s); | |
410 | obj = setdoto(s); | |
411 | ||
412 | #if TARGET==PDP11 || TARGET==VAX | |
413 | #ifdef PASS2OPT | |
414 | if(optimflag) | |
415 | { | |
416 | if( sys(sprintf(buff, "%s %s %s", PASS2OPT, asmpass2, optzfname)) ) | |
417 | rmf(optzfname); | |
418 | else | |
419 | sys(sprintf(buff,"mv %s %s", optzfname, asmpass2)); | |
420 | } | |
421 | #endif | |
422 | #endif | |
423 | ||
424 | if(saveasmflag) | |
425 | { | |
426 | *lastc = 's'; | |
427 | #if TARGET == INTERDATA | |
428 | sys( sprintf(buff, "cat %s %s %s >%s", | |
429 | asmfname, setfname, asmpass2, obj) ); | |
430 | #else | |
431 | sys( sprintf(buff, "cat %s %s >%s", | |
432 | asmfname, asmpass2, obj) ); | |
433 | #endif | |
434 | *lastc = 'o'; | |
435 | } | |
436 | else | |
437 | { | |
438 | if(verbose) | |
439 | fprintf(diagfile, " ASM."); | |
440 | #if TARGET == INTERDATA | |
441 | sprintf(buff, "%s -o %s %s %s %s", asmname, obj, asmfname, setfname, asmpass2); | |
442 | #endif | |
443 | ||
444 | #if TARGET == VAX | |
445 | /* vax assembler currently accepts only one input file */ | |
446 | sys(sprintf(buff, "cat %s >>%s", asmpass2, asmfname)); | |
447 | sprintf(buff, "%s -o %s %s", asmname, obj, asmfname); | |
448 | #endif | |
449 | ||
450 | #if TARGET == PDP11 | |
451 | sprintf(buff, "%s -u -o %s %s %s", asmname, obj, asmfname, asmpass2); | |
452 | #endif | |
453 | ||
454 | #if TARGET!=INTERDATA && TARGET!=PDP11 && TARGET!=VAX | |
455 | sprintf(buff, "%s -o %s %s %s", asmname, obj, asmfname, asmpass2); | |
456 | #endif | |
457 | ||
458 | if( sys(buff) ) | |
459 | fatal("assembler error"); | |
460 | if(verbose) | |
461 | fprintf(diagfile, "\n"); | |
462 | #if HERE==PDP11 && TARGET!=PDP11 | |
463 | rmf(obj); | |
464 | #endif | |
465 | } | |
466 | ||
467 | rmf(asmpass2); | |
468 | } | |
469 | ||
470 | ||
471 | ||
472 | doload(v0, v) | |
473 | register char *v0[], *v[]; | |
474 | { | |
475 | char **p; | |
476 | int waitpid; | |
477 | ||
478 | for(p = liblist ; *p ; *v++ = *p++) | |
479 | ; | |
480 | ||
481 | *v++ = "-o"; | |
482 | *v++ = aoutname; | |
483 | *v = NULL; | |
484 | ||
485 | if(verbose) | |
486 | fprintf(diagfile, "LOAD."); | |
487 | if(debugflag) | |
488 | { | |
489 | for(p = v0 ; p<v ; ++p) | |
490 | fprintf(diagfile, "%s ", *p); | |
491 | fprintf(diagfile, "\n"); | |
492 | } | |
493 | ||
494 | #if HERE==PDP11 || HERE==INTERDATA || HERE==VAX | |
495 | if( (waitpid = fork()) == 0) | |
496 | { | |
497 | enbint(SIG_DFL); | |
498 | execv(ldname, v0); | |
499 | fatal1("couldn't load %s", ldname); | |
500 | } | |
501 | await(waitpid); | |
502 | #endif | |
503 | ||
504 | #if HERE==INTERDATA | |
505 | if(optimflag) | |
506 | { | |
507 | char buff[100]; | |
508 | if( sys(sprintf(buff, "nopt %s -o junk.%d", aoutname, pid)) | |
509 | || sys(sprintf(buff, "mv junk.%d %s", pid, aoutname)) ) | |
510 | err("bad optimization"); | |
511 | } | |
512 | #endif | |
513 | ||
514 | if(verbose) | |
515 | fprintf(diagfile, "\n"); | |
516 | } | |
517 | \f | |
518 | /* Process control and Shell-simulating routines */ | |
519 | ||
520 | sys(str) | |
521 | char *str; | |
522 | { | |
523 | register char *s, *t; | |
524 | char *argv[100], path[100]; | |
525 | char *inname, *outname; | |
526 | int append; | |
527 | int waitpid; | |
528 | int argc; | |
529 | ||
530 | ||
531 | if(debugflag) | |
532 | fprintf(diagfile, "%s\n", str); | |
533 | inname = NULL; | |
534 | outname = NULL; | |
535 | argv[0] = shellname; | |
536 | argc = 1; | |
537 | ||
538 | t = str; | |
539 | while( isspace(*t) ) | |
540 | ++t; | |
541 | while(*t) | |
542 | { | |
543 | if(*t == '<') | |
544 | inname = t+1; | |
545 | else if(*t == '>') | |
546 | { | |
547 | if(t[1] == '>') | |
548 | { | |
549 | append = YES; | |
550 | outname = t+2; | |
551 | } | |
552 | else { | |
553 | append = NO; | |
554 | outname = t+1; | |
555 | } | |
556 | } | |
557 | else | |
558 | argv[argc++] = t; | |
559 | while( !isspace(*t) && *t!='\0' ) | |
560 | ++t; | |
561 | if(*t) | |
562 | { | |
563 | *t++ = '\0'; | |
564 | while( isspace(*t) ) | |
565 | ++t; | |
566 | } | |
567 | } | |
568 | ||
569 | if(argc == 1) /* no command */ | |
570 | return(-1); | |
571 | argv[argc] = 0; | |
572 | ||
573 | s = path; | |
574 | t = "/usr/bin/"; | |
575 | while(*t) | |
576 | *s++ = *t++; | |
577 | for(t = argv[1] ; *s++ = *t++ ; ) | |
578 | ; | |
579 | if((waitpid = fork()) == 0) | |
580 | { | |
581 | if(inname) | |
582 | freopen(inname, "r", stdin); | |
583 | if(outname) | |
584 | freopen(outname, (append ? "a" : "w"), stdout); | |
585 | enbint(SIG_DFL); | |
586 | ||
587 | texec(path+9, argv); /* command */ | |
588 | texec(path+4, argv); /* /bin/command */ | |
589 | texec(path , argv); /* /usr/bin/command */ | |
590 | ||
591 | fatal1("Cannot load %s",path+9); | |
592 | } | |
593 | ||
594 | return( await(waitpid) ); | |
595 | } | |
596 | ||
597 | ||
598 | ||
599 | ||
600 | ||
601 | #include <errno.h> | |
602 | ||
603 | /* modified version from the Shell */ | |
604 | texec(f, av) | |
605 | char *f; | |
606 | char **av; | |
607 | { | |
608 | extern int errno; | |
609 | ||
610 | execv(f, av+1); | |
611 | ||
612 | if (errno==ENOEXEC) | |
613 | { | |
614 | av[1] = f; | |
615 | execv(shellname, av); | |
616 | fatal("No shell!"); | |
617 | } | |
618 | if (errno==ENOMEM) | |
619 | fatal1("%s: too large", f); | |
620 | } | |
621 | ||
622 | ||
623 | ||
624 | ||
625 | ||
626 | ||
627 | done(k) | |
628 | int k; | |
629 | { | |
630 | static int recurs = NO; | |
631 | ||
632 | if(recurs == NO) | |
633 | { | |
634 | recurs = YES; | |
635 | rmfiles(); | |
636 | } | |
637 | exit(k); | |
638 | } | |
639 | ||
640 | ||
641 | ||
642 | ||
643 | ||
644 | ||
645 | enbint(k) | |
646 | int (*k)(); | |
647 | { | |
648 | if(sigivalue == 0) | |
649 | signal(SIGINT,k); | |
650 | if(sigqvalue == 0) | |
651 | signal(SIGQUIT,k); | |
652 | } | |
653 | ||
654 | ||
655 | ||
656 | ||
657 | intrupt() | |
658 | { | |
659 | done(2); | |
660 | } | |
661 | ||
662 | ||
663 | ||
664 | await(waitpid) | |
665 | int waitpid; | |
666 | { | |
667 | int w, status; | |
668 | ||
669 | enbint(SIG_IGN); | |
670 | while ( (w = wait(&status)) != waitpid) | |
671 | if(w == -1) | |
672 | fatal("bad wait code"); | |
673 | enbint(intrupt); | |
674 | if(status & 0377) | |
675 | { | |
676 | if(status != SIGINT) | |
677 | fprintf(diagfile, "Termination code %d", status); | |
678 | done(3); | |
679 | } | |
680 | return(status>>8); | |
681 | } | |
682 | \f | |
683 | /* File Name and File Manipulation Routines */ | |
684 | ||
685 | unreadable(s) | |
686 | register char *s; | |
687 | { | |
688 | register FILE *fp; | |
689 | ||
690 | if(fp = fopen(s, "r")) | |
691 | { | |
692 | fclose(fp); | |
693 | return(NO); | |
694 | } | |
695 | ||
696 | else | |
697 | { | |
698 | fprintf(diagfile, "Error: Cannot read file %s\n", s); | |
699 | loadflag = NO; | |
700 | return(YES); | |
701 | } | |
702 | } | |
703 | ||
704 | ||
705 | ||
706 | clf(p) | |
707 | FILEP *p; | |
708 | { | |
709 | if(p!=NULL && *p!=NULL && *p!=stdout) | |
710 | { | |
711 | if(ferror(*p)) | |
712 | fatal("writing error"); | |
713 | fclose(*p); | |
714 | } | |
715 | *p = NULL; | |
716 | } | |
717 | ||
718 | rmfiles() | |
719 | { | |
720 | rmf(textfname); | |
721 | rmf(asmfname); | |
722 | rmf(initfname); | |
723 | rmf(asmpass2); | |
724 | #if TARGET == INTERDATA | |
725 | rmf(setfname); | |
726 | #endif | |
727 | } | |
728 | ||
729 | ||
730 | ||
731 | ||
732 | ||
733 | ||
734 | ||
735 | ||
736 | /* return -1 if file does not exist, 0 if it is of zero length | |
737 | and 1 if of positive length | |
738 | */ | |
739 | content(filename) | |
740 | char *filename; | |
741 | { | |
742 | #include <sys/types.h> | |
743 | #include <sys/stat.h> | |
744 | struct stat buf; | |
745 | if(stat(filename,&buf) < 0) | |
746 | return(-1); | |
747 | else | |
748 | return( buf.st_size > 0 ); | |
749 | } | |
750 | ||
751 | ||
752 | ||
753 | ||
754 | crfnames() | |
755 | { | |
756 | fname(textfname, "x"); | |
757 | fname(asmfname, "s"); | |
758 | fname(asmpass2, "a"); | |
759 | fname(initfname, "d"); | |
760 | fname(sortfname, "S"); | |
761 | fname(objfdefault, "o"); | |
762 | fname(prepfname, "p"); | |
763 | fname(optzfname, "z"); | |
764 | fname(setfname, "A"); | |
765 | } | |
766 | ||
767 | ||
768 | ||
769 | ||
770 | rmf(fn) | |
771 | register char *fn; | |
772 | { | |
773 | if(!debugflag && fn!=NULL && *fn!='\0') | |
774 | unlink(fn); | |
775 | } | |
776 | ||
777 | ||
778 | ||
779 | ||
780 | ||
781 | LOCAL fname(name, suff) | |
782 | char *name, *suff; | |
783 | { | |
784 | sprintf(name, "fort%d.%s", pid, suff); | |
785 | } | |
786 | ||
787 | ||
788 | ||
789 | ||
790 | dotchar(s) | |
791 | register char *s; | |
792 | { | |
793 | for( ; *s ; ++s) | |
794 | if(s[0]=='.' && s[1]!='\0' && s[2]=='\0') | |
795 | return( s[1] ); | |
796 | return(NO); | |
797 | } | |
798 | ||
799 | ||
800 | ||
801 | char *lastfield(s) | |
802 | register char *s; | |
803 | { | |
804 | register char *t; | |
805 | for(t = s; *s ; ++s) | |
806 | if(*s == '/') | |
807 | t = s+1; | |
808 | return(t); | |
809 | } | |
810 | ||
811 | ||
812 | ||
813 | char *lastchar(s) | |
814 | register char *s; | |
815 | { | |
816 | while(*s) | |
817 | ++s; | |
818 | return(s-1); | |
819 | } | |
820 | ||
821 | char *setdoto(s) | |
822 | register char *s; | |
823 | { | |
824 | *lastchar(s) = 'o'; | |
825 | return( lastfield(s) ); | |
826 | } | |
827 | ||
828 | ||
829 | ||
830 | badfile(s) | |
831 | char *s; | |
832 | { | |
833 | fatal1("cannot open intermediate file %s", s); | |
834 | } | |
835 | ||
836 | ||
837 | ||
838 | ptr ckalloc(n) | |
839 | int n; | |
840 | { | |
841 | ptr p, calloc(); | |
842 | ||
843 | if( p = calloc(1, (unsigned) n) ) | |
844 | return(p); | |
845 | ||
846 | fatal("out of memory"); | |
847 | /* NOTREACHED */ | |
848 | } | |
849 | ||
850 | ||
851 | ||
852 | ||
853 | ||
854 | copyn(n, s) | |
855 | register int n; | |
856 | register char *s; | |
857 | { | |
858 | register char *p, *q; | |
859 | ||
860 | p = q = (char *) ckalloc(n); | |
861 | while(n-- > 0) | |
862 | *q++ = *s++; | |
863 | return(p); | |
864 | } | |
865 | ||
866 | ||
867 | ||
868 | copys(s) | |
869 | char *s; | |
870 | { | |
871 | return( copyn( strlen(s)+1 , s) ); | |
872 | } | |
873 | ||
874 | ||
875 | ||
876 | ||
877 | ||
878 | nodup(s) | |
879 | char *s; | |
880 | { | |
881 | register char **p; | |
882 | ||
883 | for(p = loadargs ; p < loadp ; ++p) | |
884 | if( !strcmp(*p, s) ) | |
885 | return(NO); | |
886 | ||
887 | return(YES); | |
888 | } | |
889 | ||
890 | ||
891 | ||
892 | static fatal(t) | |
893 | char *t; | |
894 | { | |
895 | fprintf(diagfile, "Compiler error in file %s: %s\n", infname, t); | |
896 | if(debugflag) | |
897 | abort(); | |
898 | done(1); | |
899 | exit(1); | |
900 | } | |
901 | ||
902 | ||
903 | ||
904 | ||
905 | static fatal1(t,d) | |
906 | char *t, *d; | |
907 | { | |
908 | char buff[100]; | |
909 | fatal( sprintf(buff, t, d) ); | |
910 | } | |
911 | ||
912 | ||
913 | ||
914 | ||
915 | err(s) | |
916 | char *s; | |
917 | { | |
918 | fprintf(diagfile, "Error in file %s: %s\n", infname, s); | |
919 | } | |
920 | \f | |
921 | LOCAL int nch = 0; | |
922 | LOCAL FILEP asmfile; | |
923 | LOCAL FILEP sortfile; | |
924 | ||
925 | #include "ftypes" | |
926 | ||
927 | static ftnint typesize[NTYPES] | |
928 | = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG, | |
929 | 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1}; | |
930 | static int typealign[NTYPES] | |
931 | = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE, | |
932 | ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1}; | |
933 | ||
934 | dodata() | |
935 | { | |
936 | char buff[50]; | |
937 | char varname[XL+1], ovarname[XL+1]; | |
938 | int status; | |
939 | flag erred; | |
940 | ftnint offset, vlen, type; | |
941 | register ftnint ooffset, ovlen; | |
942 | ftnint vchar; | |
943 | int size, align; | |
944 | int vargroup; | |
945 | ftnint totlen, doeven(); | |
946 | ||
947 | erred = NO; | |
948 | ovarname[0] = '\0'; | |
949 | ooffset = 0; | |
950 | ovlen = 0; | |
951 | totlen = 0; | |
952 | nch = 0; | |
953 | ||
954 | if(status = sys( sprintf(buff, "sort %s >%s", initfname, sortfname) ) ) | |
955 | fatal1("call sort status = %d", status); | |
956 | if( (sortfile = fopen(sortfname, "r")) == NULL) | |
957 | badfile(sortfname); | |
958 | if( (asmfile = fopen(asmfname, "a")) == NULL) | |
959 | badfile(asmfname); | |
960 | pruse(asmfile, USEINIT); | |
961 | ||
962 | while( rdname(&vargroup, varname) && rdlong(&offset) && rdlong(&vlen) && rdlong(&type) ) | |
963 | { | |
964 | size = typesize[type]; | |
965 | if( strcmp(varname, ovarname) ) | |
966 | { | |
967 | prspace(ovlen-ooffset); | |
968 | strcpy(ovarname, varname); | |
969 | ooffset = 0; | |
970 | totlen += ovlen; | |
971 | ovlen = vlen; | |
972 | if(vargroup == 0) | |
973 | align = (type==TYCHAR ? SZLONG : typealign[type]); | |
974 | else align = ALIDOUBLE; | |
975 | totlen = doeven(totlen, align); | |
976 | if(vargroup == 2) | |
977 | prcomblock(asmfile, varname); | |
978 | else | |
979 | fprintf(asmfile, LABELFMT, varname); | |
980 | } | |
981 | if(offset < ooffset) | |
982 | { | |
983 | erred = YES; | |
984 | err("overlapping initializations"); | |
985 | } | |
986 | if(offset > ooffset) | |
987 | { | |
988 | prspace(offset-ooffset); | |
989 | ooffset = offset; | |
990 | } | |
991 | if(type == TYCHAR) | |
992 | { | |
993 | if( ! rdlong(&vchar) ) | |
994 | fatal("bad intermediate file format"); | |
995 | prch( (int) vchar ); | |
996 | } | |
997 | else | |
998 | { | |
999 | putc('\t', asmfile); | |
1000 | while ( putc( getc(sortfile), asmfile) != '\n') | |
1001 | ; | |
1002 | } | |
1003 | if( (ooffset += size) > ovlen) | |
1004 | { | |
1005 | erred = YES; | |
1006 | err("initialization out of bounds"); | |
1007 | } | |
1008 | } | |
1009 | ||
1010 | prspace(ovlen-ooffset); | |
1011 | totlen = doeven(totlen+ovlen, (ALIDOUBLE>SZLONG ? ALIDOUBLE : SZLONG) ); | |
1012 | clf(&sortfile); | |
1013 | clf(&asmfile); | |
1014 | clf(&sortfile); | |
1015 | rmf(sortfname); | |
1016 | return(erred); | |
1017 | } | |
1018 | ||
1019 | ||
1020 | ||
1021 | ||
1022 | prspace(n) | |
1023 | register ftnint n; | |
1024 | { | |
1025 | register ftnint m; | |
1026 | ||
1027 | while(nch>0 && n>0) | |
1028 | { | |
1029 | --n; | |
1030 | prch(0); | |
1031 | } | |
1032 | m = SZSHORT * (n/SZSHORT); | |
1033 | if(m > 0) | |
1034 | prskip(asmfile, m); | |
1035 | for(n -= m ; n>0 ; --n) | |
1036 | prch(0); | |
1037 | } | |
1038 | ||
1039 | ||
1040 | ||
1041 | ||
1042 | ftnint doeven(tot, align) | |
1043 | register ftnint tot; | |
1044 | int align; | |
1045 | { | |
1046 | ftnint new; | |
1047 | new = roundup(tot, align); | |
1048 | prspace(new - tot); | |
1049 | return(new); | |
1050 | } | |
1051 | ||
1052 | ||
1053 | ||
1054 | rdname(vargroupp, name) | |
1055 | int *vargroupp; | |
1056 | register char *name; | |
1057 | { | |
1058 | register int i, c; | |
1059 | ||
1060 | if( (c = getc(sortfile)) == EOF) | |
1061 | return(NO); | |
1062 | *vargroupp = c - '0'; | |
1063 | ||
1064 | for(i = 0 ; i<XL ; ++i) | |
1065 | { | |
1066 | if( (c = getc(sortfile)) == EOF) | |
1067 | return(NO); | |
1068 | if(c != ' ') | |
1069 | *name++ = c; | |
1070 | } | |
1071 | *name = '\0'; | |
1072 | return(YES); | |
1073 | } | |
1074 | ||
1075 | ||
1076 | ||
1077 | rdlong(n) | |
1078 | register ftnint *n; | |
1079 | { | |
1080 | register int c; | |
1081 | ||
1082 | for(c = getc(sortfile) ; c!=EOF && isspace(c) ; c = getc(sortfile) ); | |
1083 | ; | |
1084 | if(c == EOF) | |
1085 | return(NO); | |
1086 | ||
1087 | for(*n = 0 ; isdigit(c) ; c = getc(sortfile) ) | |
1088 | *n = 10* (*n) + c - '0'; | |
1089 | return(YES); | |
1090 | } | |
1091 | ||
1092 | ||
1093 | ||
1094 | ||
1095 | prch(c) | |
1096 | register int c; | |
1097 | { | |
1098 | static int buff[SZSHORT]; | |
1099 | ||
1100 | buff[nch++] = c; | |
1101 | if(nch == SZSHORT) | |
1102 | { | |
1103 | prchars(asmfile, buff); | |
1104 | nch = 0; | |
1105 | } | |
1106 | } |