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