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