xref: /netbsd-src/external/bsd/pcc/dist/pcc/f77/fcom/main.c (revision f48728536a6f10f4708abc604536ab7469d46dd7)
1 /*	Id: main.c,v 1.17 2012/03/22 18:51:40 plunky Exp 	*/
2 /*	$NetBSD: main.c,v 1.1.1.5 2012/03/26 14:27:08 plunky Exp $	*/
3 /*
4  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
5  *
6  * Redistribution and use in source and binary forms, with or without
7  * modification, are permitted provided that the following conditions
8  * are met:
9  *
10  * Redistributions of source code and documentation must retain the above
11  * copyright notice, this list of conditions and the following disclaimer.
12  * Redistributions in binary form must reproduce the above copyright
13  * notice, this list of conditionsand the following disclaimer in the
14  * documentation and/or other materials provided with the distribution.
15  * All advertising materials mentioning features or use of this software
16  * must display the following acknowledgement:
17  * 	This product includes software developed or owned by Caldera
18  *	International, Inc.
19  * Neither the name of Caldera International, Inc. nor the names of other
20  * contributors may be used to endorse or promote products derived from
21  * this software without specific prior written permission.
22  *
23  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
24  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
25  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
28  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
32  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
33  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34  * POSSIBILITY OF SUCH DAMAGE.
35  */
36 char xxxvers[] = "\nFORTRAN 77 PASS 1, VERSION 1.16,  3 NOVEMBER 1978\n";
37 
38 #include <unistd.h>
39 
40 #include "defines.h"
41 #include "defs.h"
42 
43 void mkdope(void);
44 
45 int ndebug;
46 int b2debug, c2debug, e2debug, f2debug, g2debug, o2debug;
47 int r2debug, s2debug, t2debug, u2debug, x2debug;
48 int kflag;
49 int xdeljumps, xtemps, xssa, xdce;
50 
51 int mflag, tflag;
52 
53 char *ftitle = "<unknown>";
54 
55 #if 1 /* RAGGE */
56 FILE *initfile, *sortfile;
57 int dodata(char *file);
58 LOCAL int nch   = 0;
59 #endif
60 
61 static void
usage(void)62 usage(void)
63 {
64 	fprintf(stderr, "usage: fcom [qw:UuOdpC1I:Z:]\n");
65 	exit(1);
66 }
67 
68 int
main(int argc,char ** argv)69 main(int argc, char **argv)
70 {
71 	int ch;
72 	int k, retcode;
73 
74 	infile = stdin;
75 	diagfile = stderr;
76 #if 1 /* RAGGE */
77 	char file[] = "/tmp/initfile.XXXXXX";
78 	char buf[100];
79 	close(mkstemp(file));
80 	sprintf(buf, "sort > %s", file);
81 	initfile = popen(buf, "w");
82 #endif
83 
84 
85 #define DONE(c)	{ retcode = c; goto finis; }
86 
87 	while ((ch = getopt(argc, argv, "qw:UuOdpC1I:Z:X:")) != -1)
88 		switch (ch) {
89 		case 'q':
90 			quietflag = YES;
91 			break;
92 
93 		case 'w':
94 			if(optarg[0]=='6' && optarg[1]=='6') {
95 				ftn66flag = YES;
96 			} else
97 				nowarnflag = YES;
98 			break;
99 
100 		case 'U':
101 			shiftcase = NO;
102 			break;
103 
104 		case 'u':
105 			undeftype = YES;
106 			break;
107 
108 		case 'O':
109 			optimflag = YES;
110 #ifdef notyet
111 			xdeljumps = 1;
112 			xtemps = 1;
113 #endif
114 			break;
115 
116 		case 'd':
117 			debugflag = YES;
118 			break;
119 
120 		case 'p':
121 			profileflag = YES;
122 			break;
123 
124 		case 'C':
125 			checksubs = YES;
126 			break;
127 
128 		case '1':
129 			onetripflag = YES;
130 			break;
131 
132 		case 'I':
133 			if(*optarg == '2')
134 				tyint = TYSHORT;
135 			else if(*optarg == '4') {
136 				shortsubs = NO;
137 				tyint = TYLONG;
138 			} else if(*optarg == 's')
139 				shortsubs = YES;
140 			else
141 				fatal1("invalid flag -I%c\n", *optarg);
142 			tylogical = tyint;
143 			break;
144 
145 		case 'Z':	/* pass2 debugging */
146 			while (*optarg)
147 				switch (*optarg++) {
148 				case 'b': /* basic block and SSA building */
149 					++b2debug;
150 					break;
151 				case 'c': /* code printout */
152 					++c2debug;
153 					break;
154 				case 'e': /* print tree upon pass2 enter */
155 					++e2debug;
156 					break;
157 				case 'f': /* instruction matching */
158 					++f2debug;
159 					break;
160 				case 'g':
161 					++g2debug;
162 					break;
163 				case 'n':
164 					++ndebug;
165 					break;
166 				case 'o':
167 					++o2debug;
168 					break;
169 				case 'r': /* register alloc/graph coloring */
170 					++r2debug;
171 					break;
172 				case 's': /* shape matching */
173 					++s2debug;
174 					break;
175 				case 't':
176 					++t2debug;
177 					break;
178 				case 'u': /* Sethi-Ullman debugging */
179 					++u2debug;
180 					break;
181 				case 'x':
182 					++x2debug;
183 					break;
184 				default:
185 					fprintf(stderr, "unknown Z flag '%c'\n",
186 					    optarg[-1]);
187 					exit(1);
188 				}
189 			break;
190 
191 		case 'X':	/* pass1 debugging */
192 			while (*optarg)
193 				switch (*optarg++) {
194 				case 'm': /* memory allocation */
195 					++mflag;
196 					break;
197 				case 't': /* tree debugging */
198 					tflag++;
199 					break;
200 				default:
201 					usage();
202 				}
203 			break;
204 
205 		default:
206 			usage();
207 		}
208 	argc -= optind;
209 	argv += optind;
210 
211 	mkdope();
212 	initkey();
213 	if (argc > 0) {
214 		if (inilex(copys(argv[0])))
215 			DONE(1);
216 		if (!quietflag)
217 			fprintf(diagfile, "%s:\n", argv[0]);
218 		if (argc != 1)
219 			if (freopen(argv[1], "w", stdout) == NULL) {
220 				fprintf(stderr, "open output file '%s':",
221 				    argv[1]);
222 				perror(NULL);
223 				exit(1);
224 			}
225 	} else {
226 		inilex(copys(""));
227 	}
228 	fileinit();
229 	procinit();
230 	if((k = yyparse())) {
231 		fprintf(diagfile, "Bad parse, return code %d\n", k);
232 		DONE(1);
233 	}
234 	if(nerr > 0)
235 		DONE(1);
236 	if(parstate != OUTSIDE) {
237 		warn("missing END statement");
238 		endproc();
239 	}
240 	doext();
241 	preven(ALIDOUBLE);
242 	prtail();
243 	puteof();
244 	DONE(0);
245 
246 
247 finis:
248 	pclose(initfile);
249 	retcode |= dodata(file);
250 	unlink(file);
251 	done(retcode);
252 	return(retcode);
253 }
254 
255 #define USEINIT ".data\t2"
256 #define LABELFMT "%s:\n"
257 
258 static void
prcha(FILEP fp,int * s)259 prcha(FILEP fp, int *s)
260 {
261 
262 fprintf(fp, ".byte 0%o,0%o\n", s[0], s[1]);
263 }
264 
265 static void
prskip(FILEP fp,ftnint k)266 prskip(FILEP fp, ftnint k)
267 {
268 fprintf(fp, "\t.space\t%ld\n", k);
269 }
270 
271 
272 static void
prch(int c)273 prch(int c)
274 {
275 static int buff[SZSHORT];
276 
277 buff[nch++] = c;
278 if(nch == SZSHORT)
279         {
280         prcha(stdout, buff);
281         nch = 0;
282         }
283 }
284 
285 
286 static int
rdname(int * vargroupp,char * name)287 rdname(int *vargroupp, char *name)
288 {
289 register int i, c;
290 
291 if( (c = getc(sortfile)) == EOF)
292         return(NO);
293 *vargroupp = c - '0';
294 
295 for(i = 0 ; i<XL ; ++i)
296         {
297         if( (c = getc(sortfile)) == EOF)
298                 return(NO);
299         if(c != ' ')
300                 *name++ = c;
301         }
302 *name = '\0';
303 return(YES);
304 }
305 
306 static int
rdlong(ftnint * n)307 rdlong(ftnint *n)
308 {
309 register int c;
310 
311 for(c = getc(sortfile) ; c!=EOF && isspace(c) ; c = getc(sortfile) );
312         ;
313 if(c == EOF)
314         return(NO);
315 
316 for(*n = 0 ; isdigit(c) ; c = getc(sortfile) )
317         *n = 10* (*n) + c - '0';
318 return(YES);
319 }
320 
321 static void
prspace(ftnint n)322 prspace(ftnint n)
323 {
324 register ftnint m;
325 
326 while(nch>0 && n>0)
327         {
328         --n;
329         prch(0);
330         }
331 m = SZSHORT * (n/SZSHORT);
332 if(m > 0)
333         prskip(stdout, m);
334 for(n -= m ; n>0 ; --n)
335         prch(0);
336 }
337 
338 static ftnint
doeven(ftnint tot,int align)339 doeven(ftnint tot, int align)
340 {
341 ftnint new;
342 new = roundup(tot, align);
343 prspace(new - tot);
344 return(new);
345 }
346 
347 
348 int
dodata(char * file)349 dodata(char *file)
350 {
351 	char varname[XL+1], ovarname[XL+1];
352 	flag erred;
353 	ftnint offset, vlen, type;
354 	register ftnint ooffset, ovlen;
355 	ftnint vchar;
356 	int size, align;
357 	int vargroup;
358 	ftnint totlen;
359 
360 	erred = NO;
361 	ovarname[0] = '\0';
362 	ooffset = 0;
363 	ovlen = 0;
364 	totlen = 0;
365 	nch = 0;
366 	ftitle = file;
367 
368 	if( (sortfile = fopen(file, "r")) == NULL)
369 		fatal1(file);
370 #if 0
371 	pruse(asmfile, USEINIT);
372 #else
373 	printf("\t%s\n", USEINIT);
374 #endif
375 	while (rdname(&vargroup, varname) && rdlong(&offset) &&
376 	    rdlong(&vlen) && rdlong(&type) ) {
377 		size = typesize[type];
378 		if( strcmp(varname, ovarname) ) {
379 			prspace(ovlen-ooffset);
380 			strcpy(ovarname, varname);
381 			ooffset = 0;
382 			totlen += ovlen;
383 			ovlen = vlen;
384 			if(vargroup == 0)
385 				align = (type==TYCHAR ? SZLONG :
386 				    typealign[type]);
387 			else
388 				align = ALIDOUBLE;
389 			totlen = doeven(totlen, align);
390 			if(vargroup == 2) {
391 #if 0
392 				prcomblock(asmfile, varname);
393 #else
394 				printf(LABELFMT, varname);
395 #endif
396 			} else {
397 #if 0
398 				fprintf(asmfile, LABELFMT, varname);
399 #else
400 				printf(LABELFMT, varname);
401 #endif
402 			}
403 		}
404 		if(offset < ooffset) {
405 			erred = YES;
406 			err("overlapping initializations");
407 		}
408 		if(offset > ooffset) {
409 			prspace(offset-ooffset);
410 			ooffset = offset;
411 		}
412 		if(type == TYCHAR) {
413 			if( ! rdlong(&vchar) )
414 				fatal("bad intermediate file format");
415 			prch( (int) vchar );
416 		} else {
417 			putc('\t', stdout);
418 			while	( putc( getc(sortfile), stdout)  != '\n')
419 				;
420 		}
421 		if( (ooffset += size) > ovlen) {
422 			erred = YES;
423 			err("initialization out of bounds");
424 		}
425 	}
426 
427 	prspace(ovlen-ooffset);
428 	totlen = doeven(totlen+ovlen, (ALIDOUBLE>SZLONG ? ALIDOUBLE : SZLONG) );
429 	return(erred);
430 }
431 
432 void
done(k)433 done(k)
434 int k;
435 {
436 static int recurs	= NO;
437 
438 if(recurs == NO)
439 	{
440 	recurs = YES;
441 	}
442 exit(k);
443 }
444