char *xxxvers
[] = "\n@(#) FORTRAN 77 DRIVER, VERSION 2.03.5, 7 NOVEMBER 1980\n";
static FILEP diagfile
= {stderr
} ;
static int sigivalue
= 0;
static int sigqvalue
= 0;
static int sighvalue
= 0;
static int sigtvalue
= 0;
static char *pass1name
= PASS1NAME
;
static char *pass2name
= PASS2NAME
;
static char *asmname
= ASMNAME
;
static char *ldname
= LDNAME
;
static char *footname
= FOOTNAME
;
static char *proffoot
= PROFFOOT
;
static char *macroname
= "m4";
static char *shellname
= "/bin/sh";
static char *aoutname
= "a.out" ;
static char *temppref
= TEMPPREF
;
static char textfname
[44];
static char asmfname
[44];
static char asmpass2
[44];
static char initfname
[44];
static char sortfname
[44];
static char prepfname
[44];
static char objfdefault
[44];
static char optzfname
[44];
static char setfname
[44];
static char fflags
[50] = "-";
static char cflags
[50] = "-c";
static char eflags
[30] = "system=gcos ";
static char eflags
[30] = "system=unix ";
static char rflags
[30] = "";
static char lflag
[3] = "-x";
static char *fflagp
= fflags
+1;
static char *cflagp
= cflags
+2;
static char *eflagp
= eflags
+12;
static char *rflagp
= rflags
;
static flag loadflag
= YES
;
static flag saveasmflag
= NO
;
static flag profileflag
= NO
;
static flag optimflag
= NO
;
static flag debugflag
= NO
;
static flag verbose
= NO
;
static flag nofloating
= NO
;
static flag fortonly
= NO
;
static flag macroflag
= NO
;
static flag sdbflag
= NO
;
char *setdoto(), *lastchar(), *lastfield(), *copys();
sigivalue
= (int) signal(SIGINT
, SIG_IGN
) & 01;
sigqvalue
= (int) signal(SIGQUIT
,SIG_IGN
) & 01;
sighvalue
= (int) signal(SIGHUP
, SIG_IGN
) & 01;
sigtvalue
= (int) signal(SIGTERM
,SIG_IGN
) & 01;
loadargs
= (char **) ckalloc( (argc
+20) * sizeof(*loadargs
) );
#if HERE==PDP11 || HERE==VAX
while(argc
>0 && argv
[0][0]=='-' && argv
[0][1]!='\0')
for(s
= argv
[0]+1 ; *s
; ++s
) switch(*s
)
case 'T': /* use special passes */
pass1name
= s
+1; goto endfor
;
pass2name
= s
+1; goto endfor
;
asmname
= s
+1; goto endfor
;
ldname
= s
+1; goto endfor
;
footname
= s
+1; goto endfor
;
macroname
= s
+1; goto endfor
;
temppref
= s
+1; goto endfor
;
fatali("bad option -T%c", *s
);
fprintf(diagfile
, "invalid flag 6%c\n", s
[1]);
if(s
[1]=='6' && s
[2]=='6')
if( oneof(*++s
, "qxscn") )
fprintf(diagfile
, "invalid flag -N%c\n", *s
);
if( ! strcmp(s
, "onetrip") )
if(s
[1]=='2' || s
[1]=='4' || s
[1]=='s')
fprintf(diagfile
, "invalid flag -I%c\n", s
[1]);
case 'l': /* letter ell--library */
case 'E': /* EFL flag argument */
while( *rflagp
++ = *++s
)
*loadp
++ = (profileflag
? NOFLPROF
: NOFLFOOT
);
*loadp
++ = (profileflag
? proffoot
: footname
);
for(i
= 0 ; i
<argc
; ++i
)
switch(c
= dotchar(infname
= argv
[i
]) )
case 'r': /* Ratfor file */
if( unreadable(argv
[i
]) )
sprintf(buff
, "%s %s >%s", macroname
, infname
, prepfname
);
sprintf(buff
, "efl %s %s >%s", eflags
, infname
, fortfile
);
sprintf(buff
, "ratfor %s %s >%s", rflags
, infname
, fortfile
);
infname
= argv
[i
] = lastfield(argv
[i
]);
*lastchar(infname
) = 'f';
if( nodup(t
= setdoto(argv
[i
])) )
case 'f': /* Fortran file */
if( unreadable(argv
[i
]) )
else if( dofort(argv
[i
]) )
else if( nodup(t
=setdoto(argv
[i
])) )
case 's': /* Assembler file */
if( unreadable(argv
[i
]) )
#if HERE==PDP11 || HERE==VAX
fprintf(diagfile
, "%s:\n", argv
[i
]);
sprintf(buff
, "cc %s %s", cflags
, argv
[i
] );
if( nodup(t
= setdoto(argv
[i
])) )
if( ! strcmp(argv
[i
], "-o") )
sprintf(buff
, "%s %s %s %s %s %s",
pass1name
, fflags
, s
, asmfname
, initfname
, textfname
);
if(content(initfname
) > 0)
fprintf(diagfile
, "\nError. No assembly.\n");
fprintf(diagfile
, "\ncompiler error.\n");
fprintf(diagfile
, "PASS2.");
sprintf(buff
, "%s %s - %s", pass2name
, textfname
, asmpass2
);
sprintf(buff
, "%s -A%s <%s >%s", pass2name
, setfname
, textfname
, asmpass2
);
sprintf(buff
, "%s %s >%s", pass2name
, textfname
, asmpass2
);
char *lastchar(), *setdoto();
#if TARGET==PDP11 || TARGET==VAX
sprintf(buff
, "%s %s %s", PASS2OPT
, asmpass2
, optzfname
);
sprintf(buff
,"mv %s %s", optzfname
, asmpass2
);
sprintf(buff
, "cat %s %s %s >%s",asmfname
, setfname
, asmpass2
, obj
);
sprintf(buff
, "cat %s %s >%s", asmfname
, asmpass2
, obj
);
fprintf(diagfile
, " ASM.");
sprintf(buff
, "%s -o %s %s %s %s", asmname
, obj
, asmfname
, setfname
, asmpass2
);
/* vax assembler currently accepts only one input file */
sprintf(buff
, "cat %s >>%s", asmpass2
, asmfname
);
sprintf(buff
, "%s -o %s %s", asmname
, obj
, asmfname
);
sprintf(buff
, "%s -u -o %s %s %s", asmname
, obj
, asmfname
, asmpass2
);
#if TARGET!=INTERDATA && TARGET!=PDP11 && TARGET!=VAX
sprintf(buff
, "%s -o %s %s %s", asmname
, obj
, asmfname
, asmpass2
);
fatal("assembler error");
#if HERE==PDP11 && TARGET!=PDP11
register char *v0
[], *v
[];
for(p
= liblist
; *p
; *v
++ = *p
++)
fprintf(diagfile
, "LOAD.");
fprintf(diagfile
, "%s ", *p
);
#if HERE==PDP11 || HERE==INTERDATA || HERE==VAX
if( (waitpid
= fork()) == 0)
fatalstr("couldn't load %s", ldname
);
char buff1
[100], buff2
[100];
sprintf(buff1
, "nopt %s -o junk.%d", aoutname
, pid
);
sprintf(buff2
, "mv junk.%d %s", pid
, aoutname
);
if( sys(buff1
) || sys(buff2
) )
/* Process control and Shell-simulating routines */
char *argv
[100], path
[100];
fprintf(diagfile
, "%s\n", str
);
while( !isspace(*t
) && *t
!='\0' )
if(argc
== 1) /* no command */
for(t
= argv
[1] ; *s
++ = *t
++ ; )
if((waitpid
= fork()) == 0)
freopen(inname
, "r", stdin
);
freopen(outname
, (append
? "a" : "w"), stdout
);
texec(path
+9, argv
); /* command */
texec(path
+4, argv
); /* /bin/command */
texec(path
, argv
); /* /usr/bin/command */
fatalstr("Cannot load %s",path
+9);
return( await(waitpid
) );
/* modified version from the Shell */
fatalstr("%s: too large", f
);
while ( (w
= wait(&status
)) != waitpid
)
fprintf(diagfile
, "Termination code %d", status
);
/* File Name and File Manipulation Routines */
fprintf(diagfile
, "Error: Cannot read file %s\n", s
);
if(p
!=NULL
&& *p
!=NULL
&& *p
!=stdout
)
/* return -1 if file does not exist, 0 if it is of zero length
and 1 if of positive length
if(stat(filename
,&buf
) < 0)
return(buf
.size0
|| buf
.size1
);
return( buf
.st_size
> 0 );
if(!debugflag
&& fn
!=NULL
&& *fn
!='\0')
sprintf(name
, "/tmp/%s%d.%s", temppref
, pid
, suff
);
if(s
[0]=='.' && s
[1]!='\0' && s
[2]=='\0')
fatalstr("cannot open intermediate file %s", s
);
if( p
= calloc(1, (unsigned) n
) )
p
= q
= (char *) ckalloc(n
);
return( copyn( strlen(s
)+1 , s
) );
for(p
= loadargs
; p
< loadp
; ++p
)
fprintf(diagfile
, "Compiler error in file %s: %s\n", infname
, t
);
fprintf(diagfile
, "Error in file %s: %s\n", infname
, s
);
/* Code to generate initializations for DATA statements */
static ftnint typesize
[NTYPES
]
= { 1, SZADDR
, SZSHORT
, SZLONG
, SZLONG
, 2*SZLONG
,
2*SZLONG
, 4*SZLONG
, SZLONG
, 1, 1, 1};
static int typealign
[NTYPES
]
= { 1, ALIADDR
, ALISHORT
, ALILONG
, ALILONG
, ALIDOUBLE
,
ALILONG
, ALIDOUBLE
, ALILONG
, 1, 1, 1};
char varname
[XL
+1], ovarname
[XL
+1];
ftnint offset
, vlen
, type
;
register ftnint ooffset
, ovlen
;
sprintf(buff
, "sort %s >%s", initfname
, sortfname
);
fatali("call sort status = %d", status
);
if( (sortfile
= fopen(sortfname
, "r")) == NULL
)
if( (asmfile
= fopen(asmfname
, "a")) == NULL
)
while( rdname(&vargroup
, varname
) && rdlong(&offset
) && rdlong(&vlen
) && rdlong(&type
) )
if( strcmp(varname
, ovarname
) )
strcpy(ovarname
, varname
);
align
= (type
==TYCHAR
|| type
==TYBLANK
?
SZLONG
: typealign
[type
]);
totlen
= doeven(totlen
, align
);
prcomblock(asmfile
, varname
);
fprintf(asmfile
, LABELFMT
, varname
);
err("overlapping initializations");
fatal("bad intermediate file format");
fatal("bad intermediate file format");
while ( putc( getc(sortfile
), asmfile
) != '\n')
if( (ooffset
+= size
) > ovlen
)
err("initialization out of bounds");
totlen
= doeven(totlen
+ovlen
, (ALIDOUBLE
>SZLONG
? ALIDOUBLE
: SZLONG
) );
m
= SZSHORT
* (n
/SZSHORT
);
ftnint
doeven(tot
, align
)
new = roundup(tot
, align
);
if( (c
= getc(sortfile
)) == EOF
)
if( (c
= getc(sortfile
)) == EOF
)
for(c
= getc(sortfile
) ; c
!=EOF
&& isspace(c
) ; c
= getc(sortfile
) );
for(*n
= 0 ; isdigit(c
) ; c
= getc(sortfile
) )
static int buff
[SZSHORT
];