![[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 [CSRG BSD Unix] / 42BSD / usr.bin / efl|
Return to main.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / efl |
1.1 root 1: static char xxxvers[ ] = "\n@(#)EFL VERSION 1.14, 19 AUGUST 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: sysflag = UNIX;
164:
165: /*
166: meter();
167: */
168: if( (signal(2,1) & 01) == 0)
169: signal(2, intrupt);
170: #endif
171:
172: #ifdef gcos
173: /*
174: meter();
175: */
176: sysflag = (intss() ? GCOS : GCOSBCD);
177: #endif
178:
179:
180: crii();
181: --argc;
182: ++argv;
183: tailinit(systab + sysflag);
184:
185: while(argc>0 && ( (argv[0][0]=='-' && argv[0][1]!='\0') || eqlstrng(argv[0]) ))
186: {
187: if(argv[0][0] == '-')
188: for(p = argv[0]+1 ; *p ; ++p) switch(*p)
189: {
190: case ' ':
191: break;
192:
193: case 'd':
194: case 'D':
195: switch( *++p)
196: {
197: case '1':
198: dbgflag = YES;
199: break;
200: case '2':
201: setyydeb();
202: break;
203: case '3':
204: dumpcore = YES;
205: break;
206: case '4':
207: dumpic = YES;
208: break;
209: case 'm':
210: case 'M':
211: memdump = YES;
212: break;
213:
214: default:
215: dbgflag = YES;
216: --p;
217: break;
218: }
219: break;
220:
221: case 'w':
222: case 'W':
223: nowarnflag = YES;
224: break;
225:
226: case 'v':
227: case 'V':
228: verbose = YES;
229: break;
230:
231: case '#':
232: nocommentflag = YES;
233: break;
234:
235: case 'C':
236: case 'c':
237: nocommentflag = NO;
238: break;
239:
240: #ifdef gcos
241: case 'O':
242: case 'o':
243: compile |= OPTZ;
244: break;
245:
246: case 'E':
247: case 'e':
248: compile = 0;
249: break;
250: #endif
251:
252: default:
253: fprintf(diagfile, "Illegal EFL flag %c\n", *p);
254: exit(1);
255: }
256: --argc;
257: ++argv;
258: }
259:
260: kwinit();
261: geninit();
262: knowninit();
263: init();
264: implinit();
265: neflnm0 = neflnames;
266:
267: #ifdef gcos
268: if( intss() )
269: compile = 0;
270: else
271: gcoutf();
272: #endif
273:
274: /* fprintf(diagfile, "EFL 1.10\n"); */
275:
276: if(argc==0)
277: {
278: filenames[0] = "-";
279: dofile(stdin);
280: }
281: else
282: while(argc>0)
283: {
284: if( eqlstrng(argv[0]) )
285: {
286: --argc;
287: ++argv;
288: continue;
289: }
290: if(argv[0][0]=='-' && argv[0][1]=='\0')
291: {
292: basefile = "";
293: fd = stdin;
294: }
295: else {
296: basefile = argv[0];
297: fd = fopen(argv[0], "r");
298: }
299: if(fd == NULL)
300: {
301: sprintf(msg, "Cannot open file %s", argv[0]);
302: fprintf(diagfile, "%s. Stop\n", msg);
303: done(2);
304: }
305: filenames[0] = argv[0];
306: filedepth = 0;
307:
308: nftnames = 0;
309: nftnm0 = 0;
310: neflnames = neflnm0;
311:
312: dofile(fd);
313: if(fd != stdin)
314: fclose(fd);
315: --argc;
316: ++argv;
317: }
318: p2flush();
319: if(verbose)
320: fprintf(diagfile, "End of compilation\n");
321: /*
322: prhisto();
323: /* */
324: rmiis();
325:
326: #ifdef gcos
327: gccomp();
328: #endif
329:
330: done(nbad);
331: }
332:
333:
334: dofile(fd)
335: FILE *fd;
336: {
337: int k;
338:
339: fprintf(diagfile, "File %s:\n", filenames[0]);
340:
341: #ifdef gcos
342: if( fd==stdin && intss() && inquire(stdin, _TTY) )
343: freopen("*src", "rt", stdin);
344: #endif
345:
346: yyin = fileptrs[0] = fd;
347: yylineno = filelines[0] = 1;
348: filedepth = 0;
349: ateof = 0;
350:
351: do {
352: nerrs = 0;
353: nwarns = 0;
354: eofneed = 0;
355: forcerr = 0;
356: comneed = 0;
357: optneed = 0;
358: defneed = 0;
359: lettneed = 0;
360: iobrlevel = 0;
361: prevbg = 0;
362:
363: constno = 0;
364: labno = 0;
365: nxtstno = 0;
366: afterif = 0;
367: thisexec = 0;
368: thisctl = 0;
369: nxtindif = 0;
370: inproc = 0;
371: blklevel = 0;
372:
373: implinit();
374:
375: opiis();
376: swii(icfile);
377:
378: if(k = yyparse())
379: fprintf(diagfile, "Error in source file.\n");
380: else switch(graal)
381: {
382: case PARSERR:
383: /*
384: fprintf(diagfile, "error\n");
385: */
386: break;
387:
388: case PARSEOF:
389: break;
390:
391: case PARSOPT:
392: propts();
393: break;
394:
395: case PARSDCL:
396: fprintf(diagfile, "external declaration\n");
397: break;
398:
399: case PARSPROC:
400: /* work already done in endproc */
401: break;
402:
403: case PARSDEF:
404: break;
405: }
406:
407: cliis();
408: if(nerrs) ++nbad;
409:
410: } while(graal!=PARSEOF && !ateof);
411: }
412:
413: ptr bgnproc()
414: {
415: ptr bgnexec();
416:
417: if(blklevel > 0)
418: {
419: execerr("procedure %s terminated prematurely", procnm() );
420: endproc();
421: }
422: ctllevel = 0;
423: procname = 0;
424: procclass = 0;
425: thisargs = 0;
426: dclsect = 0;
427: blklevel = 1;
428: nftnm0 = nftnames;
429: dclsect = 1;
430: ndecl[1] = 0;
431: nhid[1] = 0;
432:
433: thisctl = allexcblock();
434: thisctl->tag = TCONTROL;
435: thisctl->subtype = STPROC;
436: inproc = 1;
437: return( bgnexec() );
438: }
439:
440:
441: endproc()
442: {
443: char comline[50], *concat();
444: ptr p;
445:
446: inproc = 0;
447:
448: if(nerrs == 0)
449: {
450: pass2();
451: unhide();
452: cleanst();
453: if(dumpic)
454: system( concat("od ", icfile->filename, comline) );
455: if(memdump)
456: prmem();
457: }
458: else {
459: fprintf(diagfile, "**Procedure %s not generated\n", procnm());
460: for( ; blklevel > 0 ; --blklevel)
461: unhide();
462: cleanst();
463: }
464:
465: if(nerrs==0 && nwarns>0)
466: if(nwarns == 1)
467: fprintf(diagfile,"*1 warning\n");
468: else fprintf(diagfile, "*%d warnings\n", nwarns);
469:
470: blklevel = 0;
471: thisargs = 0;
472: procname = 0;
473: procclass = 0;
474: while(thisctl)
475: {
476: p = thisctl;
477: thisctl = thisctl->prevctl;
478: frexcblock(p);
479: }
480:
481: while(thisexec)
482: {
483: p = thisexec;
484: thisexec = thisexec->prevexec;
485: frexcblock(p);
486: }
487:
488: nftnames = nftnm0;
489: if(verbose)
490: {
491: fprintf(diagfile, "Highwater mark %d words. ", nmemused);
492: fprintf(diagfile, "%ld words left over\n", totalloc-totfreed);
493: }
494: }
495:
496:
497:
498:
499: implinit()
500: {
501: setimpl(TYREAL, 'a', 'z');
502: setimpl(TYINT, 'i', 'n');
503: }
504:
505:
506:
507: init()
508: {
509: eflftn[TYINT] = FTNINT;
510: eflftn[TYREAL] = FTNREAL;
511: eflftn[TYLREAL] = FTNDOUBLE;
512: eflftn[TYLOG] = FTNLOG;
513: eflftn[TYCOMPLEX] = FTNCOMPLEX;
514: eflftn[TYCHAR] = FTNINT;
515: eflftn[TYFIELD] = FTNINT;
516: eflftn[TYLCOMPLEX] = FTNDOUBLE;
517: }
518:
519:
520:
521:
522: #ifdef gcos
523: meter()
524: {
525: FILE *mout;
526: char *cuserid(), *datime(), *s;
527: if(equals(s = cuserid(), "efl")) return;
528: mout = fopen("efl/eflmeter", "a");
529: if(mout == NULL)
530: fprintf(diagfile,"cannot open meter file");
531:
532: else {
533: fprintf(mout, "%s user %s at %s\n",
534: ( rutss()? "tss " : "batch"), s, datime() );
535: fclose(mout);
536: }
537: }
538: #endif
539:
540:
541:
542: #ifdef unix
543: meter() /* temporary metering of non-SIF usage */
544: {
545: FILE *mout;
546: int tvec[2];
547: int uid;
548: char *ctime(), *p;
549:
550: uid = getuid() & 0377;
551: if(uid == 91) return; /* ignore sif uses */
552: mout = fopen("/usr/sif/efl/Meter", "a");
553: if(mout == NULL)
554: fprintf(diagfile, "cannot open meter file");
555: else {
556: time(tvec);
557: p = ctime(tvec);
558: p[16] = '\0';
559: fprintf(mout,"User %d, %s\n", uid, p+4);
560: fclose(mout);
561: }
562: }
563:
564: intrupt()
565: {
566: done(0);
567: }
568: #endif
569:
570:
571: done(k)
572: int k;
573: {
574: rmiis();
575: exit(k);
576: }
577:
578:
579:
580:
581:
582: /* if string has an embedded equal sign, set option with it*/
583: eqlstrng(s)
584: char *s;
585: {
586: register char *t;
587:
588: for(t = s; *t; ++t)
589: if(*t == '=')
590: {
591: *t = '\0';
592: while( *++t == ' ' )
593: ;
594: setopt(s, t);
595: return(YES);
596: }
597:
598: return(NO);
599: }
600:
601: #ifdef gcos
602:
603: /* redirect output unit */
604:
605: gcoutf()
606: {
607: if (!intss())
608: {
609: fputs("\t\t Version 2.10 : read INFO/EFL (03/27/80)\n", stderr);
610: if (compile)
611: {
612: static char name[80] = "s*", opts[20] = "yw";
613: char *opt = (char *)inquire(stdout, _OPTIONS);
614: if (!strchr(opt, 't'))
615: { /* if stdout is diverted */
616: sprintf(name, "%s\"s*\"",
617: (char *)inquire(stdout, _FILENAME));
618: strcpy(&opts[1], opt);
619: }
620: if (freopen(name, opts, stdout) == NULL)
621: cant(name);
622: }
623: }
624: }
625:
626:
627:
628: /* call in fortran compiler if necessary */
629:
630: gccomp()
631: {
632: if (compile)
633: {
634: if (nbad > 0) /* abort */
635: cretsw(EXEC);
636:
637: else { /* good: call forty */
638: FILE *dstar; /* to intercept "gosys" action */
639:
640: if ((dstar = fopen("d*", "wv")) == NULL)
641: cant("d*");
642: fputs("$\tforty\tascii", dstar);
643: if (fopen("*1", "o") == NULL)
644: cant("*1");
645: fclose(stdout, "rl");
646: cretsw(FORM | LNO | BCD);
647: if (! tailor.ftncontnu)
648: compile |= FORM;
649: csetsw(compile);
650: gosys("forty");
651: }
652: }
653: }
654:
655:
656: cant(s)
657: char *s;
658: {
659: ffiler(s);
660: done(1);
661: }
662: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.