1/*	Id: f77.c,v 1.22 2011/08/04 08:32:32 mickey Exp 	*/
2/*	$NetBSD: f77.c,v 1.1.1.4 2011/09/01 12:47:05 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
37char xxxvers[] = "FORTRAN 77 DRIVER, VERSION 1.11,   28 JULY 1978\n";
38
39#include <sys/wait.h>
40
41#include <stdio.h>
42#include <ctype.h>
43#include <signal.h>
44#include <unistd.h>
45#include <string.h>
46#include <stdlib.h>
47#include <stdarg.h>
48#include <errno.h>
49
50#include "ccconfig.h"
51
52typedef FILE *FILEP;
53typedef int flag;
54#define	YES 1
55#define NO 0
56
57FILEP diagfile;
58
59static int pid;
60static int sigivalue	= 0;
61static int sigqvalue	= 0;
62
63#ifndef FCOM
64#define	FCOM		"fcom"
65#endif
66
67#ifndef ASSEMBLER
68#define ASSEMBLER       "as"
69#endif
70
71#ifndef LINKER
72#define LINKER          "ld"
73#endif
74
75static char *fcom	= LIBEXECDIR "/" FCOM ;
76static char *asmname	= ASSEMBLER ;
77static char *ldname	= LINKER ;
78static char *startfiles[] = STARTFILES;
79static char *endfiles[] = ENDFILES;
80static char *dynlinker[] = DYNLINKER;
81static char *crt0file = CRT0FILE;
82static char *macroname	= "m4";
83static char *shellname	= "/bin/sh";
84static char *aoutname	= "a.out" ;
85static char *libdir	= LIBDIR ;
86static char *liblist[] = F77LIBLIST;
87
88static char *infname;
89static char asmfname[15];
90static char prepfname[15];
91
92#define MAXARGS 100
93int ffmax;
94static char *ffary[MAXARGS];
95static char eflags[30]	= "";
96static char rflags[30]	= "";
97static char lflag[3]	= "-x";
98static char *eflagp	= eflags;
99static char *rflagp	= rflags;
100static char **loadargs;
101static char **loadp;
102static int oflag;
103
104static flag loadflag	= YES;
105static flag saveasmflag	= NO;
106static flag profileflag	= NO;
107static flag optimflag	= NO;
108static flag debugflag	= NO;
109static flag verbose	= NO;
110static flag fortonly	= NO;
111static flag macroflag	= NO;
112
113static char *setdoto(char *), *lastchar(char *), *lastfield(char *);
114static void intrupt(int);
115static void enbint(void (*)(int));
116static void crfnames(void);
117static void fatal1(char *, ...);
118static void done(int), texec(char *, char **);
119static char *copyn(int, char *);
120static int dotchar(char *), unreadable(char *), sys(char *), dofort(char *);
121static int nodup(char *);
122static int await(int);
123static void rmf(char *), doload(char *[], char *[]), doasm(char *);
124static int callsys(char *, char **);
125static void errorx(char *, ...);
126
127static void
128addarg(char **ary, int *num, char *arg)
129{
130	ary[(*num)++] = arg;
131	if ((*num) == MAXARGS) {
132		fprintf(stderr, "argument array too small\n");
133		exit(1);
134	}
135}
136
137int
138main(int argc, char **argv)
139{
140	int i, c, status;
141	char *s;
142	char fortfile[20], *t;
143	char buff[100];
144
145	diagfile = stderr;
146
147	sigivalue = (int) signal(SIGINT, SIG_IGN) & 01;
148	sigqvalue = (int) signal(SIGQUIT, SIG_IGN) & 01;
149	enbint(intrupt);
150
151	pid = getpid();
152	crfnames();
153
154	loadargs = (char **)calloc(1, (argc + 20) * sizeof(*loadargs));
155	if (!loadargs)
156		fatal1("out of memory");
157	loadp = loadargs;
158
159	--argc;
160	++argv;
161
162	while(argc>0 && argv[0][0]=='-' && argv[0][1]!='\0') {
163		for(s = argv[0]+1 ; *s ; ++s)
164			switch(*s) {
165			case 'T':  /* use special passes */
166				switch(*++s) {
167				case '1':
168					fcom = s+1; goto endfor;
169				case 'a':
170					asmname = s+1; goto endfor;
171				case 'l':
172					ldname = s+1; goto endfor;
173				case 'm':
174					macroname = s+1; goto endfor;
175				default:
176					fatal1("bad option -T%c", *s);
177				}
178				break;
179
180			case 'w': /* F66 warn or no warn */
181				addarg(ffary, &ffmax, s-1);
182				break;
183
184			case 'q':
185				/*
186				 * Suppress printing of procedure names during
187				 * compilation.
188				 */
189				addarg(ffary, &ffmax, s-1);
190				break;
191
192			copyfflag:
193			case 'u':
194			case 'U':
195			case 'M':
196			case '1':
197			case 'C':
198				addarg(ffary, &ffmax, s-1);
199				break;
200
201			case 'O':
202				optimflag = YES;
203				addarg(ffary, &ffmax, s-1);
204				break;
205
206			case 'm':
207				if(s[1] == '4')
208					++s;
209				macroflag = YES;
210				break;
211
212			case 'S':
213				saveasmflag = YES;
214
215			case 'c':
216				loadflag = NO;
217				break;
218
219			case 'v':
220				verbose = YES;
221				break;
222
223			case 'd':
224				debugflag = YES;
225				goto copyfflag;
226
227			case 'p':
228				profileflag = YES;
229				goto copyfflag;
230
231			case 'o':
232				if(!strcmp(s, "onetrip")) {
233					addarg(ffary, &ffmax, s-1);
234					goto endfor;
235				}
236				oflag = 1;
237				aoutname = *++argv;
238				--argc;
239				break;
240
241			case 'F':
242				fortonly = YES;
243				loadflag = NO;
244				break;
245
246			case 'I':
247				if(s[1]=='2' || s[1]=='4' || s[1]=='s')
248					goto copyfflag;
249				fprintf(diagfile, "invalid flag -I%c\n", s[1]);
250				done(1);
251
252			case 'l':	/* letter ell--library */
253				s[-1] = '-';
254				*loadp++ = s-1;
255				goto endfor;
256
257			case 'E':	/* EFL flag argument */
258				while(( *eflagp++ = *++s))
259					;
260				*eflagp++ = ' ';
261				goto endfor;
262			case 'R':
263				while(( *rflagp++ = *++s ))
264					;
265				*rflagp++ = ' ';
266				goto endfor;
267			default:
268				lflag[1] = *s;
269				*loadp++ = copyn(strlen(lflag), lflag);
270				break;
271			}
272endfor:
273	--argc;
274	++argv;
275	}
276
277	if (verbose)
278		fprintf(stderr, xxxvers);
279
280	if (argc == 0)
281		errorx("No input files");
282
283#ifdef mach_pdp11
284	if(nofloating)
285		*loadp++ = (profileflag ? NOFLPROF : NOFLFOOT);
286	else
287#endif
288
289	for(i = 0 ; i<argc ; ++i)
290		switch(c =  dotchar(infname = argv[i]) ) {
291		case 'r':	/* Ratfor file */
292		case 'e':	/* EFL file */
293			if( unreadable(argv[i]) )
294				break;
295			s = fortfile;
296			t = lastfield(argv[i]);
297			while(( *s++ = *t++))
298				;
299			s[-2] = 'f';
300
301			if(macroflag) {
302				snprintf(buff, sizeof(buff), "%s %s >%s",
303				    macroname, infname, prepfname);
304				if(sys(buff)) {
305					rmf(prepfname);
306					break;
307				}
308				infname = prepfname;
309			}
310
311			if(c == 'e')
312				snprintf(buff, sizeof(buff), "efl %s %s >%s",
313				    eflags, infname, fortfile);
314			else
315				snprintf(buff, sizeof(buff), "ratfor %s %s >%s",
316				    rflags, infname, fortfile);
317			status = sys(buff);
318			if(macroflag)
319				rmf(infname);
320			if(status) {
321				loadflag = NO;
322				rmf(fortfile);
323				break;
324			}
325
326			if( ! fortonly ) {
327				infname = argv[i] = lastfield(argv[i]);
328				*lastchar(infname) = 'f';
329
330				if( dofort(argv[i]) )
331					loadflag = NO;
332				else	{
333					if( nodup(t = setdoto(argv[i])) )
334						*loadp++ = t;
335					rmf(fortfile);
336				}
337			}
338			break;
339
340		case 'f':	/* Fortran file */
341		case 'F':
342			if( unreadable(argv[i]) )
343				break;
344			if( dofort(argv[i]) )
345				loadflag = NO;
346			else if( nodup(t=setdoto(argv[i])) )
347				*loadp++ = t;
348			break;
349
350		case 'c':	/* C file */
351		case 's':	/* Assembler file */
352			if( unreadable(argv[i]) )
353				break;
354			fprintf(diagfile, "%s:\n", argv[i]);
355			snprintf(buff, sizeof(buff), "cc -c %s", argv[i]);
356			if( sys(buff) )
357				loadflag = NO;
358			else
359				if( nodup(t = setdoto(argv[i])) )
360					*loadp++ = t;
361			break;
362
363		case 'o':
364			if( nodup(argv[i]) )
365				*loadp++ = argv[i];
366			break;
367
368		default:
369			if( ! strcmp(argv[i], "-o") )
370				aoutname = argv[++i];
371			else
372				*loadp++ = argv[i];
373			break;
374		}
375
376	if(loadflag)
377		doload(loadargs, loadp);
378	done(0);
379	return 0;
380}
381
382#define	ADD(x)	addarg(params, &nparms, (x))
383
384static int
385dofort(char *s)
386{
387	int nparms, i;
388	char *params[MAXARGS];
389
390	nparms = 0;
391	ADD(FCOM);
392	for (i = 0; i < ffmax; i++)
393		ADD(ffary[i]);
394	ADD(s);
395	ADD(asmfname);
396	ADD(NULL);
397
398	infname = s;
399	if (callsys(fcom, params))
400		errorx("Error.  No assembly.");
401	doasm(s);
402
403	if (saveasmflag == NO)
404		rmf(asmfname);
405	return(0);
406}
407
408
409static void
410doasm(char *s)
411{
412	char *obj;
413	char *params[MAXARGS];
414	int nparms;
415
416	if (oflag && loadflag == NO)
417		obj = aoutname;
418	else
419		obj = setdoto(s);
420
421	nparms = 0;
422	ADD(asmname);
423	ADD("-o");
424	ADD(obj);
425	ADD(asmfname);
426	ADD(NULL);
427
428	if (callsys(asmname, params))
429		fatal1("assembler error");
430	if(verbose)
431		fprintf(diagfile, "\n");
432}
433
434
435static void
436doload(char *v0[], char *v[])
437{
438	int nparms, i;
439	char *params[MAXARGS];
440	char **p;
441
442	nparms = 0;
443	ADD(ldname);
444	ADD("-X");
445	ADD("-d");
446	for (i = 0; dynlinker[i]; i++)
447		ADD(dynlinker[i]);
448	ADD("-o");
449	ADD(aoutname);
450	ADD(crt0file);
451	for (i = 0; startfiles[i]; i++)
452		ADD(startfiles[i]);
453	*v = NULL;
454	for(p = v0; *p ; p++)
455		ADD(*p);
456	if (libdir)
457		ADD(libdir);
458	for(p = liblist ; *p ; p++)
459		ADD(*p);
460	for (i = 0; endfiles[i]; i++)
461		ADD(endfiles[i]);
462	ADD(NULL);
463
464	if (callsys(ldname, params))
465		fatal1("couldn't load %s", ldname);
466
467	if(verbose)
468		fprintf(diagfile, "\n");
469}
470
471/* Process control and Shell-simulating routines */
472
473/*
474 * Execute f[] with parameter array v[].
475 * Copied from cc.
476 */
477static int
478callsys(char f[], char *v[])
479{
480	int t, status = 0;
481	pid_t p;
482	char *s;
483
484	if (debugflag || verbose) {
485		fprintf(stderr, "%s ", f);
486		for (t = 1; v[t]; t++)
487			fprintf(stderr, "%s ", v[t]);
488		fprintf(stderr, "\n");
489	}
490
491	if ((p = fork()) == 0) {
492#ifdef notyet
493		if (Bflag) {
494			size_t len = strlen(Bflag) + 8;
495			char *a = malloc(len);
496			if (a == NULL) {
497				error("callsys: malloc failed");
498				exit(1);
499			}
500			if ((s = strrchr(f, '/'))) {
501				strlcpy(a, Bflag, len);
502				strlcat(a, s, len);
503				execv(a, v);
504			}
505		}
506#endif
507		execvp(f, v);
508		if ((s = strrchr(f, '/')))
509			execvp(s+1, v);
510		fprintf(stderr, "Can't find %s\n", f);
511		_exit(100);
512	} else {
513		if (p == -1) {
514			printf("Try again\n");
515			return(100);
516		}
517	}
518	while (waitpid(p, &status, 0) == -1 && errno == EINTR)
519		;
520	if (WIFEXITED(status))
521		return (WEXITSTATUS(status));
522	if (WIFSIGNALED(status))
523		done(1);
524	fatal1("Fatal error in %s", f);
525	return 0; /* XXX */
526}
527
528
529static int
530sys(char *str)
531{
532	char *s, *t;
533	char *argv[100], path[100];
534	char *inname, *outname;
535	int append = 0;
536	int wait_pid;
537	int argc;
538
539
540	if(debugflag)
541		fprintf(diagfile, "%s\n", str);
542	inname  = NULL;
543	outname = NULL;
544	argv[0] = shellname;
545	argc = 1;
546
547	t = str;
548	while( isspace((int)*t) )
549		++t;
550	while(*t) {
551		if(*t == '<')
552			inname = t+1;
553		else if(*t == '>') {
554			if(t[1] == '>') {
555				append = YES;
556				outname = t+2;
557			} else	{
558				append = NO;
559				outname = t+1;
560			}
561		} else
562			argv[argc++] = t;
563		while( !isspace((int)*t) && *t!='\0' )
564			++t;
565		if(*t) {
566			*t++ = '\0';
567			while( isspace((int)*t) )
568				++t;
569		}
570	}
571
572	if(argc == 1)   /* no command */
573		return(-1);
574	argv[argc] = 0;
575
576	s = path;
577	t = "/usr/bin/";
578	while(*t)
579		*s++ = *t++;
580	for(t = argv[1] ; (*s++ = *t++) ; )
581		;
582	if((wait_pid = fork()) == 0) {
583		if(inname)
584			freopen(inname, "r", stdin);
585		if(outname)
586			freopen(outname, (append ? "a" : "w"), stdout);
587		enbint(SIG_DFL);
588
589		texec(path+9, argv);  /* command */
590		texec(path+4, argv);  /*  /bin/command */
591		texec(path  , argv);  /* /usr/bin/command */
592
593		fatal1("Cannot load %s",path+9);
594	}
595
596	return( await(wait_pid) );
597}
598
599/* modified version from the Shell */
600static void
601texec(char *f, char **av)
602{
603
604	execv(f, av+1);
605
606	if (errno==ENOEXEC) {
607		av[1] = f;
608		execv(shellname, av);
609		fatal1("No shell!");
610	}
611	if (errno==ENOMEM)
612		fatal1("%s: too large", f);
613}
614
615/*
616 * Cleanup and exit with value k.
617 */
618static void
619done(int k)
620{
621	static int recurs	= NO;
622
623	if(recurs == NO) {
624		recurs = YES;
625		if (saveasmflag == NO)
626			rmf(asmfname);
627	}
628	exit(k);
629}
630
631
632static void
633enbint(void (*k)(int))
634{
635if(sigivalue == 0)
636	signal(SIGINT,k);
637if(sigqvalue == 0)
638	signal(SIGQUIT,k);
639}
640
641
642
643static void
644intrupt(int a)
645{
646done(2);
647}
648
649
650static int
651await(int wait_pid)
652{
653int w, status;
654
655enbint(SIG_IGN);
656while ( (w = wait(&status)) != wait_pid)
657	if(w == -1)
658		fatal1("bad wait code");
659enbint(intrupt);
660if(status & 0377)
661	{
662	if(status != SIGINT)
663		fprintf(diagfile, "Termination code %d", status);
664	done(3);
665	}
666return(status>>8);
667}
668
669/* File Name and File Manipulation Routines */
670
671static int
672unreadable(char *s)
673{
674	FILE *fp;
675
676	if((fp = fopen(s, "r"))) {
677		fclose(fp);
678		return(NO);
679	} else {
680		fprintf(diagfile, "Error: Cannot read file %s\n", s);
681		loadflag = NO;
682		return(YES);
683	}
684}
685
686
687static void
688crfnames(void)
689{
690	snprintf(asmfname,  sizeof(asmfname),  "fort%d.%s", pid, "s");
691	snprintf(prepfname, sizeof(prepfname), "fort%d.%s", pid, "p");
692}
693
694
695
696static void
697rmf(char *fn)
698{
699if(!debugflag && fn!=NULL && *fn!='\0')
700	unlink(fn);
701}
702
703
704static int
705dotchar(char *s)
706{
707for( ; *s ; ++s)
708	if(s[0]=='.' && s[1]!='\0' && s[2]=='\0')
709		return( s[1] );
710return(NO);
711}
712
713
714static char *
715lastfield(char *s)
716{
717char *t;
718for(t = s; *s ; ++s)
719	if(*s == '/')
720		t = s+1;
721return(t);
722}
723
724
725static char *
726lastchar(char *s)
727{
728while(*s)
729	++s;
730return(s-1);
731}
732
733
734static char *
735setdoto(char *s)
736{
737*lastchar(s) = 'o';
738return( lastfield(s) );
739}
740
741
742static char *
743copyn(int n, char *s)
744{
745	char *p, *q;
746
747	p = q = (char *)calloc(1, (unsigned) n + 1);
748	if (!p)
749		fatal1("out of memory");
750
751	while(n-- > 0)
752		*q++ = *s++;
753	return (p);
754}
755
756
757static int
758nodup(char *s)
759{
760char **p;
761
762for(p = loadargs ; p < loadp ; ++p)
763	if( !strcmp(*p, s) )
764		return(NO);
765
766return(YES);
767}
768
769
770static void
771errorx(char *fmt, ...)
772{
773	va_list ap;
774
775	va_start(ap, fmt);
776	vfprintf(diagfile, fmt, ap);
777	fprintf(diagfile, "\n");
778	va_end(ap);
779
780	if (debugflag)
781		abort();
782	done(1);
783}
784
785
786static void
787fatal1(char *fmt, ...)
788{
789	va_list ap;
790
791	va_start(ap, fmt);
792	fprintf(diagfile, "Compiler error in file %s: ", infname);
793	vfprintf(diagfile, fmt, ap);
794	fprintf(diagfile, "\n");
795	va_end(ap);
796
797	if (debugflag)
798		abort();
799	done(1);
800}
801