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