![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to main.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / efl|
Return to main.c CVS log | Up to [Research Unix] / researchv10no / cmd / efl |
1.1 root 1: static char xxxvers[ ] = "\n@(#)EFL VERSION 1.15, 19 DECEMBER 1980";
2:
3: /* Compiler for the EFL Programming Language. Written by:
4: Stuart I. Feldman
5: Bell Laboratories
6: Murray Hill, New Jersey
7: */
8:
9:
10: /* Flags:
11: -d EFL debugging output
12: -v verbose (print out Pass numbers and memory limits)
13: -w supress warning messages
14: -f put Fortran output on appropriate .f files
15: -F put Fortran code for input file x onto x.F
16: -e divert diagnostic output to next argument
17: -# do not pass comments through to output
18: */
19:
20:
21: #include "defs"
22:
23: int sysflag;
24:
25: int nerrs = 0;
26: int nbad = 0;
27: int nwarns = 0;
28: int stnos[MAXSTNO];
29: int nxtstno = 0;
30: int constno = 0;
31: int labno = 0;
32:
33: int dumpic = NO;
34: int memdump = NO;
35: int dbgflag = NO;
36: int nowarnflag = NO;
37: int nocommentflag = NO;
38: int verbose = NO;
39: int dumpcore = NO;
40: char msg[200];
41:
42: struct fileblock fcb[4];
43: struct fileblock *iifilep;
44: struct fileblock *ibfile = &fcb[0];
45: struct fileblock *icfile = &fcb[1];
46: struct fileblock *idfile = &fcb[2];
47: struct fileblock *iefile = &fcb[3];
48:
49: FILE *diagfile = {stderr};
50: FILE *codefile = {stdout};
51: FILE *fileptrs[MAXINCLUDEDEPTH];
52: char *filenames[MAXINCLUDEDEPTH];
53: char *basefile;
54: int filelines[MAXINCLUDEDEPTH];
55: int filedepth = 0;
56: char *efmacp = NULL;
57: char *filemacs[MAXINCLUDEDEPTH];
58: int pushchars[MAXINCLUDEDEPTH];
59: int ateof = NO;
60:
61: int igeol = NO;
62: int pushlex = NO;
63: int eofneed = NO;
64: int forcerr = NO;
65: int defneed = NO;
66: int prevbg = NO;
67: int comneed = NO;
68: int optneed = NO;
69: int lettneed = NO;
70: int iobrlevel = 0;
71:
72: ptr comments = NULL;
73: ptr prevcomments = NULL;
74: ptr genequivs = NULL;
75: ptr arrays = NULL;
76: ptr generlist = NULL;
77: ptr knownlist = NULL;
78:
79: ptr thisexec;
80: ptr thisctl;
81: chainp tempvarlist = CHNULL;
82: chainp temptypelist = CHNULL;
83: chainp hidlist = CHNULL;
84: chainp commonlist = CHNULL;
85: chainp gonelist = CHNULL;
86: int blklevel = 0;
87: int ctllevel = 0;
88: int dclsect = 0;
89: int instruct = 0;
90: int inbound = 0;
91: int inproc = 0;
92: int ncases = 0;
93:
94: int graal = 0;
95: ptr procname = NULL;
96: int procclass = 0;
97: ptr thisargs = NULL;
98:
99: int nhid[MAXBLOCKDEPTH];
100: int ndecl[MAXBLOCKDEPTH];
101:
102: char ftnames[MAXFTNAMES][7];
103:
104:
105: int neflnames = 0;
106:
107: int nftnames;
108: int nftnm0;
109: int impltype[26];
110:
111: int ftnefl[NFTNTYPES] = { TYINT, TYREAL, TYLOG, TYCOMPLEX, TYLREAL,
112: TYCHAR, TYLCOMPLEX };
113: int eflftn[NEFLTYPES];
114: int ftnmask[NFTNTYPES] = { 1, 2, 4, 8, 16, 32, 64 };
115: struct tailoring tailor;
116: struct system systab[] =
117: {
118: { "portable", 0, 1, 10, 7, 15},
119: { "unix", UNIX, 4, 10, 7, 15 },
120: { "gcos", GCOS, 4, 10, 7, 15 },
121: { "gcosbcd", GCOSBCD, 6, 10, 7, 15},
122: { "cray", CRAY, 8, 10, 7, 15},
123: { "ibm", IBM, 4, 10, 7, 15 },
124: { NULL }
125: };
126:
127: double fieldmax = FIELDMAX;
128:
129: int langopt = 2;
130: int dotsopt = 0;
131: int dbgopt = 0;
132: int dbglevel = 0;
133:
134: int nftnch;
135: int nftncont;
136: int indifs[MAXINDIFS];
137: int nxtindif;
138: int afterif = 0;
139:
140: #ifdef gcos
141: # define BIT(n) (1 << (36 - 1 - n) )
142: # define FORTRAN BIT(1)
143: # define FDS BIT(4)
144: # define EXEC BIT(5)
145: # define FORM BIT(14)
146: # define LNO BIT(15)
147: # define BCD BIT(16)
148: # define OPTZ BIT(17)
149: int compile = FORTRAN | FDS;
150: #endif
151:
152:
153: main(argc,argv)
154: register int argc;
155: register char **argv;
156: {
157: FILE *fd;
158: register char *p;
159: int neflnm0;
160:
161: #ifdef unix
162: int intrupt();
163: static char errbuf[BUFSIZ];
164:
165: setbuf(stderr, errbuf);
166:
167: sysflag = UNIX;
168:
169: /*
170: meter();
171: */
172: if( (signal(2,1) & 01) == 0)
173: signal(2, intrupt);
174: #endif
175:
176: #ifdef gcos
177: /*
178: meter();
179: */
180: sysflag = (intss() ? GCOS : GCOSBCD);
181: #endif
182:
183:
184: crii();
185: --argc;
186: ++argv;
187: tailinit(systab + sysflag);
188:
189: while(argc>0 && ( (argv[0][0]=='-' && argv[0][1]!='\0') || eqlstrng(argv[0]) ))
190: {
191: if(argv[0][0] == '-')
192: for(p = argv[0]+1 ; *p ; ++p) switch(*p)
193: {
194: case ' ':
195: break;
196:
197: case 'd':
198: case 'D':
199: switch( *++p)
200: {
201: case '1':
202: dbgflag = YES;
203: break;
204: case '2':
205: setyydeb();
206: break;
207: case '3':
208: dumpcore = YES;
209: break;
210: case '4':
211: dumpic = YES;
212: break;
213: case 'm':
214: case 'M':
215: memdump = YES;
216: break;
217:
218: default:
219: dbgflag = YES;
220: --p;
221: break;
222: }
223: break;
224:
225: case 'w':
226: case 'W':
227: nowarnflag = YES;
228: break;
229:
230: case 'v':
231: case 'V':
232: verbose = YES;
233: break;
234:
235: case '#':
236: nocommentflag = YES;
237: break;
238:
239: case 'C':
240: case 'c':
241: nocommentflag = NO;
242: break;
243:
244: #ifdef gcos
245: case 'O':
246: case 'o':
247: compile |= OPTZ;
248: break;
249:
250: case 'E':
251: case 'e':
252: compile = 0;
253: break;
254: #endif
255:
256: default:
257: fprintf(diagfile, "Illegal EFL flag %c\n", *p);
258: exit(1);
259: }
260: --argc;
261: ++argv;
262: }
263:
264: kwinit();
265: geninit();
266: knowninit();
267: init();
268: implinit();
269: neflnm0 = neflnames;
270:
271: #ifdef gcos
272: if( intss() )
273: compile = 0;
274: else
275: gcoutf();
276: #endif
277:
278: /* fprintf(diagfile, "EFL 1.10\n"); */
279:
280: if(argc==0)
281: {
282: filenames[0] = "-";
283: dofile(stdin);
284: }
285: else
286: while(argc>0)
287: {
288: if( eqlstrng(argv[0]) )
289: {
290: --argc;
291: ++argv;
292: continue;
293: }
294: if(argv[0][0]=='-' && argv[0][1]=='\0')
295: {
296: basefile = "";
297: fd = stdin;
298: }
299: else {
300: basefile = argv[0];
301: fd = fopen(argv[0], "r");
302: }
303: if(fd == NULL)
304: {
305: sprintf(msg, "Cannot open file %s", argv[0]);
306: fprintf(diagfile, "%s. Stop\n", msg);
307: done(2);
308: }
309: filenames[0] = argv[0];
310: filedepth = 0;
311:
312: nftnames = 0;
313: nftnm0 = 0;
314: neflnames = neflnm0;
315:
316: dofile(fd);
317: if(fd != stdin)
318: fclose(fd);
319: --argc;
320: ++argv;
321: }
322: p2flush();
323: if(verbose)
324: fprintf(diagfile, "End of compilation\n");
325: /*
326: prhisto();
327: /* */
328: rmiis();
329:
330: #ifdef gcos
331: gccomp();
332: #endif
333:
334: done(nbad);
335: }
336:
337:
338: dofile(fd)
339: FILE *fd;
340: {
341: int k;
342:
343: fprintf(diagfile, "File %s:\n", filenames[0]);
344:
345: #ifdef gcos
346: if( fd==stdin && intss() && inquire(stdin, _TTY) )
347: freopen("*src", "rt", stdin);
348: #endif
349:
350: yyin = fileptrs[0] = fd;
351: yylineno = filelines[0] = 1;
352: filedepth = 0;
353: ateof = 0;
354:
355: do {
356: nerrs = 0;
357: nwarns = 0;
358: eofneed = 0;
359: forcerr = 0;
360: comneed = 0;
361: optneed = 0;
362: defneed = 0;
363: lettneed = 0;
364: iobrlevel = 0;
365: prevbg = 0;
366:
367: constno = 0;
368: labno = 0;
369: nxtstno = 0;
370: afterif = 0;
371: thisexec = 0;
372: thisctl = 0;
373: nxtindif = 0;
374: inproc = 0;
375: blklevel = 0;
376:
377: implinit();
378:
379: opiis();
380: swii(icfile);
381:
382: if(k = yyparse())
383: fprintf(diagfile, "Error in source file.\n");
384: else switch(graal)
385: {
386: case PARSERR:
387: /*
388: fprintf(diagfile, "error\n");
389: */
390: break;
391:
392: case PARSEOF:
393: break;
394:
395: case PARSOPT:
396: propts();
397: break;
398:
399: case PARSDCL:
400: fprintf(diagfile, "external declaration\n");
401: break;
402:
403: case PARSPROC:
404: /* work already done in endproc */
405: break;
406:
407: case PARSDEF:
408: break;
409: }
410:
411: cliis();
412: if(nerrs) ++nbad;
413:
414: } while(graal!=PARSEOF && !ateof);
415: }
416:
417: ptr bgnproc()
418: {
419: ptr bgnexec();
420:
421: if(blklevel > 0)
422: {
423: execerr("procedure %s terminated prematurely", procnm() );
424: endproc();
425: }
426: ctllevel = 0;
427: procname = 0;
428: procclass = 0;
429: thisargs = 0;
430: dclsect = 0;
431: blklevel = 1;
432: nftnm0 = nftnames;
433: dclsect = 1;
434: ndecl[1] = 0;
435: nhid[1] = 0;
436:
437: thisctl = allexcblock();
438: thisctl->tag = TCONTROL;
439: thisctl->subtype = STPROC;
440: inproc = 1;
441: return( bgnexec() );
442: }
443:
444:
445: endproc()
446: {
447: char comline[50], *concat();
448: ptr p;
449:
450: inproc = 0;
451:
452: if(nerrs == 0)
453: {
454: pass2();
455: unhide();
456: cleanst();
457: if(dumpic)
458: system( concat("od ", icfile->filename, comline) );
459: if(memdump)
460: prmem();
461: }
462: else {
463: fprintf(diagfile, "**Procedure %s not generated\n", procnm());
464: for( ; blklevel > 0 ; --blklevel)
465: unhide();
466: cleanst();
467: }
468:
469: if(nerrs==0 && nwarns>0)
470: if(nwarns == 1)
471: fprintf(diagfile,"*1 warning\n");
472: else fprintf(diagfile, "*%d warnings\n", nwarns);
473:
474: blklevel = 0;
475: thisargs = 0;
476: procname = 0;
477: procclass = 0;
478: while(thisctl)
479: {
480: p = thisctl;
481: thisctl = thisctl->prevctl;
482: frexcblock(p);
483: }
484:
485: while(thisexec)
486: {
487: p = thisexec;
488: thisexec = thisexec->prevexec;
489: frexcblock(p);
490: }
491:
492: nftnames = nftnm0;
493: #if SIF_ALLOC
494: if(verbose)
495: {
496: fprintf(diagfile, "Highwater mark %d words. ", nmemused);
497: fprintf(diagfile, "%ld words left over\n", totalloc-totfreed);
498: }
499: #endif
500: }
501:
502:
503:
504:
505: implinit()
506: {
507: setimpl(TYREAL, 'a', 'z');
508: setimpl(TYINT, 'i', 'n');
509: }
510:
511:
512:
513: init()
514: {
515: eflftn[TYINT] = FTNINT;
516: eflftn[TYREAL] = FTNREAL;
517: eflftn[TYLREAL] = FTNDOUBLE;
518: eflftn[TYLOG] = FTNLOG;
519: eflftn[TYCOMPLEX] = FTNCOMPLEX;
520: eflftn[TYCHAR] = FTNINT;
521: eflftn[TYFIELD] = FTNINT;
522: eflftn[TYLCOMPLEX] = FTNDOUBLE;
523: }
524:
525:
526:
527:
528: #ifdef gcos
529: meter()
530: {
531: FILE *mout;
532: char *cuserid(), *datime(), *s;
533: if(equals(s = cuserid(), "efl")) return;
534: mout = fopen("efl/eflmeter", "a");
535: if(mout == NULL)
536: fprintf(diagfile,"cannot open meter file");
537:
538: else {
539: fprintf(mout, "%s user %s at %s\n",
540: ( rutss()? "tss " : "batch"), s, datime() );
541: fclose(mout);
542: }
543: }
544: #endif
545:
546:
547:
548: #ifdef unix
549: meter() /* temporary metering of non-SIF usage */
550: {
551: FILE *mout;
552: int tvec[2];
553: int uid;
554: char *ctime(), *p;
555:
556: uid = getuid() & 0377;
557: if(uid == 91) return; /* ignore sif uses */
558: mout = fopen("/usr/sif/efl/Meter", "a");
559: if(mout == NULL)
560: fprintf(diagfile, "cannot open meter file");
561: else {
562: time(tvec);
563: p = ctime(tvec);
564: p[16] = '\0';
565: fprintf(mout,"User %d, %s\n", uid, p+4);
566: fclose(mout);
567: }
568: }
569:
570: intrupt()
571: {
572: done(0);
573: }
574: #endif
575:
576:
577: done(k)
578: int k;
579: {
580: rmiis();
581: exit(k);
582: }
583:
584:
585:
586:
587:
588: /* if string has an embedded equal sign, set option with it*/
589: eqlstrng(s)
590: char *s;
591: {
592: register char *t;
593:
594: for(t = s; *t; ++t)
595: if(*t == '=')
596: {
597: *t = '\0';
598: while( *++t == ' ' )
599: ;
600: if(*t == '\0')
601: t = NULL;
602: setopt(s, t);
603: return(YES);
604: }
605:
606: return(NO);
607: }
608:
609: #ifdef gcos
610:
611: /* redirect output unit */
612:
613: gcoutf()
614: {
615: if (!intss())
616: {
617: fputs("\t\t Version 2.10 : read INFO/EFL (03/27/80)\n", stderr);
618: if (compile)
619: {
620: static char name[80] = "s*", opts[20] = "yw";
621: char *opt = (char *)inquire(stdout, _OPTIONS);
622: if (!strchr(opt, 't'))
623: { /* if stdout is diverted */
624: sprintf(name, "%s\"s*\"",
625: (char *)inquire(stdout, _FILENAME));
626: strcpy(&opts[1], opt);
627: }
628: if (freopen(name, opts, stdout) == NULL)
629: cant(name);
630: }
631: }
632: }
633:
634:
635:
636: /* call in fortran compiler if necessary */
637:
638: gccomp()
639: {
640: if (compile)
641: {
642: if (nbad > 0) /* abort */
643: cretsw(EXEC);
644:
645: else { /* good: call forty */
646: FILE *dstar; /* to intercept "gosys" action */
647:
648: if ((dstar = fopen("d*", "wv")) == NULL)
649: cant("d*");
650: fputs("$\tforty\tascii", dstar);
651: if (fopen("*1", "o") == NULL)
652: cant("*1");
653: fclose(stdout, "rl");
654: cretsw(FORM | LNO | BCD);
655: if (! tailor.ftncontnu)
656: compile |= FORM;
657: csetsw(compile);
658: gosys("forty");
659: }
660: }
661: }
662:
663:
664: cant(s)
665: char *s;
666: {
667: ffiler(s);
668: done(1);
669: }
670: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.