![[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 / old|
Return to driver.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 / old |
1.1 root 1: char xxxvers[] = "\n@(#) FORTRAN 77 DRIVER, VERSION 2.03.6, 15 FEBRUARY 1987\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: 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++ = "-lsdb";
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: /* doug busted freopen, so let's try with system */
599: return(system(str) >> 8);
600: /* NOTREACHED (pjw) */
601: inname = NULL;
602: outname = NULL;
603: argv[0] = shellname;
604: argc = 1;
605:
606: t = str;
607: while( isspace(*t) )
608: ++t;
609: while(*t)
610: {
611: if(*t == '<')
612: inname = t+1;
613: else if(*t == '>')
614: {
615: if(t[1] == '>')
616: {
617: append = YES;
618: outname = t+2;
619: }
620: else {
621: append = NO;
622: outname = t+1;
623: }
624: }
625: else
626: argv[argc++] = t;
627: while( !isspace(*t) && *t!='\0' )
628: ++t;
629: if(*t)
630: {
631: *t++ = '\0';
632: while( isspace(*t) )
633: ++t;
634: }
635: }
636:
637: if(argc == 1) /* no command */
638: return(-1);
639: argv[argc] = 0;
640:
641: s = path;
642: t = "/usr/bin/";
643: while(*t)
644: *s++ = *t++;
645: for(t = argv[1] ; *s++ = *t++ ; )
646: ;
647: if((waitpid = fork()) == 0)
648: {
649: if(inname)
650: freopen(inname, "r", stdin);
651: if(outname)
652: freopen(outname, (append ? "a" : "w"), stdout);
653: enbint(SIG_DFL);
654:
655: texec(path+9, argv); /* command */
656: texec(path+4, argv); /* /bin/command */
657: texec(path , argv); /* /usr/bin/command */
658:
659: fatalstr("Cannot load %s",path+9);
660: }
661:
662: return( await(waitpid) );
663: }
664:
665:
666:
667:
668:
669: #include "errno.h"
670:
671: /* modified version from the Shell */
672: texec(f, av)
673: char *f;
674: char **av;
675: {
676: extern int errno;
677:
678: execv(f, av+1);
679:
680: if (errno==ENOEXEC)
681: {
682: av[1] = f;
683: execv(shellname, av);
684: fatal("No shell!");
685: }
686: if (errno==ENOMEM)
687: fatalstr("%s: too large", f);
688: }
689:
690:
691:
692:
693:
694:
695: done(k)
696: int k;
697: {
698: static int recurs = NO;
699:
700: if(recurs == NO)
701: {
702: recurs = YES;
703: rmfiles();
704: }
705: exit(k);
706: }
707:
708:
709:
710:
711:
712:
713: enbint(k)
714: int (*k)();
715: {
716: if(sigivalue == 0)
717: signal(SIGINT,k);
718: if(sigqvalue == 0)
719: signal(SIGQUIT,k);
720: if(sighvalue == 0)
721: signal(SIGHUP,k);
722: if(sigtvalue == 0)
723: signal(SIGTERM,k);
724: }
725:
726:
727:
728:
729: intrupt()
730: {
731: done(2);
732: }
733:
734:
735:
736: await(waitpid)
737: int waitpid;
738: {
739: int w, status;
740:
741: enbint(SIG_IGN);
742: while ( (w = wait(&status)) != waitpid)
743: if(w == -1)
744: fatal("bad wait code");
745: enbint(intrupt);
746: if(status & 0377)
747: {
748: if(status != SIGINT)
749: fprintf(diagfile, "Termination code %d", status);
750: done(3);
751: }
752: return(status>>8);
753: }
754:
755: /* File Name and File Manipulation Routines */
756:
757: unreadable(s)
758: register char *s;
759: {
760: register FILE *fp;
761:
762: if(fp = fopen(s, "r"))
763: {
764: fclose(fp);
765: return(NO);
766: }
767:
768: else
769: {
770: fprintf(diagfile, "Error: Cannot read file %s\n", s);
771: return(YES);
772: }
773: }
774:
775:
776:
777: clf(p)
778: FILEP *p;
779: {
780: if(p!=NULL && *p!=NULL && *p!=stdout)
781: {
782: if(ferror(*p))
783: fatal("writing error");
784: fclose(*p);
785: }
786: *p = NULL;
787: }
788:
789: rmfiles()
790: {
791: rmf(textfname);
792: rmf(asmfname);
793: rmf(initfname);
794: rmf(asmpass2);
795: #if TARGET == INTERDATA
796: rmf(setfname);
797: #endif
798: }
799:
800:
801:
802:
803:
804:
805:
806:
807: /* return -1 if file does not exist, 0 if it is of zero length
808: and 1 if of positive length
809: */
810: content(filename)
811: char *filename;
812: {
813: #ifdef VERSION6
814: struct stat
815: {
816: char cjunk[9];
817: char size0;
818: int size1;
819: int ijunk[12];
820: } buf;
821: #else
822: # include <sys/types.h>
823: # include <sys/stat.h>
824: struct stat buf;
825: #endif
826:
827: if(stat(filename,&buf) < 0)
828: return(-1);
829: #ifdef VERSION6
830: return(buf.size0 || buf.size1);
831: #else
832: return( buf.st_size > 0 );
833: #endif
834: }
835:
836:
837:
838:
839: crfnames()
840: {
841: fname(textfname, "x");
842: fname(asmfname, "s");
843: fname(asmpass2, "a");
844: fname(initfname, "d");
845: fname(sortfname, "S");
846: fname(objfdefault, "o");
847: fname(prepfname, "p");
848: fname(optzfname, "z");
849: fname(setfname, "A");
850: }
851:
852:
853:
854:
855: rmf(fn)
856: register char *fn;
857: {
858: if(!debugflag && fn!=NULL && *fn!='\0')
859: unlink(fn);
860: }
861:
862:
863:
864:
865:
866: LOCAL fname(name, suff)
867: char *name, *suff;
868: {
869: sprintf(name, "/tmp/%s%d.%s", temppref, pid, suff);
870: }
871:
872:
873:
874:
875: dotchar(s)
876: register char *s;
877: {
878: for( ; *s ; ++s)
879: if(s[0]=='.' && s[1]!='\0' && s[2]=='\0')
880: return( s[1] );
881: return(NO);
882: }
883:
884:
885:
886: char *lastfield(s)
887: register char *s;
888: {
889: register char *t;
890: for(t = s; *s ; ++s)
891: if(*s == '/')
892: t = s+1;
893: return(t);
894: }
895:
896:
897:
898: char *lastchar(s)
899: register char *s;
900: {
901: while(*s)
902: ++s;
903: return(s-1);
904: }
905:
906: char *setdoto(s)
907: register char *s;
908: {
909: *lastchar(s) = 'o';
910: return( lastfield(s) );
911: }
912:
913:
914:
915: badfile(s)
916: char *s;
917: {
918: fatalstr("cannot open intermediate file %s", s);
919: }
920:
921:
922:
923: ptr ckalloc(n)
924: int n;
925: {
926: ptr p, calloc();
927:
928: if( p = calloc(1, (unsigned) n) )
929: return(p);
930:
931: fatal("out of memory");
932: /* NOTREACHED */
933: }
934:
935:
936:
937:
938:
939: char *copyn(n, s)
940: register int n;
941: register char *s;
942: {
943: register char *p, *q;
944:
945: p = q = (char *) ckalloc(n);
946: while(n-- > 0)
947: *q++ = *s++;
948: return(p);
949: }
950:
951:
952:
953: char *copys(s)
954: char *s;
955: {
956: return( copyn( strlen(s)+1 , s) );
957: }
958:
959:
960:
961:
962:
963: oneof(c,s)
964: register c;
965: register char *s;
966: {
967: while( *s )
968: if(*s++ == c)
969: return(YES);
970: return(NO);
971: }
972:
973:
974:
975: nodup(s)
976: char *s;
977: {
978: register char **p;
979:
980: for(p = loadargs ; p < loadp ; ++p)
981: if( !strcmp(*p, s) )
982: return(NO);
983:
984: return(YES);
985: }
986:
987:
988:
989: static fatal(t)
990: char *t;
991: {
992: fprintf(diagfile, "Compiler error in file %s: %s\n", infname, t);
993: if(debugflag)
994: abort();
995: done(1);
996: exit(1);
997: }
998:
999:
1000:
1001:
1002: static fatali(t,d)
1003: char *t;
1004: int d;
1005: {
1006: char buff[100];
1007: sprintf(buff, t, d);
1008: fatal(buff);
1009: }
1010:
1011:
1012:
1013:
1014: static fatalstr(t, s)
1015: char *t, *s;
1016: {
1017: char buff[100];
1018: sprintf(buff, t, s);
1019: fatal(buff);
1020: }
1021: err(s)
1022: char *s;
1023: {
1024: fprintf(diagfile, "Error in file %s: %s\n", infname, s);
1025: }
1026:
1027: /* Code to generate initializations for DATA statements */
1028:
1029: LOCAL int nch = 0;
1030: LOCAL FILEP asmfile;
1031: LOCAL FILEP sortfile;
1032:
1033: #include "ftypes"
1034:
1035: static ftnint typesize[NTYPES]
1036: = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
1037: 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1};
1038: static int typealign[NTYPES]
1039: = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
1040: ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1};
1041:
1042: dodata()
1043: {
1044: char buff[50];
1045: char varname[XL+1], ovarname[XL+1];
1046: int status;
1047: flag erred;
1048: ftnint offset, vlen, type;
1049: register ftnint ooffset, ovlen;
1050: ftnint nblank, vchar;
1051: int size, align;
1052: int vargroup;
1053: ftnint totlen, doeven();
1054:
1055: erred = NO;
1056: ovarname[0] = '\0';
1057: ooffset = 0;
1058: ovlen = 0;
1059: totlen = 0;
1060: nch = 0;
1061:
1062: sprintf(buff, "sort %s >%s", initfname, sortfname);
1063: if(status = sys(buff))
1064: fatali("call sort status = %d", status);
1065: if( (sortfile = fopen(sortfname, "r")) == NULL)
1066: badfile(sortfname);
1067: if( (asmfile = fopen(asmfname, "a")) == NULL)
1068: badfile(asmfname);
1069: pruse(asmfile, USEINIT);
1070:
1071: while( rdname(&vargroup, varname) && rdlong(&offset) && rdlong(&vlen) && rdlong(&type) )
1072: {
1073: size = typesize[type];
1074: if( strcmp(varname, ovarname) )
1075: {
1076: prspace(ovlen-ooffset);
1077: strcpy(ovarname, varname);
1078: ooffset = 0;
1079: totlen += ovlen;
1080: ovlen = vlen;
1081: if(vargroup == 0)
1082: align = (type==TYCHAR || type==TYBLANK ?
1083: SZLONG : typealign[type]);
1084: else align = ALIDOUBLE;
1085: totlen = doeven(totlen, align);
1086: if(vargroup == 2)
1087: prcomblock(asmfile, varname);
1088: else
1089: fprintf(asmfile, LABELFMT, varname);
1090: }
1091: if(offset < ooffset)
1092: {
1093: erred = YES;
1094: err("overlapping initializations");
1095: ooffset = offset;
1096: }
1097: if(offset > ooffset)
1098: {
1099: prspace(offset-ooffset);
1100: ooffset = offset;
1101: }
1102: if(type == TYCHAR)
1103: {
1104: if( rdlong(&vchar) )
1105: prch( (int) vchar );
1106: else
1107: fatal("bad intermediate file format");
1108: }
1109: else if(type == TYBLANK)
1110: {
1111: if( rdlong(&nblank) )
1112: {
1113: size = nblank;
1114: while( --nblank >= 0)
1115: prch( ' ' );
1116: }
1117: else
1118: fatal("bad intermediate file format");
1119: }
1120: else
1121: {
1122: putc('\t', asmfile);
1123: while ( putc( getc(sortfile), asmfile) != '\n')
1124: ;
1125: }
1126: if( (ooffset += size) > ovlen)
1127: {
1128: erred = YES;
1129: err("initialization out of bounds");
1130: }
1131: }
1132:
1133: prspace(ovlen-ooffset);
1134: totlen = doeven(totlen+ovlen, (ALIDOUBLE>SZLONG ? ALIDOUBLE : SZLONG) );
1135: clf(&sortfile);
1136: clf(&asmfile);
1137: clf(&sortfile);
1138: rmf(sortfname);
1139: return(erred);
1140: }
1141:
1142:
1143:
1144:
1145: prspace(n)
1146: register ftnint n;
1147: {
1148: register ftnint m;
1149:
1150: while(nch>0 && n>0)
1151: {
1152: --n;
1153: prch(0);
1154: }
1155: m = SZSHORT * (n/SZSHORT);
1156: if(m > 0)
1157: prskip(asmfile, m);
1158: for(n -= m ; n>0 ; --n)
1159: prch(0);
1160: }
1161:
1162:
1163:
1164:
1165: ftnint doeven(tot, align)
1166: register ftnint tot;
1167: int align;
1168: {
1169: ftnint new;
1170: new = roundup(tot, align);
1171: prspace(new - tot);
1172: return(new);
1173: }
1174:
1175:
1176:
1177: rdname(vargroupp, name)
1178: int *vargroupp;
1179: register char *name;
1180: {
1181: register int i, c;
1182:
1183: if( (c = getc(sortfile)) == EOF)
1184: return(NO);
1185: *vargroupp = c - '0';
1186:
1187: for(i = 0 ; i<XL ; ++i)
1188: {
1189: if( (c = getc(sortfile)) == EOF)
1190: return(NO);
1191: if(c != ' ')
1192: *name++ = c;
1193: }
1194: *name = '\0';
1195: return(YES);
1196: }
1197:
1198:
1199:
1200: rdlong(n)
1201: register ftnint *n;
1202: {
1203: register int c;
1204:
1205: for(c = getc(sortfile) ; c!=EOF && isspace(c) ; c = getc(sortfile) );
1206: ;
1207: if(c == EOF)
1208: return(NO);
1209:
1210: for(*n = 0 ; isdigit(c) ; c = getc(sortfile) )
1211: *n = 10* (*n) + c - '0';
1212: return(YES);
1213: }
1214:
1215:
1216:
1217:
1218: prch(c)
1219: register int c;
1220: {
1221: static int buff[SZSHORT];
1222:
1223: buff[nch++] = c;
1224: if(nch == SZSHORT)
1225: {
1226: prchars(asmfile, buff);
1227: nch = 0;
1228: }
1229: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.