d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Added

Browse source
This commit is contained in:
ceriel 1991-10-07 16:35:03 +00:00
parent 98b019c735
commit 0f16a0f6f8
69 changed files with 31026 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lang/fortran/.distr Normal file
View file

@ -0,0 +1,7 @@
changes
comp
disclaimer
fc
fixes
index
lib

1184
lang/fortran/changes Normal file
View file

File diff suppressed because it is too large Load diff

60
lang/fortran/comp/.distr Normal file
View file

@ -0,0 +1,60 @@
Notice
README
cds.c
data.c
defines.h
defs.h
equiv.c
error.c
exec.c
expr.c
f2c.1
f2c.1t
f2c.6
f2c.h
format.c
format.h
formatdata.c
ftypes.h
gram.dcl
gram.exec
gram.expr
gram.head
gram.io
init.c
intr.c
io.c
iob.h
lex.c
machdefs.h
main.c
makefile
malloc.c
mem.c
memset.c
misc.c
names.c
names.h
niceprintf.c
niceprintf.h
output.c
output.h
p1defs.h
p1output.c
parse.h
parse_args.c
pccdefs.h
pread.c
proc.c
proto.make
put.c
putpcc.c
string.h
sysdep.c
sysdep.h
tokens
usignal.h
vax.c
version.c
xsum.c
xsum0.out

23
lang/fortran/comp/Notice Normal file
View file

@ -0,0 +1,23 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/

73
lang/fortran/comp/README Normal file
View file

@ -0,0 +1,73 @@
Type "make" to check the validity of the f2c source and compile f2c.
If (in accordance with what follows) you need to modify the makefile
or any of the source files, first issue a "make xsum.out" to check
the validity of the f2c source, then make your changes, then type
"make f2c".
The file usignal.h is for the benefit of strictly ANSI include files
on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
You may need to modify usignal.h if you are not running f2c on a UNIX
system.
Should you get the message "xsum0.out xsum1.out differ", see what lines
are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
the files in question "from f2c/src". For example, if exec.c and
expr.c have incorrect check sums, you would send netlib the message
send exec.c expr.c from f2c/src
On some systems, the malloc and free in malloc.c let f2c run faster
than do the standard malloc and free. Other systems cannot tolerate
redefinition of malloc and free. If yours is such a system, you may
either modify the makefile appropriately, or simply execute
cc -c -DCRAY malloc.c
before typing "make". Still other systems have a -lmalloc that
provides performance competitive with that from malloc.c; you may
wish to compare the two on your system.
On some BSD systems, you may need to create a file named "string.h"
whose single line is
#include <strings.h>
you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
assignment in the makefile -- see the comments in memset.c .
For non-UNIX systems, you may need to change some things in sysdep.c,
such as the choice of intermediate file names.
On some systems, you may need to modify parts of sysdep.h (which is
included by defs.h). In particular, for Sun 4.1 systems and perhaps
some others, you need to comment out the typedef of size_t.
Alas, some systems #define __STDC__ but do not provide a true standard
(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours
is such a system, then (a) you should complain loudly to your vendor
about __STDC__ being erroneously defined, and (b) you should insert
#undef __STDC__
at the beginning of sysdep.h . You may need to make other adjustments.
For some non-ANSI versions of stdio, you must change the values given
to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w".
You may need to make this change if you run f2c and get an error
message of the form
Compiler error ... cannot open intermediate file ...
On many systems, it is best to combine libF77 and libI77 into a single
library, say libf2c, as suggested in "index from f2c". If you do this,
then you should adjust the definition of link_msg in sysdep.c
appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c").
Some older C compilers object to
typedef void (*foo)();
or to
typedef void zap;
zap (*foo)();
If yours is such a compiler, change the definition of VOID in
f2c.h from void to int.
Please send bug reports to dmg@research.att.com . The index file
("send index from f2c") will report recent changes in the recent-change
log at its end; all changes will be shown in the "fixes" file
("send fixes from f2c"). To keep current source, you will need to
request xsum0.out and version.c, in addition to the changed source
files.

178
lang/fortran/comp/cds.c Normal file
View file

@ -0,0 +1,178 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
/* Put strings representing decimal floating-point numbers
* into canonical form: always have a decimal point or
* exponent field; if using an exponent field, have the
* number before it start with a digit and decimal point
* (if the number has more than one digit); only have an
* exponent field if it saves space.
*
* Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' .
*/
#include "sysdep.h"
char *
cds(s, z0)
char *s, *z0;
{
int ea, esign, et, i, k, nd = 0, sign = 0, tz;
char c, *z;
char ebuf[24];
long ex = 0;
static char etype[Table_size], *db;
static int dblen = 64;
if (!db) {
etype['E'] = 1;
etype['e'] = 1;
etype['D'] = 1;
etype['d'] = 1;
etype['+'] = 2;
etype['-'] = 3;
db = Alloc(dblen);
}
while((c = *s++) == '0');
if (c == '-')
{ sign = 1; c = *s++; }
else if (c == '+')
c = *s++;
k = strlen(s) + 2;
if (k >= dblen) {
do dblen <<= 1;
while(k >= dblen);
free(db);
db = Alloc(dblen);
}
if (etype[(unsigned char)c] >= 2)
while(c == '0') c = *s++;
tz = 0;
while(c >= '0' && c <= '9') {
if (c == '0')
tz++;
else {
if (nd)
for(; tz; --tz)
db[nd++] = '0';
else
tz = 0;
db[nd++] = c;
}
c = *s++;
}
ea = -tz;
if (c == '.') {
while((c = *s++) >= '0' && c <= '9') {
if (c == '0')
tz++;
else {
if (tz) {
ea += tz;
if (nd)
for(; tz; --tz)
db[nd++] = '0';
else
tz = 0;
}
db[nd++] = c;
ea++;
}
}
}
if (et = etype[(unsigned char)c]) {
esign = et == 3;
c = *s++;
if (et == 1) {
if(etype[(unsigned char)c] > 1) {
if (c == '-')
esign = 1;
c = *s++;
}
}
while(c >= '0' && c <= '9') {
ex = 10*ex + (c - '0');
c = *s++;
}
if (esign)
ex = -ex;
}
/* debug */ if (c)
/* debug*/ Fatal("unexpected character in cds");
ex -= ea;
if (!nd) {
if (!z0)
z0 = mem(4,0);
strcpy(z0, "-0.");
sign = 0;
}
else if (ex > 2 || ex + nd < -2) {
sprintf(ebuf, "%ld", ex + nd - 1);
k = strlen(ebuf) + nd + 3;
if (nd > 1)
k++;
if (!z0)
z0 = mem(k,0);
z = z0;
*z++ = '-';
*z++ = *db;
if (nd > 1) {
*z++ = '.';
for(k = 1; k < nd; k++)
*z++ = db[k];
}
*z++ = 'e';
strcpy(z, ebuf);
}
else {
k = (int)(ex + nd);
i = nd + 3;
if (k < 0)
i -= k;
else if (ex > 0)
i += ex;
if (!z0)
z0 = mem(i,0);
z = z0;
*z++ = '-';
if (ex >= 0) {
for(k = 0; k < nd; k++)
*z++ = db[k];
while(--ex >= 0)
*z++ = '0';
*z++ = '.';
}
else {
for(i = 0; i < k;)
*z++ = db[i++];
*z++ = '.';
while(++k <= 0)
*z++ = '0';
while(i < nd)
*z++ = db[i++];
}
*z = 0;
}
return sign ? z0 : z0+1;
}

436
lang/fortran/comp/data.c Normal file
View file

@ -0,0 +1,436 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
static char datafmt[] = "%s\t%09ld\t%d";
static char *cur_varname;
/* another initializer, called from parser */
dataval(repp, valp)
register expptr repp, valp;
{
int i, nrep;
ftnint elen;
register Addrp p;
Addrp nextdata();
if (parstate < INDATA) {
frexpr(repp);
goto ret;
}
if(repp == NULL)
nrep = 1;
else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
nrep = repp->constblock.Const.ci;
else
{
err("invalid repetition count in DATA statement");
frexpr(repp);
goto ret;
}
frexpr(repp);
if( ! ISCONST(valp) )
{
err("non-constant initializer");
goto ret;
}
if(toomanyinit) goto ret;
for(i = 0 ; i < nrep ; ++i)
{
p = nextdata(&elen);
if(p == NULL)
{
err("too many initializers");
toomanyinit = YES;
goto ret;
}
setdata((Addrp)p, (Constp)valp, elen);
frexpr((expptr)p);
}
ret:
frexpr(valp);
}
Addrp nextdata(elenp)
ftnint *elenp;
{
register struct Impldoblock *ip;
struct Primblock *pp;
register Namep np;
register struct Rplblock *rp;
tagptr p;
expptr neltp;
register expptr q;
int skip;
ftnint off, vlen;
while(curdtp)
{
p = (tagptr)curdtp->datap;
if(p->tag == TIMPLDO)
{
ip = &(p->impldoblock);
if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
fatali("bad impldoblock 0%o", (int) ip);
if(ip->isactive)
ip->varvp->Const.ci += ip->impdiff;
else
{
q = fixtype(cpexpr(ip->implb));
if( ! ISICON(q) )
goto doerr;
ip->varvp = (Constp) q;
if(ip->impstep)
{
q = fixtype(cpexpr(ip->impstep));
if( ! ISICON(q) )
goto doerr;
ip->impdiff = q->constblock.Const.ci;
frexpr(q);
}
else
ip->impdiff = 1;
q = fixtype(cpexpr(ip->impub));
if(! ISICON(q))
goto doerr;
ip->implim = q->constblock.Const.ci;
frexpr(q);
ip->isactive = YES;
rp = ALLOC(Rplblock);
rp->rplnextp = rpllist;
rpllist = rp;
rp->rplnp = ip->varnp;
rp->rplvp = (expptr) (ip->varvp);
rp->rpltag = TCONST;
}
if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
|| (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
{ /* start new loop */
curdtp = ip->datalist;
goto next;
}
/* clean up loop */
if(rpllist)
{
rp = rpllist;
rpllist = rpllist->rplnextp;
free( (charptr) rp);
}
else
Fatal("rpllist empty");
frexpr((expptr)ip->varvp);
ip->isactive = NO;
curdtp = curdtp->nextp;
goto next;
}
pp = (struct Primblock *) p;
np = pp->namep;
cur_varname = np->fvarname;
skip = YES;
if(p->primblock.argsp==NULL && np->vdim!=NULL)
{ /* array initialization */
q = (expptr) mkaddr(np);
off = typesize[np->vtype] * curdtelt;
if(np->vtype == TYCHAR)
off *= np->vleng->constblock.Const.ci;
q->addrblock.memoffset =
mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
if( (neltp = np->vdim->nelt) && ISCONST(neltp))
{
if(++curdtelt < neltp->constblock.Const.ci)
skip = NO;
}
else
err("attempt to initialize adjustable array");
}
else
q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
if(skip)
{
curdtp = curdtp->nextp;
curdtelt = 0;
}
if(q->headblock.vtype == TYCHAR)
if(ISICON(q->headblock.vleng))
*elenp = q->headblock.vleng->constblock.Const.ci;
else {
err("initialization of string of nonconstant length");
continue;
}
else *elenp = typesize[q->headblock.vtype];
if (np->vstg == STGBSS) {
vlen = np->vtype==TYCHAR
? np->vleng->constblock.Const.ci
: typesize[np->vtype];
if(vlen > 0)
np->vstg = STGINIT;
}
return( (Addrp) q );
doerr:
err("nonconstant implied DO parameter");
frexpr(q);
curdtp = curdtp->nextp;
next:
curdtelt = 0;
}
return(NULL);
}
LOCAL FILEP dfile;
setdata(varp, valp, elen)
register Addrp varp;
ftnint elen;
register Constp valp;
{
struct Constblock con;
register int type;
int i, k, valtype;
ftnint offset;
char *dataname(), *varname;
static Addrp badvar;
register unsigned char *s;
static int last_lineno;
static char *last_varname;
if (varp->vstg == STGCOMMON) {
if (!(dfile = blkdfile))
dfile = blkdfile = opf(blkdfname, textwrite);
}
else {
if (procclass == CLBLOCK) {
if (varp != badvar) {
badvar = varp;
warn1("%s is not in a COMMON block",
varp->uname_tag == UNAM_NAME
? varp->user.name->fvarname
: "???");
}
return;
}
if (!(dfile = initfile))
dfile = initfile = opf(initfname, textwrite);
}
varname = dataname(varp->vstg, varp->memno);
offset = varp->memoffset->constblock.Const.ci;
type = varp->vtype;
valtype = valp->vtype;
if(type!=TYCHAR && valtype==TYCHAR)
{
if(! ftn66flag
&& (last_varname != cur_varname || last_lineno != lineno)) {
/* prevent multiple warnings */
last_lineno = lineno;
warn1(
"non-character datum %.42s initialized with character string",
last_varname = cur_varname);
}
varp->vleng = ICON(typesize[type]);
varp->vtype = type = TYCHAR;
}
else if( (type==TYCHAR && valtype!=TYCHAR) ||
(cktype(OPASSIGN,type,valtype) == TYERROR) )
{
err("incompatible types in initialization");
return;
}
if(type == TYADDR)
con.Const.ci = valp->Const.ci;
else if(type != TYCHAR)
{
if(valtype == TYUNKNOWN)
con.Const.ci = valp->Const.ci;
else consconv(type, &con, valp);
}
k = 1;
switch(type)
{
case TYLOGICAL:
if (tylogical != TYLONG)
type = tylogical;
case TYSHORT:
case TYLONG:
dataline(varname, offset, type);
prconi(dfile, con.Const.ci);
break;
case TYADDR:
dataline(varname, offset, type);
prcona(dfile, con.Const.ci);
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
case TYREAL:
case TYDREAL:
dataline(varname, offset, type);
prconr(dfile, &con, k);
break;
case TYCHAR:
k = valp -> vleng -> constblock.Const.ci;
if (elen < k)
k = elen;
s = (unsigned char *)valp->Const.ccp;
for(i = 0 ; i < k ; ++i) {
dataline(varname, offset++, TYCHAR);
fprintf(dfile, "\t%d\n", *s++);
}
k = elen - valp->vleng->constblock.Const.ci;
if(k > 0) {
dataline(varname, offset, TYBLANK);
fprintf(dfile, "\t%d\n", k);
}
break;
default:
badtype("setdata", type);
}
}
/*
output form of name is padded with blanks and preceded
with a storage class digit
*/
char *dataname(stg,memno)
int stg;
long memno;
{
static char varname[64];
register char *s, *t;
char buf[16], *memname();
if (stg == STGCOMMON) {
varname[0] = '2';
sprintf(s = buf, "Q.%ld", memno);
}
else {
varname[0] = stg==STGEQUIV ? '1' : '0';
s = memname(stg, memno);
}
t = varname + 1;
while(*t++ = *s++);
*t = 0;
return(varname);
}
frdata(p0)
chainp p0;
{
register struct Chain *p;
register tagptr q;
for(p = p0 ; p ; p = p->nextp)
{
q = (tagptr)p->datap;
if(q->tag == TIMPLDO)
{
if(q->impldoblock.isbusy)
return; /* circular chain completed */
q->impldoblock.isbusy = YES;
frdata(q->impldoblock.datalist);
free( (charptr) q);
}
else
frexpr(q);
}
frchain( &p0);
}
dataline(varname, offset, type)
char *varname;
ftnint offset;
int type;
{
fprintf(dfile, datafmt, varname, offset, type);
}
void
make_param(p, e)
register struct Paramblock *p;
expptr e;
{
register expptr q;
p->vclass = CLPARAM;
impldcl((Namep)p);
p->paramval = q = mkconv(p->vtype, e);
if (p->vtype == TYCHAR) {
if (q->tag == TEXPR)
p->paramval = q = fixexpr(q);
if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
errstr("invalid value for character parameter %s",
p->fvarname);
return;
}
if (!(e = p->vleng))
p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
+ q->constblock.Const.ccp1.blanks);
else if (q->constblock.vleng->constblock.Const.ci
> e->constblock.Const.ci) {
q->constblock.vleng->constblock.Const.ci
= e->constblock.Const.ci;
q->constblock.Const.ccp1.blanks = 0;
}
else
q->constblock.Const.ccp1.blanks
= e->constblock.Const.ci
- q->constblock.vleng->constblock.Const.ci;
}
}

289
lang/fortran/comp/defines.h Normal file
View file

@ -0,0 +1,289 @@
#define PDP11 4
#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */
#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */
#define M(x) (1<<x) /* Mask (x) returns 2^x */
#define ALLOC(x) (struct x *) ckalloc(sizeof(struct x))
#define ALLEXPR (expptr) ckalloc( sizeof(union Expression) )
typedef int *ptr;
typedef char *charptr;
typedef FILE *FILEP;
typedef int flag;
typedef char field; /* actually need only 4 bits */
typedef long int ftnint;
#define LOCAL static
#define NO 0
#define YES 1
#define CNULL (char *) 0 /* Character string null */
#define PNULL (ptr) 0
#define CHNULL (chainp) 0 /* Chain null */
#define ENULL (expptr) 0
/* BAD_MEMNO - used to distinguish between long string constants and other
constants in the table */
#define BAD_MEMNO -32768
/* block tag values -- syntactic stuff */
#define TNAME 1
#define TCONST 2
#define TEXPR 3
#define TADDR 4
#define TPRIM 5 /* Primitive datum - should not appear in an
expptr variable, it should have already been
identified */
#define TLIST 6
#define TIMPLDO 7
#define TERROR 8
/* parser states - order is important, since there are several tests for
state < INDATA */
#define OUTSIDE 0
#define INSIDE 1
#define INDCL 2
#define INDATA 3
#define INEXEC 4
/* procedure classes */
#define PROCMAIN 1
#define PROCBLOCK 2
#define PROCSUBR 3
#define PROCFUNCT 4
/* storage classes -- vstg values. BSS and INIT are used in the later
merge pass over identifiers; and they are entered differently into the
symbol table */
#define STGUNKNOWN 0
#define STGARG 1 /* adjustable dimensions */
#define STGAUTO 2 /* for stack references */
#define STGBSS 3 /* uninitialized storage (normal variables) */
#define STGINIT 4 /* initialized storage */
#define STGCONST 5
#define STGEXT 6 /* external storage */
#define STGINTR 7 /* intrinsic (late decision) reference. See
chapter 5 of the Fortran 77 standard */
#define STGSTFUNCT 8
#define STGCOMMON 9
#define STGEQUIV 10
#define STGREG 11 /* register - the outermost DO loop index will be
in a register (because the compiler is one
pass, it can't know where the innermost loop is
*/
#define STGLENG 12
#define STGNULL 13
#define STGMEMNO 14 /* interemediate-file pointer to constant table */
/* name classes -- vclass values, also procclass values */
#define CLUNKNOWN 0
#define CLPARAM 1 /* Parameter - macro definition */
#define CLVAR 2 /* variable */
#define CLENTRY 3
#define CLMAIN 4
#define CLBLOCK 5
#define CLPROC 6
#define CLNAMELIST 7 /* in data with this tag, the vdcldone flag should
be ignored (according to vardcl()) */
/* vprocclass values -- there is some overlap with the vclass values given
above */
#define PUNKNOWN 0
#define PEXTERNAL 1
#define PINTRINSIC 2
#define PSTFUNCT 3
#define PTHISPROC 4 /* here to allow recursion - further distinction
is given in the CL tag (those just above).
This applies to the presence of the name of a
function used within itself. The function name
means either call the function again, or assign
some value to the storage allocated to the
function's return value. */
/* control stack codes - these are part of a state machine which handles
the nesting of blocks (i.e. what to do about the ELSE statement) */
#define CTLDO 1
#define CTLIF 2
#define CTLELSE 3
#define CTLIFX 4
/* operators for both Fortran input and C output. They are common because
so many are shared between the trees */
#define OPPLUS 1
#define OPMINUS 2
#define OPSTAR 3
#define OPSLASH 4
#define OPPOWER 5
#define OPNEG 6
#define OPOR 7
#define OPAND 8
#define OPEQV 9
#define OPNEQV 10
#define OPNOT 11
#define OPCONCAT 12
#define OPLT 13
#define OPEQ 14
#define OPGT 15
#define OPLE 16
#define OPNE 17
#define OPGE 18
#define OPCALL 19
#define OPCCALL 20
#define OPASSIGN 21
#define OPPLUSEQ 22
#define OPSTAREQ 23
#define OPCONV 24
#define OPLSHIFT 25
#define OPMOD 26
#define OPCOMMA 27
#define OPQUEST 28
#define OPCOLON 29
#define OPABS 30
#define OPMIN 31
#define OPMAX 32
#define OPADDR 33
#define OPCOMMA_ARG 34
#define OPBITOR 35
#define OPBITAND 36
#define OPBITXOR 37
#define OPBITNOT 38
#define OPRSHIFT 39
#define OPWHATSIN 40 /* dereferencing operator */
#define OPMINUSEQ 41 /* assignment operators */
#define OPSLASHEQ 42
#define OPMODEQ 43
#define OPLSHIFTEQ 44
#define OPRSHIFTEQ 45
#define OPBITANDEQ 46
#define OPBITXOREQ 47
#define OPBITOREQ 48
#define OPPREINC 49 /* Preincrement (++x) operator */
#define OPPREDEC 50 /* Predecrement (--x) operator */
#define OPDOT 51 /* structure field reference */
#define OPARROW 52 /* structure pointer field reference */
#define OPNEG1 53 /* simple negation under forcedouble */
#define OPDMIN 54 /* min(a,b) macro under forcedouble */
#define OPDMAX 55 /* max(a,b) macro under forcedouble */
#define OPASSIGNI 56 /* assignment for inquire stmt */
#define OPIDENTITY 57 /* for turning TADDR into TEXPR */
#define OPCHARCAST 58 /* for casting to char * (in I/O stmts) */
#define OPDABS 59 /* abs macro under forcedouble */
#define OPMIN2 60 /* min(a,b) macro */
#define OPMAX2 61 /* max(a,b) macro */
/* label type codes -- used with the ASSIGN statement */
#define LABUNKNOWN 0
#define LABEXEC 1
#define LABFORMAT 2
#define LABOTHER 3
/* INTRINSIC function codes*/
#define INTREND 0
#define INTRCONV 1
#define INTRMIN 2
#define INTRMAX 3
#define INTRGEN 4 /* General intrinsic, e.g. cos v. dcos, zcos, ccos */
#define INTRSPEC 5
#define INTRBOOL 6
#define INTRCNST 7 /* constants, e.g. bigint(1.0) v. bigint (1d0) */
/* I/O statement codes - these all form Integer Constants, and are always
reevaluated */
#define IOSTDIN ICON(5)
#define IOSTDOUT ICON(6)
#define IOSTDERR ICON(0)
#define IOSBAD (-1)
#define IOSPOSITIONAL 0
#define IOSUNIT 1
#define IOSFMT 2
#define IOINQUIRE 1
#define IOOPEN 2
#define IOCLOSE 3
#define IOREWIND 4
#define IOBACKSPACE 5
#define IOENDFILE 6
#define IOREAD 7
#define IOWRITE 8
/* User name tags -- these identify the form of the original identifier
stored in a struct Addrblock structure (in the user field). */
#define UNAM_UNKNOWN 0 /* Not specified */
#define UNAM_NAME 1 /* Local symbol, store in the hash table */
#define UNAM_IDENT 2 /* Character string not stored elsewhere */
#define UNAM_EXTERN 3 /* External reference; check symbol table
using memno as index */
#define UNAM_CONST 4 /* Constant value */
#define UNAM_CHARP 5 /* pointer to string */
#define IDENT_LEN 31 /* Maximum length user.ident */
/* type masks - TYLOGICAL defined in ftypes */
#define MSKLOGICAL M(TYLOGICAL)
#define MSKADDR M(TYADDR)
#define MSKCHAR M(TYCHAR)
#define MSKINT M(TYSHORT)|M(TYLONG)
#define MSKREAL M(TYREAL)|M(TYDREAL) /* DREAL means Double Real */
#define MSKCOMPLEX M(TYCOMPLEX)|M(TYDCOMPLEX)
#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
/* miscellaneous macros */
/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is
the log of one of the OR'ed masks in y) */
#define ONEOF(x,y) (M(x) & (y))
#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
#define ISREAL(z) ONEOF(z, MSKREAL)
#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype))
/* ISCHAR assumes that z has some kind of structure, i.e. is not null */
#define ISCHAR(z) (z->headblock.vtype==TYCHAR)
#define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */
#define ISCONST(z) (z->tag==TCONST)
#define ISERROR(z) (z->tag==TERROR)
#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS)
#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR)
#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1)
#define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */
#define ICON(z) mkintcon( (ftnint)(z) )
/* NO66 -- F77 feature is being used
NOEXT -- F77 extension is being used */
#define NO66(s) if(no66flag) err66(s)
#define NOEXT(s) if(noextflag) errext(s)
/* round a up to the nearest multiple of b:
a = b * floor ( (a + (b - 1)) / b )*/
#define roundup(a,b) ( b * ( (a+b-1)/b) )

769
lang/fortran/comp/defs.h Normal file
View file

@ -0,0 +1,769 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories, Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "sysdep.h"
#include "ftypes.h"
#include "defines.h"
#include "machdefs.h"
#define MAXDIM 20
#define MAXINCLUDES 10
#define MAXLITERALS 200 /* Max number of constants in the literal
pool */
#define MAXTOKENLEN 302 /* length of longest token */
#define MAXCTL 20
#define MAXHASH 401
#define MAXSTNO 801
#define MAXEXT 200
#define MAXEQUIV 150
#define MAXLABLIST 125 /* Max number of labels in an alternate
return CALL */
/* These are the primary pointer types used in the compiler */
typedef union Expression *expptr, *tagptr;
typedef struct Chain *chainp;
typedef struct Addrblock *Addrp;
typedef struct Constblock *Constp;
typedef struct Exprblock *Exprp;
typedef struct Nameblock *Namep;
extern FILEP opf();
extern FILEP infile;
extern FILEP diagfile;
extern FILEP textfile;
extern FILEP asmfile;
extern FILEP c_file; /* output file for all functions; extern
declarations will have to be prepended */
extern FILEP pass1_file; /* Temp file to hold the function bodies
read on pass 1 */
extern FILEP expr_file; /* Debugging file */
extern FILEP initfile; /* Intermediate data file pointer */
extern FILEP blkdfile; /* BLOCK DATA file */
extern int current_ftn_file;
extern char *blkdfname, *initfname, *sortfname;
extern long int headoffset; /* Since the header block requires data we
don't know about until AFTER each
function has been processed, we keep a
pointer to the current (dummy) header
block (at the top of the assembly file)
here */
extern char main_alias[]; /* name given to PROGRAM psuedo-op */
extern char token [ ];
extern int toklen;
extern long lineno;
extern char *infname;
extern int needkwd;
extern struct Labelblock *thislabel;
/* Used to allow runtime expansion of internal tables. In particular,
these values can exceed their associated constants */
extern int maxctl;
extern int maxequiv;
extern int maxstno;
extern int maxhash;
extern int maxext;
extern flag nowarnflag;
extern flag ftn66flag; /* Generate warnings when weird f77
features are used (undeclared dummy
procedure, non-char initialized with
string, 1-dim subscript in EQUIV) */
extern flag no66flag; /* Generate an error when a generic
function (f77 feature) is used */
extern flag noextflag; /* Generate an error when an extension to
Fortran 77 is used (hex/oct/bin
constants, automatic, static, double
complex types) */
extern flag zflag; /* enable double complex intrinsics */
extern flag shiftcase;
extern flag undeftype;
extern flag shortsubs; /* Use short subscripts on arrays? */
extern flag onetripflag; /* if true, always execute DO loop body */
extern flag checksubs;
extern flag debugflag;
extern int nerr;
extern int nwarn;
extern int parstate;
extern flag headerdone; /* True iff the current procedure's header
data has been written */
extern int blklevel;
extern flag saveall;
extern flag substars; /* True iff some formal parameter is an
asterisk */
extern int impltype[ ];
extern ftnint implleng[ ];
extern int implstg[ ];
extern int tycomplex, tyint, tyioint, tyreal;
extern int tylogical; /* TY____ of the implementation of logical.
This will be LONG unless '-2' is given
on the command line */
extern int type_choice[];
extern char *typename[];
extern int typesize[]; /* size (in bytes) of an object of each
type. Indexed by TY___ macros */
extern int typealign[];
extern int proctype; /* Type of return value in this procedure */
extern char * procname; /* External name of the procedure, or last ENTRY name */
extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */
extern Addrp retslot;
extern Addrp xretslot[];
extern int cxslot; /* Complex return argument slot (frame pointer offset)*/
extern int chslot; /* Character return argument slot (fp offset) */
extern int chlgslot; /* Argument slot for length of character buffer */
extern int procclass; /* Class of the current procedure: either CLPROC,
CLMAIN, CLBLOCK or CLUNKNOWN */
extern ftnint procleng; /* Length of function return value (e.g. char
string length). If this is -1, then the length is
not known at compile time */
extern int nentry; /* Number of entry points (other than the original
function call) into this procedure */
extern flag multitype; /* YES iff there is more than one return value
possible */
extern int blklevel;
extern long lastiolabno;
extern int lastlabno;
extern int lastvarno;
extern int lastargslot; /* integer offset pointing to the next free
location for an argument to the current routine */
extern int argloc;
extern int autonum[]; /* for numbering
automatic variables, e.g. temporaries */
extern int retlabel;
extern int ret0label;
extern int dorange; /* Number of the label which terminates
the innermost DO loop */
extern int regnum[ ]; /* Numbers of DO indicies named in
regnamep (below) */
extern Namep regnamep[ ]; /* List of DO indicies in registers */
extern int maxregvar; /* number of elts in regnamep */
extern int highregvar; /* keeps track of the highest register
number used by DO index allocator */
extern int nregvar; /* count of DO indicies in registers */
extern chainp templist[];
extern int maxdim;
extern chainp earlylabs;
extern chainp holdtemps;
extern struct Entrypoint *entries;
extern struct Rplblock *rpllist;
extern struct Chain *curdtp;
extern ftnint curdtelt;
extern chainp allargs; /* union of args in entries */
extern int nallargs; /* total number of args */
extern int nallchargs; /* total number of character args */
extern flag toomanyinit; /* True iff too many initializers in a
DATA statement */
extern flag inioctl;
extern int iostmt;
extern Addrp ioblkp;
extern int nioctl;
extern int nequiv;
extern int eqvstart; /* offset to eqv number to guarantee uniqueness
and prevent <something> from going negative */
extern int nintnames;
/* Chain of tagged blocks */
struct Chain
{
chainp nextp;
char * datap; /* Tagged block */
};
extern chainp chains;
/* Recall that field is intended to hold four-bit characters */
/* This structure exists only to defeat the type checking */
struct Headblock
{
field tag;
field vtype;
field vclass;
field vstg;
expptr vleng; /* Expression for length of char string -
this may be a constant, or an argument
generated by mkarg() */
} ;
/* Control construct info (for do loops, else, etc) */
struct Ctlframe
{
unsigned ctltype:8;
unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */
unsigned dowhile:1;
int ctlabels[4]; /* Control labels, defined below */
int dolabel; /* label marking end of this DO loop */
Namep donamep; /* DO index variable */
expptr domax; /* constant or temp variable holding MAX
loop value; or expr of while(expr) */
expptr dostep; /* expression */
Namep loopname;
};
#define endlabel ctlabels[0]
#define elselabel ctlabels[1]
#define dobodylabel ctlabels[1]
#define doposlabel ctlabels[2]
#define doneglabel ctlabels[3]
extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF
structures - this is the stack
bottom */
extern struct Ctlframe *ctlstack; /* Pointer to current nesting
level */
extern struct Ctlframe *lastctl; /* Point to end of
dynamically-allocated array */
typedef struct {
int type;
chainp cp;
} Atype;
typedef struct {
int nargs, changes;
Atype atypes[1];
} Argtypes;
/* External Symbols */
struct Extsym
{
char *fextname; /* Fortran version of external name */
char *cextname; /* C version of external name */
field extstg; /* STG -- should be COMMON, UNKNOWN or EXT
*/
unsigned extype:4; /* for transmitting type to output routines */
unsigned used_here:1; /* Boolean - true on the second pass
through a function if the block has
been referenced */
unsigned exused:1; /* Has been used (for help with error msgs
about externals typed differently in
different modules) */
unsigned exproto:1; /* type specified in a .P file */
unsigned extinit:1; /* Procedure has been defined,
or COMMON has DATA */
unsigned extseen:1; /* True if previously referenced */
chainp extp; /* List of identifiers in the common
block for this function, stored as
Namep (hash table pointers) */
chainp allextp; /* List of lists of identifiers; we keep one
list for each layout of this common block */
int curno; /* current number for this common block,
used for constructing appending _nnn
to the common block name */
int maxno; /* highest curno value for this common block */
ftnint extleng;
ftnint maxleng;
Argtypes *arginfo;
};
typedef struct Extsym Extsym;
extern Extsym *extsymtab; /* External symbol table */
extern Extsym *nextext;
extern Extsym *lastext;
extern int complex_seen, dcomplex_seen;
/* Statement labels */
struct Labelblock
{
int labelno; /* Internal label */
unsigned blklevel:8; /* level of nesting , for branch-in-loop
checking */
unsigned labused:1;
unsigned fmtlabused:1;
unsigned labinacc:1; /* inaccessible? (i.e. has its scope
vanished) */
unsigned labdefined:1; /* YES or NO */
unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */
ftnint stateno; /* Original label */
char *fmtstring; /* format string */
};
extern struct Labelblock *labeltab; /* Label table - keeps track of
all labels, including undefined */
extern struct Labelblock *labtabend;
extern struct Labelblock *highlabtab;
/* Entry point list */
struct Entrypoint
{
struct Entrypoint *entnextp;
Extsym *entryname; /* Name of this ENTRY */
chainp arglist;
int typelabel; /* Label for function exit; this
will return the proper type of
object */
Namep enamep; /* External name */
};
/* Primitive block, or Primary block. This is a general template returned
by the parser, which will be interpreted in context. It is a template
for an identifier (variable name, function name), parenthesized
arguments (array subscripts, function parameters) and substring
specifications. */
struct Primblock
{
field tag;
field vtype;
Namep namep; /* Pointer to structure Nameblock */
struct Listblock *argsp;
expptr fcharp; /* first-char-index-pointer (in
substring) */
expptr lcharp; /* last-char-index-pointer (in
substring) */
};
struct Hashentry
{
int hashval;
Namep varp;
};
extern struct Hashentry *hashtab; /* Hash table */
extern struct Hashentry *lasthash;
struct Intrpacked /* bits for intrinsic function description */
{
unsigned f1:3;
unsigned f2:4;
unsigned f3:7;
unsigned f4:1;
};
struct Nameblock
{
field tag;
field vtype;
field vclass;
field vstg;
expptr vleng; /* length of character string, if applicable */
char *fvarname; /* name in the Fortran source */
char *cvarname; /* name in the resulting C */
chainp vlastdim; /* datap points to new_vars entry for the */
/* system variable, if any, storing the final */
/* dimension; we zero the datap if this */
/* variable is needed */
unsigned vprocclass:3; /* P____ macros - selects the varxptr
field below */
unsigned vdovar:1; /* "is it a DO variable?" for register
and multi-level loop checking */
unsigned vdcldone:1; /* "do I think I'm done?" - set when the
context is sufficient to determine its
status */
unsigned vadjdim:1; /* "adjustable dimension?" - needed for
information about copies */
unsigned vsave:1;
unsigned vimpldovar:1; /* used to prevent erroneous error messages
for variables used only in DATA stmt
implicit DOs */
unsigned vis_assigned:1;/* True if this variable has had some
label ASSIGNED to it; hence
varxptr.assigned_values is valid */
unsigned vimplstg:1; /* True if storage type is assigned implicitly;
this allows a COMMON variable to participate
in a DIMENSION before the COMMON declaration.
*/
unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */
unsigned vfmt_asg:1; /* True if char *var_fmt needed */
unsigned vpassed:1; /* True if passed as a character-variable arg */
unsigned vknownarg:1; /* True if seen in a previous entry point */
unsigned visused:1; /* True if variable is referenced -- so we */
/* can omit variables that only appear in DATA */
unsigned vnamelist:1; /* Appears in a NAMELIST */
unsigned vimpltype:1; /* True if implicitly typed and not
invoked as a function or subroutine
(so we can consistently type procedures
declared external and passed as args
but never invoked).
*/
unsigned vtypewarned:1; /* so we complain just once about
changed types of external procedures */
unsigned vinftype:1; /* so we can restore implicit type to a
procedure if it is invoked as a function
after being given a different type by -it */
unsigned vinfproc:1; /* True if -it infers this to be a procedure */
unsigned vcalled:1; /* has been invoked */
unsigned vdimfinish:1; /* need to invoke dim_finish() */
/* The vardesc union below is used to store the number of an intrinsic
function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
store the index of this external symbol in extsymtab (when vstg ==
STGEXT and vprocclass == PEXTERNAL) */
union {
int varno; /* Return variable for a function.
This is used when a function is
assigned a return value. Also
used to point to the COMMON
block, when this is a field of
that block. Also points to
EQUIV block when STGEQUIV */
struct Intrpacked intrdesc; /* bits for intrinsic function*/
} vardesc;
struct Dimblock *vdim; /* points to the dimensions if they exist */
ftnint voffset; /* offset in a storage block (the variable
name will be "v.%d", voffset in a
common blck on the vax). Also holds
pointers for automatic variables. When
STGEQUIV, this is -(offset from array
base) */
union {
chainp namelist; /* points to names in the NAMELIST,
if this is a NAMELIST name */
chainp vstfdesc; /* points to (formals, expr) pair */
chainp assigned_values; /* list of integers, each being a
statement label assigned to
this variable in the current function */
} varxptr;
int argno; /* for multiple entries */
Argtypes *arginfo;
};
/* PARAMETER statements */
struct Paramblock
{
field tag;
field vtype;
field vclass;
field vstg;
expptr vleng;
char *fvarname;
char *cvarname;
expptr paramval;
} ;
/* Expression block */
struct Exprblock
{
field tag;
field vtype;
field vclass;
field vstg;
expptr vleng; /* in the case of a character expression, this
value is inherited from the children */
unsigned opcode;
expptr leftp;
expptr rightp;
};
union Constant
{
struct {
char *ccp0;
ftnint blanks;
} ccp1;
ftnint ci; /* Constant long integer */
double cd[2];
char *cds[2];
};
#define ccp ccp1.ccp0
struct Constblock
{
field tag;
field vtype;
field vclass;
field vstg; /* vstg = 1 when using Const.cds */
expptr vleng;
union Constant Const;
};
struct Listblock
{
field tag;
field vtype;
chainp listp;
};
/* Address block - this is the FINAL form of identifiers before being
sent to pass 2. We'll want to add the original identifier here so that it can
be preserved in the translation.
An example identifier is q.7. The "q" refers to the storage class
(field vstg), the 7 to the variable number (int memno). */
struct Addrblock
{
field tag;
field vtype;
field vclass;
field vstg;
expptr vleng;
/* put union...user here so the beginning of an Addrblock
* is the same as a Constblock.
*/
union {
Namep name; /* contains a pointer into the hash table */
char ident[IDENT_LEN + 1]; /* C string form of identifier */
char *Charp;
union Constant Const; /* Constant value */
struct {
double dfill[2];
field vstg1;
} kludge; /* so we can distinguish string vs binary
* floating-point constants */
} user;
long memno; /* when vstg == STGCONST, this is the
numeric part of the assembler label
where the constant value is stored */
expptr memoffset; /* used in subscript computations, usually */
unsigned istemp:1; /* used in stack management of temporary
variables */
unsigned isarray:1; /* used to show that memoffset is
meaningful, even if zero */
unsigned ntempelt:10; /* for representing temporary arrays, as
in concatenation */
unsigned dbl_builtin:1; /* builtin to be declared double */
unsigned charleng:1; /* so saveargtypes can get i/o calls right */
ftnint varleng; /* holds a copy of a constant length which
is stored in the vleng field (e.g.
a double is 8 bytes) */
int uname_tag; /* Tag describing which of the unions()
below to use */
char *Field; /* field name when dereferencing a struct */
}; /* struct Addrblock */
/* Errorbock - placeholder for errors, to allow the compilation to
continue */
struct Errorblock
{
field tag;
field vtype;
};
/* Implicit DO block, especially related to DATA statements. This block
keeps track of the compiler's location in the implicit DO while it's
running. In particular, the isactive and isbusy flags tell where
it is */
struct Impldoblock
{
field tag;
unsigned isactive:1;
unsigned isbusy:1;
Namep varnp;
Constp varvp;
chainp impdospec;
expptr implb;
expptr impub;
expptr impstep;
ftnint impdiff;
ftnint implim;
struct Chain *datalist;
};
/* Each of these components has a first field called tag. This union
exists just for allocation simplicity */
union Expression
{
field tag;
struct Addrblock addrblock;
struct Constblock constblock;
struct Errorblock errorblock;
struct Exprblock exprblock;
struct Headblock headblock;
struct Impldoblock impldoblock;
struct Listblock listblock;
struct Nameblock nameblock;
struct Paramblock paramblock;
struct Primblock primblock;
} ;
struct Dimblock
{
int ndim;
expptr nelt; /* This is NULL if the array is unbounded */
expptr baseoffset; /* a constant or local variable holding
the offset in this procedure */
expptr basexpr; /* expression for comuting the offset, if
it's not constant. If this is
non-null, the register named in
baseoffset will get initialized to this
value in the procedure's prolog */
struct
{
expptr dimsize; /* constant or register holding the size
of this dimension */
expptr dimexpr; /* as above in basexpr, this is an
expression for computing a variable
dimension */
} dims[1]; /* Dimblocks are allocated with enough
space for this to become dims[ndim] */
};
/* Statement function identifier stack - this holds the name and value of
the parameters in a statement function invocation. For example,
f(x,y,z)=x+y+z
.
.
y = f(1,2,3)
generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
at the definition */
struct Rplblock /* name replacement block */
{
struct Rplblock *rplnextp;
Namep rplnp; /* Name of the formal parameter */
expptr rplvp; /* Value of the actual parameter */
expptr rplxp; /* Initialization of temporary variable,
if required; else null */
int rpltag; /* Tag on the value of the actual param */
};
/* Equivalence block */
struct Equivblock
{
struct Eqvchain *equivs; /* List (Eqvchain) of primblocks
holding variable identifiers */
flag eqvinit;
long int eqvtop;
long int eqvbottom;
int eqvtype;
} ;
#define eqvleng eqvtop
extern struct Equivblock *eqvclass;
struct Eqvchain
{
struct Eqvchain *eqvnextp;
union
{
struct Primblock *eqvlhs;
Namep eqvname;
} eqvitem;
long int eqvoffset;
} ;
/* For allocation purposes only, and to keep lint quiet. In particular,
don't count on the tag being able to tell you which structure is used */
/* There is a tradition in Fortran that the compiler not generate the same
bit pattern more than is necessary. This structure is used to do just
that; if two integer constants have the same bit pattern, just generate
it once. This could be expanded to optimize without regard to type, by
removing the type check in putconst() */
struct Literal
{
short littype;
short litnum; /* numeric part of the assembler
label for this constant value */
int lituse; /* usage count */
union {
ftnint litival;
double litdval[2];
ftnint litival2[2]; /* length, nblanks for strings */
} litval;
char *cds[2];
};
extern struct Literal *litpool;
extern int maxliterals, nliterals;
extern char Letters[];
#define letter(x) Letters[x]
struct Dims { expptr lb, ub; };
/* popular functions with non integer return values */
int *ckalloc();
char *varstr(), *nounder(), *addunder();
char *copyn(), *copys();
chainp hookup(), mkchain(), revchain();
ftnint convci();
char *convic();
char *setdoto();
double convcd();
Namep mkname();
struct Labelblock *mklabel(), *execlab();
Extsym *mkext(), *newentry();
expptr addrof(), call1(), call2(), call3(), call4();
Addrp builtin(), mktmp(), mktmp0(), mktmpn(), autovar();
Addrp mkplace(), mkaddr(), putconst(), memversion();
expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype();
expptr errnode(), mkaddcon(), mkintcon(), putcxop();
tagptr cpexpr();
ftnint lmin(), lmax(), iarrlen();
char *dbconst(), *flconst();
void puteq (), putex1 ();
expptr putx (), putsteq (), putassign ();
extern int forcedouble; /* force real functions to double */
extern int doin_setbound; /* special handling for array bounds */
extern int Ansi;
extern char *cds(), *cpstring(), *dtos(), *string_num();
extern char *c_type_decl();
extern char hextoi_tab[];
#define hextoi(x) hextoi_tab[(x) & 0xff]
extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
extern int Castargs, infertypes;
extern FILE *protofile;
extern void exit(), inferdcl(), protowrite(), save_argtypes();
extern char binread[], binwrite[], textread[], textwrite[];
extern char *ei_first, *ei_last, *ei_next;
extern char *wh_first, *wh_last, *wh_next;
extern void putwhile();
extern char *halign;

372
lang/fortran/comp/equiv.c Normal file
View file

@ -0,0 +1,372 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
LOCAL eqvcommon(), eqveqv(), nsubs();
/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
/* called at end of declarations section to process chains
created by EQUIVALENCE statements
*/
doequiv()
{
register int i;
int inequiv; /* True if one namep occurs in
several EQUIV declarations */
int comno; /* Index into Extsym table of the last
COMMON block seen (implicitly assuming
that only one will be given) */
int ovarno;
ftnint comoffset; /* Index into the COMMON block */
ftnint offset; /* Offset from array base */
ftnint leng;
register struct Equivblock *equivdecl;
register struct Eqvchain *q;
struct Primblock *primp;
register Namep np;
int k, k1, ns, pref, t;
chainp cp;
extern int type_pref[];
for(i = 0 ; i < nequiv ; ++i)
{
/* Handle each equivalence declaration */
equivdecl = &eqvclass[i];
equivdecl->eqvbottom = equivdecl->eqvtop = 0;
comno = -1;
for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
{
offset = 0;
primp = q->eqvitem.eqvlhs;
vardcl(np = primp->namep);
if(primp->argsp || primp->fcharp)
{
expptr offp, suboffset();
/* Pad ones onto the end of an array declaration when needed */
if(np->vdim!=NULL && np->vdim->ndim>1 &&
nsubs(primp->argsp)==1 )
{
if(! ftn66flag)
warni
("1-dim subscript in EQUIVALENCE, %d-dim declared",
np -> vdim -> ndim);
cp = NULL;
ns = np->vdim->ndim;
while(--ns > 0)
cp = mkchain((char *)ICON(1), cp);
primp->argsp->listp->nextp = cp;
}
offp = suboffset(primp);
if(ISICON(offp))
offset = offp->constblock.Const.ci;
else {
dclerr
("nonconstant subscript in equivalence ",
np);
np = NULL;
}
frexpr(offp);
}
/* Free up the primblock, since we now have a hash table (Namep) entry */
frexpr((expptr)primp);
if(np && (leng = iarrlen(np))<0)
{
dclerr("adjustable in equivalence", np);
np = NULL;
}
if(np) switch(np->vstg)
{
case STGUNKNOWN:
case STGBSS:
case STGEQUIV:
break;
case STGCOMMON:
/* The code assumes that all COMMON references in a given EQUIVALENCE will
be to the same COMMON block, and will all be consistent */
comno = np->vardesc.varno;
comoffset = np->voffset + offset;
break;
default:
dclerr("bad storage class in equivalence", np);
np = NULL;
break;
}
if(np)
{
q->eqvoffset = offset;
/* eqvbottom gets the largest difference between the array base address
and the address specified in the EQUIV declaration */
equivdecl->eqvbottom =
lmin(equivdecl->eqvbottom, -offset);
/* eqvtop gets the largest difference between the end of the array and
the address given in the EQUIVALENCE */
equivdecl->eqvtop =
lmax(equivdecl->eqvtop, leng-offset);
}
q->eqvitem.eqvname = np;
}
/* Now all equivalenced variables are in the hash table with the proper
offset, and eqvtop and eqvbottom are set. */
if(comno >= 0)
/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
*/
eqvcommon(equivdecl, comno, comoffset);
else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
{
if(np = q->eqvitem.eqvname)
{
inequiv = NO;
if(np->vstg==STGEQUIV)
if( (ovarno = np->vardesc.varno) == i)
{
/* Can't EQUIV different elements of the same array */
if(np->voffset + q->eqvoffset != 0)
dclerr
("inconsistent equivalence", np);
}
else {
offset = np->voffset;
inequiv = YES;
}
np->vstg = STGEQUIV;
np->vardesc.varno = i;
np->voffset = - q->eqvoffset;
if(inequiv)
/* Combine 2 equivalence declarations */
eqveqv(i, ovarno, q->eqvoffset + offset);
}
}
}
/* Now each equivalence declaration is distinct (all connections have been
merged in eqveqv()), and some may be empty. */
for(i = 0 ; i < nequiv ; ++i)
{
equivdecl = & eqvclass[i];
if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
/* a live chain */
k = TYCHAR;
pref = 1;
for(q = equivdecl->equivs ; q; q = q->eqvnextp)
if (np = q->eqvitem.eqvname){
np->voffset -= equivdecl->eqvbottom;
t = typealign[k1 = np->vtype];
if (pref < type_pref[k1]) {
k = k1;
pref = type_pref[k1];
}
if(np->voffset % t != 0) {
dclerr("bad alignment forced by equivalence", np);
--nerr; /* don't give bad return code for this */
}
}
equivdecl->eqvtype = k;
}
freqchain(equivdecl);
}
}
/* put equivalence chain p at common block comno + comoffset */
LOCAL eqvcommon(p, comno, comoffset)
struct Equivblock *p;
int comno;
ftnint comoffset;
{
int ovarno;
ftnint k, offq;
register Namep np;
register struct Eqvchain *q;
if(comoffset + p->eqvbottom < 0)
{
errstr("attempt to extend common %s backward",
extsymtab[comno].fextname);
freqchain(p);
return;
}
if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
extsymtab[comno].extleng = k;
for(q = p->equivs ; q ; q = q->eqvnextp)
if(np = q->eqvitem.eqvname)
{
switch(np->vstg)
{
case STGUNKNOWN:
case STGBSS:
np->vstg = STGCOMMON;
np->vcommequiv = 1;
np->vardesc.varno = comno;
/* np -> voffset will point to the base of the array */
np->voffset = comoffset - q->eqvoffset;
break;
case STGEQUIV:
ovarno = np->vardesc.varno;
/* offq will point to the current element, even if it's in an array */
offq = comoffset - q->eqvoffset - np->voffset;
np->vstg = STGCOMMON;
np->vcommequiv = 1;
np->vardesc.varno = comno;
/* np -> voffset will point to the base of the array */
np->voffset += offq;
if(ovarno != (p - eqvclass))
eqvcommon(&eqvclass[ovarno], comno, offq);
break;
case STGCOMMON:
if(comno != np->vardesc.varno ||
comoffset != np->voffset+q->eqvoffset)
dclerr("inconsistent common usage", np);
break;
default:
badstg("eqvcommon", np->vstg);
}
}
freqchain(p);
p->eqvbottom = p->eqvtop = 0;
}
/* Move all items on ovarno chain to the front of nvarno chain.
* adjust offsets of ovarno elements and top and bottom of nvarno chain
*/
LOCAL eqveqv(nvarno, ovarno, delta)
int ovarno, nvarno;
ftnint delta;
{
register struct Equivblock *neweqv, *oldeqv;
register Namep np;
struct Eqvchain *q, *q1;
neweqv = eqvclass + nvarno;
oldeqv = eqvclass + ovarno;
neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
oldeqv->eqvbottom = oldeqv->eqvtop = 0;
for(q = oldeqv->equivs ; q ; q = q1)
{
q1 = q->eqvnextp;
if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
{
q->eqvnextp = neweqv->equivs;
neweqv->equivs = q;
q->eqvoffset += delta;
np->vardesc.varno = nvarno;
np->voffset -= delta;
}
else free( (charptr) q);
}
oldeqv->equivs = NULL;
}
freqchain(p)
register struct Equivblock *p;
{
register struct Eqvchain *q, *oq;
for(q = p->equivs ; q ; q = oq)
{
oq = q->eqvnextp;
free( (charptr) q);
}
p->equivs = NULL;
}
/* nsubs -- number of subscripts in this arglist (just the length of the
list) */
LOCAL nsubs(p)
register struct Listblock *p;
{
register int n;
register chainp q;
n = 0;
if(p)
for(q = p->listp ; q ; q = q->nextp)
++n;
return(n);
}

252
lang/fortran/comp/error.c Normal file
View file

@ -0,0 +1,252 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
warni(s,t)
char *s;
int t;
{
char buf[100];
sprintf(buf,s,t);
warn(buf);
}
warn1(s,t)
char *s, *t;
{
char buff[100];
sprintf(buff, s, t);
warn(buff);
}
warn(s)
char *s;
{
if(nowarnflag)
return;
if (infname && *infname)
fprintf(diagfile, "Warning on line %ld of %s: %s\n",
lineno, infname, s);
else
fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s);
fflush(diagfile);
++nwarn;
}
errstr(s, t)
char *s, *t;
{
char buff[100];
sprintf(buff, s, t);
err(buff);
}
erri(s,t)
char *s;
int t;
{
char buff[100];
sprintf(buff, s, t);
err(buff);
}
errl(s,t)
char *s;
long t;
{
char buff[100];
sprintf(buff, s, t);
err(buff);
}
char *err_proc = 0;
err(s)
char *s;
{
if (err_proc)
fprintf(diagfile,
"Error processing %s before line %ld",
err_proc, lineno);
else
fprintf(diagfile, "Error on line %ld", lineno);
if (infname && *infname)
fprintf(diagfile, " of %s", infname);
fprintf(diagfile, ": %s\n", s);
fflush(diagfile);
++nerr;
}
yyerror(s)
char *s;
{
err(s);
}
dclerr(s, v)
char *s;
Namep v;
{
char buff[100];
if(v)
{
sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
err(buff);
}
else
errstr("Declaration error %s", s);
}
execerr(s, n)
char *s, *n;
{
char buf1[100], buf2[100];
sprintf(buf1, "Execution error %s", s);
sprintf(buf2, buf1, n);
err(buf2);
}
Fatal(t)
char *t;
{
fprintf(diagfile, "Compiler error line %ld", lineno);
if (infname)
fprintf(diagfile, " of %s", infname);
fprintf(diagfile, ": %s\n", t);
done(3);
}
fatalstr(t,s)
char *t, *s;
{
char buff[100];
sprintf(buff, t, s);
Fatal(buff);
}
fatali(t,d)
char *t;
int d;
{
char buff[100];
sprintf(buff, t, d);
Fatal(buff);
}
badthing(thing, r, t)
char *thing, *r;
int t;
{
char buff[50];
sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
Fatal(buff);
}
badop(r, t)
char *r;
int t;
{
badthing("opcode", r, t);
}
badtag(r, t)
char *r;
int t;
{
badthing("tag", r, t);
}
badstg(r, t)
char *r;
int t;
{
badthing("storage class", r, t);
}
badtype(r, t)
char *r;
int t;
{
badthing("type", r, t);
}
many(s, c, n)
char *s, c;
int n;
{
char buff[250];
sprintf(buff,
"Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n",
s, n, c, 2*n);
Fatal(buff);
}
err66(s)
char *s;
{
errstr("Fortran 77 feature used: %s", s);
--nerr;
}
errext(s)
char *s;
{
errstr("F77 compiler extension used: %s", s);
--nerr;
}

831
lang/fortran/comp/exec.c Normal file
View file

@ -0,0 +1,831 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "p1defs.h"
#include "names.h"
LOCAL void exar2(), popctl(), pushctl();
/* Logical IF codes
*/
exif(p)
expptr p;
{
pushctl(CTLIF);
putif(p, 0); /* 0 => if, not elseif */
}
exelif(p)
expptr p;
{
if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
putif(p, 1); /* 1 ==> elseif */
else
execerr("elseif out of place", CNULL);
}
exelse()
{
register struct Ctlframe *c;
for(c = ctlstack; c->ctltype == CTLIFX; --c);
if(c->ctltype == CTLIF) {
p1_else ();
c->ctltype = CTLELSE;
}
else
execerr("else out of place", CNULL);
}
exendif()
{
while(ctlstack->ctltype == CTLIFX) {
popctl();
p1else_end();
}
if(ctlstack->ctltype == CTLIF) {
popctl();
p1_endif ();
}
else if(ctlstack->ctltype == CTLELSE) {
popctl();
p1else_end ();
}
else
execerr("endif out of place", CNULL);
}
new_endif()
{
if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
pushctl(CTLIFX);
else
err("new_endif bug");
}
/* pushctl -- Start a new control construct, initialize the labels (to
zero) */
LOCAL void
pushctl(code)
int code;
{
register int i;
if(++ctlstack >= lastctl)
many("loops or if-then-elses", 'c', maxctl);
ctlstack->ctltype = code;
for(i = 0 ; i < 4 ; ++i)
ctlstack->ctlabels[i] = 0;
ctlstack->dowhile = 0;
++blklevel;
}
LOCAL void
popctl()
{
if( ctlstack-- < ctls )
Fatal("control stack empty");
--blklevel;
}
/* poplab -- update the flags in labeltab */
LOCAL poplab()
{
register struct Labelblock *lp;
for(lp = labeltab ; lp < highlabtab ; ++lp)
if(lp->labdefined)
{
/* mark all labels in inner blocks unreachable */
if(lp->blklevel > blklevel)
lp->labinacc = YES;
}
else if(lp->blklevel > blklevel)
{
/* move all labels referred to in inner blocks out a level */
lp->blklevel = blklevel;
}
}
/* BRANCHING CODE
*/
exgoto(lab)
struct Labelblock *lab;
{
lab->labused = 1;
p1_goto (lab -> stateno);
}
exequals(lp, rp)
register struct Primblock *lp;
register expptr rp;
{
if(lp->tag != TPRIM)
{
err("assignment to a non-variable");
frexpr((expptr)lp);
frexpr(rp);
}
else if(lp->namep->vclass!=CLVAR && lp->argsp)
{
if(parstate >= INEXEC)
err("statement function amid executables");
mkstfunct(lp, rp);
}
else
{
expptr new_lp, new_rp;
if(parstate < INDATA)
enddcl();
new_lp = mklhs (lp);
new_rp = fixtype (rp);
puteq(new_lp, new_rp);
}
}
/* Make Statement Function */
long laststfcn = -1, thisstno;
int doing_stmtfcn;
mkstfunct(lp, rp)
struct Primblock *lp;
expptr rp;
{
register struct Primblock *p;
register Namep np;
chainp args;
laststfcn = thisstno;
np = lp->namep;
if(np->vclass == CLUNKNOWN)
np->vclass = CLPROC;
else
{
dclerr("redeclaration of statement function", np);
return;
}
np->vprocclass = PSTFUNCT;
np->vstg = STGSTFUNCT;
/* Set the type of the function */
impldcl(np);
if (np->vtype == TYCHAR && !np->vleng)
err("character statement function with length (*)");
args = (lp->argsp ? lp->argsp->listp : CHNULL);
np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
for(doing_stmtfcn = 1 ; args ; args = args->nextp)
/* It is an error for the formal parameters to have arguments or
subscripts */
if( ((tagptr)(args->datap))->tag!=TPRIM ||
(p = (struct Primblock *)(args->datap) )->argsp ||
p->fcharp || p->lcharp )
err("non-variable argument in statement function definition");
else
{
/* Replace the name on the left-hand side */
args->datap = (char *)p->namep;
vardcl(p -> namep);
free((char *)p);
}
doing_stmtfcn = 0;
}
static void
mixed_type(np)
Namep np;
{
char buf[128];
sprintf(buf, "%s function %.90s invoked as subroutine",
ftn_types[np->vtype], np->fvarname);
warn(buf);
}
excall(name, args, nstars, labels)
Namep name;
struct Listblock *args;
int nstars;
struct Labelblock *labels[ ];
{
register expptr p;
if (name->vtype != TYSUBR) {
if (name->vinfproc && !name->vcalled) {
name->vtype = TYSUBR;
frexpr(name->vleng);
name->vleng = 0;
}
else if (!name->vimpltype && name->vtype != TYUNKNOWN)
mixed_type(name);
else
settype(name, TYSUBR, (ftnint)0);
}
p = mkfunct( mkprim(name, args, CHNULL) );
/* Subroutines and their identifiers acquire the type INT */
p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
/* Handle the alternate return mechanism */
if(nstars > 0)
putcmgo(putx(fixtype(p)), nstars, labels);
else
putexpr(p);
}
exstop(stop, p)
int stop;
register expptr p;
{
char *str;
int n;
expptr mkstrcon();
if(p)
{
if( ! ISCONST(p) )
{
execerr("pause/stop argument must be constant", CNULL);
frexpr(p);
p = mkstrcon(0, CNULL);
}
else if( ISINT(p->constblock.vtype) )
{
str = convic(p->constblock.Const.ci);
n = strlen(str);
if(n > 0)
{
p->constblock.Const.ccp = copyn(n, str);
p->constblock.Const.ccp1.blanks = 0;
p->constblock.vtype = TYCHAR;
p->constblock.vleng = (expptr) ICON(n);
}
else
p = (expptr) mkstrcon(0, CNULL);
}
else if(p->constblock.vtype != TYCHAR)
{
execerr("pause/stop argument must be integer or string", CNULL);
p = (expptr) mkstrcon(0, CNULL);
}
}
else p = (expptr) mkstrcon(0, CNULL);
{
expptr subr_call;
subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
putexpr( subr_call );
}
}
/* DO LOOP CODE */
#define DOINIT par[0]
#define DOLIMIT par[1]
#define DOINCR par[2]
/* Macros for ctlstack -> dostepsign */
#define VARSTEP 0
#define POSSTEP 1
#define NEGSTEP 2
/* exdo -- generate DO loop code. In the case of a variable increment,
positive increment tests are placed above the body, negative increment
tests are placed below (see enddo() ) */
exdo(range, loopname, spec)
int range; /* end label */
Namep loopname;
chainp spec; /* input spec must have at least 2 exprs */
{
register expptr p;
register Namep np;
chainp cp; /* loops over the fields in spec */
register int i;
int dotype; /* type of the index variable */
int incsign; /* sign of the increment, if it's constant
*/
Addrp dovarp; /* loop index variable */
expptr doinit; /* constant or register for init param */
expptr par[3]; /* local specification parameters */
expptr init, test, inc; /* Expressions in the resulting FOR loop */
test = ENULL;
pushctl(CTLDO);
dorange = ctlstack->dolabel = range;
ctlstack->loopname = loopname;
/* Declare the loop index */
np = (Namep)spec->datap;
ctlstack->donamep = NULL;
if (!np) { /* do while */
ctlstack->dowhile = 1;
#if 0
if (loopname) {
if (loopname->vtype == TYUNKNOWN) {
loopname->vdcldone = 1;
loopname->vclass = CLLABEL;
loopname->vprocclass = PLABEL;
loopname->vtype = TYLABEL;
}
if (loopname->vtype == TYLABEL)
if (loopname->vdovar)
dclerr("already in use as a loop name",
loopname);
else
loopname->vdovar = 1;
else
dclerr("already declared; cannot be a loop name",
loopname);
}
#endif
putwhile((expptr)spec->nextp);
NOEXT("do while");
spec->nextp = 0;
frchain(&spec);
return;
}
if(np->vdovar)
{
errstr("nested loops with variable %s", np->fvarname);
ctlstack->donamep = NULL;
return;
}
/* Create a memory-resident version of the index variable */
dovarp = mkplace(np);
if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
{
err("bad type on do variable");
return;
}
ctlstack->donamep = np;
np->vdovar = YES;
/* Now dovarp points to the index to be used within the loop, dostgp
points to the one which may need to be stored */
dotype = dovarp->vtype;
/* Count the input specifications and type-check each one independently;
this just eliminates non-numeric values from the specification */
for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
{
p = par[i++] = fixtype((tagptr)cp->datap);
if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
{
err("bad type on DO parameter");
return;
}
}
frchain(&spec);
switch(i)
{
case 0:
case 1:
err("too few DO parameters");
return;
default:
err("too many DO parameters");
return;
case 2:
DOINCR = (expptr) ICON(1);
case 3:
break;
}
/* Now all of the local specification fields are set, but their types are
not yet consistent */
/* Declare the loop initialization value, casting it properly and declaring a
register if need be */
if (ISCONST (DOINIT) || !onetripflag)
/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
since mkconv is called just before */
doinit = putx (mkconv (dotype, DOINIT));
else {
doinit = (expptr) mktmp(dotype, ENULL);
puteq (cpexpr (doinit), DOINIT);
} /* else */
/* Declare the loop ending value, casting it to the type of the index
variable */
if( ISCONST(DOLIMIT) )
ctlstack->domax = mkconv(dotype, DOLIMIT);
else {
ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
puteq (cpexpr (ctlstack -> domax), DOLIMIT);
} /* else */
/* Declare the loop increment value, casting it to the type of the index
variable */
if( ISCONST(DOINCR) )
{
ctlstack->dostep = mkconv(dotype, DOINCR);
if( (incsign = conssgn(ctlstack->dostep)) == 0)
err("zero DO increment");
ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
}
else
{
ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
ctlstack->dostepsign = VARSTEP;
puteq (cpexpr (ctlstack -> dostep), DOINCR);
}
/* All data is now properly typed and in the ctlstack, except for the
initial value. Assignments of temps have been generated already */
switch (ctlstack -> dostepsign) {
case VARSTEP:
test = mkexpr (OPQUEST, mkexpr (OPLT,
cpexpr (ctlstack -> dostep), ICON(0)),
mkexpr (OPCOLON,
mkexpr (OPGE, cpexpr((expptr)dovarp),
cpexpr (ctlstack -> domax)),
mkexpr (OPLE, cpexpr((expptr)dovarp),
cpexpr (ctlstack -> domax))));
break;
case POSSTEP:
test = mkexpr (OPLE, cpexpr((expptr)dovarp),
cpexpr (ctlstack -> domax));
break;
case NEGSTEP:
test = mkexpr (OPGE, cpexpr((expptr)dovarp),
cpexpr (ctlstack -> domax));
break;
default:
erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign);
break;
} /* switch (ctlstack -> dostepsign) */
if (onetripflag)
test = mkexpr (OPOR, test,
mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
&& ctlstack -> dostepsign != VARSTEP) {
expptr tester;
tester = mkexpr (OPMINUS, cpexpr (doinit),
cpexpr (ctlstack -> domax));
if (incsign == conssgn (tester))
warn ("DO range never executed");
frexpr (tester);
} /* if !onetripflag && */
p1_for (init, test, inc);
}
exenddo(np)
Namep np;
{
Namep np1;
int here;
struct Ctlframe *cf;
if( ctlstack < ctls )
Fatal("control stack empty");
here = ctlstack->dolabel;
if (ctlstack->ctltype != CTLDO || here >= 0) {
err("misplaced ENDDO");
return;
}
if (np != ctlstack->loopname) {
if (np1 = ctlstack->loopname)
errstr("expected \"enddo %s\"", np1->fvarname);
else
err("expected unnamed ENDDO");
for(cf = ctls; cf < ctlstack; cf++)
if (cf->ctltype == CTLDO && cf->loopname == np) {
here = cf->dolabel;
break;
}
}
enddo(here);
}
enddo(here)
int here;
{
register struct Ctlframe *q;
Namep np; /* name of the current DO index */
Addrp ap;
register int i;
register expptr e;
/* Many DO's can end at the same statement, so keep looping over all
nested indicies */
while(here == dorange)
{
if(np = ctlstack->donamep)
{
p1for_end ();
/* Now we're done with all of the tests, and the loop has terminated.
Store the index value back in long-term memory */
if(ap = memversion(np))
puteq((expptr)ap, (expptr)mkplace(np));
for(i = 0 ; i < 4 ; ++i)
ctlstack->ctlabels[i] = 0;
deregister(ctlstack->donamep);
ctlstack->donamep->vdovar = NO;
e = ctlstack->dostep;
if (e->tag == TADDR && e->addrblock.istemp)
frtemp((Addrp)e);
else
frexpr(e);
e = ctlstack->domax;
if (e->tag == TADDR && e->addrblock.istemp)
frtemp((Addrp)e);
else
frexpr(e);
}
else if (ctlstack->dowhile)
p1for_end ();
/* Set dorange to the closing label of the next most enclosing DO loop
*/
popctl();
poplab();
dorange = 0;
for(q = ctlstack ; q>=ctls ; --q)
if(q->ctltype == CTLDO)
{
dorange = q->dolabel;
break;
}
}
}
exassign(vname, labelval)
register Namep vname;
struct Labelblock *labelval;
{
Addrp p;
expptr mkaddcon();
register Addrp q;
static char nullstr[] = "";
char *fs;
register chainp cp, cpprev;
register ftnint k, stno;
p = mkplace(vname);
if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
err("noninteger assign variable");
return;
}
/* If the label hasn't been defined, then we do things twice:
* once for an executable stmt label, once for a format
*/
/* code for executable label... */
/* Now store the assigned value in a list associated with this variable.
This will be used later to generate a switch() statement in the C output */
if (!labelval->labdefined || !labelval->fmtstring) {
if (vname -> vis_assigned == 0) {
vname -> varxptr.assigned_values = CHNULL;
vname -> vis_assigned = 1;
}
/* don't duplicate labels... */
stno = labelval->stateno;
cpprev = 0;
for(k = 0, cp = vname->varxptr.assigned_values;
cp; cpprev = cp, cp = cp->nextp, k++)
if ((ftnint)cp->datap == stno)
break;
if (!cp) {
cp = mkchain((char *)stno, CHNULL);
if (cpprev)
cpprev->nextp = cp;
else
vname->varxptr.assigned_values = cp;
labelval->labused = 1;
}
putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
}
/* Code for FORMAT label... */
fs = labelval->fmtstring;
if (!labelval->labdefined || fs && fs != nullstr) {
extern void fmtname();
if (!fs)
labelval->fmtstring = nullstr;
labelval->fmtlabused = 1;
p = ALLOC(Addrblock);
p->tag = TADDR;
p->vtype = TYCHAR;
p->vstg = STGAUTO;
p->memoffset = ICON(0);
fmtname(vname, p);
q = ALLOC(Addrblock);
q->tag = TADDR;
q->vtype = TYCHAR;
q->vstg = STGAUTO;
q->ntempelt = 1;
q->memoffset = ICON(0);
q->uname_tag = UNAM_IDENT;
sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
}
} /* exassign */
exarif(expr, neglab, zerlab, poslab)
expptr expr;
struct Labelblock *neglab, *zerlab, *poslab;
{
register int lm, lz, lp;
lm = neglab->stateno;
lz = zerlab->stateno;
lp = poslab->stateno;
expr = fixtype(expr);
if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
{
err("invalid type of arithmetic if expression");
frexpr(expr);
}
else
{
if (lm == lz && lz == lp)
exgoto (neglab);
else if(lm == lz)
exar2(OPLE, expr, neglab, poslab);
else if(lm == lp)
exar2(OPNE, expr, neglab, zerlab);
else if(lz == lp)
exar2(OPGE, expr, zerlab, neglab);
else {
expptr t;
if (!addressable (expr)) {
t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
expr = mkexpr (OPASSIGN, cpexpr (t), expr);
} else
t = (expptr) cpexpr (expr);
p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
exgoto(neglab);
p1_elif (mkexpr (OPEQ, t, ICON (0)));
exgoto(zerlab);
p1_else ();
exgoto(poslab);
p1else_end ();
} /* else */
}
}
/* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0)
goto l2 else goto l1. If this seems backwards, that's because it is,
in order to make the 1 pass algorithm work. */
LOCAL void
exar2(op, e, l1, l2)
int op;
expptr e;
struct Labelblock *l1, *l2;
{
expptr comp;
comp = mkexpr (op, e, ICON (0));
p1_if(putx(fixtype(comp)));
exgoto(l1);
p1_else ();
exgoto(l2);
p1else_end ();
}
/* exreturn -- return the value in p from a SUBROUTINE call -- used to
implement the alternate return mechanism */
exreturn(p)
register expptr p;
{
if(procclass != CLPROC)
warn("RETURN statement in main or block data");
if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
{
err("alternate return in nonsubroutine");
p = 0;
}
if (p || proctype == TYSUBR) {
if (p == ENULL) p = ICON (0);
p = mkconv (TYLONG, fixtype (p));
p1_subr_ret (p);
} /* if p || proctype == TYSUBR */
else
p1_subr_ret((expptr)retslot);
}
exasgoto(labvar)
Namep labvar;
{
register Addrp p;
void p1_asgoto();
p = mkplace(labvar);
if( ! ISINT(p->vtype) )
err("assigned goto variable must be integer");
else {
p1_asgoto (p);
} /* else */
}

2882
lang/fortran/comp/expr.c Normal file
View file

File diff suppressed because it is too large Load diff

182
lang/fortran/comp/f2c.1 Normal file
View file

@ -0,0 +1,182 @@
F2C(1) F2C(1)
NAME
f2c - Convert Fortran 77 to C or C++
SYNOPSIS
f2c [ option ... ] file ...
DESCRIPTION
F2c converts Fortran 77 source code in files with names end-
ing in `.f' or `.F' to C (or C++) source files in the
current directory, with `.c' substituted for the final `.f'
or `.F'. If no Fortran files are named, f2c reads Fortran
from standard input and writes C on standard output. File
names that end with `.p' or `.P' are taken to be prototype
files, as produced by option `-P', and are read first.
The following options have the same meaning as in f77(1).
-C Compile code to check that subscripts are within
declared array bounds.
-I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long
int. Assume the default libF77 and libI77: allow only
INTEGER*4 (and no LOGICAL) variables in INQUIREs.
Option `-I4' confirms the default rendering of INTEGER
as long int.
-onetrip
Compile DO loops that are performed at least once if
reached. (Fortran 77 DO loops are not performed at all
if the upper limit is smaller than the lower limit.)
-U Honor the case of variable and external names. Fortran
keywords must be in lower case.
-u Make the default type of a variable `undefined' rather
than using the default Fortran rules.
-w Suppress all warning messages. If the option is
`-w66', only Fortran 66 compatibility warnings are
suppressed.
The following options are peculiar to f2c.
-A Produce ANSI C. Default is old-style C.
-a Make local variables automatic rather than static
unless they appear in a DATA, EQUIVALENCE, NAMELIST, or
SAVE statement.
-C++ Output C++ code.
-c Include original Fortran source as comments.
Page 1 Tenth Edition (printed 4/25/91)
F2C(1) F2C(1)
-E Declare uninitialized COMMON to be Extern (overridably
defined in f2c.h as extern).
-ec Place uninitialized COMMON blocks in separate files:
COMMON /ABC/ appears in file abc_com.c. Option `-e1c'
bundles the separate files into the output file, with
comments that give an unbundling sed(1) script.
-ext Complain about f77(1) extensions.
-g Include original Fortran line numbers as comments.
-h Try to align character strings on word (or, if the
option is `-hd', on double-word) boundaries.
-i2 Similar to -I2, but assume a modified libF77 and libI77
(compiled with -Df2c_i2), so INTEGER and LOGICAL vari-
ables may be assigned by INQUIRE and array lengths are
stored in short ints.
-kr Use temporary values to enforce Fortran expression
evaluation where K&R (first edition) parenthesization
rules allow rearrangement. If the option is `-krd',
use double precision temporaries even for single-
precision operands.
-P Write a file.P of ANSI (or C++) prototypes for pro-
cedures defined in each input file.f or file.F. When
reading Fortran from standard input, write prototypes
at the beginning of standard output. Implies -A unless
option `-C++' is present. Option -Ps implies -P , and
gives exit status 4 if rerunning f2c may change proto-
types or declarations.
-p Supply preprocessor definitions to make common-block
members look like local variables.
-R Do not promote REAL functions and operations to DOUBLE
PRECISION. Option `-!R' confirms the default, which
imitates f77.
-r Cast values of REAL functions (including intrinsics) to
REAL.
-r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
COMPLEX.
-Tdir
Put temporary files in directory dir.
-w8 Suppress warnings when COMMON or EQUIVALENCE forces
odd-word alignment of doubles.
Page 2 Tenth Edition (printed 4/25/91)
F2C(1) F2C(1)
-Wn Assume n characters/word (default 4) when initializing
numeric variables with character data.
-z Do not implicitly recognize DOUBLE COMPLEX.
-!bs Do not recognize backslash escapes (\", \', \0, \\, \b,
\f, \n, \r, \t, \v) in character strings.
-!c Inhibit C output, but produce -P output.
-!I Reject include statements.
-!it Don't infer types of untyped EXTERNAL procedures from
use as parameters to previously defined or prototyped
procedures.
-!P Do not attempt to infer ANSI or C++ prototypes from
usage.
The resulting C invokes the support routines of f77; object
code should be loaded by f77 or with ld(1) or cc(1) options
-lF77 -lI77 -lm. Calling conventions are those of f77: see
the reference below.
FILES
file.[fF]
input file
*.c output file
/usr/include/f2c.h
header file
/usr/lib/libF77.a
intrinsic function library
/usr/lib/libI77.a
Fortran I/O library
/lib/libc.a
C library, see section 3
SEE ALSO
S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77
Compiler', UNIX Time Sharing System Programmer's Manual,
Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
DIAGNOSTICS
The diagnostics produced by f2c are intended to be self-
explanatory.
BUGS
Page 3 Tenth Edition (printed 4/25/91)
F2C(1) F2C(1)
Floating-point constant expressions are simplified in the
floating-point arithmetic of the machine running f2c, so
they are typically accurate to at most 16 or 17 decimal
places.
Untypable EXTERNAL functions are declared int.
Page 4 Tenth Edition (printed 4/25/91)

326
lang/fortran/comp/f2c.1t Normal file
View file

@ -0,0 +1,326 @@
. \" Definitions of F, L and LR for the benefit of systems
. \" whose -man lacks them...
.de F
.nh
.if n \%\&\\$1
.if t \%\&\f(CW\\$1\fR
.hy 14
..
.de L
.nh
.if n \%`\\$1'
.if t \%\&\f(CW\\$1\fR
.hy 14
..
.de LR
.nh
.if n \%`\\$1'\\$2
.if t \%\&\f(CW\\$1\fR\\$2
.hy 14
..
.TH F2C 1
.CT 1 prog_other
.SH NAME
f\^2c \(mi Convert Fortran 77 to C or C++
.SH SYNOPSIS
.B f\^2c
[
.I option ...
]
.I file ...
.SH DESCRIPTION
.I F2c
converts Fortran 77 source code in
.I files
with names ending in
.L .f
or
.L .F
to C (or C++) source files in the
current directory, with
.L .c
substituted
for the final
.L .f
or
.LR .F .
If no Fortran files are named,
.I f\^2c
reads Fortran from standard input and
writes C on standard output.
.I File
names that end with
.L .p
or
.L .P
are taken to be prototype
files, as produced by option
.LR -P ,
and are read first.
.PP
The following options have the same meaning as in
.IR f\^77 (1).
.TP
.B -C
Compile code to check that subscripts are within declared array bounds.
.TP
.B -I2
Render INTEGER and LOGICAL as short,
INTEGER\(**4 as long int. Assume the default \fIlibF77\fR
and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL)
variables in INQUIREs. Option
.L -I4
confirms the default rendering of INTEGER as long int.
.TP
.B -onetrip
Compile DO loops that are performed at least once if reached.
(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
.TP
.B -U
Honor the case of variable and external names. Fortran keywords must be in
.I
lower
case.
.TP
.B -u
Make the default type of a variable `undefined' rather than using the default Fortran rules.
.TP
.B -w
Suppress all warning messages.
If the option is
.LR -w66 ,
only Fortran 66 compatibility warnings are suppressed.
.PP
The following options are peculiar to
.IR f\^2c .
.TP
.B -A
Produce
.SM ANSI
C.
Default is old-style C.
.TP
.B -a
Make local variables automatic rather than static
unless they appear in a
.SM "DATA, EQUIVALENCE, NAMELIST,"
or
.SM SAVE
statement.
.TP
.B -C++
Output C++ code.
.TP
.B -c
Include original Fortran source as comments.
.TP
.B -E
Declare uninitialized
.SM COMMON
to be
.B Extern
(overridably defined in
.F f2c.h
as
.B extern).
.TP
.B -ec
Place uninitialized
.SM COMMON
blocks in separate files:
.B COMMON /ABC/
appears in file
.BR abc_com.c .
Option
.LR -e1c
bundles the separate files
into the output file, with comments that give an unbundling
.IR sed (1)
script.
.TP
.B -ext
Complain about
.IR f\^77 (1)
extensions.
.TP
.B -g
Include original Fortran line numbers as comments.
.TP
.B -h
Try to align character strings on word (or, if the option is
.LR -hd ,
on double-word) boundaries.
.TP
.B -i2
Similar to
.BR -I2 ,
but assume a modified
.I libF77
and
.I libI77
(compiled with
.BR -Df\^2c_i2 ),
so
.SM INTEGER
and
.SM LOGICAL
variables may be assigned by
.SM INQUIRE
and array lengths are stored in short ints.
.TP
.B -kr
Use temporary values to enforce Fortran expression evaluation
where K&R (first edition) parenthesization rules allow rearrangement.
If the option is
.LR -krd ,
use double precision temporaries even for single-precision operands.
.TP
.B -P
Write a
.IB file .P
of ANSI (or C++) prototypes
for procedures defined in each input
.IB file .f
or
.IB file .F .
When reading Fortran from standard input, write prototypes
at the beginning of standard output.
Implies
.B -A
unless option
.L -C++
is present. Option
.B -Ps
implies
.B -P ,
and gives exit status 4 if rerunning
.I f\^2c
may change prototypes or declarations.
.TP
.B -p
Supply preprocessor definitions to make common-block members
look like local variables.
.TP
.B -R
Do not promote
.SM REAL
functions and operations to
.SM DOUBLE PRECISION.
Option
.L -!R
confirms the default, which imitates
.IR f\^77 .
.TP
.B -r
Cast values of REAL functions (including intrinsics) to REAL.
.TP
.B -r8
Promote
.SM REAL
to
.SM DOUBLE PRECISION, COMPLEX
to
.SM DOUBLE COMPLEX.
.TP
.BI -T dir
Put temporary files in directory
.I dir.
.TP
.B -w8
Suppress warnings when
.SM COMMON
or
.SM EQUIVALENCE
forces odd-word alignment of doubles.
.TP
.BI -W n
Assume
.I n
characters/word (default 4)
when initializing numeric variables with character data.
.TP
.B -z
Do not implicitly recognize
.SM DOUBLE COMPLEX.
.TP
.B -!bs
Do not recognize \fIb\fRack\fIs\fRlash escapes
(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
.TP
.B -!c
Inhibit C output, but produce
.B -P
output.
.TP
.B -!I
Reject
.B include
statements.
.TP
.B -!it
Don't infer types of untyped
.SM EXTERNAL
procedures from use as parameters to previously defined or prototyped
procedures.
.TP
.B -!P
Do not attempt to infer
.SM ANSI
or C++
prototypes from usage.
.PP
The resulting C invokes the support routines of
.IR f\^77 ;
object code should be loaded by
.I f\^77
or with
.IR ld (1)
or
.IR cc (1)
options
.BR "-lF77 -lI77 -lm" .
Calling conventions
are those of
.IR f\&77 :
see the reference below.
.br
.SH FILES
.TP
.IB file .[fF]
input file
.TP
.B *.c
output file
.TP
.F /usr/include/f2c.h
header file
.TP
.F /usr/lib/libF77.a
intrinsic function library
.TP
.F /usr/lib/libI77.a
Fortran I/O library
.TP
.F /lib/libc.a
C library, see section 3
.SH "SEE ALSO"
S. I. Feldman and
P. J. Weinberger,
`A Portable Fortran 77 Compiler',
\fIUNIX Time Sharing System Programmer's Manual\fR,
Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
.SH DIAGNOSTICS
The diagnostics produced by
.I f\^2c
are intended to be
self-explanatory.
.SH BUGS
Floating-point constant expressions are simplified in
the floating-point arithmetic of the machine running
.IR f\^2c ,
so they are typically accurate to at most 16 or 17 decimal places.
.br
Untypable
.SM EXTERNAL
functions are declared
.BR int .

317
lang/fortran/comp/f2c.6 Normal file
View file

@ -0,0 +1,317 @@
. \" Definitions of F, L and LR for the benefit of systems
. \" whose -man lacks them...
.de F
.nh
.if n \%\&\\$1
.if t \%\&\f(CW\\$1\fR
.hy 14
..
.de L
.nh
.if n \%`\\$1'
.if t \%\&\f(CW\\$1\fR
.hy 14
..
.de LR
.nh
.if n \%`\\$1'\\$2
.if t \%\&\f(CW\\$1\fR\\$2
.hy 14
..
.TH F2C 6
.CT 1 prog_other
.SH NAME
f\^2c \(mi Convert Fortran 77 to C or C++
.SH SYNOPSIS
.B ~em/lib.bin/f\^2c
[
.I option ...
]
.I file ...
.SH DESCRIPTION
.I F2c
converts Fortran 77 source code in
.I files
with names ending in
.L .f
or
.L .F
to C (or C++) source files in the
current directory, with
.L .c
substituted
for the final
.L .f
or
.LR .F .
If no Fortran files are named,
.I f\^2c
reads Fortran from standard input and
writes C on standard output.
.I File
names that end with
.L .p
or
.L .P
are taken to be prototype
files, as produced by option
.LR -P ,
and are read first.
.PP
The following options have the same meaning as in
.IR f\^77 (1).
.TP
.B -C
Compile code to check that subscripts are within declared array bounds.
.TP
.B -I2
Render INTEGER and LOGICAL as short,
INTEGER\(**4 as long int. Assume the default \fIlibF77\fR
and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL)
variables in INQUIREs. Option
.L -I4
confirms the default rendering of INTEGER as long int.
.TP
.B -onetrip
Compile DO loops that are performed at least once if reached.
(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
.TP
.B -U
Honor the case of variable and external names. Fortran keywords must be in
.I
lower
case.
.TP
.B -u
Make the default type of a variable `undefined' rather than using the default Fortran rules.
.TP
.B -w
Suppress all warning messages.
If the option is
.LR -w66 ,
only Fortran 66 compatibility warnings are suppressed.
.PP
The following options are peculiar to
.IR f\^2c .
.TP
.B -A
Produce
.SM ANSI
C.
Default is old-style C.
.TP
.B -a
Make local variables automatic rather than static
unless they appear in a
.SM "DATA, EQUIVALENCE, NAMELIST,"
or
.SM SAVE
statement.
.TP
.B -C++
Output C++ code.
.TP
.B -c
Include original Fortran source as comments.
.TP
.B -E
Declare uninitialized
.SM COMMON
to be
.B Extern
(overridably defined in
.F f2c.h
as
.B extern).
.TP
.B -ec
Place uninitialized
.SM COMMON
blocks in separate files:
.B COMMON /ABC/
appears in file
.BR abc_com.c .
Option
.LR -e1c
bundles the separate files
into the output file, with comments that give an unbundling
.IR sed (1)
script.
.TP
.B -ext
Complain about
.IR f\^77 (1)
extensions.
.TP
.B -g
Include original Fortran line numbers as comments.
.TP
.B -h
Try to align character strings on word (or, if the option is
.LR -hd ,
on double-word) boundaries.
.TP
.B -i2
Similar to
.BR -I2 ,
but assume a modified
.I libF77
and
.I libI77
(compiled with
.BR -Df\^2c_i2 ),
so
.SM INTEGER
and
.SM LOGICAL
variables may be assigned by
.SM INQUIRE
and array lengths are stored in short ints.
.TP
.B -kr
Use temporary values to enforce Fortran expression evaluation
where K&R (first edition) parenthesization rules allow rearrangement.
If the option is
.LR -krd ,
use double precision temporaries even for single-precision operands.
.TP
.B -P
Write a
.IB file .P
of ANSI (or C++) prototypes
for procedures defined in each input
.IB file .f
or
.IB file .F .
When reading Fortran from standard input, write prototypes
at the beginning of standard output.
Implies
.B -A
unless option
.L -C++
is present. Option
.B -Ps
implies
.B -P ,
and gives exit status 4 if rerunning
.I f\^2c
may change prototypes or declarations.
.TP
.B -p
Supply preprocessor definitions to make common-block members
look like local variables.
.TP
.B -R
Do not promote
.SM REAL
functions and operations to
.SM DOUBLE PRECISION.
Option
.L -!R
confirms the default, which imitates
.IR f\^77 .
.TP
.B -r
Cast values of REAL functions (including intrinsics) to REAL.
.TP
.B -r8
Promote
.SM REAL
to
.SM DOUBLE PRECISION, COMPLEX
to
.SM DOUBLE COMPLEX.
.TP
.BI -T dir
Put temporary files in directory
.I dir.
.TP
.B -w8
Suppress warnings when
.SM COMMON
or
.SM EQUIVALENCE
forces odd-word alignment of doubles.
.TP
.BI -W n
Assume
.I n
characters/word (default 4)
when initializing numeric variables with character data.
.TP
.B -z
Do not implicitly recognize
.SM DOUBLE COMPLEX.
.TP
.B -!bs
Do not recognize \fIb\fRack\fIs\fRlash escapes
(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
.TP
.B -!c
Inhibit C output, but produce
.B -P
output.
.TP
.B -!I
Reject
.B include
statements.
.TP
.B -!it
Don't infer types of untyped
.SM EXTERNAL
procedures from use as parameters to previously defined or prototyped
procedures.
.TP
.B -!P
Do not attempt to infer
.SM ANSI
or C++
prototypes from usage.
.PP
The resulting C invokes the support routines of
.IR f\^77 ;
object code should be loaded by
.I f\^77
or with
.IR ld (1)
or
.IR cc (1)
options
.BR "-lF77 -lI77 -lm" .
Calling conventions
are those of
.IR f\&77 :
see the reference below.
.br
.SH FILES
.TP
.IB file .[fF]
input file
.TP
.B *.c
output file
.TP
.F ~em/include/fortran/f2c.h
header file
.SH "SEE ALSO"
S. I. Feldman and
P. J. Weinberger,
`A Portable Fortran 77 Compiler',
\fIUNIX Time Sharing System Programmer's Manual\fR,
Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
.SH DIAGNOSTICS
The diagnostics produced by
.I f\^2c
are intended to be
self-explanatory.
.SH BUGS
Floating-point constant expressions are simplified in
the floating-point arithmetic of the machine running
.IR f\^2c ,
so they are typically accurate to at most 16 or 17 decimal places.
.br
Untypable
.SM EXTERNAL
functions are declared
.BR int .

209
lang/fortran/comp/f2c.h Normal file
View file

@ -0,0 +1,209 @@
/* f2c.h -- Standard Fortran to C header file */
/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
#ifndef F2C_INCLUDE
#define F2C_INCLUDE
typedef long int integer;
typedef char *address;
typedef short int shortint;
typedef float real;
typedef double doublereal;
typedef struct { real r, i; } complex;
typedef struct { doublereal r, i; } doublecomplex;
typedef long int logical;
typedef short int shortlogical;
#define TRUE_ (1)
#define FALSE_ (0)
/* Extern is for use with -E */
#ifndef Extern
#define Extern extern
#endif
/* I/O stuff */
#ifdef f2c_i2
/* for -i2 */
typedef short flag;
typedef short ftnlen;
typedef short ftnint;
#else
typedef long flag;
typedef long ftnlen;
typedef long ftnint;
#endif
/*external read, write*/
typedef struct
{ flag cierr;
ftnint ciunit;
flag ciend;
char *cifmt;
ftnint cirec;
} cilist;
/*internal read, write*/
typedef struct
{ flag icierr;
char *iciunit;
flag iciend;
char *icifmt;
ftnint icirlen;
ftnint icirnum;
} icilist;
/*open*/
typedef struct
{ flag oerr;
ftnint ounit;
char *ofnm;
ftnlen ofnmlen;
char *osta;
char *oacc;
char *ofm;
ftnint orl;
char *oblnk;
} olist;
/*close*/
typedef struct
{ flag cerr;
ftnint cunit;
char *csta;
} cllist;
/*rewind, backspace, endfile*/
typedef struct
{ flag aerr;
ftnint aunit;
} alist;
/* inquire */
typedef struct
{ flag inerr;
ftnint inunit;
char *infile;
ftnlen infilen;
ftnint *inex; /*parameters in standard's order*/
ftnint *inopen;
ftnint *innum;
ftnint *innamed;
char *inname;
ftnlen innamlen;
char *inacc;
ftnlen inacclen;
char *inseq;
ftnlen inseqlen;
char *indir;
ftnlen indirlen;
char *infmt;
ftnlen infmtlen;
char *inform;
ftnint informlen;
char *inunf;
ftnlen inunflen;
ftnint *inrecl;
ftnint *innrec;
char *inblank;
ftnlen inblanklen;
} inlist;
#define VOID void
union Multitype { /* for multiple entry points */
shortint h;
integer i;
real r;
doublereal d;
complex c;
doublecomplex z;
};
typedef union Multitype Multitype;
typedef long Long; /* No longer used; formerly in Namelist */
struct Vardesc { /* for Namelist */
char *name;
char *addr;
ftnlen *dims;
int type;
};
typedef struct Vardesc Vardesc;
struct Namelist {
char *name;
Vardesc **vars;
int nvars;
};
typedef struct Namelist Namelist;
#define abs(x) ((x) >= 0 ? (x) : -(x))
#define dabs(x) (doublereal)abs(x)
#define min(a,b) ((a) <= (b) ? (a) : (b))
#define max(a,b) ((a) >= (b) ? (a) : (b))
#define dmin(a,b) (doublereal)min(a,b)
#define dmax(a,b) (doublereal)max(a,b)
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
#ifdef __cplusplus
typedef int /* Unknown procedure type */ (*U_fp)(...);
typedef shortint (*J_fp)(...);
typedef integer (*I_fp)(...);
typedef real (*R_fp)(...);
typedef doublereal (*D_fp)(...), (*E_fp)(...);
typedef /* Complex */ VOID (*C_fp)(...);
typedef /* Double Complex */ VOID (*Z_fp)(...);
typedef logical (*L_fp)(...);
typedef shortlogical (*K_fp)(...);
typedef /* Character */ VOID (*H_fp)(...);
typedef /* Subroutine */ int (*S_fp)(...);
#else
typedef int /* Unknown procedure type */ (*U_fp)();
typedef shortint (*J_fp)();
typedef integer (*I_fp)();
typedef real (*R_fp)();
typedef doublereal (*D_fp)(), (*E_fp)();
typedef /* Complex */ VOID (*C_fp)();
typedef /* Double Complex */ VOID (*Z_fp)();
typedef logical (*L_fp)();
typedef shortlogical (*K_fp)();
typedef /* Character */ VOID (*H_fp)();
typedef /* Subroutine */ int (*S_fp)();
#endif
/* E_fp is for real functions when -R is not specified */
typedef VOID C_f; /* complex function */
typedef VOID H_f; /* character function */
typedef VOID Z_f; /* double complex function */
typedef doublereal E_f; /* real function with -R not specified */
/* undef any lower-case symbols that your C compiler predefines, e.g.: */
#ifndef Skip_f2c_Undefs
#undef cray
#undef gcos
#undef mc68010
#undef mc68020
#undef mips
#undef pdp11
#undef sgi
#undef sparc
#undef sun
#undef sun2
#undef sun3
#undef sun4
#undef u370
#undef u3b
#undef u3b2
#undef u3b5
#undef unix
#undef vax
#endif
#endif

2108
lang/fortran/comp/format.c Normal file
View file

File diff suppressed because it is too large Load diff

10
lang/fortran/comp/format.h Normal file
View file

@ -0,0 +1,10 @@
#define DEF_C_LINE_LENGTH 77
/* actual max will be 79 */
extern int c_output_line_length; /* max # chars per line in C source
code */
char *wr_ardecls (/* FILE *, struct Dimblock * */);
void list_init_data (), wr_one_init (), wr_output_values ();
int do_init_data ();
chainp data_value ();

1037
lang/fortran/comp/formatdata.c Normal file
View file

File diff suppressed because it is too large Load diff

39
lang/fortran/comp/ftypes.h Normal file
View file

@ -0,0 +1,39 @@
/* variable types (stored in the vtype field of expptr)
* numeric assumptions:
* int < reals < complexes
* TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
*/
#define TYUNKNOWN 0
#define TYADDR 1
#define TYSHORT 2
#define TYLONG 3
#define TYREAL 4
#define TYDREAL 5
#define TYCOMPLEX 6
#define TYDCOMPLEX 7
#define TYLOGICAL 8
#define TYCHAR 9
#define TYSUBR 10
#define TYERROR 11
#define TYCILIST 12
#define TYICILIST 13
#define TYOLIST 14
#define TYCLLIST 15
#define TYALIST 16
#define TYINLIST 17
#define TYVOID 18
#define TYLABEL 19
#define TYFTNLEN 20
/* TYVOID is not in any tables. */
/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
type. Such tables can include the size (in bytes) of objects of a given
type, or labels for returning objects of different types from procedures
(see array rtvlabels) */
#define NTYPES TYVOID
#define NTYPES0 TYCILIST
#define TYBLANK TYSUBR /* Huh? */

399
lang/fortran/comp/gram.dcl Normal file
View file

@ -0,0 +1,399 @@
spec: dcl
| common
| external
| intrinsic
| equivalence
| data
| implicit
| namelist
| SSAVE
{ NO66("SAVE statement");
saveall = YES; }
| SSAVE savelist
{ NO66("SAVE statement"); }
| SFORMAT
{ fmtstmt(thislabel); setfmt(thislabel); }
| SPARAM in_dcl SLPAR paramlist SRPAR
{ NO66("PARAMETER statement"); }
;
dcl: type opt_comma name in_dcl new_dcl dims lengspec
{ settype($3, $1, $7);
if(ndim>0) setbound($3,ndim,dims);
}
| dcl SCOMMA name dims lengspec
{ settype($3, $1, $5);
if(ndim>0) setbound($3,ndim,dims);
}
| dcl SSLASHD datainit vallist SSLASHD
{ if (new_dcl == 2) {
err("attempt to give DATA in type-declaration");
new_dcl = 1;
}
}
;
new_dcl: { new_dcl = 2; }
type: typespec lengspec
{ varleng = $2;
if (vartype == TYLOGICAL && varleng == 1) {
varleng = 0;
err("treating LOGICAL*1 as LOGICAL");
--nerr; /* allow generation of .c file */
}
}
;
typespec: typename
{ varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
vartype = $1; }
;
typename: SINTEGER { $$ = TYLONG; }
| SREAL { $$ = tyreal; }
| SCOMPLEX { ++complex_seen; $$ = tycomplex; }
| SDOUBLE { $$ = TYDREAL; }
| SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
| SLOGICAL { $$ = TYLOGICAL; }
| SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; }
| SUNDEFINED { $$ = TYUNKNOWN; }
| SDIMENSION { $$ = TYUNKNOWN; }
| SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
| SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; }
;
lengspec:
{ $$ = varleng; }
| SSTAR intonlyon expr intonlyoff
{
expptr p;
p = $3;
NO66("length specification *n");
if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
{
$$ = 0;
dclerr("length must be a positive integer constant",
NPNULL);
}
else {
if (vartype == TYCHAR)
$$ = p->constblock.Const.ci;
else switch((int)p->constblock.Const.ci) {
case 1: $$ = 1; break;
case 2: $$ = typesize[TYSHORT]; break;
case 4: $$ = typesize[TYLONG]; break;
case 8: $$ = typesize[TYDREAL]; break;
case 16: $$ = typesize[TYDCOMPLEX]; break;
default:
dclerr("invalid length",NPNULL);
$$ = varleng;
}
}
}
| SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
{ NO66("length specification *(*)"); $$ = -1; }
;
common: SCOMMON in_dcl var
{ incomm( $$ = comblock("") , $3 ); }
| SCOMMON in_dcl comblock var
{ $$ = $3; incomm($3, $4); }
| common opt_comma comblock opt_comma var
{ $$ = $3; incomm($3, $5); }
| common SCOMMA var
{ incomm($1, $3); }
;
comblock: SCONCAT
{ $$ = comblock(""); }
| SSLASH SNAME SSLASH
{ $$ = comblock(token); }
;
external: SEXTERNAL in_dcl name
{ setext($3); }
| external SCOMMA name
{ setext($3); }
;
intrinsic: SINTRINSIC in_dcl name
{ NO66("INTRINSIC statement"); setintr($3); }
| intrinsic SCOMMA name
{ setintr($3); }
;
equivalence: SEQUIV in_dcl equivset
| equivalence SCOMMA equivset
;
equivset: SLPAR equivlist SRPAR
{
struct Equivblock *p;
if(nequiv >= maxequiv)
many("equivalences", 'q', maxequiv);
p = & eqvclass[nequiv++];
p->eqvinit = NO;
p->eqvbottom = 0;
p->eqvtop = 0;
p->equivs = $2;
}
;
equivlist: lhs
{ $$=ALLOC(Eqvchain);
$$->eqvitem.eqvlhs = (struct Primblock *)$1;
}
| equivlist SCOMMA lhs
{ $$=ALLOC(Eqvchain);
$$->eqvitem.eqvlhs = (struct Primblock *) $3;
$$->eqvnextp = $1;
}
;
data: SDATA in_data datalist
| data opt_comma datalist
;
in_data:
{ if(parstate == OUTSIDE)
{
newproc();
startproc(ESNULL, CLMAIN);
}
if(parstate < INDATA)
{
enddcl();
parstate = INDATA;
datagripe = 1;
}
}
;
datalist: datainit datavarlist SSLASH datapop vallist SSLASH
{ ftnint junk;
if(nextdata(&junk) != NULL)
err("too few initializers");
frdata($2);
frrpl();
}
;
datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
datapop: /* nothing */ { pop_datastack(); }
vallist: { toomanyinit = NO; } val
| vallist SCOMMA val
;
val: value
{ dataval(ENULL, $1); }
| simple SSTAR value
{ dataval($1, $3); }
;
value: simple
| addop simple
{ if( $1==OPMINUS && ISCONST($2) )
consnegop((Constp)$2);
$$ = $2;
}
| complex_const
;
savelist: saveitem
| savelist SCOMMA saveitem
;
saveitem: name
{ int k;
$1->vsave = YES;
k = $1->vstg;
if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
dclerr("can only save static variables", $1);
}
| comblock
;
paramlist: paramitem
| paramlist SCOMMA paramitem
;
paramitem: name SEQUALS expr
{ if($1->vclass == CLUNKNOWN)
make_param((struct Paramblock *)$1, $3);
else dclerr("cannot make into parameter", $1);
}
;
var: name dims
{ if(ndim>0) setbound($1, ndim, dims); }
;
datavar: lhs
{ Namep np;
np = ( (struct Primblock *) $1) -> namep;
vardcl(np);
if(np->vstg == STGCOMMON)
extsymtab[np->vardesc.varno].extinit = YES;
else if(np->vstg==STGEQUIV)
eqvclass[np->vardesc.varno].eqvinit = YES;
else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
dclerr("inconsistent storage classes", np);
$$ = mkchain((char *)$1, CHNULL);
}
| SLPAR datavarlist SCOMMA dospec SRPAR
{ chainp p; struct Impldoblock *q;
pop_datastack();
q = ALLOC(Impldoblock);
q->tag = TIMPLDO;
(q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
p = $4->nextp;
if(p) { q->implb = (expptr)(p->datap); p = p->nextp; }
if(p) { q->impub = (expptr)(p->datap); p = p->nextp; }
if(p) { q->impstep = (expptr)(p->datap); }
frchain( & ($4) );
$$ = mkchain((char *)q, CHNULL);
q->datalist = hookup($2, $$);
}
;
datavarlist: datavar
{ if (!datastack)
curdtp = 0;
datastack = mkchain((char *)curdtp, datastack);
curdtp = $1; curdtelt = 0;
}
| datavarlist SCOMMA datavar
{ $$ = hookup($1, $3); }
;
dims:
{ ndim = 0; }
| SLPAR dimlist SRPAR
;
dimlist: { ndim = 0; } dim
| dimlist SCOMMA dim
;
dim: ubound
{
if(ndim == maxdim)
err("too many dimensions");
else if(ndim < maxdim)
{ dims[ndim].lb = 0;
dims[ndim].ub = $1;
}
++ndim;
}
| expr SCOLON ubound
{
if(ndim == maxdim)
err("too many dimensions");
else if(ndim < maxdim)
{ dims[ndim].lb = $1;
dims[ndim].ub = $3;
}
++ndim;
}
;
ubound: SSTAR
{ $$ = 0; }
| expr
;
labellist: label
{ nstars = 1; labarray[0] = $1; }
| labellist SCOMMA label
{ if(nstars < MAXLABLIST) labarray[nstars++] = $3; }
;
label: SICON
{ $$ = execlab( convci(toklen, token) ); }
;
implicit: SIMPLICIT in_dcl implist
{ NO66("IMPLICIT statement"); }
| implicit SCOMMA implist
;
implist: imptype SLPAR letgroups SRPAR
| imptype
{ if (vartype != TYUNKNOWN)
dclerr("-- expected letter range",NPNULL);
setimpl(vartype, varleng, 'a', 'z'); }
;
imptype: { needkwd = 1; } type
/* { vartype = $2; } */
;
letgroups: letgroup
| letgroups SCOMMA letgroup
;
letgroup: letter
{ setimpl(vartype, varleng, $1, $1); }
| letter SMINUS letter
{ setimpl(vartype, varleng, $1, $3); }
;
letter: SNAME
{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
{
dclerr("implicit item must be single letter", NPNULL);
$$ = 0;
}
else $$ = token[0];
}
;
namelist: SNAMELIST
| namelist namelistentry
;
namelistentry: SSLASH name SSLASH namelistlist
{
if($2->vclass == CLUNKNOWN)
{
$2->vclass = CLNAMELIST;
$2->vtype = TYINT;
$2->vstg = STGBSS;
$2->varxptr.namelist = $4;
$2->vardesc.varno = ++lastvarno;
}
else dclerr("cannot be a namelist name", $2);
}
;
namelistlist: name
{ $$ = mkchain((char *)$1, CHNULL); }
| namelistlist SCOMMA name
{ $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
;
in_dcl:
{ switch(parstate)
{
case OUTSIDE: newproc();
startproc(ESNULL, CLMAIN);
case INSIDE: parstate = INDCL;
case INDCL: break;
case INDATA:
if (datagripe) {
errstr(
"Statement order error: declaration after DATA",
CNULL);
datagripe = 0;
}
break;
default:
dclerr("declaration among executables", NPNULL);
}
}
;

143
lang/fortran/comp/gram.exec Normal file
View file

@ -0,0 +1,143 @@
exec: iffable
| SDO end_spec intonlyon label intonlyoff opt_comma dospecw
{
if($4->labdefined)
execerr("no backward DO loops", CNULL);
$4->blklevel = blklevel+1;
exdo($4->labelno, NPNULL, $7);
}
| SDO end_spec opt_comma dospecw
{
exdo((int)(ctls - ctlstack - 2), NPNULL, $4);
NOEXT("DO without label");
}
| SENDDO
{ exenddo(NPNULL); }
| logif iffable
{ exendif(); thiswasbranch = NO; }
| logif STHEN
| SELSEIF end_spec SLPAR expr SRPAR STHEN
{ exelif($4); lastwasbranch = NO; }
| SELSE end_spec
{ exelse(); lastwasbranch = NO; }
| SENDIF end_spec
{ exendif(); lastwasbranch = NO; }
;
logif: SLOGIF end_spec SLPAR expr SRPAR
{ exif($4); }
;
dospec: name SEQUALS exprlist
{ $$ = mkchain((char *)$1, $3); }
;
dospecw: dospec
| SWHILE SLPAR expr SRPAR
{ $$ = mkchain(CNULL, (chainp)$3); }
;
iffable: let lhs SEQUALS expr
{ exequals((struct Primblock *)$2, $4); }
| SASSIGN end_spec assignlabel STO name
{ exassign($5, $3); }
| SCONTINUE end_spec
| goto
| io
{ inioctl = NO; }
| SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label
{ exarif($4, $6, $8, $10); thiswasbranch = YES; }
| call
{ excall($1, LBNULL, 0, labarray); }
| call SLPAR SRPAR
{ excall($1, LBNULL, 0, labarray); }
| call SLPAR callarglist SRPAR
{ if(nstars < MAXLABLIST)
excall($1, mklist(revchain($3)), nstars, labarray);
else
err("too many alternate returns");
}
| SRETURN end_spec opt_expr
{ exreturn($3); thiswasbranch = YES; }
| stop end_spec opt_expr
{ exstop($1, $3); thiswasbranch = $1; }
;
assignlabel: SICON
{ $$ = mklabel( convci(toklen, token) ); }
;
let: SLET
{ if(parstate == OUTSIDE)
{
newproc();
startproc(ESNULL, CLMAIN);
}
}
;
goto: SGOTO end_spec label
{ exgoto($3); thiswasbranch = YES; }
| SASGOTO end_spec name
{ exasgoto($3); thiswasbranch = YES; }
| SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
{ exasgoto($3); thiswasbranch = YES; }
| SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
{ if(nstars < MAXLABLIST)
putcmgo(putx(fixtype($7)), nstars, labarray);
else
err("computed GOTO list too long");
}
;
opt_comma:
| SCOMMA
;
call: SCALL end_spec name
{ nstars = 0; $$ = $3; }
;
callarglist: callarg
{ $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; }
| callarglist SCOMMA callarg
{ $$ = $3 ? mkchain((char *)$3, $1) : $1; }
;
callarg: expr
| SSTAR label
{ if(nstars<MAXLABLIST) labarray[nstars++] = $2; $$ = 0; }
;
stop: SPAUSE
{ $$ = 0; }
| SSTOP
{ $$ = 1; }
;
exprlist: expr
{ $$ = mkchain((char *)$1, CHNULL); }
| exprlist SCOMMA expr
{ $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
;
end_spec:
{ if(parstate == OUTSIDE)
{
newproc();
startproc(ESNULL, CLMAIN);
}
/* This next statement depends on the ordering of the state table encoding */
if(parstate < INDATA) enddcl();
}
;
intonlyon:
{ intonly = YES; }
;
intonlyoff:
{ intonly = NO; }
;

141
lang/fortran/comp/gram.expr Normal file
View file

@ -0,0 +1,141 @@
funarglist:
{ $$ = 0; }
| funargs
{ $$ = revchain($1); }
;
funargs: expr
{ $$ = mkchain((char *)$1, CHNULL); }
| funargs SCOMMA expr
{ $$ = mkchain((char *)$3, $1); }
;
expr: uexpr
| SLPAR expr SRPAR { $$ = $2; }
| complex_const
;
uexpr: lhs
| simple_const
| expr addop expr %prec SPLUS
{ $$ = mkexpr($2, $1, $3); }
| expr SSTAR expr
{ $$ = mkexpr(OPSTAR, $1, $3); }
| expr SSLASH expr
{ $$ = mkexpr(OPSLASH, $1, $3); }
| expr SPOWER expr
{ $$ = mkexpr(OPPOWER, $1, $3); }
| addop expr %prec SSTAR
{ if($1 == OPMINUS)
$$ = mkexpr(OPNEG, $2, ENULL);
else $$ = $2;
}
| expr relop expr %prec SEQ
{ $$ = mkexpr($2, $1, $3); }
| expr SEQV expr
{ NO66(".EQV. operator");
$$ = mkexpr(OPEQV, $1,$3); }
| expr SNEQV expr
{ NO66(".NEQV. operator");
$$ = mkexpr(OPNEQV, $1, $3); }
| expr SOR expr
{ $$ = mkexpr(OPOR, $1, $3); }
| expr SAND expr
{ $$ = mkexpr(OPAND, $1, $3); }
| SNOT expr
{ $$ = mkexpr(OPNOT, $2, ENULL); }
| expr SCONCAT expr
{ NO66("concatenation operator //");
$$ = mkexpr(OPCONCAT, $1, $3); }
;
addop: SPLUS { $$ = OPPLUS; }
| SMINUS { $$ = OPMINUS; }
;
relop: SEQ { $$ = OPEQ; }
| SGT { $$ = OPGT; }
| SLT { $$ = OPLT; }
| SGE { $$ = OPGE; }
| SLE { $$ = OPLE; }
| SNE { $$ = OPNE; }
;
lhs: name
{ $$ = mkprim($1, LBNULL, CHNULL); }
| name substring
{ NO66("substring operator :");
$$ = mkprim($1, LBNULL, $2); }
| name SLPAR funarglist SRPAR
{ $$ = mkprim($1, mklist($3), CHNULL); }
| name SLPAR funarglist SRPAR substring
{ NO66("substring operator :");
$$ = mkprim($1, mklist($3), $5); }
;
substring: SLPAR opt_expr SCOLON opt_expr SRPAR
{ $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); }
;
opt_expr:
{ $$ = 0; }
| expr
;
simple: name
{ if($1->vclass == CLPARAM)
$$ = (expptr) cpexpr(
( (struct Paramblock *) ($1) ) -> paramval);
}
| simple_const
;
simple_const: STRUE { $$ = mklogcon(1); }
| SFALSE { $$ = mklogcon(0); }
| SHOLLERITH { $$ = mkstrcon(toklen, token); }
| SICON = { $$ = mkintcon( convci(toklen, token) ); }
| SRCON = { $$ = mkrealcon(tyreal, token); }
| SDCON = { $$ = mkrealcon(TYDREAL, token); }
| bit_const
;
complex_const: SLPAR uexpr SCOMMA uexpr SRPAR
{ $$ = mkcxcon($2,$4); }
;
bit_const: SHEXCON
{ NOEXT("hex constant");
$$ = mkbitcon(4, toklen, token); }
| SOCTCON
{ NOEXT("octal constant");
$$ = mkbitcon(3, toklen, token); }
| SBITCON
{ NOEXT("binary constant");
$$ = mkbitcon(1, toklen, token); }
;
fexpr: unpar_fexpr
| SLPAR fexpr SRPAR
{ $$ = $2; }
;
unpar_fexpr: lhs
| simple_const
| fexpr addop fexpr %prec SPLUS
{ $$ = mkexpr($2, $1, $3); }
| fexpr SSTAR fexpr
{ $$ = mkexpr(OPSTAR, $1, $3); }
| fexpr SSLASH fexpr
{ $$ = mkexpr(OPSLASH, $1, $3); }
| fexpr SPOWER fexpr
{ $$ = mkexpr(OPPOWER, $1, $3); }
| addop fexpr %prec SSTAR
{ if($1 == OPMINUS)
$$ = mkexpr(OPNEG, $2, ENULL);
else $$ = $2;
}
| fexpr SCONCAT fexpr
{ NO66("concatenation operator //");
$$ = mkexpr(OPCONCAT, $1, $3); }
;

299
lang/fortran/comp/gram.head Normal file
View file

@ -0,0 +1,299 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories, Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
%{
# include "defs.h"
# include "p1defs.h"
static int nstars; /* Number of labels in an
alternate return CALL */
static int datagripe;
static int ndim;
static int vartype;
int new_dcl;
static ftnint varleng;
static struct Dims dims[MAXDIM+1];
static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
return CALL */
/* The next two variables are used to verify that each statement might be reached
during runtime. lastwasbranch is tested only in the defintion of the
stat: nonterminal. */
int lastwasbranch = NO;
static int thiswasbranch = NO;
extern ftnint yystno;
extern flag intonly;
static chainp datastack;
extern long laststfcn, thisstno;
extern int can_include; /* for netlib */
ftnint convci();
Addrp nextdata();
expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
expptr mkcxcon();
struct Listblock *mklist();
struct Listblock *mklist();
struct Impldoblock *mkiodo();
Extsym *comblock();
#define ESNULL (Extsym *)0
#define NPNULL (Namep)0
#define LBNULL (struct Listblock *)0
extern void freetemps(), make_param();
static void
pop_datastack() {
chainp d0 = datastack;
if (d0->datap)
curdtp = (chainp)d0->datap;
datastack = d0->nextp;
d0->nextp = 0;
frchain(&d0);
}
%}
/* Specify precedences and associativities. */
%union {
int ival;
ftnint lval;
char *charpval;
chainp chval;
tagptr tagval;
expptr expval;
struct Labelblock *labval;
struct Nameblock *namval;
struct Eqvchain *eqvval;
Extsym *extval;
}
%left SCOMMA
%nonassoc SCOLON
%right SEQUALS
%left SEQV SNEQV
%left SOR
%left SAND
%left SNOT
%nonassoc SLT SGT SLE SGE SEQ SNE
%left SCONCAT
%left SPLUS SMINUS
%left SSTAR SSLASH
%right SPOWER
%start program
%type <labval> thislabel label assignlabel
%type <tagval> other inelt
%type <ival> type typespec typename dcl letter addop relop stop nameeq
%type <lval> lengspec
%type <charpval> filename
%type <chval> datavar datavarlist namelistlist funarglist funargs
%type <chval> dospec dospecw
%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
%type <namval> name arg call var
%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
%type <expval> ubound simple value callarg complex_const simple_const bit_const
%type <extval> common comblock entryname progname
%type <eqvval> equivlist
%%
program:
| program stat SEOS
;
stat: thislabel entry
{
/* stat: is the nonterminal for Fortran statements */
lastwasbranch = NO; }
| thislabel spec
| thislabel exec
{ /* forbid further statement function definitions... */
if (parstate == INDATA && laststfcn != thisstno)
parstate = INEXEC;
thisstno++;
if($1 && ($1->labelno==dorange))
enddo($1->labelno);
if(lastwasbranch && thislabel==NULL)
warn("statement cannot be reached");
lastwasbranch = thiswasbranch;
thiswasbranch = NO;
if($1)
{
if($1->labtype == LABFORMAT)
err("label already that of a format");
else
$1->labtype = LABEXEC;
}
freetemps();
}
| thislabel SINCLUDE filename
{ if (can_include)
doinclude( $3 );
else {
fprintf(diagfile, "Cannot open file %s\n", $3);
done(1);
}
}
| thislabel SEND end_spec
{ if ($1)
lastwasbranch = NO;
endproc(); /* lastwasbranch = NO; -- set in endproc() */
}
| thislabel SUNKNOWN
{ extern void unclassifiable();
unclassifiable();
/* flline flushes the current line, ignoring the rest of the text there */
flline(); };
| error
{ flline(); needkwd = NO; inioctl = NO;
yyerrok; yyclearin; }
;
thislabel: SLABEL
{
if(yystno != 0)
{
$$ = thislabel = mklabel(yystno);
if( ! headerdone ) {
if (procclass == CLUNKNOWN)
procclass = CLMAIN;
puthead(CNULL, procclass);
}
if(thislabel->labdefined)
execerr("label %s already defined",
convic(thislabel->stateno) );
else {
if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
&& thislabel->labtype!=LABFORMAT)
warn1("there is a branch to label %s from outside block",
convic( (ftnint) (thislabel->stateno) ) );
thislabel->blklevel = blklevel;
thislabel->labdefined = YES;
if(thislabel->labtype != LABFORMAT)
p1_label((long)(thislabel - labeltab));
}
}
else $$ = thislabel = NULL;
}
;
entry: SPROGRAM new_proc progname
{startproc($3, CLMAIN); }
| SPROGRAM new_proc progname progarglist
{ warn("ignoring arguments to main program");
/* hashclear(); */
startproc($3, CLMAIN); }
| SBLOCK new_proc progname
{ if($3) NO66("named BLOCKDATA");
startproc($3, CLBLOCK); }
| SSUBROUTINE new_proc entryname arglist
{ entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); }
| SFUNCTION new_proc entryname arglist
{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
| type SFUNCTION new_proc entryname arglist
{ entrypt(CLPROC, $1, varleng, $4, $5); }
| SENTRY entryname arglist
{ if(parstate==OUTSIDE || procclass==CLMAIN
|| procclass==CLBLOCK)
execerr("misplaced entry statement", CNULL);
entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
}
;
new_proc:
{ newproc(); }
;
entryname: name
{ $$ = newentry($1, 1); }
;
name: SNAME
{ $$ = mkname(token); }
;
progname: { $$ = NULL; }
| entryname
;
progarglist:
SLPAR SRPAR
| SLPAR progargs SRPAR
;
progargs: progarg
| progargs SCOMMA progarg
;
progarg: SNAME
| SNAME SEQUALS SNAME
;
arglist:
{ $$ = 0; }
| SLPAR SRPAR
{ NO66(" () argument list");
$$ = 0; }
| SLPAR args SRPAR
{$$ = $2; }
;
args: arg
{ $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
| args SCOMMA arg
{ if($3) $1 = $$ = mkchain((char *)$3, $1); }
;
arg: name
{ if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
dclerr("name declared as argument after use", $1);
$1->vstg = STGARG;
}
| SSTAR
{ NO66("altenate return argument");
/* substars means that '*'ed formal parameters should be replaced.
This is used to specify alternate return labels; in theory, only
parameter slots which have '*' should accept the statement labels.
This compiler chooses to ignore the '*'s in the formal declaration, and
always return the proper value anyway.
This variable is only referred to in proc.c */
$$ = 0; substars = YES; }
;
filename: SHOLLERITH
{
char *s;
s = copyn(toklen+1, token);
s[toklen] = '\0';
$$ = s;
}
;

173
lang/fortran/comp/gram.io Normal file
View file

@ -0,0 +1,173 @@
/* Input/Output Statements */
io: io1
{ endio(); }
;
io1: iofmove ioctl
| iofmove unpar_fexpr
{ ioclause(IOSUNIT, $2); endioctl(); }
| iofmove SSTAR
{ ioclause(IOSUNIT, ENULL); endioctl(); }
| iofmove SPOWER
{ ioclause(IOSUNIT, IOSTDERR); endioctl(); }
| iofctl ioctl
| read ioctl
{ doio(CHNULL); }
| read infmt
{ doio(CHNULL); }
| read ioctl inlist
{ doio(revchain($3)); }
| read infmt SCOMMA inlist
{ doio(revchain($4)); }
| read ioctl SCOMMA inlist
{ doio(revchain($4)); }
| write ioctl
{ doio(CHNULL); }
| write ioctl outlist
{ doio(revchain($3)); }
| print
{ doio(CHNULL); }
| print SCOMMA outlist
{ doio(revchain($3)); }
;
iofmove: fmkwd end_spec in_ioctl
;
fmkwd: SBACKSPACE
{ iostmt = IOBACKSPACE; }
| SREWIND
{ iostmt = IOREWIND; }
| SENDFILE
{ iostmt = IOENDFILE; }
;
iofctl: ctlkwd end_spec in_ioctl
;
ctlkwd: SINQUIRE
{ iostmt = IOINQUIRE; }
| SOPEN
{ iostmt = IOOPEN; }
| SCLOSE
{ iostmt = IOCLOSE; }
;
infmt: unpar_fexpr
{
ioclause(IOSUNIT, ENULL);
ioclause(IOSFMT, $1);
endioctl();
}
| SSTAR
{
ioclause(IOSUNIT, ENULL);
ioclause(IOSFMT, ENULL);
endioctl();
}
;
ioctl: SLPAR fexpr SRPAR
{
ioclause(IOSUNIT, $2);
endioctl();
}
| SLPAR ctllist SRPAR
{ endioctl(); }
;
ctllist: ioclause
| ctllist SCOMMA ioclause
;
ioclause: fexpr
{ ioclause(IOSPOSITIONAL, $1); }
| SSTAR
{ ioclause(IOSPOSITIONAL, ENULL); }
| SPOWER
{ ioclause(IOSPOSITIONAL, IOSTDERR); }
| nameeq expr
{ ioclause($1, $2); }
| nameeq SSTAR
{ ioclause($1, ENULL); }
| nameeq SPOWER
{ ioclause($1, IOSTDERR); }
;
nameeq: SNAMEEQ
{ $$ = iocname(); }
;
read: SREAD end_spec in_ioctl
{ iostmt = IOREAD; }
;
write: SWRITE end_spec in_ioctl
{ iostmt = IOWRITE; }
;
print: SPRINT end_spec fexpr in_ioctl
{
iostmt = IOWRITE;
ioclause(IOSUNIT, ENULL);
ioclause(IOSFMT, $3);
endioctl();
}
| SPRINT end_spec SSTAR in_ioctl
{
iostmt = IOWRITE;
ioclause(IOSUNIT, ENULL);
ioclause(IOSFMT, ENULL);
endioctl();
}
;
inlist: inelt
{ $$ = mkchain((char *)$1, CHNULL); }
| inlist SCOMMA inelt
{ $$ = mkchain((char *)$3, $1); }
;
inelt: lhs
{ $$ = (tagptr) $1; }
| SLPAR inlist SCOMMA dospec SRPAR
{ $$ = (tagptr) mkiodo($4,revchain($2)); }
;
outlist: uexpr
{ $$ = mkchain((char *)$1, CHNULL); }
| other
{ $$ = mkchain((char *)$1, CHNULL); }
| out2
;
out2: uexpr SCOMMA uexpr
{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
| uexpr SCOMMA other
{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
| other SCOMMA uexpr
{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
| other SCOMMA other
{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
| out2 SCOMMA uexpr
{ $$ = mkchain((char *)$3, $1); }
| out2 SCOMMA other
{ $$ = mkchain((char *)$3, $1); }
;
other: complex_const
{ $$ = (tagptr) $1; }
| SLPAR expr SRPAR
{ $$ = (tagptr) $2; }
| SLPAR uexpr SCOMMA dospec SRPAR
{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
| SLPAR other SCOMMA dospec SRPAR
{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
| SLPAR out2 SCOMMA dospec SRPAR
{ $$ = (tagptr) mkiodo($4, revchain($2)); }
;
in_ioctl:
{ startioctl(); }
;

446
lang/fortran/comp/init.c Normal file
View file

@ -0,0 +1,446 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "output.h"
#include "iob.h"
/* State required for the C output */
char *fl_fmt_string; /* Float format string */
char *db_fmt_string; /* Double format string */
char *cm_fmt_string; /* Complex format string */
char *dcm_fmt_string; /* Double complex format string */
chainp new_vars = CHNULL; /* List of newly created locals in this
function. These may have identifiers
which have underscores and more than VL
characters */
chainp used_builtins = CHNULL; /* List of builtins used by this function.
These are all Addrps with UNAM_EXTERN
*/
chainp assigned_fmts = CHNULL; /* assigned formats */
chainp allargs; /* union of args in all entry points */
chainp earlylabs; /* labels seen before enddcl() */
char main_alias[52]; /* PROGRAM name, if any is given */
int tab_size = 4;
FILEP infile;
FILEP diagfile;
FILEP c_file;
FILEP pass1_file;
FILEP initfile;
FILEP blkdfile;
char token[MAXTOKENLEN];
int toklen;
long lineno; /* Current line in the input file, NOT the
Fortran statement label number */
char *infname;
int needkwd;
struct Labelblock *thislabel = NULL;
int nerr;
int nwarn;
flag saveall;
flag substars;
int parstate = OUTSIDE;
flag headerdone = NO;
int blklevel;
int doin_setbound;
int impltype[26];
ftnint implleng[26];
int implstg[26];
int tyint = TYLONG ;
int tylogical = TYLONG;
int typesize[NTYPES] = {
1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
4*SZLONG + SZADDR, /* sizeof(cilist) */
4*SZLONG + 2*SZADDR, /* sizeof(icilist) */
4*SZLONG + 5*SZADDR, /* sizeof(olist) */
2*SZLONG + SZADDR, /* sizeof(cllist) */
2*SZLONG, /* sizeof(alist) */
11*SZLONG + 15*SZADDR /* sizeof(inlist) */
};
int typealign[NTYPES] = {
1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT };
char *typename[] = {
"<<unknown>>",
"address",
"shortint",
"integer",
"real",
"doublereal",
"complex",
"doublecomplex",
"logical",
"char" /* character */
};
int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 };
char *protorettypes[] = {
"?", "??", "shortint", "integer", "real", "doublereal",
"C_f", "Z_f", "logical", "H_f", "int"
};
char *casttypes[TYSUBR+1] = {
"U_fp", "??bug??",
"J_fp", "I_fp", "R_fp",
"D_fp", "C_fp", "Z_fp",
"L_fp", "H_fp", "S_fp"
};
char *usedcasts[TYSUBR+1];
char *dfltarg[] = {
0, 0,
"(shortint *)0", "(integer *)0", "(real *)0",
"(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
"(logical *)0", "(char *)0"
};
static char *dflt0proc[] = {
0, 0,
"(shortint (*)())0", "(integer (*)())0", "(real (*)())0",
"(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
"(logical (*)())0", "(char (*)())0", "(int (*)())0"
};
char *dflt1proc[] = { "(U_fp)0", "(??bug??)0",
"(J_fp)0", "(I_fp)0", "(R_fp)0",
"(D_fp)0", "(C_fp)0", "(Z_fp)0",
"(L_fp)0", "(H_fp)0", "(S_fp)0"
};
char **dfltproc = dflt0proc;
static char Bug[] = "bug";
char *ftn_types[] = { "external", "??",
"integer*2", "integer", "real",
"double precision", "complex", "double complex",
"logical", "character", "subroutine",
Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
};
int init_ac[TYSUBR+1] = { 0,0,0,0,0,0, 1, 1, 0, 2};
int proctype = TYUNKNOWN;
char *procname;
int rtvlabel[NTYPES0];
Addrp retslot; /* Holds automatic variable which was
allocated the function return value
*/
Addrp xretslot[NTYPES0]; /* for multiple entry points */
int cxslot = -1;
int chslot = -1;
int chlgslot = -1;
int procclass = CLUNKNOWN;
int nentry;
int nallargs;
int nallchargs;
flag multitype;
ftnint procleng;
long lastiolabno;
int lastlabno;
int lastvarno;
int lastargslot;
int autonum[TYVOID];
char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
"??TYSUBR??", "??TYERROR??","ci", "ici",
"o", "cl", "al", "ioin" };
extern int maxctl;
struct Ctlframe *ctls;
struct Ctlframe *ctlstack;
struct Ctlframe *lastctl;
Namep regnamep[MAXREGVAR];
int highregvar;
int nregvar;
extern int maxext;
Extsym *extsymtab;
Extsym *nextext;
Extsym *lastext;
extern int maxequiv;
struct Equivblock *eqvclass;
extern int maxhash;
struct Hashentry *hashtab;
struct Hashentry *lasthash;
extern int maxstno; /* Maximum number of statement labels */
struct Labelblock *labeltab;
struct Labelblock *labtabend;
struct Labelblock *highlabtab;
int maxdim = MAXDIM;
struct Rplblock *rpllist = NULL;
struct Chain *curdtp = NULL;
flag toomanyinit;
ftnint curdtelt;
chainp templist[TYVOID];
chainp holdtemps;
int dorange = 0;
struct Entrypoint *entries = NULL;
chainp chains = NULL;
flag inioctl;
int iostmt;
int nioctl;
int nequiv = 0;
int eqvstart = 0;
int nintnames = 0;
struct Literal *litpool;
int nliterals;
char dflttype[26];
char hextoi_tab[Table_size], Letters[Table_size];
char *ei_first, *ei_next, *ei_last;
char *wh_first, *wh_next, *wh_last;
#define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x))
fileinit()
{
register char *s;
register int i, j;
extern void fmt_init(), mem_init(), np_init();
lastiolabno = 100000;
lastlabno = 0;
lastvarno = 0;
nliterals = 0;
nerr = 0;
infile = stdin;
memset(dflttype, tyreal, 26);
memset(dflttype + 'i' - 'a', tyint, 6);
memset(hextoi_tab, 16, sizeof(hextoi_tab));
for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
hextoi(*s) = i;
for(i = 10, s = "ABCDEF"; *s; i++, s++)
hextoi(*s) = i;
for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
Letters[i] = Letters[i+'A'-'a'] = j;
ctls = ALLOCN(maxctl+1, Ctlframe);
extsymtab = ALLOCN(maxext, Extsym);
eqvclass = ALLOCN(maxequiv, Equivblock);
hashtab = ALLOCN(maxhash, Hashentry);
labeltab = ALLOCN(maxstno, Labelblock);
litpool = ALLOCN(maxliterals, Literal);
fmt_init();
mem_init();
np_init();
ctlstack = ctls++;
lastctl = ctls + maxctl;
nextext = extsymtab;
lastext = extsymtab + maxext;
lasthash = hashtab + maxhash;
labtabend = labeltab + maxstno;
highlabtab = labeltab;
main_alias[0] = '\0';
if (forcedouble)
dfltproc[TYREAL] = dfltproc[TYDREAL];
/* Initialize the routines for providing C output */
out_init ();
}
hashclear() /* clear hash table */
{
register struct Hashentry *hp;
register Namep p;
register struct Dimblock *q;
register int i;
for(hp = hashtab ; hp < lasthash ; ++hp)
if(p = hp->varp)
{
frexpr(p->vleng);
if(q = p->vdim)
{
for(i = 0 ; i < q->ndim ; ++i)
{
frexpr(q->dims[i].dimsize);
frexpr(q->dims[i].dimexpr);
}
frexpr(q->nelt);
frexpr(q->baseoffset);
frexpr(q->basexpr);
free( (charptr) q);
}
if(p->vclass == CLNAMELIST)
frchain( &(p->varxptr.namelist) );
free( (charptr) p);
hp->varp = NULL;
}
}
procinit()
{
register struct Labelblock *lp;
struct Chain *cp;
int i;
extern struct memblock *curmemblock, *firstmemblock;
extern char *mem_first, *mem_next, *mem_last, *mem0_last;
extern void frexchain();
curmemblock = firstmemblock;
mem_next = mem_first;
mem_last = mem0_last;
ei_next = ei_first = ei_last = 0;
wh_next = wh_first = wh_last = 0;
iob_list = 0;
for(i = 0; i < 9; i++)
io_structs[i] = 0;
parstate = OUTSIDE;
headerdone = NO;
blklevel = 1;
saveall = NO;
substars = NO;
nwarn = 0;
thislabel = NULL;
needkwd = 0;
proctype = TYUNKNOWN;
procname = "MAIN_";
procclass = CLUNKNOWN;
nentry = 0;
nallargs = nallchargs = 0;
multitype = NO;
retslot = NULL;
for(i = 0; i < NTYPES0; i++) {
frexpr((expptr)xretslot[i]);
xretslot[i] = 0;
}
cxslot = -1;
chslot = -1;
chlgslot = -1;
procleng = 0;
blklevel = 1;
lastargslot = 0;
for(lp = labeltab ; lp < labtabend ; ++lp)
lp->stateno = 0;
hashclear();
/* Clear the list of newly generated identifiers from the previous
function */
frexchain(&new_vars);
frexchain(&used_builtins);
frchain(&assigned_fmts);
frchain(&allargs);
frchain(&earlylabs);
nintnames = 0;
highlabtab = labeltab;
ctlstack = ctls - 1;
for(i = TYADDR; i < TYVOID; i++) {
for(cp = templist[i]; cp ; cp = cp->nextp)
free( (charptr) (cp->datap) );
frchain(templist + i);
autonum[i] = 0;
}
holdtemps = NULL;
dorange = 0;
nregvar = 0;
highregvar = 0;
entries = NULL;
rpllist = NULL;
inioctl = NO;
eqvstart += nequiv;
nequiv = 0;
dcomplex_seen = 0;
for(i = 0 ; i<NTYPES0 ; ++i)
rtvlabel[i] = 0;
if(undeftype)
setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
else
{
setimpl(tyreal, (ftnint) 0, 'a', 'z');
setimpl(tyint, (ftnint) 0, 'i', 'n');
}
setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
setlog();
}
setimpl(type, length, c1, c2)
int type;
ftnint length;
int c1, c2;
{
int i;
char buff[100];
if(c1==0 || c2==0)
return;
if(c1 > c2) {
sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
err(buff);
}
else {
c1 = letter(c1);
c2 = letter(c2);
if(type < 0)
for(i = c1 ; i<=c2 ; ++i)
implstg[i] = - type;
else {
type = lengtype(type, length);
if(type != TYCHAR)
length = 0;
for(i = c1 ; i<=c2 ; ++i) {
impltype[i] = type;
implleng[i] = length;
}
}
}
}

846
lang/fortran/comp/intr.c Normal file
View file

@ -0,0 +1,846 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "names.h"
void cast_args ();
union
{
int ijunk;
struct Intrpacked bits;
} packed;
struct Intrbits
{
char intrgroup /* :3 */;
char intrstuff /* result type or number of generics */;
char intrno /* :7 */;
char dblcmplx;
char dblintrno; /* for -r8 */
};
/* List of all intrinsic functions. */
LOCAL struct Intrblock
{
char intrfname[8];
struct Intrbits intrval;
} intrtab[ ] =
{
"int", { INTRCONV, TYLONG },
"real", { INTRCONV, TYREAL, 1 },
/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
"dble", { INTRCONV, TYDREAL },
"cmplx", { INTRCONV, TYCOMPLEX },
"dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 },
"ifix", { INTRCONV, TYLONG },
"idint", { INTRCONV, TYLONG },
"float", { INTRCONV, TYREAL },
"dfloat", { INTRCONV, TYDREAL },
"sngl", { INTRCONV, TYREAL },
"ichar", { INTRCONV, TYLONG },
"iachar", { INTRCONV, TYLONG },
"char", { INTRCONV, TYCHAR },
"achar", { INTRCONV, TYCHAR },
/* any MAX or MIN can be used with any types; the compiler will cast them
correctly. So rules against bad syntax in these expressions are not
enforced */
"max", { INTRMAX, TYUNKNOWN },
"max0", { INTRMAX, TYLONG },
"amax0", { INTRMAX, TYREAL },
"max1", { INTRMAX, TYLONG },
"amax1", { INTRMAX, TYREAL },
"dmax1", { INTRMAX, TYDREAL },
"and", { INTRBOOL, TYUNKNOWN, OPBITAND },
"or", { INTRBOOL, TYUNKNOWN, OPBITOR },
"xor", { INTRBOOL, TYUNKNOWN, OPBITXOR },
"not", { INTRBOOL, TYUNKNOWN, OPBITNOT },
"lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT },
"rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT },
"min", { INTRMIN, TYUNKNOWN },
"min0", { INTRMIN, TYLONG },
"amin0", { INTRMIN, TYREAL },
"min1", { INTRMIN, TYLONG },
"amin1", { INTRMIN, TYREAL },
"dmin1", { INTRMIN, TYDREAL },
"aint", { INTRGEN, 2, 0 },
"dint", { INTRSPEC, TYDREAL, 1 },
"anint", { INTRGEN, 2, 2 },
"dnint", { INTRSPEC, TYDREAL, 3 },
"nint", { INTRGEN, 4, 4 },
"idnint", { INTRGEN, 2, 6 },
"abs", { INTRGEN, 6, 8 },
"iabs", { INTRGEN, 2, 9 },
"dabs", { INTRSPEC, TYDREAL, 11 },
"cabs", { INTRSPEC, TYREAL, 12, 0, 13 },
"zabs", { INTRSPEC, TYDREAL, 13, 1 },
"mod", { INTRGEN, 4, 14 },
"amod", { INTRSPEC, TYREAL, 16, 0, 17 },
"dmod", { INTRSPEC, TYDREAL, 17 },
"sign", { INTRGEN, 4, 18 },
"isign", { INTRGEN, 2, 19 },
"dsign", { INTRSPEC, TYDREAL, 21 },
"dim", { INTRGEN, 4, 22 },
"idim", { INTRGEN, 2, 23 },
"ddim", { INTRSPEC, TYDREAL, 25 },
"dprod", { INTRSPEC, TYDREAL, 26 },
"len", { INTRSPEC, TYLONG, 27 },
"index", { INTRSPEC, TYLONG, 29 },
"imag", { INTRGEN, 2, 31 },
"aimag", { INTRSPEC, TYREAL, 31, 0, 32 },
"dimag", { INTRSPEC, TYDREAL, 32 },
"conjg", { INTRGEN, 2, 33 },
"dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 },
"sqrt", { INTRGEN, 4, 35 },
"dsqrt", { INTRSPEC, TYDREAL, 36 },
"csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
"zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 },
"exp", { INTRGEN, 4, 39 },
"dexp", { INTRSPEC, TYDREAL, 40 },
"cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
"zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 },
"log", { INTRGEN, 4, 43 },
"alog", { INTRSPEC, TYREAL, 43, 0, 44 },
"dlog", { INTRSPEC, TYDREAL, 44 },
"clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
"zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 },
"log10", { INTRGEN, 2, 47 },
"alog10", { INTRSPEC, TYREAL, 47, 0, 48 },
"dlog10", { INTRSPEC, TYDREAL, 48 },
"sin", { INTRGEN, 4, 49 },
"dsin", { INTRSPEC, TYDREAL, 50 },
"csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
"zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 },
"cos", { INTRGEN, 4, 53 },
"dcos", { INTRSPEC, TYDREAL, 54 },
"ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
"zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 },
"tan", { INTRGEN, 2, 57 },
"dtan", { INTRSPEC, TYDREAL, 58 },
"asin", { INTRGEN, 2, 59 },
"dasin", { INTRSPEC, TYDREAL, 60 },
"acos", { INTRGEN, 2, 61 },
"dacos", { INTRSPEC, TYDREAL, 62 },
"atan", { INTRGEN, 2, 63 },
"datan", { INTRSPEC, TYDREAL, 64 },
"atan2", { INTRGEN, 2, 65 },
"datan2", { INTRSPEC, TYDREAL, 66 },
"sinh", { INTRGEN, 2, 67 },
"dsinh", { INTRSPEC, TYDREAL, 68 },
"cosh", { INTRGEN, 2, 69 },
"dcosh", { INTRSPEC, TYDREAL, 70 },
"tanh", { INTRGEN, 2, 71 },
"dtanh", { INTRSPEC, TYDREAL, 72 },
"lge", { INTRSPEC, TYLOGICAL, 73},
"lgt", { INTRSPEC, TYLOGICAL, 75},
"lle", { INTRSPEC, TYLOGICAL, 77},
"llt", { INTRSPEC, TYLOGICAL, 79},
#if 0
"epbase", { INTRCNST, 4, 0 },
"epprec", { INTRCNST, 4, 4 },
"epemin", { INTRCNST, 2, 8 },
"epemax", { INTRCNST, 2, 10 },
"eptiny", { INTRCNST, 2, 12 },
"ephuge", { INTRCNST, 4, 14 },
"epmrsp", { INTRCNST, 2, 18 },
#endif
"fpexpn", { INTRGEN, 4, 81 },
"fpabsp", { INTRGEN, 2, 85 },
"fprrsp", { INTRGEN, 2, 87 },
"fpfrac", { INTRGEN, 2, 89 },
"fpmake", { INTRGEN, 2, 91 },
"fpscal", { INTRGEN, 2, 93 },
"" };
LOCAL struct Specblock
{
char atype; /* Argument type; every arg must have
this type */
char rtype; /* Result type */
char nargs; /* Number of arguments */
char spxname[8]; /* Name of the function in Fortran */
char othername; /* index into callbyvalue table */
} spectab[ ] =
{
{ TYREAL,TYREAL,1,"r_int" },
{ TYDREAL,TYDREAL,1,"d_int" },
{ TYREAL,TYREAL,1,"r_nint" },
{ TYDREAL,TYDREAL,1,"d_nint" },
{ TYREAL,TYSHORT,1,"h_nint" },
{ TYREAL,TYLONG,1,"i_nint" },
{ TYDREAL,TYSHORT,1,"h_dnnt" },
{ TYDREAL,TYLONG,1,"i_dnnt" },
{ TYREAL,TYREAL,1,"r_abs" },
{ TYSHORT,TYSHORT,1,"h_abs" },
{ TYLONG,TYLONG,1,"i_abs" },
{ TYDREAL,TYDREAL,1,"d_abs" },
{ TYCOMPLEX,TYREAL,1,"c_abs" },
{ TYDCOMPLEX,TYDREAL,1,"z_abs" },
{ TYSHORT,TYSHORT,2,"h_mod" },
{ TYLONG,TYLONG,2,"i_mod" },
{ TYREAL,TYREAL,2,"r_mod" },
{ TYDREAL,TYDREAL,2,"d_mod" },
{ TYREAL,TYREAL,2,"r_sign" },
{ TYSHORT,TYSHORT,2,"h_sign" },
{ TYLONG,TYLONG,2,"i_sign" },
{ TYDREAL,TYDREAL,2,"d_sign" },
{ TYREAL,TYREAL,2,"r_dim" },
{ TYSHORT,TYSHORT,2,"h_dim" },
{ TYLONG,TYLONG,2,"i_dim" },
{ TYDREAL,TYDREAL,2,"d_dim" },
{ TYREAL,TYDREAL,2,"d_prod" },
{ TYCHAR,TYSHORT,1,"h_len" },
{ TYCHAR,TYLONG,1,"i_len" },
{ TYCHAR,TYSHORT,2,"h_indx" },
{ TYCHAR,TYLONG,2,"i_indx" },
{ TYCOMPLEX,TYREAL,1,"r_imag" },
{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
{ TYREAL,TYREAL,1,"r_sqrt", 1 },
{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
{ TYREAL,TYREAL,1,"r_exp", 2 },
{ TYDREAL,TYDREAL,1,"d_exp", 2 },
{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
{ TYREAL,TYREAL,1,"r_log", 3 },
{ TYDREAL,TYDREAL,1,"d_log", 3 },
{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
{ TYREAL,TYREAL,1,"r_lg10" },
{ TYDREAL,TYDREAL,1,"d_lg10" },
{ TYREAL,TYREAL,1,"r_sin", 4 },
{ TYDREAL,TYDREAL,1,"d_sin", 4 },
{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
{ TYREAL,TYREAL,1,"r_cos", 5 },
{ TYDREAL,TYDREAL,1,"d_cos", 5 },
{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
{ TYREAL,TYREAL,1,"r_tan", 6 },
{ TYDREAL,TYDREAL,1,"d_tan", 6 },
{ TYREAL,TYREAL,1,"r_asin", 7 },
{ TYDREAL,TYDREAL,1,"d_asin", 7 },
{ TYREAL,TYREAL,1,"r_acos", 8 },
{ TYDREAL,TYDREAL,1,"d_acos", 8 },
{ TYREAL,TYREAL,1,"r_atan", 9 },
{ TYDREAL,TYDREAL,1,"d_atan", 9 },
{ TYREAL,TYREAL,2,"r_atn2", 10 },
{ TYDREAL,TYDREAL,2,"d_atn2", 10 },
{ TYREAL,TYREAL,1,"r_sinh", 11 },
{ TYDREAL,TYDREAL,1,"d_sinh", 11 },
{ TYREAL,TYREAL,1,"r_cosh", 12 },
{ TYDREAL,TYDREAL,1,"d_cosh", 12 },
{ TYREAL,TYREAL,1,"r_tanh", 13 },
{ TYDREAL,TYDREAL,1,"d_tanh", 13 },
{ TYCHAR,TYLOGICAL,2,"hl_ge" },
{ TYCHAR,TYLOGICAL,2,"l_ge" },
{ TYCHAR,TYLOGICAL,2,"hl_gt" },
{ TYCHAR,TYLOGICAL,2,"l_gt" },
{ TYCHAR,TYLOGICAL,2,"hl_le" },
{ TYCHAR,TYLOGICAL,2,"l_le" },
{ TYCHAR,TYLOGICAL,2,"hl_lt" },
{ TYCHAR,TYLOGICAL,2,"l_lt" },
{ TYREAL,TYSHORT,1,"hr_expn" },
{ TYREAL,TYLONG,1,"ir_expn" },
{ TYDREAL,TYSHORT,1,"hd_expn" },
{ TYDREAL,TYLONG,1,"id_expn" },
{ TYREAL,TYREAL,1,"r_absp" },
{ TYDREAL,TYDREAL,1,"d_absp" },
{ TYREAL,TYDREAL,1,"r_rrsp" },
{ TYDREAL,TYDREAL,1,"d_rrsp" },
{ TYREAL,TYREAL,1,"r_frac" },
{ TYDREAL,TYDREAL,1,"d_frac" },
{ TYREAL,TYREAL,2,"r_make" },
{ TYDREAL,TYDREAL,2,"d_make" },
{ TYREAL,TYREAL,2,"r_scal" },
{ TYDREAL,TYDREAL,2,"d_scal" },
{ 0 }
} ;
#if 0
LOCAL struct Incstblock
{
char atype;
char rtype;
char constno;
} consttab[ ] =
{
{ TYSHORT, TYLONG, 0 },
{ TYLONG, TYLONG, 1 },
{ TYREAL, TYLONG, 2 },
{ TYDREAL, TYLONG, 3 },
{ TYSHORT, TYLONG, 4 },
{ TYLONG, TYLONG, 5 },
{ TYREAL, TYLONG, 6 },
{ TYDREAL, TYLONG, 7 },
{ TYREAL, TYLONG, 8 },
{ TYDREAL, TYLONG, 9 },
{ TYREAL, TYLONG, 10 },
{ TYDREAL, TYLONG, 11 },
{ TYREAL, TYREAL, 0 },
{ TYDREAL, TYDREAL, 1 },
{ TYSHORT, TYLONG, 12 },
{ TYLONG, TYLONG, 13 },
{ TYREAL, TYREAL, 2 },
{ TYDREAL, TYDREAL, 3 },
{ TYREAL, TYREAL, 4 },
{ TYDREAL, TYDREAL, 5 }
};
#endif
char *callbyvalue[ ] =
{0,
"sqrt",
"exp",
"log",
"sin",
"cos",
"tan",
"asin",
"acos",
"atan",
"atan2",
"sinh",
"cosh",
"tanh"
};
void
r8fix() /* adjust tables for -r8 */
{
register struct Intrblock *I;
register struct Specblock *S;
for(I = intrtab; I->intrfname[0]; I++)
if (I->intrval.intrgroup != INTRGEN)
switch(I->intrval.intrstuff) {
case TYREAL:
I->intrval.intrstuff = TYDREAL;
I->intrval.intrno = I->intrval.dblintrno;
break;
case TYCOMPLEX:
I->intrval.intrstuff = TYDCOMPLEX;
I->intrval.intrno = I->intrval.dblintrno;
I->intrval.dblcmplx = 1;
}
for(S = spectab; S->atype; S++)
switch(S->atype) {
case TYCOMPLEX:
S->atype = TYDCOMPLEX;
if (S->rtype == TYREAL)
S->rtype = TYDREAL;
else if (S->rtype == TYCOMPLEX)
S->rtype = TYDCOMPLEX;
switch(S->spxname[0]) {
case 'r':
S->spxname[0] = 'd';
break;
case 'c':
S->spxname[0] = 'z';
break;
default:
Fatal("r8fix bug");
}
break;
case TYREAL:
S->atype = TYDREAL;
switch(S->rtype) {
case TYREAL:
S->rtype = TYDREAL;
if (S->spxname[0] != 'r')
Fatal("r8fix bug");
S->spxname[0] = 'd';
case TYDREAL: /* d_prod */
break;
case TYSHORT:
if (!strcmp(S->spxname, "hr_expn"))
S->spxname[1] = 'd';
else if (!strcmp(S->spxname, "h_nint"))
strcpy(S->spxname, "h_dnnt");
else Fatal("r8fix bug");
break;
case TYLONG:
if (!strcmp(S->spxname, "ir_expn"))
S->spxname[1] = 'd';
else if (!strcmp(S->spxname, "i_nint"))
strcpy(S->spxname, "i_dnnt");
else Fatal("r8fix bug");
break;
default:
Fatal("r8fix bug");
}
}
}
expptr intrcall(np, argsp, nargs)
Namep np;
struct Listblock *argsp;
int nargs;
{
int i, rettype;
Addrp ap;
register struct Specblock *sp;
register struct Chain *cp;
expptr Inline(), mkcxcon(), mkrealcon();
expptr q, ep;
int mtype;
int op;
int f1field, f2field, f3field;
packed.ijunk = np->vardesc.varno;
f1field = packed.bits.f1;
f2field = packed.bits.f2;
f3field = packed.bits.f3;
if(nargs == 0)
goto badnargs;
mtype = 0;
for(cp = argsp->listp ; cp ; cp = cp->nextp)
{
ep = (expptr)cp->datap;
if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
cp->datap = (char *) mkconv(tyint, ep);
mtype = maxtype(mtype, ep->headblock.vtype);
}
switch(f1field)
{
case INTRBOOL:
op = f3field;
if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
goto badtype;
if(op == OPBITNOT)
{
if(nargs != 1)
goto badnargs;
q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
}
else
{
if(nargs != 2)
goto badnargs;
q = mkexpr(op, (expptr)argsp->listp->datap,
(expptr)argsp->listp->nextp->datap);
}
frchain( &(argsp->listp) );
free( (charptr) argsp);
return(q);
case INTRCONV:
rettype = f2field;
if(rettype == TYLONG)
rettype = tyint;
if( ISCOMPLEX(rettype) && nargs==2)
{
expptr qr, qi;
qr = (expptr) argsp->listp->datap;
qi = (expptr) argsp->listp->nextp->datap;
if(ISCONST(qr) && ISCONST(qi))
q = mkcxcon(qr,qi);
else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
mkconv(rettype-2,qi));
}
else if(nargs == 1) {
if (f3field && ((Exprp)argsp->listp->datap)->vtype
== TYDCOMPLEX)
rettype = TYDREAL;
q = mkconv(rettype+100, (expptr)argsp->listp->datap);
}
else goto badnargs;
q->headblock.vtype = rettype;
frchain(&(argsp->listp));
free( (charptr) argsp);
return(q);
#if 0
case INTRCNST:
/* Machine-dependent f77 stuff that f2c omits:
intcon contains
radix for short int
radix for long int
radix for single precision
radix for double precision
precision for short int
precision for long int
precision for single precision
precision for double precision
emin for single precision
emin for double precision
emax for single precision
emax for double prcision
largest short int
largest long int
realcon contains
tiny for single precision
tiny for double precision
huge for single precision
huge for double precision
mrsp (epsilon) for single precision
mrsp (epsilon) for double precision
*/
{ register struct Incstblock *cstp;
extern ftnint intcon[14];
extern double realcon[6];
cstp = consttab + f3field;
for(i=0 ; i<f2field ; ++i)
if(cstp->atype == mtype)
goto foundconst;
else
++cstp;
goto badtype;
foundconst:
switch(cstp->rtype)
{
case TYLONG:
return(mkintcon(intcon[cstp->constno]));
case TYREAL:
case TYDREAL:
return(mkrealcon(cstp->rtype,
realcon[cstp->constno]) );
default:
Fatal("impossible intrinsic constant");
}
}
#endif
case INTRGEN:
sp = spectab + f3field;
if(no66flag)
if(sp->atype == mtype)
goto specfunct;
else err66("generic function");
for(i=0; i<f2field ; ++i)
if(sp->atype == mtype)
goto specfunct;
else
++sp;
warn1 ("bad argument type to intrinsic %s", np->fvarname);
/* Made this a warning rather than an error so things like "log (5) ==>
log (5.0)" can be accommodated. When none of these cases matches, the
argument is cast up to the first type in the spectab list; this first
type is assumed to be the "smallest" type, e.g. REAL before DREAL
before COMPLEX, before DCOMPLEX */
sp = spectab + f3field;
mtype = sp -> atype;
goto specfunct;
case INTRSPEC:
sp = spectab + f3field;
specfunct:
if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
&& (sp+1)->atype==sp->atype)
++sp;
if(nargs != sp->nargs)
goto badnargs;
if(mtype != sp->atype)
goto badtype;
/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
the inline expression wouldn't get put into the constant table */
fixargs (NO, argsp);
cast_args (mtype, argsp -> listp);
if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
{
frchain( &(argsp->listp) );
free( (charptr) argsp);
} else {
if(sp->othername) {
/* C library routines that return double... */
/* sp->rtype might be TYREAL */
ap = builtin(sp->rtype,
callbyvalue[sp->othername], 1);
q = fixexpr((Exprp)
mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
} else {
fixargs(YES, argsp);
ap = builtin(sp->rtype, sp->spxname, 0);
q = fixexpr((Exprp)
mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
} /* else */
} /* else */
return(q);
case INTRMIN:
case INTRMAX:
if(nargs < 2)
goto badnargs;
if( ! ONEOF(mtype, MSKINT|MSKREAL) )
goto badtype;
argsp->vtype = mtype;
q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
q->headblock.vtype = mtype;
rettype = f2field;
if(rettype == TYLONG)
rettype = tyint;
else if(rettype == TYUNKNOWN)
rettype = mtype;
return( mkconv(rettype, q) );
default:
fatali("intrcall: bad intrgroup %d", f1field);
}
badnargs:
errstr("bad number of arguments to intrinsic %s", np->fvarname);
goto bad;
badtype:
errstr("bad argument type to intrinsic %s", np->fvarname);
bad:
return( errnode() );
}
intrfunct(s)
char *s;
{
register struct Intrblock *p;
for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
{
if( !strcmp(s, p->intrfname) )
{
packed.bits.f1 = p->intrval.intrgroup;
packed.bits.f2 = p->intrval.intrstuff;
packed.bits.f3 = p->intrval.intrno;
packed.bits.f4 = p->intrval.dblcmplx;
return(packed.ijunk);
}
}
return(0);
}
Addrp intraddr(np)
Namep np;
{
Addrp q;
register struct Specblock *sp;
int f3field;
if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
fatalstr("intraddr: %s is not intrinsic", np->fvarname);
packed.ijunk = np->vardesc.varno;
f3field = packed.bits.f3;
switch(packed.bits.f1)
{
case INTRGEN:
/* imag, log, and log10 arent specific functions */
if(f3field==31 || f3field==43 || f3field==47)
goto bad;
case INTRSPEC:
sp = spectab + f3field;
if(tyint==TYLONG && sp->rtype==TYSHORT)
++sp;
q = builtin(sp->rtype, sp->spxname,
sp->othername ? 1 : 0);
return(q);
case INTRCONV:
case INTRMIN:
case INTRMAX:
case INTRBOOL:
case INTRCNST:
bad:
errstr("cannot pass %s as actual", np->fvarname);
return((Addrp)errnode());
}
fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
/* NOT REACHED */ return 0;
}
void cast_args (maxtype, args)
int maxtype;
chainp args;
{
for (; args; args = args -> nextp) {
expptr e = (expptr) args->datap;
if (e -> headblock.vtype != maxtype)
if (e -> tag == TCONST)
args->datap = (char *) mkconv(maxtype, e);
else {
Addrp temp = mktmp(maxtype, ENULL);
puteq(cpexpr((expptr)temp), e);
args->datap = (char *)temp;
} /* else */
} /* for */
} /* cast_args */
expptr Inline(fno, type, args)
int fno;
int type;
struct Chain *args;
{
register expptr q, t, t1;
switch(fno)
{
case 8: /* real abs */
case 9: /* short int abs */
case 10: /* long int abs */
case 11: /* double precision abs */
if( addressable(q = (expptr) args->datap) )
{
t = q;
q = NULL;
}
else
t = (expptr) mktmp(type,ENULL);
t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
cpexpr(t), ENULL);
if(q)
t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
frexpr(t);
return(t1);
case 26: /* dprod */
q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
(expptr)args->nextp->datap);
return(q);
case 27: /* len of character string */
q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
frexpr((expptr)args->datap);
return(q);
case 14: /* half-integer mod */
case 15: /* mod */
return mkexpr(OPMOD, (expptr) args->datap,
(expptr) args->nextp->datap);
}
return(NULL);
}

1416
lang/fortran/comp/io.c Normal file
View file

File diff suppressed because it is too large Load diff

24
lang/fortran/comp/iob.h Normal file
View file

@ -0,0 +1,24 @@
struct iob_data {
struct iob_data *next;
char *type;
char *name;
char *fields[1];
};
struct io_setup {
char **fields;
int nelt, type;
};
struct defines {
struct defines *next;
char defname[1];
};
typedef struct iob_data iob_data;
typedef struct io_setup io_setup;
typedef struct defines defines;
extern iob_data *iob_list;
extern struct Addrblock *io_structs[9];
extern void def_start(), new_iob_data(), other_undefs();
extern char *tostring();

1453
lang/fortran/comp/lex.c Normal file
View file

File diff suppressed because it is too large Load diff

31
lang/fortran/comp/machdefs.h Normal file
View file

@ -0,0 +1,31 @@
#define TYLENG TYLONG /* char string length field */
#define TYINT TYLONG
#define SZADDR 4
#define SZSHORT 2
#define SZINT 4
#define SZLONG 4
#define SZLENG SZLONG
#define SZDREAL 8
/* Alignment restrictions */
#define ALIADDR SZADDR
#define ALISHORT SZSHORT
#define ALILONG 4
#define ALIDOUBLE 8
#define ALIINT ALILONG
#define ALILENG ALILONG
#define BLANKCOMMON "_BLNK__" /* Name for the unnamed
common block; this is unique
because of underscores */
#define LABELFMT "%s:\n"
#define MAXREGVAR 4
#define TYIREG TYLONG
#define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies
which can be put in registers */

590
lang/fortran/comp/main.c Normal file
View file

@ -0,0 +1,590 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
extern char F2C_version[];
#include "defs.h"
#include "parse.h"
int complex_seen, dcomplex_seen;
LOCAL int Max_ftn_files;
char **ftn_files;
int current_ftn_file = 0;
flag ftn66flag = NO;
flag nowarnflag = NO;
flag noextflag = NO;
flag no66flag = NO; /* Must also set noextflag to this
same value */
flag zflag = YES; /* recognize double complex intrinsics */
flag debugflag = NO;
flag onetripflag = NO;
flag shiftcase = YES;
flag undeftype = NO;
flag checksubs = NO;
flag r8flag = NO;
flag use_bs = YES;
int tyreal = TYREAL;
int tycomplex = TYCOMPLEX;
extern void r8fix(), read_Pfiles();
int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */
int maxequiv = MAXEQUIV;
int maxext = MAXEXT;
int maxstno = MAXSTNO;
int maxctl = MAXCTL;
int maxhash = MAXHASH;
int maxliterals = MAXLITERALS;
int extcomm, ext1comm, useauto;
int can_include = YES; /* so we can disable includes for netlib */
static char *def_i2 = "";
static int useshortints = NO; /* YES => tyint = TYSHORT */
static int uselongints = NO; /* YES => tyint = TYLONG */
int addftnsrc = NO; /* Include ftn source in output */
int usedefsforcommon = NO; /* Use #defines for common reference */
int forcedouble = YES; /* force real functions to double */
int Ansi = NO;
int def_equivs = YES;
int tyioint = TYLONG;
int szleng = SZLENG;
int inqmask = M(TYLONG)|M(TYLOGICAL);
int wordalign = NO;
int forcereal = NO;
static int skipC, skipversion;
char *filename0, *parens;
int Castargs = 1;
static int typedefs = 0;
int chars_per_wd, gflag, protostatus;
int infertypes = 1;
char used_rets[TYSUBR+1];
extern char *tmpdir;
static int h0align = 0;
char *halign, *ohalign;
int krparens = NO;
int hsize; /* for padding under -h */
int htype; /* for wr_equiv_init under -h */
#define f2c_entry(swit,count,type,store,size) \
p_entry ("-", swit, 0, count, type, store, size)
static arg_info table[] = {
f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
/* options omitted from man pages */
/* -ev ==> implement equivalence with initialized pointers */
f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
/* -!it used to be the default when -it was more agressive */
f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
/* -Pd is similar to -P, but omits :ref: lines */
f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
/* -t ==> emit typedefs (under -A or -C++) for procedure
argument types used. This is meant for netlib's
f2c service, so -A and -C++ will work with older
versions of f2c.h
*/
f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
/* -!V ==> omit version msg (to facilitate using diff in
regression testing)
*/
f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
}; /* table */
extern char *c_functions; /* "c_functions" */
extern char *coutput; /* "c_output" */
extern char *initfname; /* "raw_data" */
extern char *blkdfname; /* "block_data" */
extern char *p1_file; /* "p1_file" */
extern char *p1_bakfile; /* "p1_file.BAK" */
extern char *sortfname; /* "init_file" */
static char *proto_fname; /* "proto_file" */
FILE *protofile;
extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
extern char *c_name();
set_externs ()
{
static char *hset[3] = { 0, "integer", "doublereal" };
/* Adjust the global flags according to the command line parameters */
if (chars_per_wd > 0) {
typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
typesize[TYLOGICAL] = chars_per_wd;
typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
typesize[TYDCOMPLEX] = chars_per_wd << 2;
typesize[TYSHORT] = chars_per_wd >> 1;
typesize[TYCILIST] = 5*chars_per_wd;
typesize[TYICILIST] = 6*chars_per_wd;
typesize[TYOLIST] = 9*chars_per_wd;
typesize[TYCLLIST] = 3*chars_per_wd;
typesize[TYALIST] = 2*chars_per_wd;
typesize[TYINLIST] = 26*chars_per_wd;
}
if (wordalign)
typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
if (!tyioint) {
tyioint = TYSHORT;
szleng = typesize[TYSHORT];
def_i2 = "#define f2c_i2 1\n";
inqmask = M(TYSHORT)|M(TYLOGICAL);
goto checklong;
}
else
szleng = typesize[TYLONG];
if (useshortints) {
inqmask = M(TYLONG);
checklong:
protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
typesize[TYLOGICAL] = typesize[TYSHORT];
casttypes[TYLOGICAL] = "K_fp";
if (uselongints)
err ("Can't use both long and short ints");
else
tyint = tylogical = TYSHORT;
}
else if (uselongints)
tyint = TYLONG;
if (h0align) {
if (tyint == TYLONG && wordalign)
h0align = 1;
ohalign = halign = hset[h0align];
htype = h0align == 1 ? tyint : TYDREAL;
hsize = typesize[htype];
}
if (no66flag)
noextflag = no66flag;
if (noextflag)
zflag = 0;
if (r8flag) {
tyreal = TYDREAL;
tycomplex = TYDCOMPLEX;
r8fix();
}
if (forcedouble) {
protorettypes[TYREAL] = "E_f";
casttypes[TYREAL] = "E_fp";
}
if (maxregvar > MAXREGVAR) {
warni("-O%d: too many register variables", maxregvar);
maxregvar = MAXREGVAR;
} /* if maxregvar > MAXREGVAR */
/* Check the list of input files */
{
int bad, i, cur_max = Max_ftn_files;
for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
if (ftn_files[i][0] == '-') {
errstr ("Invalid flag '%s'", ftn_files[i]);
bad++;
}
if (bad)
exit(1);
} /* block */
} /* set_externs */
static int
comm2dcl()
{
Extsym *ext;
if (ext1comm)
for(ext = extsymtab; ext < nextext; ext++)
if (ext->extstg == STGCOMMON && !ext->extinit)
return ext1comm;
return 0;
}
static void
write_typedefs(outfile)
FILE *outfile;
{
register int i;
register char *s, *p = 0;
static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
static char stl[4] = { 'E', 'C', 'Z', 'H' };
for(i = 0; i <= TYSUBR; i++)
if (s = usedcasts[i]) {
if (!p) {
p = Ansi == 1 ? "()" : "(...)";
nice_printf(outfile,
"/* Types for casting procedure arguments: */\
\n\n#ifndef F2C_proc_par_types\n");
if (i == 0) {
nice_printf(outfile,
"typedef int /* Unknown procedure type */ (*%s)%s;\n",
s, p);
continue;
}
}
nice_printf(outfile, "typedef %s (*%s)%s;\n",
c_type_decl(i,1), s, p);
}
for(i = !forcedouble; i < 4; i++)
if (used_rets[st[i]])
nice_printf(outfile,
"typedef %s %c_f; /* %s function */\n",
p = i ? "VOID" : "doublereal",
stl[i], ftn_types[st[i]]);
if (p)
nice_printf(outfile, "#endif\n\n");
}
static void
commonprotos(outfile)
register FILE *outfile;
{
register Extsym *e, *ee;
register Argtypes *at;
Atype *a, *ae;
int k;
extern int proc_protochanges;
if (!outfile)
return;
for (e = extsymtab, ee = nextext; e < ee; e++)
if (e->extstg == STGCOMMON && e->allextp)
nice_printf(outfile, "/* comlen %s %ld */\n",
e->cextname, e->maxleng);
if (Castargs < 3)
return;
/* -Pr: special comments conveying current knowledge
of external references */
k = proc_protochanges;
for (e = extsymtab, ee = nextext; e < ee; e++)
if (e->extstg == STGEXT
&& e->cextname != e->fextname) /* not a library function */
if (at = e->arginfo) {
if ((!e->extinit || at->changes & 1)
/* not defined here or
changed since definition */
&& at->nargs >= 0) {
nice_printf(outfile, "/*:ref: %s %d %d",
e->cextname, e->extype, at->nargs);
a = at->atypes;
for(ae = a + at->nargs; a < ae; a++)
nice_printf(outfile, " %d", a->type);
nice_printf(outfile, " */\n");
if (at->changes & 1)
k++;
}
}
else if (e->extype)
/* typed external, never invoked */
nice_printf(outfile, "/*:ref: %s %d :*/\n",
e->cextname, e->extype);
if (k) {
nice_printf(outfile,
"/* Rerunning f2c -P may change prototypes or declarations. */\n");
if (nerr)
return;
if (protostatus)
done(4);
if (protofile != stdout) {
fprintf(diagfile,
"Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
filename0, proto_fname);
fflush(diagfile);
}
}
}
int retcode = 0;
main(argc, argv)
int argc;
char **argv;
{
int c2d, k;
FILE *c_output;
char *filename, *cdfilename;
static char stderrbuf[BUFSIZ];
extern void def_commons();
extern char **dfltproc, *dflt1proc[];
extern char link_msg[];
diagfile = stderr;
setbuf(stderr, stderrbuf); /* arrange for fast error msgs */
Max_ftn_files = argc - 1;
ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
ftn_files, Max_ftn_files);
if (!can_include && ext1comm == 2)
ext1comm = 1;
if (ext1comm && !extcomm)
extcomm = 2;
if (protostatus)
Castargs = 3;
else if (Castargs == 1 && !Ansi)
Castargs = 0;
if (Castargs >= 2 && !Ansi)
Ansi = 1;
if (!Ansi)
parens = "()";
else if (!Castargs)
parens = Ansi == 1 ? "()" : "(...)";
else
dfltproc = dflt1proc;
set_externs();
fileinit();
read_Pfiles(ftn_files);
for(k = 1; ftn_files[k]; k++)
if (dofork())
break;
filename0 = filename = ftn_files[current_ftn_file = k - 1];
set_tmp_names();
sigcatch();
c_file = opf(c_functions, textwrite);
pass1_file=opf(p1_file, binwrite);
initkey();
if (filename && *filename) {
if (debugflag != 1) {
coutput = c_name(filename,'c');
if (Castargs >= 2)
proto_fname = c_name(filename,'P');
}
cdfilename = coutput;
if (skipC)
coutput = 0;
else if (!(c_output = fopen(coutput, textwrite))) {
filename = coutput;
coutput = 0; /* don't delete read-only .c file */
fatalstr("can't open %.86s", filename);
}
if (Castargs >= 2
&& !(protofile = fopen(proto_fname, textwrite)))
fatalstr("Can't open %.84s\n", proto_fname);
}
else {
filename = "";
cdfilename = "f2c_out.c";
c_output = stdout;
coutput = 0;
if (Castargs >= 2) {
protofile = stdout;
if (!skipC)
printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
}
}
if(inilex( copys(filename) ))
done(1);
if (filename0) {
fprintf(diagfile, "%s:\n", filename);
fflush(diagfile);
}
procinit();
if(k = yyparse())
{
fprintf(diagfile, "Bad parse, return code %d\n", k);
done(1);
}
commonprotos(protofile);
if (protofile == stdout && !skipC)
printf("#endif\n\n");
if (nerr || skipC)
goto C_skipped;
/* Write out the declarations which are global to this file */
if ((c2d = comm2dcl()) == 1)
nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
/* Split this into several files by piping it through\n\n\
sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
*/\n\
/*<<</dev/null>>>*/\n\
/*>>>'%s'<<<*/\n", cdfilename);
if (!skipversion) {
nice_printf (c_output, "/* %s -- translated by f2c ", filename);
nice_printf (c_output, "(version of %s).\n", F2C_version);
nice_printf (c_output,
" You must link the resulting object file with the libraries:\n\
%s (in that order)\n*/\n\n", link_msg);
}
if (Ansi == 2)
nice_printf(c_output,
"#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
if (Castargs && typedefs)
write_typedefs(c_output);
nice_printf (c_file, "\n");
fclose (c_file);
c_file = c_output; /* HACK to get the next indenting
to work */
wr_common_decls (c_output);
if (blkdfile)
list_init_data(&blkdfile, blkdfname, c_output);
wr_globals (c_output);
if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
Fatal("main - couldn't reopen c_functions");
ffilecopy (c_file, c_output);
if (*main_alias) {
nice_printf (c_output, "/* Main program alias */ ");
nice_printf (c_output, "int %s () { MAIN__ (); }\n",
main_alias);
}
if (Ansi == 2)
nice_printf(c_output,
"#ifdef __cplusplus\n\t}\n#endif\n");
if (c2d) {
if (c2d == 1)
fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
else
fclose(c_output);
def_commons(c_output);
}
if (c2d != 2)
fclose (c_output);
C_skipped:
if(parstate != OUTSIDE)
{
warn("missing final end statement");
endproc();
}
done(nerr ? 1 : 0);
}
FILEP opf(fn, mode)
char *fn, *mode;
{
FILEP fp;
if( fp = fopen(fn, mode) )
return(fp);
fatalstr("cannot open intermediate file %s", fn);
/* NOT REACHED */ return 0;
}
clf(p, what, quit)
FILEP *p;
char *what;
int quit;
{
if(p!=NULL && *p!=NULL && *p!=stdout)
{
if(ferror(*p)) {
fprintf(stderr, "I/O error on %s\n", what);
if (quit)
done(3);
retcode = 3;
}
fclose(*p);
}
*p = NULL;
}
done(k)
int k;
{
clf(&initfile, "initfile", 0);
clf(&c_file, "c_file", 0);
clf(&pass1_file, "pass1_file", 0);
Un_link_all(k);
exit(k|retcode);
}

84
lang/fortran/comp/makefile Normal file
View file

@ -0,0 +1,84 @@
# Makefile for f2c, a Fortran 77 to C converter
g = -g
CFLAGS = $g
SHELL = /bin/sh
OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \
parse_args.o niceprintf.o cds.o sysdep.o version.o
OBJECTS = $(OBJECTSd) malloc.o
all: xsum.out f2c
f2c: $(OBJECTS)
$(CC) $(LDFLAGS) $(OBJECTS) -o f2c
size f2c
gram.c: gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h
( sed <tokdefs.h "s/#define/%token/" ;\
cat gram.head gram.dcl gram.expr gram.exec gram.io ) >gram.in
$(YACC) $(YFLAGS) gram.in
echo "(expect 4 shift/reduce)"
sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
rm -f gram.in y.tab.c
$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h
tokdefs.h: tokens
grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
cds.o: sysdep.h
exec.o: p1defs.h names.h
expr.o: output.h niceprintf.h names.h
format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h
formatdata.o: format.h output.h niceprintf.h names.h
gram.o: p1defs.h
init.o: output.h niceprintf.h iob.h
intr.o: names.h
io.o: names.h iob.h
lex.o : tokdefs.h p1defs.h
main.o: parse.h usignal.h
mem.o: iob.h
names.o: iob.h names.h output.h niceprintf.h
niceprintf.o: defs.h names.h output.h niceprintf.h
output.o: output.h niceprintf.h names.h
p1output.o: p1defs.h output.h niceprintf.h names.h
parse_args.o: parse.h
proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h
put.o: names.h pccdefs.h p1defs.h
putpcc.o: names.h
vax.o: defs.h output.h pccdefs.h
output.h: niceprintf.h
put.o putpcc.o: pccdefs.h
f2c.t: f2c.1t
troff -man f2c.1t >f2c.t
f2c.1: f2c.1t
nroff -man f2c.1t | col -b | uniq >f2c.1
clean:
rm -f gram.c *.o f2c tokdefs.h f2c.t
b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \
exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \
ftypes.h gram.dcl gram.exec gram.expr gram.head gram.io \
init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile \
malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \
niceprintf.h output.c output.h p1defs.h p1output.c \
parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \
sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c
bundle:
bundle $b xsum0.out >/tmp/f2c.bundle
xsum: xsum.c
$(CC) -o xsum xsum.c
#Check validity of transmitted source...
xsum.out: xsum
./xsum $b >xsum1.out
cmp xsum0.out xsum1.out && mv xsum1.out xsum.out

142
lang/fortran/comp/malloc.c Normal file
View file

@ -0,0 +1,142 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#ifndef CRAY
#define STACKMIN 512
#define MINBLK (2*sizeof(struct mem) + 16)
#define MSTUFF _malloc_stuff_
#define F MSTUFF.free
#define B MSTUFF.busy
#define SBGULP 8192
char *memcpy();
struct mem {
struct mem *next;
unsigned len;
};
struct {
struct mem *free;
char *busy;
} MSTUFF;
char *
malloc(size)
register unsigned size;
{
register struct mem *p, *q, *r, *s;
unsigned register k, m;
extern char *sbrk();
char *top, *top1;
size = (size+7) & ~7;
r = (struct mem *) &F;
for (p = F, q = 0; p; r = p, p = p->next) {
if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; }
}
if (q) {
if (q->len - size >= MINBLK) { /* split block */
p = (struct mem *) (((char *) (q+1)) + size);
p->next = q->next;
p->len = q->len - size - sizeof(struct mem);
s->next = p;
q->len = size;
}
else s->next = q->next;
}
else {
top = B ? B : (char *)(((long)sbrk(0) + 7) & ~7);
if (F && (char *)(F+1) + F->len == B)
{ q = F; F = F->next; }
else q = (struct mem *) top;
top1 = (char *)(q+1) + size;
if (top1 > top) {
if (sbrk((int)(top1-top+SBGULP)) == (char *) -1)
return 0;
r = (struct mem *)top1;
r->len = SBGULP - sizeof(struct mem);
r->next = F;
F = r;
top1 += SBGULP;
}
q->len = size;
B = top1;
}
return (char *) (q+1);
}
free(f)
char *f;
{
struct mem *p, *q, *r;
char *pn, *qn;
if (!f) return;
q = (struct mem *) (f - sizeof(struct mem));
qn = f + q->len;
for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) {
if (qn == (char *) p) {
q->len += p->len + sizeof(struct mem);
p = p->next;
}
pn = p ? ((char *) (p+1)) + p->len : 0;
if (pn == (char *) q) {
p->len += sizeof(struct mem) + q->len;
q->len = 0;
q->next = p;
r->next = p;
break;
}
if (pn < (char *) q) {
r->next = q;
q->next = p;
break;
}
}
}
char *
realloc(f, size)
char *f;
unsigned size;
{
struct mem *p;
char *q, *f1;
unsigned s1;
if (!f) return malloc(size);
p = (struct mem *) (f - sizeof(struct mem));
s1 = p->len;
free(f);
if (s1 > size) s1 = size + 7 & ~7;
if (!p->len) {
f1 = (char *)(p->next + 1);
memcpy(f1, f, s1);
f = f1;
}
q = malloc(size);
if (q && q != f)
memcpy(q, f, s1);
return q;
}
#endif

230
lang/fortran/comp/mem.c Normal file
View file

@ -0,0 +1,230 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "iob.h"
#define MEMBSIZE 32000
#define GMEMBSIZE 16000
extern void exit();
char *
gmem(n, round)
int n, round;
{
static char *last, *next;
char *rv;
if (round)
#ifdef CRAY
if ((long)next & 0xe000000000000000)
next = (char *)(((long)next & 0x1fffffffffffffff) + 1);
#else
#ifdef MSDOS
if ((int)next & 1)
next++;
#else
next = (char *)(((long)next + sizeof(char *)-1)
& ~((long)sizeof(char *)-1));
#endif
#endif
rv = next;
if ((next += n) > last) {
rv = Alloc(n + GMEMBSIZE);
next = rv + n;
last = next + GMEMBSIZE;
}
return rv;
}
struct memblock {
struct memblock *next;
char buf[MEMBSIZE];
};
typedef struct memblock memblock;
static memblock *mem0;
memblock *curmemblock, *firstmemblock;
char *mem_first, *mem_next, *mem_last, *mem0_last;
void
mem_init()
{
curmemblock = firstmemblock = mem0
= (memblock *)Alloc(sizeof(memblock));
mem_first = mem0->buf;
mem_next = mem0->buf;
mem_last = mem0->buf + MEMBSIZE;
mem0_last = mem0->buf + MEMBSIZE;
mem0->next = 0;
}
char *
mem(n, round)
int n, round;
{
memblock *b;
register char *rv, *s;
if (round)
#ifdef CRAY
if ((long)mem_next & 0xe000000000000000)
mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1);
#else
#ifdef MSDOS
if ((int)mem_next & 1)
mem_next++;
#else
mem_next = (char *)(((long)mem_next + sizeof(char *)-1)
& ~((long)sizeof(char *)-1));
#endif
#endif
rv = mem_next;
s = rv + n;
if (s >= mem_last) {
if (n > MEMBSIZE) {
fprintf(stderr, "mem(%d) failure!\n", n);
exit(1);
}
if (!(b = curmemblock->next)) {
b = (memblock *)Alloc(sizeof(memblock));
curmemblock->next = b;
b->next = 0;
}
curmemblock = b;
rv = b->buf;
mem_last = rv + sizeof(b->buf);
s = rv + n;
}
mem_next = s;
return rv;
}
char *
tostring(s,n)
register char *s;
int n;
{
register char *s1, *se, **sf;
char *rv, *s0;
register int k = n + 2, t;
sf = str_fmt;
sf['%'] = "%";
s0 = s;
se = s + n;
for(; s < se; s++) {
t = *(unsigned char *)s;
s1 = sf[t];
while(*++s1)
k++;
}
sf['%'] = "%%";
rv = s1 = mem(k,0);
*s1++ = '"';
for(s = s0; s < se; s++) {
t = *(unsigned char *)s;
sprintf(s1, sf[t], t);
s1 += strlen(s1);
}
*s1 = 0;
return rv;
}
char *
cpstring(s)
register char *s;
{
return strcpy(mem(strlen(s)+1,0), s);
}
void
new_iob_data(ios, name)
register io_setup *ios;
char *name;
{
register iob_data *iod;
register char **s, **se;
iod = (iob_data *)
mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
iod->next = iob_list;
iob_list = iod;
iod->type = ios->fields[0];
iod->name = cpstring(name);
s = iod->fields;
se = s + ios->nelt;
while(s < se)
*s++ = "0";
*s = 0;
}
char *
string_num(pfx, n)
char *pfx;
long n;
{
char buf[32];
sprintf(buf, "%s%ld", pfx, n);
/* can't trust return type of sprintf -- BSD gets it wrong */
return strcpy(mem(strlen(buf)+1,0), buf);
}
static defines *define_list;
void
def_start(outfile, s1, s2, post)
FILE *outfile;
char *s1, *s2, *post;
{
defines *d;
int n, n1;
n = n1 = strlen(s1);
if (s2)
n += strlen(s2);
d = (defines *)mem(sizeof(defines)+n, 1);
d->next = define_list;
define_list = d;
strcpy(d->defname, s1);
if (s2)
strcpy(d->defname + n1, s2);
nice_printf(outfile, "#define %s %s", d->defname, post);
}
void
other_undefs(outfile)
FILE *outfile;
{
defines *d;
if (d = define_list) {
define_list = 0;
nice_printf(outfile, "\n");
do
nice_printf(outfile, "#undef %s\n", d->defname);
while(d = d->next);
nice_printf(outfile, "\n");
}
}

66
lang/fortran/comp/memset.c Normal file
View file

@ -0,0 +1,66 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
/* This is for the benefit of people whose systems don't provide
* memset, memcpy, and memcmp. If yours is such a system, adjust
* the makefile by adding memset.o to the "OBJECTS =" assignment.
* WARNING: the memcpy below is adequate for f2c, but is not a
* general memcpy routine (which must correctly handle overlapping
* fields).
*/
int
memcmp(s1, s2, n)
register char *s1, *s2;
int n;
{
register char *se;
for(se = s1 + n; s1 < se; s1++, s2++)
if (*s1 != *s2)
return *s1 - *s2;
return 0;
}
char *
memcpy(s1, s2, n)
register char *s1, *s2;
int n;
{
register char *s0 = s1, *se = s1 + n;
while(s1 < se)
*s1++ = *s2++;
return s0;
}
memset(s, c, n)
register char *s;
register int c;
int n;
{
register char *se = s + n;
while(s < se)
*s++ = c;
}

1041
lang/fortran/comp/misc.c Normal file
View file

File diff suppressed because it is too large Load diff

711
lang/fortran/comp/names.c Normal file
View file

@ -0,0 +1,711 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "output.h"
#include "names.h"
#include "iob.h"
/* Names generated by the translator are guaranteed to be unique from the
Fortan names because Fortran does not allow underscores in identifiers,
and all of the system generated names do have underscores. The various
naming conventions are outlined below:
FORMAT APPLICATION
----------------------------------------------------------------------
io_# temporaries generated by IO calls; these will
contain the device number (e.g. 5, 6, 0)
ret_val function return value, required for complex and
character functions.
ret_val_len length of the return value in character functions
ssss_len length of character argument "ssss"
c_# member of the literal pool, where # is an
arbitrary label assigned by the system
cs_# short integer constant in the literal pool
t_# expression temporary, # is the depth of arguments
on the stack.
L# label "#", given by user in the Fortran program.
This is unique because Fortran labels are numeric
pad_# label on an init field required for alignment
xxx_init label on a common block union, if a block data
requires a separate declaration
*/
/* generate variable references */
char *c_type_decl (type, is_extern)
int type, is_extern;
{
static char buff[100];
switch (type) {
case TYADDR: strcpy (buff, "address"); break;
case TYSHORT: strcpy (buff, "shortint"); break;
case TYLONG: strcpy (buff, "integer"); break;
case TYREAL: if (!is_extern || !forcedouble)
{ strcpy (buff, "real");break; }
case TYDREAL: strcpy (buff, "doublereal"); break;
case TYCOMPLEX: if (is_extern)
strcpy (buff, Ansi ? "/* Complex */ VOID"
: "/* Complex */ int");
else
strcpy (buff, "complex");
break;
case TYDCOMPLEX:if (is_extern)
strcpy (buff, Ansi ? "/* Double Complex */ VOID"
: "/* Double Complex */ int");
else
strcpy (buff, "doublecomplex");
break;
case TYLOGICAL: strcpy(buff, typename[TYLOGICAL]);
break;
case TYCHAR: if (is_extern)
strcpy (buff, Ansi ? "/* Character */ VOID"
: "/* Character */ int");
else
strcpy (buff, "char");
break;
case TYUNKNOWN: strcpy (buff, "UNKNOWN");
/* If a procedure's type is unknown, assume it's a subroutine */
if (!is_extern)
break;
/* Subroutines must return an INT, because they might return a label
value. Even if one doesn't, the caller will EXPECT it to. */
case TYSUBR: strcpy (buff, "/* Subroutine */ int");
break;
case TYERROR: strcpy (buff, "ERROR"); break;
case TYVOID: strcpy (buff, "void"); break;
case TYCILIST: strcpy (buff, "cilist"); break;
case TYICILIST: strcpy (buff, "icilist"); break;
case TYOLIST: strcpy (buff, "olist"); break;
case TYCLLIST: strcpy (buff, "cllist"); break;
case TYALIST: strcpy (buff, "alist"); break;
case TYINLIST: strcpy (buff, "inlist"); break;
case TYFTNLEN: strcpy (buff, "ftnlen"); break;
default: sprintf (buff, "BAD DECL '%d'", type);
break;
} /* switch */
return buff;
} /* c_type_decl */
char *new_func_length()
{ return "ret_val_len"; }
char *new_arg_length(arg)
Namep arg;
{
static char buf[64];
sprintf (buf, "%s_len", arg->fvarname);
return buf;
} /* new_arg_length */
/* declare_new_addr -- Add a new local variable to the function, given a
pointer to an Addrblock structure (which must have the uname_tag set)
This list of idents will be printed in reverse (i.e., chronological)
order */
void
declare_new_addr (addrp)
struct Addrblock *addrp;
{
extern chainp new_vars;
new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
} /* declare_new_addr */
wr_nv_ident_help (outfile, addrp)
FILE *outfile;
struct Addrblock *addrp;
{
int eltcount = 0;
if (addrp == (struct Addrblock *) NULL)
return;
if (addrp -> isarray) {
frexpr (addrp -> memoffset);
addrp -> memoffset = ICON(0);
eltcount = addrp -> ntempelt;
addrp -> ntempelt = 0;
addrp -> isarray = 0;
} /* if */
out_addr (outfile, addrp);
if (eltcount)
nice_printf (outfile, "[%d]", eltcount);
} /* wr_nv_ident_help */
int nv_type_help (addrp)
struct Addrblock *addrp;
{
if (addrp == (struct Addrblock *) NULL)
return -1;
return addrp -> vtype;
} /* nv_type_help */
/* lit_name -- returns a unique identifier for the given literal. Make
the label useful, when possible. For example:
1 -> c_1 (constant 1)
2 -> c_2 (constant 2)
1000 -> c_1000 (constant 1000)
1000000 -> c_b<memno> (big constant number)
1.2 -> c_1_2 (constant 1.2)
1.234345 -> c_b<memno> (big constant number)
-1 -> c_n1 (constant -1)
-1.0 -> c_n1_0 (constant -1.0)
.true. -> c_true (constant true)
.false. -> c_false (constant false)
default -> c_b<memno> (default label)
*/
char *lit_name (litp)
struct Literal *litp;
{
static char buf[CONST_IDENT_MAX];
if (litp == (struct Literal *) NULL)
return NULL;
switch (litp -> littype) {
case TYSHORT:
if (litp -> litval.litival < 32768 &&
litp -> litval.litival > -32769) {
ftnint val = litp -> litval.litival;
if (val < 0)
sprintf (buf, "cs_n%ld", -val);
else
sprintf (buf, "cs__%ld", val);
} else
sprintf (buf, "c_b%d", litp -> litnum);
break;
case TYLONG:
if (litp -> litval.litival < 100000 &&
litp -> litval.litival > -10000) {
ftnint val = litp -> litval.litival;
if (val < 0)
sprintf (buf, "c_n%ld", -val);
else
sprintf (buf, "c__%ld", val);
} else
sprintf (buf, "c_b%d", litp -> litnum);
break;
case TYLOGICAL:
sprintf (buf, "c_%s", (litp -> litval.litival ? "true" : "false"));
break;
case TYREAL:
case TYDREAL:
/* Given a limit of 6 or 8 character on external names, */
/* few f.p. values can be meaningfully encoded in the */
/* constant name. Just going with the default cb_# */
/* seems to be the best course for floating-point */
/* constants. */
case TYCHAR:
/* Shouldn't be any of these */
case TYADDR:
case TYCOMPLEX:
case TYDCOMPLEX:
case TYSUBR:
default:
sprintf (buf, "c_b%d", litp -> litnum);
break;
} /* switch */
return buf;
} /* lit_name */
char *
comm_union_name(count)
int count;
{
static char buf[12];
sprintf(buf, "%d", count);
return buf;
}
/* wr_globals -- after every function has been translated, we need to
output the global declarations, such as the static table of constant
values */
wr_globals (outfile)
FILE *outfile;
{
struct Literal *litp, *lastlit;
extern int hsize;
extern char *lit_name();
char *litname;
int did_one, t;
struct Constblock cb;
ftnint x, y;
if (nliterals == 0)
return;
lastlit = litpool + nliterals;
did_one = 0;
for (litp = litpool; litp < lastlit; litp++) {
if (!litp->lituse)
continue;
litname = lit_name(litp);
if (!did_one) {
margin_printf(outfile, "/* Table of constant values */\n\n");
did_one = 1;
}
cb.vtype = litp->littype;
if (litp->littype == TYCHAR) {
x = litp->litval.litival2[0] + litp->litval.litival2[1];
y = x + 1;
nice_printf(outfile,
"static struct { %s fill; char val[%ld+1];", halign, x);
if (y %= hsize)
nice_printf(outfile, " char fill2[%ld];", hsize - y);
nice_printf(outfile, " } %s_st = { 0,", litname);
cb.vleng = ICON(litp->litval.litival2[0]);
cb.Const.ccp = litp->cds[0];
cb.Const.ccp1.blanks = litp->litval.litival2[1];
cb.vtype = TYCHAR;
out_const(outfile, &cb);
frexpr(cb.vleng);
nice_printf(outfile, " };\n");
nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
continue;
}
nice_printf(outfile, "static %s %s = ",
c_type_decl(litp->littype,0), litname);
t = litp->littype;
if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
cb.vstg = 1;
cb.Const.cds[0] = litp->cds[0];
cb.Const.cds[1] = litp->cds[1];
}
else {
memcpy((char *)&cb.Const, (char *)&litp->litval,
sizeof(cb.Const));
cb.vstg = 0;
}
out_const(outfile, &cb);
nice_printf (outfile, ";\n");
} /* for */
if (did_one)
nice_printf (outfile, "\n");
} /* wr_globals */
ftnint
commlen(vl)
register chainp vl;
{
ftnint size;
int type;
struct Dimblock *t;
Namep v;
while(vl->nextp)
vl = vl->nextp;
v = (Namep)vl->datap;
type = v->vtype;
if (type == TYCHAR)
size = v->vleng->constblock.Const.ci;
else
size = typesize[type];
if ((t = v->vdim) && ISCONST(t->nelt))
size *= t->nelt->constblock.Const.ci;
return size + v->voffset;
}
static void /* Pad common block if an EQUIVALENCE extended it. */
pad_common(c)
Extsym *c;
{
register chainp cvl;
register Namep v;
long L = c->maxleng;
int type;
struct Dimblock *t;
int szshort = typesize[TYSHORT];
for(cvl = c->allextp; cvl; cvl = cvl->nextp)
if (commlen((chainp)cvl->datap) >= L)
return;
v = ALLOC(Nameblock);
v->vtype = type = L % szshort ? TYCHAR
: type_choice[L/szshort % 4];
v->vstg = STGCOMMON;
v->vclass = CLVAR;
v->tag = TNAME;
v->vdim = t = ALLOC(Dimblock);
t->ndim = 1;
t->dims[0].dimsize = ICON(L / typesize[type]);
v->fvarname = v->cvarname = "eqv_pad";
c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
}
/* wr_common_decls -- outputs the common declarations in one of three
formats. If all references to a common block look the same (field
names and types agree), only one actual declaration will appear.
Otherwise, the same block will require many structs. If there is no
block data, these structs will be union'ed together (so the linker
knows the size of the largest one). If there IS a block data, only
that version will be associated with the variable, others will only be
defined as types, so the pointer can be cast to it. e.g.
FORTRAN C
----------------------------------------------------------------------
common /com1/ a, b, c struct { real a, b, c; } com1_;
common /com1/ a, b, c union {
common /com1/ i, j, k struct { real a, b, c; } _1;
struct { integer i, j, k; } _2;
} com1_;
common /com1/ a, b, c struct com1_1_ { real a, b, c; };
block data struct { integer i, j, k; } com1_ =
common /com1/ i, j, k { 1, 2, 3 };
data i/1/, j/2/, k/3/
All of these versions will be followed by #defines, since the code in
the function bodies can't know ahead of time which of these options
will be taken */
/* Macros for deciding the output type */
#define ONE_STRUCT 1
#define UNION_STRUCT 2
#define INIT_STRUCT 3
wr_common_decls(outfile)
FILE *outfile;
{
Extsym *ext;
extern int extcomm;
static char *Extern[4] = {"", "Extern ", "extern "};
char *E, *E0 = Extern[extcomm];
int did_one = 0;
for (ext = extsymtab; ext < nextext; ext++) {
if (ext -> extstg == STGCOMMON && ext->allextp) {
chainp comm;
int count = 1;
int which; /* which display to use;
ONE_STRUCT, UNION or INIT */
if (!did_one)
nice_printf (outfile, "/* Common Block Declarations */\n\n");
pad_common(ext);
/* Construct the proper, condensed list of structs; eliminate duplicates
from the initial list ext -> allextp */
comm = ext->allextp = revchain(ext->allextp);
if (ext -> extinit)
which = INIT_STRUCT;
else if (comm->nextp) {
which = UNION_STRUCT;
nice_printf (outfile, "%sunion {\n", E0);
next_tab (outfile);
E = "";
}
else {
which = ONE_STRUCT;
E = E0;
}
for (; comm; comm = comm -> nextp, count++) {
if (which == INIT_STRUCT)
nice_printf (outfile, "struct %s%d_ {\n",
ext->cextname, count);
else
nice_printf (outfile, "%sstruct {\n", E);
next_tab (c_file);
wr_struct (outfile, (chainp) comm -> datap);
prev_tab (c_file);
if (which == UNION_STRUCT)
nice_printf (outfile, "} _%d;\n", count);
else if (which == ONE_STRUCT)
nice_printf (outfile, "} %s;\n", ext->cextname);
else
nice_printf (outfile, "};\n");
} /* for */
if (which == UNION_STRUCT) {
prev_tab (c_file);
nice_printf (outfile, "} %s;\n", ext->cextname);
} /* if */
did_one = 1;
nice_printf (outfile, "\n");
for (count = 1, comm = ext -> allextp; comm;
comm = comm -> nextp, count++) {
def_start(outfile, ext->cextname,
comm_union_name(count), "");
switch (which) {
case ONE_STRUCT:
extern_out (outfile, ext);
break;
case UNION_STRUCT:
nice_printf (outfile, "(");
extern_out (outfile, ext);
nice_printf(outfile, "._%d)", count);
break;
case INIT_STRUCT:
nice_printf (outfile, "(*(struct ");
extern_out (outfile, ext);
nice_printf (outfile, "%d_ *) &", count);
extern_out (outfile, ext);
nice_printf (outfile, ")");
break;
} /* switch */
nice_printf (outfile, "\n");
} /* for count = 1, comm = ext -> allextp */
nice_printf (outfile, "\n");
} /* if ext -> extstg == STGCOMMON */
} /* for ext = extsymtab */
} /* wr_common_decls */
wr_struct (outfile, var_list)
FILE *outfile;
chainp var_list;
{
int last_type = -1;
int did_one = 0;
chainp this_var;
for (this_var = var_list; this_var; this_var = this_var -> nextp) {
Namep var = (Namep) this_var -> datap;
int type;
char *comment = NULL, *wr_ardecls ();
if (var == (Namep) NULL)
err ("wr_struct: null variable");
else if (var -> tag != TNAME)
erri ("wr_struct: bad tag on variable '%d'",
var -> tag);
type = var -> vtype;
if (last_type == type && did_one)
nice_printf (outfile, ", ");
else {
if (did_one)
nice_printf (outfile, ";\n");
nice_printf (outfile, "%s ",
c_type_decl (type, var -> vclass == CLPROC));
} /* else */
/* Character type is really a string type. Put out a '*' for parameters
with unknown length and functions returning character */
if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
|| var -> vclass == CLPROC))
nice_printf (outfile, "*");
var -> vstg = STGAUTO;
out_name (outfile, var);
if (var -> vclass == CLPROC)
nice_printf (outfile, "()");
else if (var -> vdim)
comment = wr_ardecls(outfile, var->vdim,
var->vtype == TYCHAR && ISICON(var->vleng)
? var->vleng->constblock.Const.ci : 1L);
else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
ISICON ((var -> vleng)))
nice_printf (outfile, "[%ld]",
var -> vleng -> constblock.Const.ci);
if (comment)
nice_printf (outfile, "%s", comment);
did_one = 1;
last_type = type;
} /* for this_var */
if (did_one)
nice_printf (outfile, ";\n");
} /* wr_struct */
char *user_label(stateno)
ftnint stateno;
{
static char buf[USER_LABEL_MAX + 1];
static char *Lfmt[2] = { "L_%ld", "L%ld" };
if (stateno >= 0)
sprintf(buf, Lfmt[shiftcase], stateno);
else
sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
return buf;
} /* user_label */
char *temp_name (starter, num, storage)
char *starter;
int num;
char *storage;
{
static char buf[IDENT_LEN];
char *pointer = buf;
char *prefix = "t";
if (storage)
pointer = storage;
if (starter && *starter)
prefix = starter;
sprintf (pointer, "%s__%d", prefix, num);
return pointer;
} /* temp_name */
char *equiv_name (memno, store)
int memno;
char *store;
{
static char buf[IDENT_LEN];
char *pointer = buf;
if (store)
pointer = store;
sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
return pointer;
} /* equiv_name */
void
def_commons(of)
FILE *of;
{
Extsym *ext;
int c, onefile, Union;
char buf[64];
chainp comm;
extern int ext1comm;
if (ext1comm == 1) {
onefile = 1;
c_file = of;
fprintf(of, "/*>>>'/dev/null'<<<*/\n\
#ifdef Define_COMMONs\n\
/*<<</dev/null>>>*/\n");
}
else
onefile = 0;
for(ext = extsymtab; ext < nextext; ext++)
if (ext->extstg == STGCOMMON
&& !ext->extinit && (comm = ext->allextp)) {
sprintf(buf, "%scom.c", ext->cextname);
if (onefile)
fprintf(of, "/*>>>'%s'<<<*/\n",
buf);
else {
c_file = of = fopen(buf,textwrite);
if (!of)
fatalstr("can't open %s", buf);
}
fprintf(of, "#include \"f2c.h\"\n");
if (comm->nextp) {
Union = 1;
nice_printf(of, "union {\n");
next_tab(of);
}
else
Union = 0;
for(c = 1; comm; comm = comm->nextp) {
nice_printf(of, "struct {\n");
next_tab(of);
wr_struct(of, (chainp)comm->datap);
prev_tab(of);
if (Union)
nice_printf(of, "} _%d;\n", c++);
}
if (Union)
prev_tab(of);
nice_printf(of, "} %s;\n", ext->cextname);
if (onefile)
fprintf(of, "/*<<<%s>>>*/\n", buf);
else
fclose(of);
}
if (onefile)
fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
/*<<</dev/null>>>*/\n");
}
/* C Language keywords. Needed to filter unwanted fortran identifiers like
* "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
* Also includes C++ keywords and types used for I/O in f2c.h .
* These keywords must be in alphabetical order (as defined by strcmp()).
*/
char *c_keywords[] = {
"Long", "Multitype", "Namelist", "Vardesc",
"abs", "acos", "address", "alist", "asin", "asm",
"atan", "atan2", "auto", "break",
"case", "catch", "char", "cilist", "class", "cllist",
"complex", "const", "continue", "cos", "cosh",
"dabs", "default", "defined", "delete",
"dmax", "dmin", "do", "double", "doublecomplex", "doublereal",
"else", "entry", "enum", "exp", "extern",
"flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
"icilist", "if", "include", "inline", "inlist", "int", "integer",
"log", "logical", "long", "max", "min", "new",
"olist", "operator", "overload", "private", "protected", "public",
"real", "register", "return",
"short", "shortint", "shortlogical", "signed", "sin", "sinh",
"sizeof", "sqrt", "static", "struct", "switch",
"tan", "tanh", "template", "this", "try", "typedef",
"union", "unsigned", "virtual", "void", "volatile", "while"
}; /* c_keywords */
int n_keywords = sizeof(c_keywords)/sizeof(char *);

22
lang/fortran/comp/names.h Normal file
View file

@ -0,0 +1,22 @@
#define CONST_IDENT_MAX 30
#define IO_IDENT_MAX 30
#define ARGUMENT_MAX 30
#define USER_LABEL_MAX 30
#define EQUIV_INIT_NAME "equiv"
#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a))
#define nv_type(x) nv_type_help ((struct Addrblock *) x)
extern char *c_keywords[];
char *new_io_ident (/* char * */);
char *new_func_length (/* char * */);
char *new_arg_length (/* Namep */);
void declare_new_addr (/* struct Addrblock * */);
char *nv_ident_help (/* struct Addrblock * */);
int nv_type_help (/* struct Addrblock */);
char *user_label (/* int */);
char *temp_name (/* int, char */);
char *c_type_decl (/* int, int */);
char *equiv_name (/* int, char * */);

367
lang/fortran/comp/niceprintf.c Normal file
View file

@ -0,0 +1,367 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "names.h"
#include "output.h"
#define TOO_LONG_INDENT (2 * tab_size)
#define MAX_INDENT 44
#define MIN_INDENT 22
static int last_was_newline = 0;
int indent = 0;
int in_comment = 0;
static int
write_indent(fp, use_indent, extra_indent, start, end)
FILE *fp;
int use_indent, extra_indent;
char *start, *end;
{
int ind, tab;
if (last_was_newline && use_indent) {
if (*start == '\n') do {
putc('\n', fp);
if (++start > end)
return;
}
while(*start == '\n');
ind = indent <= MAX_INDENT
? indent
: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
tab = ind + extra_indent;
while (tab > 7) {
putc ('\t', fp);
tab -= 8;
} /* while */
while (tab-- > 0)
putc (' ', fp);
} /* if last_was_newline */
while (start <= end)
putc (*start++, fp);
} /* write_indent */
/*VARARGS2*/
int margin_printf (fp, a, b, c, d, e, f, g)
FILE *fp;
char *a;
long b, c, d, e, f, g;
{
ind_printf (0, fp, a, b, c, d, e, f, g);
} /* margin_printf */
/*VARARGS2*/
int nice_printf (fp, a, b, c, d, e, f, g)
FILE *fp;
char *a;
long b, c, d, e, f, g;
{
ind_printf (1, fp, a, b, c, d, e, f, g);
} /* nice_printf */
#define max_line_len c_output_line_length
/* 74Number of characters allowed on an output
line. This assumes newlines are handled
nicely, i.e. a newline after a full text
line on a terminal is ignored */
/* output_buf holds the text of the next line to be printed. It gets
flushed when a newline is printed. next_slot points to the next
available location in the output buffer, i.e. where the next call to
nice_printf will have its output stored */
static char *output_buf;
static char *next_slot;
static char *string_start;
static char *word_start = NULL;
static int cursor_pos = 0;
static int In_string = 0;
void
np_init()
{
next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
memset(output_buf, 0, MAX_OUTPUT_SIZE);
}
static char *
adjust_pointer_in_string(pointer)
register char *pointer;
{
register char *s, *s1, *se, *s0;
/* arrange not to break \002 */
s1 = string_start ? string_start : output_buf;
for(s = s1; s < pointer; s++) {
s0 = s1;
s1 = s;
if (*s == '\\') {
se = s++ + 4;
if (se > pointer)
break;
if (*s < '0' || *s > '7')
continue;
while(++s < se)
if (*s < '0' || *s > '7')
break;
--s;
}
}
return s0 - 1;
}
/* ANSI says strcpy's behavior is undefined for overlapping args,
* so we roll our own fwd_strcpy: */
static void
fwd_strcpy(t, s)
register char *t, *s;
{ while(*t++ = *s++); }
/* isident -- true iff character could belong to a unit. C allows
letters, numbers and underscores in identifiers. This also doubles as
a check for numeric constants, since we include the decimal point and
minus sign. The minus has to be here, since the constant "10e-2"
cannot be broken up. The '.' also prevents structure references from
being broken, which is a quite acceptable side effect */
#define isident(x) (Tr[x] & 1)
#define isntident(x) (!Tr[x])
int ind_printf (use_indent, fp, a, b, c, d, e, f, g)
int use_indent;
FILE *fp;
char *a;
long b, c, d, e, f, g;
{
extern int max_line_len;
extern FILEP c_file;
extern char tr_tab[]; /* in output.c */
register char *Tr = tr_tab;
int ch, inc, ind;
static int extra_indent, last_indent, set_cursor = 1;
cursor_pos += indent - last_indent;
last_indent = indent;
sprintf (next_slot, a, b, c, d, e, f, g);
if (fp != c_file) {
fprintf (fp,"%s", next_slot);
return 1;
} /* if fp != c_file */
do {
char *pointer;
/* The for loop will parse one output line */
if (set_cursor) {
ind = indent <= MAX_INDENT
? indent
: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
cursor_pos = ind + extra_indent;
set_cursor = 0;
}
if (in_comment)
for (pointer = next_slot; *pointer && *pointer != '\n' &&
cursor_pos <= max_line_len; pointer++)
cursor_pos++;
else
for (pointer = next_slot; *pointer && *pointer != '\n' &&
cursor_pos <= max_line_len; pointer++) {
/* Update state variables here */
if (In_string) {
switch(*pointer) {
case '\\':
if (++cursor_pos > max_line_len) {
cursor_pos -= 2;
--pointer;
goto overflow;
}
++pointer;
break;
case '"':
In_string = 0;
word_start = 0;
}
}
else switch (*pointer) {
case '"':
if (cursor_pos + 5 > max_line_len) {
word_start = 0;
--pointer;
goto overflow;
}
In_string = 1;
string_start = word_start = pointer;
break;
case '\'':
if (pointer[1] == '\\')
if ((ch = pointer[2]) >= '0' && ch <= '7')
for(inc = 3; pointer[inc] != '\''
&& ++inc < 5;);
else
inc = 3;
else
inc = 2;
/*debug*/ if (pointer[inc] != '\'')
/*debug*/ fatalstr("Bad character constant %.10s",
pointer);
if ((cursor_pos += inc) > max_line_len) {
cursor_pos -= inc;
word_start = 0;
--pointer;
goto overflow;
}
word_start = pointer;
pointer += inc;
break;
case '\t':
cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1;
break;
default: {
/* HACK Assumes that all characters in an atomic C token will be written
at the same time. Must check for tokens first, since '-' is considered
part of an identifier; checking isident first would mean breaking up "->" */
if (!word_start && isident(*(unsigned char *)pointer))
word_start = pointer;
else if (word_start && isntident(*(unsigned char *)pointer))
word_start = NULL;
break;
} /* default */
} /* switch */
cursor_pos++;
} /* for pointer = next_slot */
overflow:
if (*pointer == '\0') {
/* The output line is not complete, so break out and don't output
anything. The current line fragment will be stored in the buffer */
next_slot = pointer;
break;
} else {
char last_char;
int in_string0 = In_string;
/* If the line was too long, move pointer back to the character before
the current word. This allows line breaking on word boundaries. Make
sure that 80 character comment lines get broken up somehow. We assume
that any non-string 80 character identifier must be in a comment.
*/
if (word_start && *pointer != '\n' && word_start > output_buf)
if (In_string)
if (string_start && pointer - string_start < 5)
pointer = string_start - 1;
else {
pointer = adjust_pointer_in_string(pointer);
string_start = 0;
}
else if (word_start == string_start
&& pointer - string_start >= 5) {
pointer = adjust_pointer_in_string(next_slot);
In_string = 1;
string_start = 0;
}
else
pointer = word_start - 1;
else if (cursor_pos > max_line_len) {
extern char *strchr();
if (In_string) {
pointer = adjust_pointer_in_string(pointer);
if (string_start && pointer > string_start)
string_start = 0;
}
else if (strchr("&*+-/<=>|", *pointer)
&& strchr("!%&*+-/<=>^|", pointer[-1])) {
pointer -= 2;
if (strchr("<>", *pointer)) /* <<=, >>= */
pointer--;
}
else
pointer--;
}
last_char = *pointer;
write_indent(fp, use_indent, extra_indent, output_buf, pointer);
next_slot = output_buf;
if (In_string && !string_start && Ansi == 1 && last_char != '\n')
*next_slot++ = '"';
fwd_strcpy(next_slot, pointer + 1);
/* insert a line break */
if (last_char == '\n') {
if (In_string)
last_was_newline = 0;
else {
last_was_newline = 1;
extra_indent = 0;
}
}
else {
extra_indent = TOO_LONG_INDENT;
if (In_string && !string_start) {
if (Ansi == 1) {
fprintf(fp, "\"\n");
use_indent = 1;
last_was_newline = 1;
}
else {
fprintf(fp, "\\\n");
last_was_newline = 0;
}
In_string = in_string0;
}
else {
putc ('\n', fp);
last_was_newline = 1;
}
} /* if *pointer != '\n' */
if (In_string && Ansi != 1 && !string_start)
cursor_pos = 0;
else
set_cursor = 1;
string_start = word_start = NULL;
} /* else */
} while (*next_slot);
return 0;
} /* ind_printf */

16
lang/fortran/comp/niceprintf.h Normal file
View file

@ -0,0 +1,16 @@
/* niceprintf.h -- contains constants and macros from the output filter
for the generated C code. We use macros for increased speed, less
function overhead. */
#define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS
the length of the longest string
printed using nice_printf */
#define next_tab(fp) (indent += tab_size)
#define prev_tab(fp) (indent -= tab_size)

1431
lang/fortran/comp/output.c Normal file
View file

File diff suppressed because it is too large Load diff

65
lang/fortran/comp/output.h Normal file
View file

@ -0,0 +1,65 @@
/* nice_printf -- same arguments as fprintf.
All output which is to become C code must be directed through this
function. For now, no buffering is done. Later on, every line of
output will be filtered to accomodate the style definitions (e.g. one
statement per line, spaces between function names and argument lists,
etc.)
*/
#include "niceprintf.h"
extern int nice_printf ();
/* Definitions for the opcode table. The table is indexed by the macros
which are #defined in defines.h */
#define UNARY_OP 01
#define BINARY_OP 02
#define SPECIAL_FMT NULL
#define is_unary_op(x) (opcode_table[x].type == UNARY_OP)
#define is_binary_op(x) (opcode_table[x].type == BINARY_OP)
#define op_precedence(x) (opcode_table[x].prec)
#define op_format(x) (opcode_table[x].format)
/* _assoc_table -- encodes left-associativity and right-associativity
information; indexed by precedence level. Only 2, 3, 14 are
right-associative. Source: Kernighan & Ritchie, p. 49 */
extern char _assoc_table[];
#define is_right_assoc(x) (_assoc_table [x])
#define is_left_assoc(x) (! _assoc_table [x])
typedef struct {
int type; /* UNARY_OP or BINARY_OP */
int prec; /* Precedence level, useful for adjusting
number of parens to insert. Zero is a
special level, and 2, 3, 14 are
right-associative */
char *format;
} table_entry;
extern char *fl_fmt_string; /* Float constant format string */
extern char *db_fmt_string; /* Double constant format string */
extern char *cm_fmt_string; /* Complex constant format string */
extern char *dcm_fmt_string; /* Double Complex constant format string */
extern int indent; /* Number of spaces to indent; this is a
temporary fix */
extern int tab_size; /* Number of spaces in each tab */
extern int in_string;
extern table_entry opcode_table[];
void expr_out (), out_init (), out_addr (), out_const ();
void out_name (), extern_out (), out_asgoto ();
void out_if (), out_else (), elif_out ();
void endif_out (), end_else_out ();
void compgoto_out (), out_for ();
void out_end_for (), out_and_free_statement ();

160
lang/fortran/comp/p1defs.h Normal file
View file

@ -0,0 +1,160 @@
#define P1_UNKNOWN 0
#define P1_COMMENT 1 /* Fortan comment string */
#define P1_EOF 2 /* End of file dummy token */
#define P1_SET_LINE 3 /* Reset the line counter */
#define P1_FILENAME 4 /* Name of current input file */
#define P1_NAME_POINTER 5 /* Pointer to hash table entry */
#define P1_CONST 6 /* Some constant value */
#define P1_EXPR 7 /* Followed by opcode */
/* The next two tokens could be grouped together, since they always come
from an Addr structure */
#define P1_IDENT 8 /* Char string identifier in addrp->user
field */
#define P1_EXTERN 9 /* Pointer to external symbol entry */
#define P1_HEAD 10 /* Function header info */
#define P1_LIST 11 /* A list of data (e.g. arguments) will
follow the tag, type, and count */
#define P1_LITERAL 12 /* Hold the index into the literal pool */
#define P1_LABEL 13 /* label value */
#define P1_ASGOTO 14 /* Store the hash table pointer of
variable used in assigned goto */
#define P1_GOTO 15 /* Store the statement number */
#define P1_IF 16 /* store the condition as an expression */
#define P1_ELSE 17 /* No data */
#define P1_ELIF 18 /* store the condition as an expression */
#define P1_ENDIF 19 /* Marks the end of a block IF */
#define P1_ENDELSE 20 /* Marks the end of a block ELSE */
#define P1_ADDR 21 /* Addr data; used for arrays, common and
equiv addressing, NOT for names, idents
or externs */
#define P1_SUBR_RET 22 /* Subroutine return; the return expression
follows */
#define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */
#define P1_FOR 24 /* C FOR loop; three expressions follow */
#define P1_ENDFOR 25 /* End of C FOR loop */
#define P1_FORTRAN 26 /* original Fortran source */
#define P1_CHARP 27 /* user.Charp field -- for long names */
#define P1_WHILE1START 28 /* start of DO WHILE */
#define P1_WHILE2START 29 /* rest of DO WHILE */
#define P1_PROCODE 30 /* invoke procode() -- to adjust params */
#define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max
in else if() */
#define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */
#define P1_STMTBUFSIZE 1400
#define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */
#define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */
extern void p1put (/* int */);
extern void p1_comment (/* char * */);
extern void p1_label (/* int */);
extern void p1_line_number (/* int */);
extern void p1put_filename();
extern void p1_expr (/* expptr */);
extern void p1_head (/* int, char * */);
extern void p1_if (/* expptr */);
extern void p1_else ();
extern void p1_elif (/* expptr */);
extern void p1_endif ();
extern void p1else_end ();
extern void p1_subr_ret (/* expptr */);
extern void p1_goto(/* long */);
extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */);
extern void p1_for (/* expptr, expptr, expptr */);
extern void p1for_end ();
extern void p1puts (/* int, char * */);
/* The pass 1 intermediate file has the following format:
<ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n
e.g. 1: This is a comment
This format is destined to change in the future, but for now a readable
form is more desirable than a compact form.
NOTES ABOUT THE P1 FORMAT
----------------------------------------------------------------------
P1_COMMENT: The comment string (in <data>) may be at most
COMMENT_BUFFER_SIZE bytes long. It must contain no newlines
or null characters. A side effect of the way comments are
read in lex.c is that no '\377' chars may be in a
comment either.
P1_SET_LINE: <data> holds the line number in the current source file.
P1_INC_LINE: Increment the source line number; <data> is empty.
P1_NAME_POINTER: <data> holds the integer representation of a
pointer into a hash table entry.
P1_CONST: the first field in <data> is a type tag (one of the
TYxxxx macros), the next field holds the constant
value
P1_EXPR: <data> holds the opcode number of the expression,
followed by the type of the expression (required for
OPCONV). Next is the value of vleng.
The type of operation represented by the
opcode determines how many of the following data items
are part of this expression.
P1_IDENT: <data> holds the type, then storage, then the
char string identifier in the addrp->user field.
P1_EXTERN: <data> holds an offset into the external symbol
table entry
P1_HEAD: the first field in <data> is the procedure class, the
second is the name of the procedure
P1_LIST: the first field in <data> is the tag, the second the
type of the list, the third the number of elements in
the list
P1_LITERAL: <data> holds the litnum of a value in the
literal pool.
P1_LABEL: <data> holds the statement number of the current
line
P1_ASGOTO: <data> holds the hash table pointer of the variable
P1_GOTO: <data> holds the statement number to jump to
P1_IF: <data> is empty, the following expression is the IF
condition.
P1_ELSE: <data> is empty.
P1_ELIF: <data> is empty, the following expression is the IF
condition.
P1_ENDIF: <data> is empty.
P1_ENDELSE: <data> is empty.
P1_ADDR: <data> holds a direct copy of the structure. The
next expression is a copy of vleng, and the next a
copy of memoffset.
P1_SUBR_RET: The next token is an expression for the return value.
P1_COMP_GOTO: The next token is an integer expression, the
following one a list of labels.
P1_FOR: The next three expressions are the Init, Test, and
Increment expressions of a C FOR loop.
P1_ENDFOR: Marks the end of the body of a FOR loop
*/

568
lang/fortran/comp/p1output.c Normal file
View file

@ -0,0 +1,568 @@
/****************************************************************
Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "p1defs.h"
#include "output.h"
#include "names.h"
static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
p1_literal(), p1_name(), p1_unary(), p1putn();
static void p1putd (/* int, int */);
static void p1putds (/* int, int, char * */);
static void p1putdds (/* int, int, int, char * */);
static void p1putdd (/* int, int, int */);
static void p1putddd (/* int, int, int, int */);
/* p1_comment -- save the text of a Fortran comment in the intermediate
file. Make sure that there are no spurious "/ *" or "* /" characters by
mapping them onto "/+" and "+/". str is assumed to hold no newlines and be
null terminated; it may be modified by this function. */
void p1_comment (str)
char *str;
{
register unsigned char *pointer, *ustr;
if (!str)
return;
/* Get rid of any open or close comment combinations that may be in the
Fortran input */
ustr = (unsigned char *)str;
for(pointer = ustr; *pointer; pointer++)
if (*pointer == '*' && (pointer[1] == '/'
|| pointer > ustr && pointer[-1] == '/'))
*pointer = '+';
/* trim trailing white space */
#ifdef isascii
while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
#else
while(--pointer >= ustr && isspace(*pointer));
#endif
pointer[1] = 0;
p1puts (P1_COMMENT, str);
} /* p1_comment */
void p1_line_number (line_number)
long line_number;
{
p1putd (P1_SET_LINE, line_number);
} /* p1_line_number */
/* p1_name -- Writes the address of a hash table entry into the
intermediate file */
static void p1_name (namep)
Namep namep;
{
p1putd (P1_NAME_POINTER, (long) namep);
namep->visused = 1;
} /* p1_name */
void p1_expr (expr)
expptr expr;
{
/* An opcode of 0 means a null entry */
if (expr == ENULL) {
p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */
return;
} /* if (expr == ENULL) */
switch (expr -> tag) {
case TNAME:
p1_name ((Namep) expr);
return;
case TCONST:
p1_const(&expr->constblock);
return;
case TEXPR:
/* Fall through the switch */
break;
case TADDR:
p1_addr (&(expr -> addrblock));
goto freeup;
case TPRIM:
warn ("p1_expr: got TPRIM");
return;
case TLIST:
p1_list (&(expr->listblock));
frchain( &(expr->listblock.listp) );
return;
case TERROR:
return;
default:
erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
return;
}
/* Now we know that the tag is TEXPR */
if (is_unary_op (expr -> exprblock.opcode))
p1_unary (&(expr -> exprblock));
else if (is_binary_op (expr -> exprblock.opcode))
p1_binary (&(expr -> exprblock));
else
erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode);
freeup:
free((char *)expr);
} /* p1_expr */
static void p1_const(cp)
register Constp cp;
{
int type = cp->vtype;
expptr vleng = cp->vleng;
union Constant *c = &cp->Const;
char cdsbuf0[64], cdsbuf1[64];
char *cds0, *cds1;
switch (type) {
case TYSHORT:
case TYLONG:
case TYLOGICAL:
fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
break;
case TYREAL:
case TYDREAL:
fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
break;
case TYCOMPLEX:
case TYDCOMPLEX:
if (cp->vstg) {
cds0 = c->cds[0];
cds1 = c->cds[1];
}
else {
cds0 = cds(dtos(c->cd[0]), cdsbuf0);
cds1 = cds(dtos(c->cd[1]), cdsbuf1);
}
fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
cds0, cds1);
break;
case TYCHAR:
if (vleng && !ISICON (vleng))
erri("p1_const: bad vleng '%d'\n", (int) vleng);
else
fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
cpexpr((expptr)cp));
break;
default:
erri ("p1_const: bad constant type '%d'", type);
break;
} /* switch */
} /* p1_const */
void p1_asgoto (addrp)
Addrp addrp;
{
p1put (P1_ASGOTO);
p1_addr (addrp);
} /* p1_asgoto */
void p1_goto (stateno)
ftnint stateno;
{
p1putd (P1_GOTO, stateno);
} /* p1_goto */
static void p1_addr (addrp)
register struct Addrblock *addrp;
{
int stg;
if (addrp == (struct Addrblock *) NULL)
return;
stg = addrp -> vstg;
if (ONEOF(stg, M(STGINIT)|M(STGREG))
|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
(!ISICON(addrp->memoffset)
|| (addrp->uname_tag == UNAM_NAME
? addrp->memoffset->constblock.Const.ci
!= addrp->user.name->voffset
: addrp->memoffset->constblock.Const.ci))
|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
(!ISICON(addrp->memoffset)
|| addrp->memoffset->constblock.Const.ci)
|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
{
p1_big_addr (addrp);
return;
}
/* Write out a level of indirection for non-array arguments, which have
addrp -> memoffset set and are handled by p1_big_addr().
Lengths are passed by value, so don't check STGLENG
28-Jun-89 (dmg) Added the check for != TYCHAR
*/
if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
p1_expr (ENULL); /* Put dummy vleng */
} /* if stg == STGARG */
switch (addrp -> uname_tag) {
case UNAM_NAME:
p1_name (addrp -> user.name);
break;
case UNAM_IDENT:
p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
addrp->user.ident);
break;
case UNAM_CHARP:
p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
addrp->user.Charp);
break;
case UNAM_EXTERN:
p1putd (P1_EXTERN, (long) addrp -> memno);
if (addrp->vclass == CLPROC)
extsymtab[addrp->memno].extype = addrp->vtype;
break;
case UNAM_CONST:
if (addrp -> memno != BAD_MEMNO)
p1_literal (addrp -> memno);
else
p1_const((struct Constblock *)addrp);
break;
case UNAM_UNKNOWN:
default:
erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag);
break;
} /* switch */
} /* p1_addr */
static void p1_list (listp)
struct Listblock *listp;
{
chainp lis;
int count = 0;
if (listp == (struct Listblock *) NULL)
return;
/* Count the number of parameters in the list */
for (lis = listp -> listp; lis; lis = lis -> nextp)
count++;
p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
for (lis = listp -> listp; lis; lis = lis -> nextp)
p1_expr ((expptr) lis -> datap);
} /* p1_list */
void p1_label (lab)
long lab;
{
if (parstate < INDATA)
earlylabs = mkchain((char *)lab, earlylabs);
else
p1putd (P1_LABEL, lab);
}
static void p1_literal (memno)
long memno;
{
p1putd (P1_LITERAL, memno);
} /* p1_literal */
void p1_if (expr)
expptr expr;
{
p1put (P1_IF);
p1_expr (expr);
} /* p1_if */
void p1_elif (expr)
expptr expr;
{
p1put (P1_ELIF);
p1_expr (expr);
} /* p1_elif */
void p1_else ()
{
p1put (P1_ELSE);
} /* p1_else */
void p1_endif ()
{
p1put (P1_ENDIF);
} /* p1_endif */
void p1else_end ()
{
p1put (P1_ENDELSE);
} /* p1else_end */
static void p1_big_addr (addrp)
Addrp addrp;
{
if (addrp == (Addrp) NULL)
return;
p1putn (P1_ADDR, sizeof (struct Addrblock), (char *) addrp);
p1_expr (addrp -> vleng);
p1_expr (addrp -> memoffset);
if (addrp->uname_tag == UNAM_NAME)
addrp->user.name->visused = 1;
} /* p1_big_addr */
static void p1_unary (e)
struct Exprblock *e;
{
if (e == (struct Exprblock *) NULL)
return;
p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
p1_expr (e -> vleng);
switch (e -> opcode) {
case OPNEG:
case OPNEG1:
case OPNOT:
case OPABS:
case OPBITNOT:
case OPPREINC:
case OPPREDEC:
case OPADDR:
case OPIDENTITY:
case OPCHARCAST:
case OPDABS:
p1_expr(e -> leftp);
break;
default:
erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
break;
} /* switch */
} /* p1_unary */
static void p1_binary (e)
struct Exprblock *e;
{
if (e == (struct Exprblock *) NULL)
return;
p1putdd (P1_EXPR, e -> opcode, e -> vtype);
p1_expr (e -> vleng);
p1_expr (e -> leftp);
p1_expr (e -> rightp);
} /* p1_binary */
void p1_head (class, name)
int class;
char *name;
{
p1putds (P1_HEAD, class, name ? name : "");
} /* p1_head */
void p1_subr_ret (retexp)
expptr retexp;
{
p1put (P1_SUBR_RET);
p1_expr (cpexpr(retexp));
} /* p1_subr_ret */
void p1comp_goto (index, count, labels)
expptr index;
int count;
struct Labelblock *labels[];
{
struct Constblock c;
int i;
register struct Labelblock *L;
p1put (P1_COMP_GOTO);
p1_expr (index);
/* Write out a P1_LIST directly, to avoid the overhead of allocating a
list before it's needed HACK HACK HACK */
p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
c.vtype = TYLONG;
c.vleng = 0;
for (i = 0; i < count; i++) {
L = labels[i];
L->labused = 1;
c.Const.ci = L->stateno;
p1_const(&c);
} /* for i = 0 */
} /* p1comp_goto */
void p1_for (init, test, inc)
expptr init, test, inc;
{
p1put (P1_FOR);
p1_expr (init);
p1_expr (test);
p1_expr (inc);
} /* p1_for */
void p1for_end ()
{
p1put (P1_ENDFOR);
} /* p1for_end */
/* ----------------------------------------------------------------------
The intermediate file actually gets written ONLY by the routines below.
To change the format of the file, you need only change these routines.
----------------------------------------------------------------------
*/
/* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that
str contains no newlines and is null-terminated. */
void p1puts (type, str)
int type;
char *str;
{
fprintf (pass1_file, "%d: %s\n", type, str);
} /* p1puts */
/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
static void p1putd (type, value)
int type;
long value;
{
fprintf (pass1_file, "%d: %ld\n", type, value);
} /* p1_putd */
/* p1putdd -- Put a typed pair of integers into the intermediate file. */
static void p1putdd (type, v1, v2)
int type, v1, v2;
{
fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
} /* p1putdd */
/* p1putddd -- Put a typed triple of integers into the intermediate file. */
static void p1putddd (type, v1, v2, v3)
int type, v1, v2, v3;
{
fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
} /* p1putddd */
union dL {
double d;
long L[2];
};
static void p1putn (type, count, str)
int type, count;
char *str;
{
int i;
fprintf (pass1_file, "%d: ", type);
for (i = 0; i < count; i++)
putc (str[i], pass1_file);
putc ('\n', pass1_file);
} /* p1putn */
/* p1put -- Put a type marker into the intermediate file. */
void p1put(type)
int type;
{
fprintf (pass1_file, "%d:\n", type);
} /* p1put */
static void p1putds (type, i, str)
int type;
int i;
char *str;
{
fprintf (pass1_file, "%d: %d %s\n", type, i, str);
} /* p1putds */
static void p1putdds (token, type, stg, str)
int token, type, stg;
char *str;
{
fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
} /* p1putdds */

39
lang/fortran/comp/parse.h Normal file
View file

@ -0,0 +1,39 @@
#ifndef PARSE_INCLUDE
#define PARSE_INCLUDE
/* macros for the parse_args routine */
#define P_STRING 1 /* Macros for the result_type attribute */
#define P_CHAR 2
#define P_SHORT 3
#define P_INT 4
#define P_LONG 5
#define P_FILE 6
#define P_OLD_FILE 7
#define P_NEW_FILE 8
#define P_FLOAT 9
#define P_DOUBLE 10
#define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */
#define P_REQUIRED_PREFIX 02
#define P_NO_ARGS 0 /* Macros for the arg_count attribute */
#define P_ONE_ARG 1
#define P_INFINITE_ARGS 2
#define p_entry(pref,swit,flag,count,type,store,size) \
{ (pref), (swit), (flag), (count), (type), (int *) (store), (size) }
typedef struct {
char *prefix;
char *string;
int flags;
int count;
int result_type;
int *result_ptr;
int table_size;
} arg_info;
extern int parse_args ();
#endif

499
lang/fortran/comp/parse_args.c Normal file
View file

@ -0,0 +1,499 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
/* parse_args
This function will parse command line input into appropriate data
structures, output error messages when appropriate and provide some
minimal type conversion.
Input to the function consists of the standard argc,argv
values, and a table which directs the parser. Each table entry has the
following components:
prefix -- the (optional) switch character string, e.g. "-" "/" "="
switch -- the command string, e.g. "o" "data" "file" "F"
flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX
arg_count -- number of arguments this command requires, e.g. 0 for
booleans, 1 for filenames, INFINITY for input files
result_type -- how to interpret the switch arguments, e.g. STRING,
CHAR, FILE, OLD_FILE, NEW_FILE
result_ptr -- pointer to storage for the result, be it a table or
a string or whatever
table_size -- if the arguments fill a table, the maximum number of
entries; if there are no arguments, the value to
load into the result storage
Although the table can be used to hold a list of filenames, only
scalar values (e.g. pointers) can be stored in the table. No vector
processing will be done, only pointers to string storage will be moved.
An example entry, which could be used to parse input filenames, is:
"-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE
*/
#include <stdio.h>
#ifndef NULL
/* ANSI C */
#include <stddef.h>
#endif
#include "parse.h"
#include <math.h> /* For atof */
#include <ctype.h>
#define MAX_INPUT_SIZE 1000
#define arg_prefix(x) ((x).prefix)
#define arg_string(x) ((x).string)
#define arg_flags(x) ((x).flags)
#define arg_count(x) ((x).count)
#define arg_result_type(x) ((x).result_type)
#define arg_result_ptr(x) ((x).result_ptr)
#define arg_table_size(x) ((x).table_size)
#ifndef TRUE
#define TRUE 1
#endif
#ifndef FALSE
#define FALSE 0
#endif
typedef int boolean;
char *lower_string (/* char [], char * */);
static char *this_program = "";
extern long atol();
static int arg_parse (/* char *, arg_info * */);
boolean parse_args (argc, argv, table, entries, others, other_count)
int argc;
char *argv[];
arg_info table[];
int entries;
char *others[];
int other_count;
{
boolean arg_verify (/* argv, table, entries */);
void init_store (/* table, entries */);
boolean result;
if (argv)
this_program = argv[0];
/* Check the validity of the table and its parameters */
result = arg_verify (argv, table, entries);
/* Initialize the storage values */
init_store (table, entries);
if (result) {
boolean use_prefix = TRUE;
char *argv0;
argc--;
argv0 = *++argv;
while (argc) {
int index, length;
index = match_table (*argv, table, entries, use_prefix, &length);
if (index < 0) {
/* The argument doesn't match anything in the table */
if (others) {
if (*argv > argv0)
*--*argv = '-'; /* complain at invalid flag */
if (other_count > 0) {
*others++ = *argv;
other_count--;
} else {
fprintf (stderr, "%s: too many parameters: ",
this_program);
fprintf (stderr, "'%s' ignored\n", *argv);
} /* else */
} /* if (others) */
argv0 = *++argv;
argc--;
} else {
/* A match was found */
if (length >= strlen (*argv)) {
argc--;
argv0 = *++argv;
use_prefix = TRUE;
} else {
(*argv) += length;
use_prefix = FALSE;
} /* else */
/* Parse any necessary arguments */
if (arg_count (table[index]) != P_NO_ARGS) {
/* Now length will be used to store the number of parsed characters */
length = arg_parse(*argv, &table[index]);
if (*argv == NULL)
argc = 0;
else if (length >= strlen (*argv)) {
argc--;
argv0 = *++argv;
use_prefix = TRUE;
} else {
(*argv) += length;
use_prefix = FALSE;
} /* else */
} /* if (argv_count != P_NO_ARGS) */
else
*arg_result_ptr(table[index]) =
arg_table_size(table[index]);
} /* else */
} /* while (argc) */
} /* if (result) */
return result;
} /* parse_args */
boolean arg_verify (argv, table, entries)
char *argv[];
arg_info table[];
int entries;
{
int i;
char *this_program = "";
if (argv)
this_program = argv[0];
for (i = 0; i < entries; i++) {
arg_info *arg = &table[i];
/* Check the argument flags */
if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) {
fprintf (stderr, "%s [arg_verify]: too many ", this_program);
fprintf (stderr, "flags in entry %d: '%x' (hex)\n", i,
arg_flags (*arg));
} /* if */
/* Check the argument count */
{ int count = arg_count (*arg);
if (count != P_NO_ARGS && count != P_ONE_ARG && count !=
P_INFINITE_ARGS) {
fprintf (stderr, "%s [arg_verify]: invalid ", this_program);
fprintf (stderr, "argument count in entry %d: '%d'\n", i,
count);
} /* if count != P_NO_ARGS ... */
/* Check the result field; want to be able to store results */
else
if (arg_result_ptr (*arg) == (int *) NULL) {
fprintf (stderr, "%s [arg_verify]: ", this_program);
fprintf (stderr, "no argument storage given for ");
fprintf (stderr, "entry %d\n", i);
} /* if arg_result_ptr */
}
/* Check the argument type */
{ int type = arg_result_type (*arg);
if (type < P_STRING || type > P_DOUBLE)
fprintf(stderr,
"%s [arg_verify]: bad arg type in entry %d: '%d'\n",
this_program, i, type);
}
/* Check table size */
{ int size = arg_table_size (*arg);
if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) {
fprintf (stderr, "%s [arg_verify]: bad ", this_program);
fprintf (stderr, "table size in entry %d: '%d'\n", i,
size);
} /* if (arg_count == P_INFINITE_ARGS && size < 1) */
}
} /* for i = 0 */
return TRUE;
} /* arg_verify */
/* match_table -- returns the index of the best entry matching the input,
-1 if no match. The best match is the one of longest length which
appears lowest in the table. The length of the match will be returned
in length ONLY IF a match was found. */
int match_table (norm_input, table, entries, use_prefix, length)
register char *norm_input;
arg_info table[];
int entries;
boolean use_prefix;
int *length;
{
extern int match (/* char *, char *, arg_info *, boolean */);
char low_input[MAX_INPUT_SIZE];
register int i;
int best_index = -1, best_length = 0;
/* FUNCTION BODY */
(void) lower_string (low_input, norm_input);
for (i = 0; i < entries; i++) {
int this_length = match (norm_input, low_input, &table[i], use_prefix);
if (this_length > best_length) {
best_index = i;
best_length = this_length;
} /* if (this_length > best_length) */
} /* for (i = 0) */
if (best_index > -1 && length != (int *) NULL)
*length = best_length;
return best_index;
} /* match_table */
/* match -- takes an input string and table entry, and returns the length
of the longer match.
0 ==> input doesn't match
For example:
INPUT PREFIX STRING RESULT
----------------------------------------------------------------------
"abcd" "-" "d" 0
"-d" "-" "d" 2 (i.e. "-d")
"dout" "-" "d" 1 (i.e. "d")
"-d" "" "-d" 2 (i.e. "-d")
"dd" "d" "d" 2 <= here's the weird one
*/
int match (norm_input, low_input, entry, use_prefix)
char *norm_input, *low_input;
arg_info *entry;
boolean use_prefix;
{
char *norm_prefix = arg_prefix (*entry);
char *norm_string = arg_string (*entry);
boolean prefix_match = FALSE, string_match = FALSE;
int result = 0;
/* Buffers for the lowercased versions of the strings being compared.
These are used when the switch is to be case insensitive */
static char low_prefix[MAX_INPUT_SIZE];
static char low_string[MAX_INPUT_SIZE];
int prefix_length = strlen (norm_prefix);
int string_length = strlen (norm_string);
/* Pointers for the required strings (lowered or nonlowered) */
register char *input, *prefix, *string;
/* FUNCTION BODY */
/* Use the appropriate strings to handle case sensitivity */
if (arg_flags (*entry) & P_CASE_INSENSITIVE) {
input = low_input;
prefix = lower_string (low_prefix, norm_prefix);
string = lower_string (low_string, norm_string);
} else {
input = norm_input;
prefix = norm_prefix;
string = norm_string;
} /* else */
/* First, check the string formed by concatenating the prefix onto the
switch string, but only when the prefix is not being ignored */
if (use_prefix && prefix != NULL && *prefix != '\0')
prefix_match = (strncmp (input, prefix, prefix_length) == 0) &&
(strncmp (input + prefix_length, string, string_length) == 0);
/* Next, check just the switch string, if that's allowed */
if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0)
string_match = strncmp (input, string, string_length) == 0;
if (prefix_match)
result = prefix_length + string_length;
else if (string_match)
result = string_length;
return result;
} /* match */
char *lower_string (dest, src)
char *dest, *src;
{
char *result = dest;
register int c;
if (dest == NULL || src == NULL)
result = NULL;
else
while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c);
return result;
} /* lower_string */
/* arg_parse -- returns the number of characters parsed for this entry */
static int arg_parse (str, entry)
char *str;
arg_info *entry;
{
int length = 0;
if (arg_count (*entry) == P_ONE_ARG) {
char **store = (char **) arg_result_ptr (*entry);
length = put_one_arg (arg_result_type (*entry), str, store,
arg_prefix (*entry), arg_string (*entry));
} /* if (arg_count == P_ONE_ARG) */
else { /* Must be a table of arguments */
char **store = (char **) arg_result_ptr (*entry);
if (store) {
while (*store)
store++;
length = put_one_arg (arg_result_type (*entry), str, store++,
arg_prefix (*entry), arg_string (*entry));
*store = (char *) NULL;
} /* if (store) */
} /* else */
return length;
} /* arg_parse */
int put_one_arg (type, str, store, prefix, string)
int type;
char *str;
char **store;
char *prefix, *string;
{
int length = 0;
long L;
if (store) {
switch (type) {
case P_STRING:
case P_FILE:
case P_OLD_FILE:
case P_NEW_FILE:
*store = str;
if (str == NULL)
fprintf (stderr, "%s: Missing argument after '%s%s'\n",
this_program, prefix, string);
length = str ? strlen (str) : 0;
break;
case P_CHAR:
*((char *) store) = *str;
length = 1;
break;
case P_SHORT:
L = atol(str);
*(short *)store = (short) L;
if (L != *(short *)store)
fprintf(stderr,
"%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n",
prefix, string, L, *(short *)store);
length = strlen (str);
break;
case P_INT:
L = atol(str);
*(int *)store = (int)L;
if (L != *(int *)store)
fprintf(stderr,
"%s%s parameter '%ld' is not an INT (truncating to %d)\n",
prefix, string, L, *(int *)store);
length = strlen (str);
break;
case P_LONG:
*(long *)store = atol(str);
length = strlen (str);
break;
case P_FLOAT:
*((float *) store) = (float) atof (str);
length = strlen (str);
break;
case P_DOUBLE:
*((double *) store) = (double) atof (str);
length = strlen (str);
break;
default:
fprintf (stderr, "put_one_arg: bad type '%d'\n",
type);
break;
} /* switch */
} /* if (store) */
return length;
} /* put_one_arg */
void init_store (table, entries)
arg_info *table;
int entries;
{
int index;
for (index = 0; index < entries; index++)
if (arg_count (table[index]) == P_INFINITE_ARGS) {
char **place = (char **) arg_result_ptr (table[index]);
if (place)
*place = (char *) NULL;
} /* if arg_count == P_INFINITE_ARGS */
} /* init_store */

64
lang/fortran/comp/pccdefs.h Normal file
View file

@ -0,0 +1,64 @@
/* The following numbers are strange, and implementation-dependent */
#define P2BAD -1
#define P2NAME 2
#define P2ICON 4 /* Integer constant */
#define P2PLUS 6
#define P2PLUSEQ 7
#define P2MINUS 8
#define P2NEG 10
#define P2STAR 11
#define P2STAREQ 12
#define P2INDIRECT 13
#define P2BITAND 14
#define P2BITOR 17
#define P2BITXOR 19
#define P2QUEST 21
#define P2COLON 22
#define P2ANDAND 23
#define P2OROR 24
#define P2GOTO 37
#define P2LISTOP 56
#define P2ASSIGN 58
#define P2COMOP 59
#define P2SLASH 60
#define P2MOD 62
#define P2LSHIFT 64
#define P2RSHIFT 66
#define P2CALL 70
#define P2CALL0 72
#define P2NOT 76
#define P2BITNOT 77
#define P2EQ 80
#define P2NE 81
#define P2LE 82
#define P2LT 83
#define P2GE 84
#define P2GT 85
#define P2REG 94
#define P2OREG 95
#define P2CONV 104
#define P2FORCE 108
#define P2CBRANCH 109
/* special operators included only for fortran's use */
#define P2PASS 200
#define P2STMT 201
#define P2SWITCH 202
#define P2LBRACKET 203
#define P2RBRACKET 204
#define P2EOF 205
#define P2ARIF 206
#define P2LABEL 207
#define P2SHORT 3
#define P2INT 4
#define P2LONG 4
#define P2CHAR 2
#define P2REAL 6
#define P2DREAL 7
#define P2PTR 020
#define P2FUNCT 040

881
lang/fortran/comp/pread.c Normal file
View file

@ -0,0 +1,881 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
static char Ptok[128], Pct[Table_size];
static char *Pfname;
static long Plineno;
static int Pbad;
static int *tfirst, *tlast, *tnext, tmax;
#define P_space 1
#define P_anum 2
#define P_delim 3
#define P_slash 4
#define TGULP 100
static void
trealloc()
{
int k = tmax;
tfirst = (int *)realloc((char *)tfirst,
(tmax += TGULP)*sizeof(int));
if (!tfirst) {
fprintf(stderr,
"Pfile: realloc failure!\n");
exit(2);
}
tlast = tfirst + tmax;
tnext = tfirst + k;
}
static void
badchar(c)
int c;
{
fprintf(stderr,
"unexpected character 0x%.2x = '%c' on line %ld of %s\n",
c, c, Plineno, Pfname);
exit(2);
}
static void
bad_type()
{
fprintf(stderr,
"unexpected type \"%s\" on line %ld of %s\n",
Ptok, Plineno, Pfname);
exit(2);
}
static void
badflag(tname, option)
char *tname, *option;
{
fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
tname, option, Plineno, Pfname);
Pbad++;
}
static void
detected(msg)
char *msg;
{
fprintf(stderr,
"%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
Pbad++;
}
static void
checklogical(k)
int k;
{
static int lastmsg = 0;
static int seen[2] = {0,0};
seen[k] = 1;
if (seen[1-k]) {
if (lastmsg < 3) {
lastmsg = 3;
detected(
"Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t");
}
return;
}
if (k) {
if (tylogical == TYLONG || lastmsg >= 2)
return;
if (!lastmsg) {
lastmsg = 2;
badflag("LOGICAL", "I4");
}
}
else {
if (tylogical == TYSHORT || lastmsg & 1)
return;
if (!lastmsg) {
lastmsg = 1;
badflag("LOGICAL", "i2` or `f2c -I2");
}
}
}
static void
checkreal(k)
{
static int warned = 0;
static int seen[2] = {0,0};
seen[k] = 1;
if (seen[1-k]) {
if (warned < 2)
detected("Illegal mixture of -R and -!R ");
warned = 2;
return;
}
if (k == forcedouble || warned)
return;
warned = 1;
badflag("REAL return", k ? "!R" : "R");
}
static void
Pnotboth(e)
Extsym *e;
{
if (e->curno)
return;
Pbad++;
e->curno = 1;
fprintf(stderr,
"%s cannot be both a procedure and a common block (line %ld of %s)\n",
e->fextname, Plineno, Pfname);
}
static int
numread(pf, n)
register FILE *pf;
int *n;
{
register int c, k;
if ((c = getc(pf)) < '0' || c > '9')
return c;
k = c - '0';
for(;;) {
if ((c = getc(pf)) == ' ') {
*n = k;
return c;
}
if (c < '0' || c > '9')
break;
k = 10*k + c - '0';
}
return c;
}
static void argverify(), Pbadret();
static int
readref(pf, e, ftype)
register FILE *pf;
Extsym *e;
int ftype;
{
register int c, *t;
int i, nargs, type;
Argtypes *at;
Atype *a, *ae;
if (ftype > TYSUBR)
return 0;
if ((c = numread(pf, &nargs)) != ' ') {
if (c != ':')
return c == EOF;
/* just a typed external */
if (e->extstg == STGUNKNOWN) {
at = 0;
goto justsym;
}
if (e->extstg == STGEXT) {
if (e->extype != ftype)
Pbadret(ftype, e);
}
else
Pnotboth(e);
return 0;
}
tnext = tfirst;
for(i = 0; i < nargs; i++) {
if ((c = numread(pf, &type)) != ' '
|| type >= 500
|| type != TYFTNLEN + 100 && type % 100 > TYSUBR)
return c == EOF;
if (tnext >= tlast)
trealloc();
*tnext++ = type;
}
if (e->extstg == STGUNKNOWN) {
save_at:
at = (Argtypes *)
gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1);
at->nargs = nargs;
at->changes = 0;
t = tfirst;
a = at->atypes;
for(ae = a + nargs; a < ae; a++) {
a->type = *t++;
a->cp = 0;
}
justsym:
e->extstg = STGEXT;
e->extype = ftype;
e->arginfo = at;
}
else if (e->extstg != STGEXT) {
Pnotboth(e);
}
else if (!e->arginfo) {
if (e->extype != ftype)
Pbadret(ftype, e);
else
goto save_at;
}
else
argverify(ftype, e);
return 0;
}
static int
comlen(pf)
register FILE *pf;
{
register int c;
register char *s, *se;
char buf[128], cbuf[128];
int refread;
long L;
Extsym *e;
if ((c = getc(pf)) == EOF)
return 1;
if (c == ' ') {
refread = 0;
s = "comlen ";
}
else if (c == ':') {
refread = 1;
s = "ref: ";
}
else {
ret0:
if (c == '*')
ungetc(c,pf);
return 0;
}
while(*s) {
if ((c = getc(pf)) == EOF)
return 1;
if (c != *s++)
goto ret0;
}
s = buf;
se = buf + sizeof(buf) - 1;
for(;;) {
if ((c = getc(pf)) == EOF)
return 1;
if (c == ' ')
break;
if (s >= se || Pct[c] != P_anum)
goto ret0;
*s++ = c;
}
*s-- = 0;
if (s <= buf || *s != '_')
return 0;
strcpy(cbuf,buf);
*s-- = 0;
if (*s == '_') {
*s-- = 0;
if (s <= buf)
return 0;
}
for(L = 0;;) {
if ((c = getc(pf)) == EOF)
return 1;
if (c == ' ')
break;
if (c < '0' && c > '9')
goto ret0;
L = 10*L + c - '0';
}
if (!L && !refread)
return 0;
e = mkext(buf, cbuf);
if (refread)
return readref(pf, e, (int)L);
if (e->extstg == STGUNKNOWN) {
e->extstg = STGCOMMON;
e->maxleng = L;
}
else if (e->extstg != STGCOMMON)
Pnotboth(e);
else if (e->maxleng != L) {
fprintf(stderr,
"incompatible lengths for common block %s (line %ld of %s)\n",
buf, Plineno, Pfname);
if (e->maxleng < L)
e->maxleng = L;
}
return 0;
}
static int
Ptoken(pf, canend)
FILE *pf;
int canend;
{
register int c;
register char *s, *se;
top:
for(;;) {
c = getc(pf);
if (c == EOF) {
if (canend)
return 0;
goto badeof;
}
if (Pct[c] != P_space)
break;
if (c == '\n')
Plineno++;
}
switch(Pct[c]) {
case P_anum:
if (c == '_')
badchar(c);
s = Ptok;
se = s + sizeof(Ptok) - 1;
do {
if (s < se)
*s++ = c;
if ((c = getc(pf)) == EOF) {
badeof:
fprintf(stderr,
"unexpected end of file in %s\n",
Pfname);
exit(2);
}
}
while(Pct[c] == P_anum);
ungetc(c,pf);
*s = 0;
return P_anum;
case P_delim:
return c;
case P_slash:
if ((c = getc(pf)) != '*') {
if (c == EOF)
goto badeof;
badchar('/');
}
if (canend && comlen(pf))
goto badeof;
for(;;) {
while((c = getc(pf)) != '*') {
if (c == EOF)
goto badeof;
if (c == '\n')
Plineno++;
}
slashseek:
switch(getc(pf)) {
case '/':
goto top;
case EOF:
goto badeof;
case '*':
goto slashseek;
}
}
default:
badchar(c);
}
/* NOT REACHED */
return 0;
}
static int
Pftype()
{
switch(Ptok[0]) {
case 'C':
if (!strcmp(Ptok+1, "_f"))
return TYCOMPLEX;
break;
case 'E':
if (!strcmp(Ptok+1, "_f")) {
/* TYREAL under forcedouble */
checkreal(1);
return TYREAL;
}
break;
case 'H':
if (!strcmp(Ptok+1, "_f"))
return TYCHAR;
break;
case 'Z':
if (!strcmp(Ptok+1, "_f"))
return TYDCOMPLEX;
break;
case 'd':
if (!strcmp(Ptok+1, "oublereal"))
return TYDREAL;
break;
case 'i':
if (!strcmp(Ptok+1, "nt"))
return TYSUBR;
if (!strcmp(Ptok+1, "nteger"))
return TYLONG;
break;
case 'l':
if (!strcmp(Ptok+1, "ogical")) {
checklogical(1);
return TYLOGICAL;
}
break;
case 'r':
if (!strcmp(Ptok+1, "eal")) {
checkreal(0);
return TYREAL;
}
break;
case 's':
if (!strcmp(Ptok+1, "hortint"))
return TYSHORT;
if (!strcmp(Ptok+1, "hortlogical")) {
checklogical(0);
return TYLOGICAL;
}
break;
}
bad_type();
/* NOT REACHED */
return 0;
}
static void
wanted(i, what)
int i;
char *what;
{
if (i != P_anum) {
Ptok[0] = i;
Ptok[1] = 0;
}
fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
what, Ptok, Plineno, Pfname);
exit(2);
}
static int
Ptype(pf)
FILE *pf;
{
int i, rv;
i = Ptoken(pf,0);
if (i == ')')
return 0;
if (i != P_anum)
badchar(i);
rv = 0;
switch(Ptok[0]) {
case 'C':
if (!strcmp(Ptok+1, "_fp"))
rv = TYCOMPLEX+200;
break;
case 'D':
if (!strcmp(Ptok+1, "_fp"))
rv = TYDREAL+200;
break;
case 'E':
case 'R':
if (!strcmp(Ptok+1, "_fp"))
rv = TYREAL+200;
break;
case 'H':
if (!strcmp(Ptok+1, "_fp"))
rv = TYCHAR+200;
break;
case 'I':
if (!strcmp(Ptok+1, "_fp"))
rv = TYLONG+200;
break;
case 'J':
if (!strcmp(Ptok+1, "_fp"))
rv = TYSHORT+200;
break;
case 'K':
checklogical(0);
goto Logical;
case 'L':
checklogical(1);
Logical:
if (!strcmp(Ptok+1, "_fp"))
rv = TYLOGICAL+200;
break;
case 'S':
if (!strcmp(Ptok+1, "_fp"))
rv = TYSUBR+200;
break;
case 'U':
if (!strcmp(Ptok+1, "_fp"))
rv = TYUNKNOWN+300;
break;
case 'Z':
if (!strcmp(Ptok+1, "_fp"))
rv = TYDCOMPLEX+200;
break;
case 'c':
if (!strcmp(Ptok+1, "har"))
rv = TYCHAR;
else if (!strcmp(Ptok+1, "omplex"))
rv = TYCOMPLEX;
break;
case 'd':
if (!strcmp(Ptok+1, "oublereal"))
rv = TYDREAL;
else if (!strcmp(Ptok+1, "oublecomplex"))
rv = TYDCOMPLEX;
break;
case 'f':
if (!strcmp(Ptok+1, "tnlen"))
rv = TYFTNLEN+100;
break;
case 'i':
if (!strcmp(Ptok+1, "nteger"))
rv = TYLONG;
break;
case 'l':
if (!strcmp(Ptok+1, "ogical")) {
checklogical(1);
rv = TYLOGICAL;
}
break;
case 'r':
if (!strcmp(Ptok+1, "eal"))
rv = TYREAL;
break;
case 's':
if (!strcmp(Ptok+1, "hortint"))
rv = TYSHORT;
else if (!strcmp(Ptok+1, "hortlogical")) {
checklogical(0);
rv = TYLOGICAL;
}
break;
case 'v':
if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
if ((i = Ptoken(pf,0)) != /*(*/ ')')
wanted(i, /*(*/ "\")\"");
return 0;
}
}
if (!rv)
bad_type();
if (rv < 100 && (i = Ptoken(pf,0)) != '*')
wanted(i, "\"*\"");
if ((i = Ptoken(pf,0)) == P_anum)
i = Ptoken(pf,0); /* skip variable name */
switch(i) {
case ')':
ungetc(i,pf);
break;
case ',':
break;
default:
wanted(i, "\",\" or \")\"");
}
return rv;
}
static char *
trimunder()
{
register char *s;
register int n;
static char buf[128];
s = Ptok + strlen(Ptok) - 1;
if (*s != '_') {
fprintf(stderr,
"warning: %s does not end in _ (line %ld of %s)\n",
Ptok, Plineno, Pfname);
return Ptok;
}
if (s[-1] == '_')
s--;
strncpy(buf, Ptok, n = s - Ptok);
buf[n] = 0;
return buf;
}
static void
Pbadmsg(msg, p)
char *msg;
Extsym *p;
{
Pbad++;
fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
p->fextname, Plineno, Pfname);
p->arginfo->nargs = -1;
}
char *Argtype();
static void
Pbadret(ftype, p)
int ftype;
Extsym *p;
{
char buf1[32], buf2[32];
Pbadmsg("inconsistent types",p);
fprintf(stderr, "here %s, previously %s\n",
Argtype(ftype+200,buf1),
Argtype(p->extype+200,buf2));
}
static void
argverify(ftype, p)
int ftype;
Extsym *p;
{
Argtypes *at;
register Atype *aty;
int i, j, k;
register int *t, *te;
char buf1[32], buf2[32];
int type_fixup();
at = p->arginfo;
if (at->nargs < 0)
return;
if (p->extype != ftype) {
Pbadret(ftype, p);
return;
}
t = tfirst;
te = tnext;
i = te - t;
if (at->nargs != i) {
j = at->nargs;
Pbadmsg("differing numbers of arguments",p);
fprintf(stderr, "here %d, previously %d\n",
i, j);
return;
}
for(aty = at->atypes; t < te; t++, aty++) {
if (*t == aty->type)
continue;
j = aty->type;
k = *t;
if (k >= 300 || k == j)
continue;
if (j >= 300) {
if (k >= 200) {
if (k == TYUNKNOWN + 200)
continue;
if (j % 100 != k - 200
&& k != TYSUBR + 200
&& j != TYUNKNOWN + 300
&& !type_fixup(at,aty,k))
goto badtypes;
}
else if (j % 100 % TYSUBR != k % TYSUBR
&& !type_fixup(at,aty,k))
goto badtypes;
}
else if (k < 200 || j < 200)
goto badtypes;
else if (k == TYUNKNOWN+200)
continue;
else if (j != TYUNKNOWN+200)
{
badtypes:
Pbadmsg("differing calling sequences",p);
i = t - tfirst + 1;
fprintf(stderr,
"arg %d: here %s, prevously %s\n",
i, Argtype(k,buf1), Argtype(j,buf2));
return;
}
/* We've subsequently learned the right type,
as in the call on zoo below...
subroutine foo(x, zap)
external zap
call goo(zap)
x = zap(3)
call zoo(zap)
end
*/
aty->type = k;
at->changes = 1;
}
}
static void
newarg(ftype, p)
int ftype;
Extsym *p;
{
Argtypes *at;
register Atype *aty;
register int *t, *te;
int i, k;
if (p->extstg == STGCOMMON) {
Pnotboth(p);
return;
}
p->extstg = STGEXT;
p->extype = ftype;
p->exproto = 1;
t = tfirst;
te = tnext;
i = te - t;
k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
at = p->arginfo = (Argtypes *)gmem(k,1);
at->nargs = i;
at->changes = 0;
for(aty = at->atypes; t < te; aty++) {
aty->type = *t++;
aty->cp = 0;
}
}
static int
Pfile(fname)
char *fname;
{
char *s;
int ftype, i;
FILE *pf;
Extsym *p;
for(s = fname; *s; s++);
if (s - fname < 2
|| s[-2] != '.'
|| (s[-1] != 'P' && s[-1] != 'p'))
return 0;
if (!(pf = fopen(fname, textread))) {
fprintf(stderr, "can't open %s\n", fname);
exit(2);
}
Pfname = fname;
Plineno = 1;
if (!Pct[' ']) {
for(s = " \t\n\r\v\f"; *s; s++)
Pct[*s] = P_space;
for(s = "*,();"; *s; s++)
Pct[*s] = P_delim;
for(i = '0'; i <= '9'; i++)
Pct[i] = P_anum;
for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++)
Pct[i] = Pct[i+'A'-'a'] = P_anum;
Pct['_'] = P_anum;
Pct['/'] = P_slash;
}
for(;;) {
if (!(i = Ptoken(pf,1)))
break;
if (i != P_anum
|| !strcmp(Ptok, "extern")
&& (i = Ptoken(pf,0)) != P_anum)
badchar(i);
ftype = Pftype();
getname:
if ((i = Ptoken(pf,0)) != P_anum)
badchar(i);
p = mkext(trimunder(), Ptok);
if ((i = Ptoken(pf,0)) != '(')
badchar(i);
tnext = tfirst;
while(i = Ptype(pf)) {
if (tnext >= tlast)
trealloc();
*tnext++ = i;
}
if (p->arginfo)
argverify(ftype, p);
else
newarg(ftype, p);
i = Ptoken(pf,0);
switch(i) {
case ';':
break;
case ',':
goto getname;
default:
wanted(i, "\";\" or \",\"");
}
}
fclose(pf);
return 1;
}
void
read_Pfiles(ffiles)
char **ffiles;
{
char **f1files, **f1files0, *s;
int k;
register Extsym *e, *ee;
register Argtypes *at;
extern int retcode;
f1files0 = f1files = ffiles;
while(s = *ffiles++)
if (!Pfile(s))
*f1files++ = s;
if (Pbad)
retcode = 8;
if (tfirst) {
free((char *)tfirst);
/* following should be unnecessary, as we won't be back here */
tfirst = tnext = tlast = 0;
tmax = 0;
}
*f1files = 0;
if (f1files == f1files0)
f1files[1] = 0;
k = 0;
ee = nextext;
for (e = extsymtab; e < ee; e++)
if (e->extstg == STGEXT
&& (at = e->arginfo)) {
if (at->nargs < 0 || at->changes)
k++;
at->changes = 2;
}
if (k) {
fprintf(diagfile,
"%d prototype%s updated while reading prototypes.\n", k,
k > 1 ? "s" : "");
}
fflush(diagfile);
}

1562
lang/fortran/comp/proc.c Normal file
View file

File diff suppressed because it is too large Load diff

373
lang/fortran/comp/proto.make Normal file
View file

@ -0,0 +1,373 @@
# $Header$
# Makefile for f2c, a Fortran 77 to C converter
#PARAMS do not remove this line!
UTIL_BIN = \
$(UTIL_HOME)/bin
SRC_DIR = \
$(SRC_HOME)/lang/fortran/comp
INCLUDES = -I$(SRC_DIR) -I.
CFLAGS = $(COPTIONS) $(INCLUDES)
LINTFLAGS = $(LINTOPTIONS) $(INCLUDES)
LDFLAGS = $(LDOPTIONS)
OBJECTS = main.$(SUF) init.$(SUF) gram.$(SUF) lex.$(SUF) proc.$(SUF) \
equiv.$(SUF) data.$(SUF) format.$(SUF) expr.$(SUF) exec.$(SUF) \
intr.$(SUF) io.$(SUF) misc.$(SUF) error.$(SUF) mem.$(SUF) \
names.$(SUF) output.$(SUF) p1output.$(SUF) pread.$(SUF) put.$(SUF) \
putpcc.$(SUF) vax.$(SUF) formatdata.$(SUF) parse_args.$(SUF) \
niceprintf.$(SUF) cds.$(SUF) sysdep.$(SUF) version.$(SUF)
GSRC = \
$(SRC_DIR)/gram.head \
$(SRC_DIR)/gram.dcl \
$(SRC_DIR)/gram.expr \
$(SRC_DIR)/gram.exec \
$(SRC_DIR)/gram.io
CSRC = \
$(SRC_DIR)/main.c \
$(SRC_DIR)/init.c \
$(SRC_DIR)/lex.c \
$(SRC_DIR)/proc.c \
$(SRC_DIR)/equiv.c \
$(SRC_DIR)/data.c \
$(SRC_DIR)/format.c \
$(SRC_DIR)/expr.c \
$(SRC_DIR)/exec.c \
$(SRC_DIR)/intr.c \
$(SRC_DIR)/io.c \
$(SRC_DIR)/misc.c \
$(SRC_DIR)/error.c \
$(SRC_DIR)/mem.c \
$(SRC_DIR)/names.c \
$(SRC_DIR)/output.c \
$(SRC_DIR)/p1output.c \
$(SRC_DIR)/pread.c \
$(SRC_DIR)/put.c \
$(SRC_DIR)/putpcc.c \
$(SRC_DIR)/vax.c \
$(SRC_DIR)/formatdata.c \
$(SRC_DIR)/parse_args.c \
$(SRC_DIR)/niceprintf.c \
$(SRC_DIR)/cds.c \
$(SRC_DIR)/sysdep.c \
$(SRC_DIR)/version.c
HSRC = \
$(SRC_DIR)/defines.h \
$(SRC_DIR)/defs.h \
$(SRC_DIR)/f2c.h \
$(SRC_DIR)/format.h \
$(SRC_DIR)/ftypes.h \
$(SRC_DIR)/iob.h \
$(SRC_DIR)/machdefs.h \
$(SRC_DIR)/names.h \
$(SRC_DIR)/niceprintf.h \
$(SRC_DIR)/output.h \
$(SRC_DIR)/p1defs.h \
$(SRC_DIR)/parse.h \
$(SRC_DIR)/pccdefs.h \
$(SRC_DIR)/sysdep.h \
$(SRC_DIR)/usignal.h
SRC = $(SRC_DIR)/tokens $(GSRC) $(HSRC) $(CSRC)
CFILES = gram.c $(CSRC)
all: f2c
install: all
rm -f $(TARGET_HOME)/lib.bin/f2c
cp f2c $(TARGET_HOME)/lib.bin/f2c
rm -f $(TARGET_HOME)/man/f2c.6
cp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
rm -f $(TARGET_HOME)/include/_tail_cc/f2c.h
cp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
cmp: all
-cmp f2c $(TARGET_HOME)/lib.bin/f2c
-cmp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
-cmp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
lint: $(CFILES) tokdefs.h
$(LINT) $(LINTFLAGS) $(CFILES)
pr:
@pr $(SRC_DIR)/proto.make $(SRC)
pr:
make pr | opr
depend: $(CFILES) tokdefs.h
sed '/^#DEPENDENCIES/,$$d' Makefile >Makefile.new
echo '#DEPENDENCIES' >>Makefile.new
for i in $(CFILES) ; do \
echo "`basename $$i .c`.$$(SUF): $$i" >> Makefile.new ; \
echo ' $$(CC) -c $$(CFLAGS)' $$i >> Makefile.new ; \
$(UTIL_HOME)/lib.bin/cpp -d $(INCLUDES) $$i | sed "s/^/`basename $$i .c`.$$(SUF): /" >> Makefile.new ; \
done
mv Makefile Makefile.old
mv Makefile.new Makefile
f2c: $(OBJECTS)
$(CC) $(LDFLAGS) $(OBJECTS) $(TARGET_HOME)/modules/lib/libstring.$(LIBSUF) -o f2c
gram.c: $(GSRC) $(SRC_DIR)/defs.h tokdefs.h
( sed <tokdefs.h "s/#define/%token/" ;\
cat $(GSRC) ) >gram.in
yacc gram.in
echo "(expect 4 shift/reduce)"
sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
rm -f gram.in y.tab.c
tokdefs.h: $(SRC_DIR)/tokens
grep -n . <$(SRC_DIR)/tokens | \
sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
clean:
rm -f gram.c *.$(SUF) f2c tokdefs.h Out
#DEPENDENCIES
gram.$(SUF): gram.c
$(CC) -c $(CFLAGS) gram.c
gram.$(SUF): $(SRC_DIR)/p1defs.h
gram.$(SUF): $(SRC_DIR)/machdefs.h
gram.$(SUF): $(SRC_DIR)/defines.h
gram.$(SUF): $(SRC_DIR)/ftypes.h
gram.$(SUF): $(SRC_DIR)/sysdep.h
gram.$(SUF): $(SRC_DIR)/defs.h
main.$(SUF): $(SRC_DIR)/main.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/main.c
main.$(SUF): $(SRC_DIR)/parse.h
main.$(SUF): $(SRC_DIR)/machdefs.h
main.$(SUF): $(SRC_DIR)/defines.h
main.$(SUF): $(SRC_DIR)/ftypes.h
main.$(SUF): $(SRC_DIR)/sysdep.h
main.$(SUF): $(SRC_DIR)/defs.h
init.$(SUF): $(SRC_DIR)/init.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/init.c
init.$(SUF): $(SRC_DIR)/iob.h
init.$(SUF): $(SRC_DIR)/niceprintf.h
init.$(SUF): $(SRC_DIR)/output.h
init.$(SUF): $(SRC_DIR)/machdefs.h
init.$(SUF): $(SRC_DIR)/defines.h
init.$(SUF): $(SRC_DIR)/ftypes.h
init.$(SUF): $(SRC_DIR)/sysdep.h
init.$(SUF): $(SRC_DIR)/defs.h
lex.$(SUF): $(SRC_DIR)/lex.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/lex.c
lex.$(SUF): $(SRC_DIR)/p1defs.h
lex.$(SUF): ./tokdefs.h
lex.$(SUF): $(SRC_DIR)/machdefs.h
lex.$(SUF): $(SRC_DIR)/defines.h
lex.$(SUF): $(SRC_DIR)/ftypes.h
lex.$(SUF): $(SRC_DIR)/sysdep.h
lex.$(SUF): $(SRC_DIR)/defs.h
proc.$(SUF): $(SRC_DIR)/proc.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/proc.c
proc.$(SUF): $(SRC_DIR)/p1defs.h
proc.$(SUF): $(SRC_DIR)/niceprintf.h
proc.$(SUF): $(SRC_DIR)/output.h
proc.$(SUF): $(SRC_DIR)/names.h
proc.$(SUF): $(SRC_DIR)/machdefs.h
proc.$(SUF): $(SRC_DIR)/defines.h
proc.$(SUF): $(SRC_DIR)/ftypes.h
proc.$(SUF): $(SRC_DIR)/sysdep.h
proc.$(SUF): $(SRC_DIR)/defs.h
equiv.$(SUF): $(SRC_DIR)/equiv.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/equiv.c
equiv.$(SUF): $(SRC_DIR)/machdefs.h
equiv.$(SUF): $(SRC_DIR)/defines.h
equiv.$(SUF): $(SRC_DIR)/ftypes.h
equiv.$(SUF): $(SRC_DIR)/sysdep.h
equiv.$(SUF): $(SRC_DIR)/defs.h
data.$(SUF): $(SRC_DIR)/data.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/data.c
data.$(SUF): $(SRC_DIR)/machdefs.h
data.$(SUF): $(SRC_DIR)/defines.h
data.$(SUF): $(SRC_DIR)/ftypes.h
data.$(SUF): $(SRC_DIR)/sysdep.h
data.$(SUF): $(SRC_DIR)/defs.h
format.$(SUF): $(SRC_DIR)/format.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/format.c
format.$(SUF): $(SRC_DIR)/iob.h
format.$(SUF): $(SRC_DIR)/names.h
format.$(SUF): $(SRC_DIR)/niceprintf.h
format.$(SUF): $(SRC_DIR)/output.h
format.$(SUF): $(SRC_DIR)/format.h
format.$(SUF): $(SRC_DIR)/p1defs.h
format.$(SUF): $(SRC_DIR)/machdefs.h
format.$(SUF): $(SRC_DIR)/defines.h
format.$(SUF): $(SRC_DIR)/ftypes.h
format.$(SUF): $(SRC_DIR)/sysdep.h
format.$(SUF): $(SRC_DIR)/defs.h
expr.$(SUF): $(SRC_DIR)/expr.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/expr.c
expr.$(SUF): $(SRC_DIR)/names.h
expr.$(SUF): $(SRC_DIR)/niceprintf.h
expr.$(SUF): $(SRC_DIR)/output.h
expr.$(SUF): $(SRC_DIR)/machdefs.h
expr.$(SUF): $(SRC_DIR)/defines.h
expr.$(SUF): $(SRC_DIR)/ftypes.h
expr.$(SUF): $(SRC_DIR)/sysdep.h
expr.$(SUF): $(SRC_DIR)/defs.h
exec.$(SUF): $(SRC_DIR)/exec.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/exec.c
exec.$(SUF): $(SRC_DIR)/names.h
exec.$(SUF): $(SRC_DIR)/p1defs.h
exec.$(SUF): $(SRC_DIR)/machdefs.h
exec.$(SUF): $(SRC_DIR)/defines.h
exec.$(SUF): $(SRC_DIR)/ftypes.h
exec.$(SUF): $(SRC_DIR)/sysdep.h
exec.$(SUF): $(SRC_DIR)/defs.h
intr.$(SUF): $(SRC_DIR)/intr.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/intr.c
intr.$(SUF): $(SRC_DIR)/names.h
intr.$(SUF): $(SRC_DIR)/machdefs.h
intr.$(SUF): $(SRC_DIR)/defines.h
intr.$(SUF): $(SRC_DIR)/ftypes.h
intr.$(SUF): $(SRC_DIR)/sysdep.h
intr.$(SUF): $(SRC_DIR)/defs.h
io.$(SUF): $(SRC_DIR)/io.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/io.c
io.$(SUF): $(SRC_DIR)/iob.h
io.$(SUF): $(SRC_DIR)/names.h
io.$(SUF): $(SRC_DIR)/machdefs.h
io.$(SUF): $(SRC_DIR)/defines.h
io.$(SUF): $(SRC_DIR)/ftypes.h
io.$(SUF): $(SRC_DIR)/sysdep.h
io.$(SUF): $(SRC_DIR)/defs.h
misc.$(SUF): $(SRC_DIR)/misc.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/misc.c
misc.$(SUF): $(SRC_DIR)/machdefs.h
misc.$(SUF): $(SRC_DIR)/defines.h
misc.$(SUF): $(SRC_DIR)/ftypes.h
misc.$(SUF): $(SRC_DIR)/sysdep.h
misc.$(SUF): $(SRC_DIR)/defs.h
error.$(SUF): $(SRC_DIR)/error.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/error.c
error.$(SUF): $(SRC_DIR)/machdefs.h
error.$(SUF): $(SRC_DIR)/defines.h
error.$(SUF): $(SRC_DIR)/ftypes.h
error.$(SUF): $(SRC_DIR)/sysdep.h
error.$(SUF): $(SRC_DIR)/defs.h
mem.$(SUF): $(SRC_DIR)/mem.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/mem.c
mem.$(SUF): $(SRC_DIR)/iob.h
mem.$(SUF): $(SRC_DIR)/machdefs.h
mem.$(SUF): $(SRC_DIR)/defines.h
mem.$(SUF): $(SRC_DIR)/ftypes.h
mem.$(SUF): $(SRC_DIR)/sysdep.h
mem.$(SUF): $(SRC_DIR)/defs.h
names.$(SUF): $(SRC_DIR)/names.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/names.c
names.$(SUF): $(SRC_DIR)/iob.h
names.$(SUF): $(SRC_DIR)/names.h
names.$(SUF): $(SRC_DIR)/niceprintf.h
names.$(SUF): $(SRC_DIR)/output.h
names.$(SUF): $(SRC_DIR)/machdefs.h
names.$(SUF): $(SRC_DIR)/defines.h
names.$(SUF): $(SRC_DIR)/ftypes.h
names.$(SUF): $(SRC_DIR)/sysdep.h
names.$(SUF): $(SRC_DIR)/defs.h
output.$(SUF): $(SRC_DIR)/output.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/output.c
output.$(SUF): $(SRC_DIR)/niceprintf.h
output.$(SUF): $(SRC_DIR)/output.h
output.$(SUF): $(SRC_DIR)/names.h
output.$(SUF): $(SRC_DIR)/machdefs.h
output.$(SUF): $(SRC_DIR)/defines.h
output.$(SUF): $(SRC_DIR)/ftypes.h
output.$(SUF): $(SRC_DIR)/sysdep.h
output.$(SUF): $(SRC_DIR)/defs.h
p1output.$(SUF): $(SRC_DIR)/p1output.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/p1output.c
p1output.$(SUF): $(SRC_DIR)/names.h
p1output.$(SUF): $(SRC_DIR)/niceprintf.h
p1output.$(SUF): $(SRC_DIR)/output.h
p1output.$(SUF): $(SRC_DIR)/p1defs.h
p1output.$(SUF): $(SRC_DIR)/machdefs.h
p1output.$(SUF): $(SRC_DIR)/defines.h
p1output.$(SUF): $(SRC_DIR)/ftypes.h
p1output.$(SUF): $(SRC_DIR)/sysdep.h
p1output.$(SUF): $(SRC_DIR)/defs.h
pread.$(SUF): $(SRC_DIR)/pread.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/pread.c
pread.$(SUF): $(SRC_DIR)/machdefs.h
pread.$(SUF): $(SRC_DIR)/defines.h
pread.$(SUF): $(SRC_DIR)/ftypes.h
pread.$(SUF): $(SRC_DIR)/sysdep.h
pread.$(SUF): $(SRC_DIR)/defs.h
put.$(SUF): $(SRC_DIR)/put.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/put.c
put.$(SUF): $(SRC_DIR)/p1defs.h
put.$(SUF): $(SRC_DIR)/pccdefs.h
put.$(SUF): $(SRC_DIR)/names.h
put.$(SUF): $(SRC_DIR)/machdefs.h
put.$(SUF): $(SRC_DIR)/defines.h
put.$(SUF): $(SRC_DIR)/ftypes.h
put.$(SUF): $(SRC_DIR)/sysdep.h
put.$(SUF): $(SRC_DIR)/defs.h
putpcc.$(SUF): $(SRC_DIR)/putpcc.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/putpcc.c
putpcc.$(SUF): $(SRC_DIR)/p1defs.h
putpcc.$(SUF): $(SRC_DIR)/names.h
putpcc.$(SUF): $(SRC_DIR)/niceprintf.h
putpcc.$(SUF): $(SRC_DIR)/output.h
putpcc.$(SUF): $(SRC_DIR)/pccdefs.h
putpcc.$(SUF): $(SRC_DIR)/machdefs.h
putpcc.$(SUF): $(SRC_DIR)/defines.h
putpcc.$(SUF): $(SRC_DIR)/ftypes.h
putpcc.$(SUF): $(SRC_DIR)/sysdep.h
putpcc.$(SUF): $(SRC_DIR)/defs.h
vax.$(SUF): $(SRC_DIR)/vax.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/vax.c
vax.$(SUF): $(SRC_DIR)/niceprintf.h
vax.$(SUF): $(SRC_DIR)/output.h
vax.$(SUF): $(SRC_DIR)/pccdefs.h
vax.$(SUF): $(SRC_DIR)/machdefs.h
vax.$(SUF): $(SRC_DIR)/defines.h
vax.$(SUF): $(SRC_DIR)/ftypes.h
vax.$(SUF): $(SRC_DIR)/sysdep.h
vax.$(SUF): $(SRC_DIR)/defs.h
formatdata.$(SUF): $(SRC_DIR)/formatdata.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/formatdata.c
formatdata.$(SUF): $(SRC_DIR)/format.h
formatdata.$(SUF): $(SRC_DIR)/names.h
formatdata.$(SUF): $(SRC_DIR)/niceprintf.h
formatdata.$(SUF): $(SRC_DIR)/output.h
formatdata.$(SUF): $(SRC_DIR)/machdefs.h
formatdata.$(SUF): $(SRC_DIR)/defines.h
formatdata.$(SUF): $(SRC_DIR)/ftypes.h
formatdata.$(SUF): $(SRC_DIR)/sysdep.h
formatdata.$(SUF): $(SRC_DIR)/defs.h
parse_args.$(SUF): $(SRC_DIR)/parse_args.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/parse_args.c
parse_args.$(SUF): $(SRC_DIR)/parse.h
niceprintf.$(SUF): $(SRC_DIR)/niceprintf.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/niceprintf.c
niceprintf.$(SUF): $(SRC_DIR)/niceprintf.h
niceprintf.$(SUF): $(SRC_DIR)/output.h
niceprintf.$(SUF): $(SRC_DIR)/names.h
niceprintf.$(SUF): $(SRC_DIR)/machdefs.h
niceprintf.$(SUF): $(SRC_DIR)/defines.h
niceprintf.$(SUF): $(SRC_DIR)/ftypes.h
niceprintf.$(SUF): $(SRC_DIR)/sysdep.h
niceprintf.$(SUF): $(SRC_DIR)/defs.h
cds.$(SUF): $(SRC_DIR)/cds.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/cds.c
cds.$(SUF): $(SRC_DIR)/sysdep.h
sysdep.$(SUF): $(SRC_DIR)/sysdep.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/sysdep.c
sysdep.$(SUF): $(SRC_DIR)/usignal.h
sysdep.$(SUF): $(SRC_DIR)/machdefs.h
sysdep.$(SUF): $(SRC_DIR)/defines.h
sysdep.$(SUF): $(SRC_DIR)/ftypes.h
sysdep.$(SUF): $(SRC_DIR)/sysdep.h
sysdep.$(SUF): $(SRC_DIR)/defs.h
version.$(SUF): $(SRC_DIR)/version.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/version.c
memset.$(SUF): $(SRC_DIR)/memset.c
$(CC) -c $(CFLAGS) $(SRC_DIR)/memset.c

399
lang/fortran/comp/put.c Normal file
View file

@ -0,0 +1,399 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
/*
* INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
* JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
*/
#include "defs.h"
#include "names.h" /* For LOCAL_CONST_NAME */
#include "pccdefs.h"
#include "p1defs.h"
/* Definitions for putconst() */
#define LIT_CHAR 1
#define LIT_FLOAT 2
#define LIT_INT 3
/*
char *ops [ ] =
{
"??", "+", "-", "*", "/", "**", "-",
"OR", "AND", "EQV", "NEQV", "NOT",
"CONCAT",
"<", "==", ">", "<=", "!=", ">=",
" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
" , ", " ? ", " : "
" abs ", " min ", " max ", " addr ", " indirect ",
" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
};
*/
/* Each of these values is defined in pccdefs */
int ops2 [ ] =
{
P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
P2BAD,
P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
P2COMOP, P2QUEST, P2COLON,
1, P2BAD, P2BAD, P2BAD, P2BAD,
P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
P2BAD, P2BAD, P2BAD, P2BAD,
1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
};
int types2 [ ] =
{
P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
};
setlog()
{
types2[TYLOGICAL] = types2[tylogical];
typesize[TYLOGICAL] = typesize[tylogical];
typealign[TYLOGICAL] = typealign[tylogical];
}
void putex1(p)
expptr p;
{
/* Write the expression to the p1 file */
p = (expptr) putx (fixtype (p));
p1_expr (p);
}
expptr putassign(lp, rp)
expptr lp, rp;
{
return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
}
void puteq(lp, rp)
expptr lp, rp;
{
putexpr(mkexpr(OPASSIGN, lp, rp) );
}
/* put code for a *= b */
expptr putsteq(a, b)
Addrp a, b;
{
return putx( fixexpr((Exprp)
mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
}
Addrp mkfield(res, f, ty)
register Addrp res;
char *f;
int ty;
{
res -> vtype = ty;
res -> Field = f;
return res;
} /* mkfield */
Addrp realpart(p)
register Addrp p;
{
register Addrp q;
expptr mkrealcon();
if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
p->user.kludge.vstg1 ? p->user.Const.cds[0]
: cds(dtos(p->user.Const.cd[0]),CNULL));
} /* if p -> uname_tag */
q = (Addrp) cpexpr((expptr) p);
if( ISCOMPLEX(p->vtype) )
q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
return(q);
}
expptr imagpart(p)
register Addrp p;
{
register Addrp q;
expptr mkrealcon();
if( ISCOMPLEX(p->vtype) )
{
if (p -> uname_tag == UNAM_CONST)
return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
p->user.kludge.vstg1 ? p->user.Const.cds[1]
: cds(dtos(p->user.Const.cd[1]),CNULL));
q = (Addrp) cpexpr((expptr) p);
q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
return( (expptr) q );
}
else
/* Cast an integer type onto a Double Real type */
return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
}
/* ncat -- computes the number of adjacent concatenation operations */
ncat(p)
register expptr p;
{
if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
else return(1);
}
/* lencat -- returns the length of the concatenated string. Each
substring must have a static (i.e. compile-time) fixed length */
ftnint lencat(p)
register expptr p;
{
if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
return(p->headblock.vleng->constblock.Const.ci);
else if(p->tag==TADDR && p->addrblock.varleng!=0)
return(p->addrblock.varleng);
else
{
err("impossible element in concatenation");
return(0);
}
}
/* putconst -- Creates a new Addrp value which maps onto the input
constant value. The Addrp doesn't retain the value of the constant,
instead that value is copied into a table of constants (called
litpool, for pool of literal values). The only way to retrieve the
actual value of the constant is to look at the memno field of the
Addrp result. You know that the associated literal is the one referred
to by q when (q -> memno == litp -> litnum).
*/
Addrp putconst(p)
register Constp p;
{
register Addrp q;
struct Literal *litp, *lastlit;
int k, len, type;
int litflavor;
double cd[2];
ftnint nblanks;
char *strp;
char cdsbuf0[64], cdsbuf1[64], *ds[2];
if (p->tag != TCONST)
badtag("putconst", p->tag);
q = ALLOC(Addrblock);
q->tag = TADDR;
type = p->vtype;
q->vtype = ( type==TYADDR ? tyint : type );
q->vleng = (expptr) cpexpr(p->vleng);
q->vstg = STGCONST;
/* Create the new label for the constant. This is wasteful of labels
because when the constant value already exists in the literal pool,
this label gets thrown away and is never reclaimed. It might be
cleaner to move this down past the first switch() statement below */
q->memno = newlabel();
q->memoffset = ICON(0);
q -> uname_tag = UNAM_CONST;
/* Copy the constant info into the Addrblock; do this by copying the
largest storage elts */
q -> user.Const = p -> Const;
q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
/* check for value in literal pool, and update pool if necessary */
k = 1;
switch(type)
{
case TYCHAR:
if (halign) {
strp = p->Const.ccp;
nblanks = p->Const.ccp1.blanks;
len = p->vleng->constblock.Const.ci;
litflavor = LIT_CHAR;
goto loop;
}
else
q->memno = BAD_MEMNO;
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
if (p->vstg)
cd[1] = atof(ds[1] = p->Const.cds[1]);
else
ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
case TYREAL:
case TYDREAL:
litflavor = LIT_FLOAT;
if (p->vstg)
cd[0] = atof(ds[0] = p->Const.cds[0]);
else
ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
goto loop;
case TYLOGICAL:
type = tylogical;
goto lit_int_flavor;
case TYLONG:
type = tyint;
case TYSHORT:
lit_int_flavor:
litflavor = LIT_INT;
/* Scan the literal pool for this constant value. If this same constant
has been assigned before, use the same label. Note that this routine
does NOT consider two differently-typed constants with the same bit
pattern to be the same constant */
loop:
lastlit = litpool + nliterals;
for(litp = litpool ; litp<lastlit ; ++litp)
/* Remove this type checking to ensure that all bit patterns are reused */
if(type == litp->littype) switch(litflavor)
{
case LIT_CHAR:
if (len == (int)litp->litval.litival2[0]
&& nblanks == litp->litval.litival2[1]
&& !memcmp(strp, litp->cds[0], len)) {
q->memno = litp->litnum;
frexpr((expptr)p);
return(q);
}
break;
case LIT_FLOAT:
if(cd[0] == litp->litval.litdval[0]
&& !strcmp(ds[0], litp->cds[0])
&& (k == 1 ||
cd[1] == litp->litval.litdval[1]
&& !strcmp(ds[1], litp->cds[1]))) {
ret:
q->memno = litp->litnum;
frexpr((expptr)p);
return(q);
}
break;
case LIT_INT:
if(p->Const.ci == litp->litval.litival)
goto ret;
break;
}
/* If there's room in the literal pool, add this new value to the pool */
if(nliterals < maxliterals)
{
++nliterals;
/* litp now points to the next free elt */
litp->littype = type;
litp->litnum = q->memno;
switch(litflavor)
{
case LIT_CHAR:
litp->litval.litival2[0] = len;
litp->litval.litival2[1] = nblanks;
q->user.Const.ccp = litp->cds[0] =
memcpy(gmem(len,0), strp, len);
break;
case LIT_FLOAT:
litp->litval.litdval[0] = cd[0];
litp->cds[0] = copys(ds[0]);
if (k == 2) {
litp->litval.litdval[1] = cd[1];
litp->cds[1] = copys(ds[1]);
}
break;
case LIT_INT:
litp->litval.litival = p->Const.ci;
break;
} /* switch (litflavor) */
}
else
many("literal constants", 'L', maxliterals);
break;
case TYADDR:
break;
default:
badtype ("putconst", p -> vtype);
break;
} /* switch */
if (type != TYCHAR || halign)
frexpr((expptr)p);
return( q );
}

1781
lang/fortran/comp/putpcc.c Normal file
View file

File diff suppressed because it is too large Load diff

16
lang/fortran/comp/string.h Normal file
View file

@ -0,0 +1,16 @@
#ifndef NULL
#define NULL 0
#endif
#define strchr strindex
#define strrchr strrindex
extern char * strcat();
extern char * strchr();
extern int strcmp();
extern char * strcpy();
extern int strlen();
extern char * strncat();
extern int strncmp();
extern char * strncpy();
extern char * strrchr();

441
lang/fortran/comp/sysdep.c Normal file
View file

@ -0,0 +1,441 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "usignal.h"
char binread[] = "rb", textread[] = "r";
char binwrite[] = "wb", textwrite[] = "w";
char *c_functions = "c_functions";
char *coutput = "c_output";
char *initfname = "raw_data";
char *initbname = "raw_data.b";
char *blkdfname = "block_data";
char *p1_file = "p1_file";
char *p1_bakfile = "p1_file.BAK";
char *sortfname = "init_file";
char link_msg[] = "-lF77 -lI77 -lm -lc";
#ifndef TMPDIR
#ifdef MSDOS
#define TMPDIR ""
#else
#define TMPDIR "/tmp"
#endif
#endif
char *tmpdir = TMPDIR;
void
Un_link_all(cdelete)
{
if (!debugflag) {
unlink(c_functions);
unlink(initfname);
unlink(p1_file);
unlink(sortfname);
unlink(blkdfname);
if (cdelete && coutput)
unlink(coutput);
}
}
void
set_tmp_names()
{
int k;
if (debugflag == 1)
return;
k = strlen(tmpdir) + 16;
c_functions = (char *)ckalloc(7*k);
initfname = c_functions + k;
initbname = initfname + k;
blkdfname = initbname + k;
p1_file = blkdfname + k;
p1_bakfile = p1_file + k;
sortfname = p1_bakfile + k;
{
#ifdef MSDOS
char buf[64], *s, *t;
if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
t = "";
else {
/* substitute \ for / to avoid confusion with a
* switch indicator in the system("sort ...")
* call in formatdata.c
*/
for(s = tmpdir, t = buf; *s; s++, t++)
if ((*t = *s) == '/')
*t = '\\';
if (t[-1] != '\\')
*t++ = '\\';
*t = 0;
t = buf;
}
sprintf(c_functions, "%sf2c_func", t);
sprintf(initfname, "%sf2c_rd", t);
sprintf(blkdfname, "%sf2c_blkd", t);
sprintf(p1_file, "%sf2c_p1f", t);
sprintf(p1_bakfile, "%sf2c_p1fb", t);
sprintf(sortfname, "%sf2c_sort", t);
#else
int pid = getpid();
sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
#endif
sprintf(initbname, "%s.b", initfname);
}
if (debugflag)
fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
initfname, blkdfname, p1_file, p1_bakfile, sortfname);
}
char *
c_name(s,ft)char *s;
{
char *b, *s0;
int c;
b = s0 = s;
while(c = *s++)
if (c == '/')
b = s;
if (--s < s0 + 3 || s[-2] != '.'
|| ((c = *--s) != 'f' && c != 'F')) {
infname = s0;
Fatal("file name must end in .f or .F");
}
*s = ft;
b = copys(b);
*s = c;
return b;
}
static void
killed()
{
signal(SIGINT, SIG_IGN);
#ifdef SIGQUIT
signal(SIGQUIT, SIG_IGN);
#endif
#ifdef SIGHUP
signal(SIGHUP, SIG_IGN);
#endif
signal(SIGTERM, SIG_IGN);
Un_link_all(1);
exit(126);
}
static void
sig1catch(sig) int sig;
{
if (signal(sig, SIG_IGN) != SIG_IGN)
signal(sig, killed);
}
static void
flovflo()
{
Fatal("floating exception during constant evaluation; cannot recover");
/* vax returns a reserved operand that generates
an illegal operand fault on next instruction,
which if ignored causes an infinite loop.
*/
signal(SIGFPE, flovflo);
}
void
sigcatch()
{
sig1catch(SIGINT);
#ifdef SIGQUIT
sig1catch(SIGQUIT);
#endif
#ifdef SIGHUP
sig1catch(SIGHUP);
#endif
sig1catch(SIGTERM);
signal(SIGFPE, flovflo); /* catch overflows */
}
dofork()
{
#ifdef MSDOS
Fatal("Only one Fortran input file allowed under MS-DOS");
#else
int pid, status, w;
extern int retcode;
if (!(pid = fork()))
return 1;
if (pid == -1)
Fatal("bad fork");
while((w = wait(&status)) != pid)
if (w == -1)
Fatal("bad wait code");
retcode |= status >> 8;
#endif
return 0;
}
/* Initialization of tables that change with the character set... */
char escapes[Table_size];
#ifdef non_ASCII
char *str_fmt[Table_size];
static char *str0fmt[127] = { /*}*/
#else
char *str_fmt[Table_size] = {
#endif
"\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
"\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017",
"\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
"\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
" ", "!", "\\\"", "#", "$", "%%", "&", "'",
"(", ")", "*", "+", ",", "-", ".", "/",
"0", "1", "2", "3", "4", "5", "6", "7",
"8", "9", ":", ";", "<", "=", ">", "?",
"@", "A", "B", "C", "D", "E", "F", "G",
"H", "I", "J", "K", "L", "M", "N", "O",
"P", "Q", "R", "S", "T", "U", "V", "W",
"X", "Y", "Z", "[", "\\\\", "]", "^", "_",
"`", "a", "b", "c", "d", "e", "f", "g",
"h", "i", "j", "k", "l", "m", "n", "o",
"p", "q", "r", "s", "t", "u", "v", "w",
"x", "y", "z", "{", "|", "}", "~"
};
#ifdef non_ASCII
char *chr_fmt[Table_size];
static char *chr0fmt[127] = { /*}*/
#else
char *chr_fmt[Table_size] = {
#endif
"\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7",
"\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17",
"\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27",
"\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37",
" ", "!", "\"", "#", "$", "%%", "&", "\\'",
"(", ")", "*", "+", ",", "-", ".", "/",
"0", "1", "2", "3", "4", "5", "6", "7",
"8", "9", ":", ";", "<", "=", ">", "?",
"@", "A", "B", "C", "D", "E", "F", "G",
"H", "I", "J", "K", "L", "M", "N", "O",
"P", "Q", "R", "S", "T", "U", "V", "W",
"X", "Y", "Z", "[", "\\\\", "]", "^", "_",
"`", "a", "b", "c", "d", "e", "f", "g",
"h", "i", "j", "k", "l", "m", "n", "o",
"p", "q", "r", "s", "t", "u", "v", "w",
"x", "y", "z", "{", "|", "}", "~"
};
void
fmt_init()
{
static char *str1fmt[6] =
{ "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
register int i, j;
register char *s;
/* str_fmt */
#ifdef non_ASCII
i = 0;
#else
i = 127;
#endif
for(; i < Table_size; i++)
str_fmt[i] = "\\%03o";
#ifdef non_ASCII
for(i = 32; i < 127; i++) {
s = str0fmt[i];
str_fmt[*(unsigned char *)s] = s;
}
str_fmt['"'] = "\\\"";
#else
if (Ansi == 1)
str_fmt[7] = chr_fmt[7] = "\\a";
#endif
/* chr_fmt */
#ifdef non_ASCII
for(i = 0; i < 32; i++)
chr_fmt[i] = chr0fmt[i];
#else
i = 127;
#endif
for(; i < Table_size; i++)
chr_fmt[i] = "\\%o";
#ifdef non_ASCII
for(i = 32; i < 127; i++) {
s = chr0fmt[i];
j = *(unsigned char *)s;
if (j == '\\')
j = *(unsigned char *)(s+1);
chr_fmt[j] = s;
}
#endif
/* escapes (used in lex.c) */
for(i = 0; i < Table_size; i++)
escapes[i] = i;
for(s = "btnfr0", i = 0; i < 6; i++)
escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
/* finish str_fmt and chr_fmt */
if (Ansi)
str1fmt[5] = "\\v";
if ('\v' == 'v') { /* ancient C compiler */
str1fmt[5] = "v";
#ifndef non_ASCII
escapes['v'] = 11;
#endif
}
else
escapes['v'] = '\v';
for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
str_fmt[j] = chr_fmt[j] = str1fmt[i++];
/* '\v' = 11 for both EBCDIC and ASCII... */
chr_fmt[11] = Ansi ? "\\v" : "\\13";
}
/* Unless SYSTEM_SORT is defined, the following gives a simple
* in-core version of dsort(). On Fortran source with huge DATA
* statements, the in-core version may exhaust the available memory,
* in which case you might either recompile this source file with
* SYSTEM_SORT defined (if that's reasonable on your system), or
* replace the dsort below with a more elaborate version that
* does a merging sort with the help of auxiliary files.
*/
#ifdef SYSTEM_SORT
dsort(from, to)
char *from, *to;
{
char buf[200];
sprintf(buf, "sort <%s >%s", from, to);
return system(buf) >> 8;
}
#else
static int
compare(a,b)
char *a, *b;
{ return strcmp(*(char **)a, *(char **)b); }
dsort(from, to)
char *from, *to;
{
extern char *Alloc();
struct Memb {
struct Memb *next;
int n;
char buf[32000];
};
typedef struct Memb memb;
memb *mb, *mb1;
register char *x, *x0, *xe;
register int c, n;
FILE *f;
char **z, **z0;
int nn = 0;
f = opf(from, textread);
mb = (memb *)Alloc(sizeof(memb));
mb->next = 0;
x0 = x = mb->buf;
xe = x + sizeof(mb->buf);
n = 0;
for(;;) {
c = getc(f);
if (x >= xe && (c != EOF || x != x0)) {
if (!n)
return 126;
nn += n;
mb->n = n;
mb1 = (memb *)Alloc(sizeof(memb));
mb1->next = mb;
mb = mb1;
memcpy(mb->buf, x0, n = x-x0);
x0 = mb->buf;
x = x0 + n;
xe = x0 + sizeof(mb->buf);
n = 0;
}
if (c == EOF)
break;
if (c == '\n') {
++n;
*x++ = 0;
x0 = x;
}
else
*x++ = c;
}
clf(&f, from, 1);
f = opf(to, textwrite);
if (x > x0) { /* shouldn't happen */
*x = 0;
++n;
}
mb->n = n;
nn += n;
if (!nn) /* shouldn't happen */
goto done;
z = z0 = (char **)Alloc(nn*sizeof(char *));
for(mb1 = mb; mb1; mb1 = mb1->next) {
x = mb1->buf;
n = mb1->n;
for(;;) {
*z++ = x;
if (--n <= 0)
break;
while(*x++);
}
}
qsort((char *)z0, nn, sizeof(char *), compare);
for(n = nn, z = z0; n > 0; n--)
fprintf(f, "%s\n", *z++);
free((char *)z0);
done:
clf(&f, to, 1);
do {
mb1 = mb->next;
free((char *)mb);
}
while(mb = mb1);
return 0;
}
#endif

83
lang/fortran/comp/sysdep.h Normal file
View file

@ -0,0 +1,83 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories, Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
/* This file is included at the start of defs.h; this file
* is an initial attempt to gather in one place some declarations
* that may need to be tweaked on some systems.
*/
#ifdef __STDC__
#ifndef ANSI_Libraries
#define ANSI_Libraries
#endif
#ifndef ANSI_Prototypes
#define ANSI_Prototypes
#endif
#endif
#include <stdio.h>
#ifdef ANSI_Libraries
#include <stddef.h>
#include <stdlib.h>
#else
char *calloc(), *malloc(), *memcpy(), *memset(), *realloc();
/* typedef int size_t; */
#ifdef ANSI_Prototypes
extern double atof(const char *);
#else
extern double atof();
#endif
#endif
#ifdef ANSI_Prototypes
extern char *gmem(int, int);
extern char *mem(int, int);
extern char *Alloc(int);
extern int* ckalloc(int);
#else
extern char *Alloc(), *gmem(), *mem();
int *ckalloc();
#endif
/* On systems like VMS where fopen might otherwise create
* multiple versions of intermediate files, you may wish to
* #define scrub(x) unlink(x)
*/
#ifndef scrub
#define scrub(x) /* do nothing */
#endif
/* On systems that severely limit the total size of statically
* allocated arrays, you may need to change the following to
* extern char **chr_fmt, *escapes, **str_fmt;
* and to modify sysdep.c appropriately
*/
extern char *chr_fmt[], escapes[], *str_fmt[];
#include "string.h"
#include "ctype.h"
#define Table_size 256
/* Table_size should be 1 << (bits/byte) */

99
lang/fortran/comp/tokens Normal file
View file

@ -0,0 +1,99 @@
SEOS
SCOMMENT
SLABEL
SUNKNOWN
SHOLLERITH
SICON
SRCON
SDCON
SBITCON
SOCTCON
SHEXCON
STRUE
SFALSE
SNAME
SNAMEEQ
SFIELD
SSCALE
SINCLUDE
SLET
SASSIGN
SAUTOMATIC
SBACKSPACE
SBLOCK
SCALL
SCHARACTER
SCLOSE
SCOMMON
SCOMPLEX
SCONTINUE
SDATA
SDCOMPLEX
SDIMENSION
SDO
SDOUBLE
SELSE
SELSEIF
SEND
SENDFILE
SENDIF
SENTRY
SEQUIV
SEXTERNAL
SFORMAT
SFUNCTION
SGOTO
SASGOTO
SCOMPGOTO
SARITHIF
SLOGIF
SIMPLICIT
SINQUIRE
SINTEGER
SINTRINSIC
SLOGICAL
SNAMELIST
SOPEN
SPARAM
SPAUSE
SPRINT
SPROGRAM
SPUNCH
SREAD
SREAL
SRETURN
SREWIND
SSAVE
SSTATIC
SSTOP
SSUBROUTINE
STHEN
STO
SUNDEFINED
SWRITE
SLPAR
SRPAR
SEQUALS
SCOLON
SCOMMA
SCURRENCY
SPLUS
SMINUS
SSTAR
SSLASH
SPOWER
SCONCAT
SAND
SOR
SNEQV
SEQV
SNOT
SEQ
SLT
SGT
SLE
SGE
SNE
SENDDO
SWHILE
SSLASHD

7
lang/fortran/comp/usignal.h Normal file
View file

@ -0,0 +1,7 @@
#include <signal.h>
#ifndef SIGHUP
#define SIGHUP 1 /* hangup */
#endif
#ifndef SIGQUIT
#define SIGQUIT 3 /* quit */
#endif

325
lang/fortran/comp/vax.c Normal file
View file

@ -0,0 +1,325 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "defs.h"
#include "pccdefs.h"
#include "output.h"
int regnum[] = {
11, 10, 9, 8, 7, 6 };
/* Put out a constant integer */
prconi(fp, n)
FILEP fp;
ftnint n;
{
fprintf(fp, "\t%ld\n", n);
}
/* Put out a constant address */
prcona(fp, a)
FILEP fp;
ftnint a;
{
fprintf(fp, "\tL%ld\n", a);
}
prconr(fp, x, k)
FILEP fp;
int k;
Constp x;
{
char *x0, *x1;
char cdsbuf0[64], cdsbuf1[64];
if (k > 1) {
if (x->vstg) {
x0 = x->Const.cds[0];
x1 = x->Const.cds[1];
}
else {
x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
}
fprintf(fp, "\t%s %s\n", x0, x1);
}
else
fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
: cds(dtos(x->Const.cd[0]), cdsbuf0));
}
char *memname(stg, mem)
int stg;
long mem;
{
static char s[20];
switch(stg)
{
case STGCOMMON:
case STGEXT:
sprintf(s, "_%s", extsymtab[mem].cextname);
break;
case STGBSS:
case STGINIT:
sprintf(s, "v.%ld", mem);
break;
case STGCONST:
sprintf(s, "L%ld", mem);
break;
case STGEQUIV:
sprintf(s, "q.%ld", mem+eqvstart);
break;
default:
badstg("memname", stg);
}
return(s);
}
/* make_int_expr -- takes an arbitrary expression, and replaces all
occurrences of arguments with indirection */
expptr make_int_expr (e)
expptr e;
{
if (e != ENULL)
switch (e -> tag) {
case TADDR:
if (e -> addrblock.vstg == STGARG)
e = mkexpr (OPWHATSIN, e, ENULL);
break;
case TEXPR:
e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
break;
default:
break;
} /* switch */
return e;
} /* make_int_expr */
/* prune_left_conv -- used in prolog() to strip type cast away from
left-hand side of parameter adjustments. This is necessary to avoid
error messages from cktype() */
expptr prune_left_conv (e)
expptr e;
{
struct Exprblock *leftp;
if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
e -> exprblock.leftp -> tag == TEXPR) {
leftp = &(e -> exprblock.leftp -> exprblock);
if (leftp -> opcode == OPCONV) {
e -> exprblock.leftp = leftp -> leftp;
free ((charptr) leftp);
}
}
return e;
} /* prune_left_conv */
static int wrote_comment;
static FILE *comment_file;
static void
write_comment()
{
if (!wrote_comment) {
wrote_comment = 1;
nice_printf (comment_file, "/* Parameter adjustments */\n");
}
}
static int *
count_args()
{
register int *ac;
register chainp cp;
register struct Entrypoint *ep;
register Namep q;
ac = (int *)ckalloc(nallargs*sizeof(int));
for(ep = entries; ep; ep = ep->entnextp)
for(cp = ep->arglist; cp; cp = cp->nextp)
if (q = (Namep)cp->datap)
ac[q->argno]++;
return ac;
}
prolog(outfile, p)
FILE *outfile;
register chainp p;
{
int addif, addif0, i, nd, size;
int *ac;
register Namep q;
register struct Dimblock *dp;
if(procclass == CLBLOCK)
return;
wrote_comment = 0;
comment_file = outfile;
ac = 0;
/* Compute the base addresses and offsets for the array parameters, and
assign these values to local variables */
addif = addif0 = nentry > 1;
for(; p ; p = p->nextp)
{
q = (Namep) p->datap;
if(dp = q->vdim) /* if this param is an array ... */
{
expptr Q, expr;
/* See whether to protect the following with an if. */
/* This only happens when there are multiple entries. */
nd = dp->ndim - 1;
if (addif0) {
if (!ac)
ac = count_args();
if (ac[q->argno] == nentry)
addif = 0;
else if (dp->basexpr
|| dp->baseoffset->constblock.Const.ci)
addif = 1;
else for(addif = i = 0; i <= nd; i++)
if (dp->dims[i].dimexpr
&& (i < nd || !q->vlastdim)) {
addif = 1;
break;
}
if (addif) {
write_comment();
nice_printf(outfile, "if (%s) {\n", /*}*/
q->cvarname);
next_tab(outfile);
}
}
for(i = 0 ; i <= nd; ++i)
/* Store the variable length of each dimension (which is fixed upon
runtime procedure entry) into a local variable */
if ((Q = dp->dims[i].dimexpr)
&& (i < nd || !q->vlastdim)) {
expr = (expptr)cpexpr(Q);
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
fixtype(cpexpr(dp->dims[i].dimsize)), expr));
} /* if dp -> dims[i].dimexpr */
/* size will equal the size of a single element, or -1 if the type is
variable length character type */
size = typesize[ q->vtype ];
if(q->vtype == TYCHAR)
if( ISICON(q->vleng) )
size *= q->vleng->constblock.Const.ci;
else
size = -1;
/* Fudge the argument pointers for arrays so subscripts
* are 0-based. Not done if array bounds are being checked.
*/
if(dp->basexpr) {
/* Compute the base offset for this procedure */
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
cpexpr(fixtype(dp->baseoffset)),
cpexpr(fixtype(dp->basexpr))));
} /* if dp -> basexpr */
if(! checksubs) {
if(dp->basexpr) {
expptr tp;
/* If the base of this array has a variable adjustment ... */
tp = (expptr) cpexpr (dp -> baseoffset);
if(size < 0 || q -> vtype == TYCHAR)
tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
write_comment();
tp = mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv(TYINT, fixtype
(fixtype (tp))));
/* Avoid type clash by removing the type conversion */
tp = prune_left_conv (tp);
out_and_free_statement (outfile, tp);
} else if(dp->baseoffset->constblock.Const.ci != 0) {
/* if the base of this array has a nonzero constant adjustment ... */
expptr tp;
write_comment();
if(size > 0 && q -> vtype != TYCHAR) {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(cpexpr (dp->baseoffset)))));
out_and_free_statement (outfile, tp);
} else {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
cpexpr (q -> vleng))))));
out_and_free_statement (outfile, tp);
} /* else */
} /* if dp -> baseoffset -> const */
} /* if !checksubs */
if (addif) {
nice_printf(outfile, /*{*/ "}\n");
prev_tab(outfile);
}
}
}
if (wrote_comment)
nice_printf (outfile, "\n/* Function Body */\n");
if (ac)
free((char *)ac);
} /* prolog */

2
lang/fortran/comp/version.c Normal file
View file

@ -0,0 +1,2 @@
char F2C_version[] = "28 August 1991 0:07:02";
char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 28 August 1991 0:07:02\n";

174
lang/fortran/comp/xsum.c Normal file
View file

@ -0,0 +1,174 @@
/****************************************************************
Copyright 1990 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/
#include "stdio.h"
char *progname;
void
usage(rc)
{
fprintf(stderr, "usage: %s [file [file...]]\n", progname);
exit(rc);
}
main(argc, argv)
char **argv;
{
int x;
char *s;
static int rc;
progname = *argv;
s = *++argv;
if (s && *s == '-') {
switch(s[1]) {
case '?':
usage(0);
case '-':
break;
default:
fprintf(stderr, "invalid option %s\n", s);
usage(1);
}
s = *++argv;
}
if (s) do {
x = open(s,0);
if (x < 0) {
fprintf(stderr, "%s: can't open %s\n", progname, s);
rc |= 1;
}
else
process(s, x);
}
while(s = *++argv);
else {
process("/dev/stdin", fileno(stdin));
}
exit(rc);
}
typedef unsigned char uchar;
long
sum32(sum, x, n)
register long sum;
register uchar *x;
int n;
{
register uchar *xe;
static long crc_table[256] = {
0, 151466134, 302932268, 453595578,
-9583591, -160762737, -312236747, -463170141,
-19167182, -136529756, -321525474, -439166584,
28724267, 145849533, 330837255, 448732561,
-38334364, -189783822, -273059512, -423738914,
47895677, 199091435, 282375505, 433292743,
57448534, 174827712, 291699066, 409324012,
-67019697, -184128295, -300991133, -418902539,
-76668728, -227995554, -379567644, -530091662,
67364049, 218420295, 369985021, 520795499,
95791354, 213031020, 398182870, 515701056,
-86479645, -203465611, -388624945, -506380967,
114897068, 266207290, 349655424, 500195606,
-105581387, -256654301, -340093543, -490887921,
-134039394, -251295736, -368256590, -485758684,
124746887, 241716241, 358686123, 476458301,
-153337456, -2395898, -455991108, -304803798,
162629001, 11973919, 465560741, 314102835,
134728098, 16841012, 436840590, 319723544,
-144044613, -26395347, -446403433, -329032703,
191582708, 40657250, 426062040, 274858062,
-200894995, -50223749, -435620671, -284179369,
-172959290, -55056048, -406931222, -289830788,
182263263, 64630089, 416513267, 299125861,
229794136, 78991822, 532414580, 381366498,
-220224191, -69691945, -523123603, -371788549,
-211162774, -93398532, -513308602, -396314416,
201600371, 84090341, 503991391, 386759881,
-268078788, -117292630, -502591472, -351526778,
258520357, 107972019, 493278217, 341959839,
249493774, 131713432, 483432482, 366454964,
-239911657, -122417791, -474129349, -356881235,
-306674912, -457198666, -4791796, -156118374,
315967289, 466778031, 14362133, 165418627,
325258002, 442776452, 23947838, 141187752,
-334573813, -452329571, -33509849, -150495567,
269456196, 419996626, 33682024, 184992510,
-278767779, -429561909, -43239823, -194312473,
-288089226, -405591072, -52790694, -170046772,
297394031, 415166457, 62373443, 179343061,
383165416, 533828478, 81314500, 232780370,
-373594127, -524527769, -72022307, -223201717,
-401789990, -519431348, -100447498, -217810336,
392228803, 510123861, 91131631, 208256633,
-345918580, -496598246, -110112096, -261561802,
336361365, 487278339, 100800185, 251995695,
364526526, 482151208, 129260178, 246639108,
-354943065, -472854735, -119955829, -237064675,
459588272, 308539942, 157983644, 7181066,
-469170519, -317835713, -167286907, -16754925,
-440448382, -323454444, -139383890, -21619912,
450006683, 332774925, 148697015, 31186721,
-422325548, -271261118, -186797064, -36011154,
431888077, 280569435, 196114401, 45565815,
403200742, 286222960, 168180682, 50400092,
-412770561, -295522711, -177471533, -59977915,
-536157576, -384970002, -234585260, -83643454,
526853729, 375396087, 225003341, 74348507,
517040714, 399923932, 215944038, 98057200,
-507728301, -390357307, -206385281, -88735767,
498987548, 347783818, 263426864, 112501670,
-489671163, -338229613, -253864151, -103192641,
-479823314, -362722632, -244835582, -126932076,
470531639, 353144481, 235265819, 117632909
};
xe = x + n;
while(x < xe)
sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff);
return sum;
}
process(s, x)
char *s;
int x;
{
register int n;
uchar buf[16*1024];
long fsize, sum;
sum = 0;
fsize = 0;
while((n = read(x, (char *)buf, sizeof(buf))) > 0) {
fsize += n;
sum = sum32(sum, buf, n);
}
sum &= 0xffffffff;
if (n==0)
printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize);
else { perror(s); }
close(x);
return(0);
}

56
lang/fortran/comp/xsum0.out Normal file
View file

@ -0,0 +1,56 @@
Notice fb5a412e 1183
README fe10cd03 3340
cds.c e93849b8 3884
data.c e552a480 9278
defines.h ef026e5f 8179
defs.h e74a0285 23464
equiv.c e7eb3399 8552
error.c 111d9ebf 3653
exec.c 18ed4ede 18027
expr.c e2bc323c 57458
f2c.1 e65632a 5799
f2c.1t 1aad289 5706
f2c.h ed0a0173 4138
format.c e7b58fa8 49914
format.h e861ad39 300
formatdata.c eeebb124 23833
ftypes.h e5db6a7c 941
gram.dcl fac72441 8102
gram.exec ff121afb 2996
gram.expr 1cdcf8c5 3081
gram.head e6859fc0 7539
gram.io 1b7c281c 3294
init.c f7ca02f1 10347
intr.c e2b8e4ab 19647
io.c c474aae 28975
iob.h fe479ed3 459
lex.c fe1e63b6 29374
machdefs.h 4950e5b 659
main.c 1e4ec3a1 16300
makefile 12f58dbe 2510
malloc.c 5c2be2a 3422
mem.c 5b007b2 4761
memset.c 17404d52 1964
misc.c 19c4624d 17758
names.c e5184875 19122
names.h f25436a3 689
niceprintf.c f9d80b51 9355
niceprintf.h c31f08c 412
output.c f97db62 37044
output.h edfe9e59 2113
p1defs.h e4e11c4e 5776
p1output.c e60446f5 12198
parse.h e457df2e 855
parse_args.c f3e5da4d 13015
pccdefs.h 1b4fbbee 1195
pread.c 135e64ca 15796
proc.c f5df26ff 34052
put.c 1f22b2c0 9499
putpcc.c 1f96161e 38473
sysdep.c 197e669f 10864
sysdep.h e602b6fd 2532
tokens 194fccfe 727
usignal.h 1c4ce909 124
vax.c b060552 7649
version.c f7b72f6f 137
xsum.c bd02396 5479

15
lang/fortran/disclaimer Normal file
View file

@ -0,0 +1,15 @@
f2c is a Fortran to C converter under development by
David Gay (AT&T Bell Labs)
Stu Feldman (Bellcore)
Mark Maimone (Carnegie-Mellon University)
Norm Schryer (AT&T Bell Labs)
Please send bug reports to dmg@research.att.com or uunet!research!dmg.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.

180
lang/fortran/fc Normal file
View file

@ -0,0 +1,180 @@
#!/bin/sh
PATH=/v/bin:/bin:/usr/bin
# f77-style shell script to compile and load fortran, C, and assembly codes
# usage: f77 [-O] [-o absfile] [-c] files [-l library]
# -o objfile Override default executable name a.out.
# -c Do not call linker, leave relocatables in *.o.
# -S leave assembler output on file.s
# -l library (passed to ld).
# -u complain about undeclared variables
# -w omit all warning messages
# -w66 omit Fortran 66 compatibility warning messages
# files FORTRAN source files ending in .f .
# C source files ending in .c .
# Assembly language files ending in .s .
# efl source files ending in .e .
# -D def passed to C compiler (for .c files)
# -I includepath passed to C compiler (for .c files)
# -Ntnnn allow nnn entries in table t
s=/tmp/stderr_$$
t=/tmp/f77_$$.o
CC=${CC_f2c:-'/v/bin/lcc -Wfdouble=8,4,1'}
EFL=${EFL:-/v/bin/efl}
EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'}
F2C=${F2C:-/v/bin/f2c}
F2CFLAGS=${F2CFLAGS:='-ARw8'}
rc=0
trap "rm -f $s $t; exit \$rc" 0
lib=/lib/num/lib.lo
OUTF=a.out
cOPT=1
set -- `getopt cD:gI:N:Oo:Suw6 "$@"`
case $? in 0);; *) exit 1;; esac
CCFLAGS=
while
test X"$1" != X--
do
case "$1"
in
-c) cOPT=0
shift
;;
-D) CCFLAGS="$CCFLAGS -D$2"
shift 2
;;
-g) CFLAGS="$CFLAGS -g"
shift;;
-I) CCFLAGS="$CCFLAGS -I$2"
shift 2
;;
-o) OUTF=$2
shift 2
;;
-O) case $2 in -1) O=-O1;; -2) O=-O2;; -3) O=-O3;; *) O=-O;; esac
case $O in -O);; *) shift;; esac
# lcc ignores -O...
shift
;;
-u) F2CFLAGS="$F2CFLAGS -u"
shift
;;
-w) F2CFLAGS="$F2CFLAGS -w"
case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift
case $2 in -6) shift;; esac;; esac
shift
;;
-N) F2CFLAGS="$F2CFLAGS $1""$2"
shift 2
;;
-S) CFLAGS="$CFLAGS -S"
cOPT=0
shift
;;
*)
echo "invalid parameter $1" 1>&2
shift
;;
esac
done
shift
while
test -n "$1"
do
case "$1"
in
*.[fF])
case "$1" in *.f) f=".f";; *.F) f=".F";; esac
b=`basename $1 $f`
$F2C $F2CFLAGS $1
case $? in 0);; *) exit;; esac
$CC -c $CFLAGS $b.c 2>$s
rc=$?
sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2
case $rc in 0);; *) exit;; esac
OFILES="$OFILES $b.o"
rm $b.c
case $cOPT in 1) cOPT=2;; esac
shift
;;
*.e)
b=`basename $1 .e`
$EFL $EFLFLAGS $1 >$b.f
case $? in 0);; *) exit;; esac
$F2C $F2CFLAGS $b.f
case $? in 0);; *) exit;; esac
$CC -c $CFLAGS $b.c
case $? in 0);; *) exit;; esac
OFILES="$OFILES $b.o"
rm $b.[cf]
case $cOPT in 1) cOPT=2;; esac
shift
;;
*.s)
echo $1: 1>&2
OFILE=`basename $1 .s`.o
${AS:-/usr/bin/as} -o $OFILE $AFLAGS $1
case $? in 0);; *) exit;; esac
OFILES="$OFILES $OFILE"
case $cOPT in 1) cOPT=2;; esac
shift
;;
*.c)
echo $1: 1>&2
OFILE=`basename $1 .c`.o
$CC -c $CFLAGS $CCFLAGS $1
rc=$?; case $rc in 0);; *) exit;; esac
OFILES="$OFILES $OFILE"
case $cOPT in 1) cOPT=2;; esac
shift
;;
*.o)
OFILES="$OFILES $1"
case $cOPT in 1) cOPT=2;; esac
shift
;;
-l)
OFILES="$OFILES -l$2"
shift 2
case $cOPT in 1) cOPT=2;; esac
;;
-l*)
OFILES="$OFILES $1"
shift
case $cOPT in 1) cOPT=2;; esac
;;
-o)
OUTF=$2; shift 2;;
*)
OFILES="$OFILES $1"
shift
case $cOPT in 1) cOPT=2;; esac
;;
esac
done
case $cOPT in 2) $CC -o $OUTF -u MAIN__ $OFILES -lf2c -lm;; esac
rc=$?
exit $rc

1184
lang/fortran/fixes Normal file
View file

File diff suppressed because it is too large Load diff

392
lang/fortran/index Normal file
View file

@ -0,0 +1,392 @@
====== index for f2c ============
FILES:
f2c.h Include file necessary for compiling output of the converter.
See the second NOTE below.
f2c.1 Man page for f2c.
f2c.1t Source for f2c.1 (to be processed by troff -man or nroff -man).
libf77 Library of non I/O support routines the generated C may need.
Fortran main programs result in a C function named MAIN__ that
is meant to be invoked by the main() in libf77.
libi77 Library of Fortran I/O routines the generated C may need.
Note that some vendors (e.g., BSD, Sun and MIPS) provide a
libF77 and libI77 that are incompatible with f2c -- they
provide some differently named routines or routines with the
names that f2c expects, but with different calling sequences.
On such systems, the recommended procedure is to merge
libf77 and libi77 into a single library, say libf2c, to install
it where you can access it by specifying -lf2c , and to adjust
the definition of link_msg in sysdep.c appropriately.
f2c.ps Postscript for a technical report on f2c. After you strip the
mail header, the first line should be "%!PS".
fixes The complete change log, reporting bug fixes and other changes.
(Some recent change-log entries are given below).
fc A shell script that uses f2c and imitates much of the behavior
of commonly found f77 commands. You will almost certainly
need to adjust some of the shell-variable assignments to make
this script work on your system.
SUBDIRECTORY:
f2c/src Source for the converter itself, including a file of checksums
and source for a program to compute the checksums (to verify
correct transmission of the source), is available: ask netlib to
send all from f2c/src
If the checksums show damage to just a few source files, or if
the change log file (see "fixes" below) reports corrections to
some source files, you can request those files individually
"from f2c/src". For example, to get defs.h and xsum0.out, you
would ask netlib to
send defs.h xsum0.out from f2c/src
"all from f2c/src" is 649642 bytes long.
Tip: if asked to send over 99,000 bytes in one request, netlib
breaks the shipment into 1000 line pieces and sends each piece
separately (since otherwise some mailers might gag). To avoid
the hassle of reassembling the pieces, try to keep each request
under 99,000 bytes long. The final number in each line of
xsum0.out gives the length of each file in f2c/src. For
example,
send exec.c expr.c from f2c/src
send format.c format_data.c from f2c/src
will give you slightly less hassle than
send exec.c expr.c format.c format_data.c from f2c/src
If you have trouble generating gram.c, you can ask netlib to
send gram.c from f2c/src
Then `xsum gram.c` should report
gram.c efa337b3 57282
NOTE: For now, you may exercise f2c by sending netlib a message whose
first line is "execute f2c" and whose remaining lines are
the Fortran 77 source that you wish to have converted.
Return mail brings you the resulting C, with f2c's error
messages between #ifdef uNdEfInEd and #endif at the end.
(To understand line numbers in the error messages, regard
the "execute f2c" line as line 0. It is stripped away by
the netlib software before f2c sees your Fortran input.)
Options described in the man page may be transmitted to
netlib by having the first line of input be a comment
whose first 6 characters are "c$f2c " and whose remaining
characters are the desired options, e.g., "c$f2c -R -u".
This scheme may change -- ask netlib to
send index from f2c
if you do not get the behavior you expect.
During the initial experimental period, incoming Fortran
will be saved in a file. Don't send any secrets!
BUGS: Please send bug reports (including the shortest example
you can find that illustrates the bug) to research!dmg
or dmg@research.att.com . You might first check whether
the bug goes away when you turn optimization off.
NOTE: f2c.h defines several types, e.g., real, integer, doublereal.
The definitions in f2c.h are suitable for most machines, but if
your machine has sizeof(double) > 2*sizeof(long), you may need
to adjust f2c.h appropriately. f2c assumes
sizeof(doublecomplex) = 2*sizeof(doublereal)
sizeof(doublereal) = sizeof(complex)
sizeof(doublereal) = 2*sizeof(real)
sizeof(real) = sizeof(integer)
sizeof(real) = sizeof(logical)
sizeof(real) = 2*sizeof(shortint)
EQUIVALENCEs may not be translated correctly if these
assumptions are violated.
There exists a C compiler that objects to the lines
typedef VOID C_f; /* complex function */
typedef VOID H_f; /* character function */
typedef VOID Z_f; /* double complex function */
in f2c.h . If yours is such a compiler, do two things:
1. Complain to your vendor about this compiler bug.
2. Find the line
#define VOID void
in f2c.h and change it to
#define VOID int
(For readability, the f2c.h lines shown above have had two
tabs inserted before their first character.)
FTP: All the material described above is now available by ftp from
research.att.com (login: netlib; Password: your E-mail address;
cd f2c). You must uncompress the .Z files once you have a
copy of them, e.g., by
uncompress *.Z
-----------------
Recent change log (partial)
-----------------
Tue Jan 15 12:00:24 EST 1991:
Fix bug when two equivalence groups are merged, the second with
nonzero offset, and the result is then merged into a common block.
Example:
INTEGER W(3), X(3), Y(3), Z(3)
COMMON /ZOT/ Z
EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
***** W WAS GIVEN THE WRONG OFFSET
Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
(Currently NML= and FMT= are treated as synonyms -- there's no
error message if, e.g., NML= specifies a format.)
libi77: minor adjustment to allow internal READs from character
string constants in read-only memory.
Wed Jan 23 00:38:48 EST 1991:
Allow hex, octal, and binary constants to have the qualifying letter
(z, x, o, or b) either before or after the quoted string containing the
digits. For now this change will not be reflected in f2c.ps .
Tue Jan 29 16:23:45 EST 1991:
Arrange for character-valued statement functions to give results of
the right length (that of the statement function's name).
Wed Jan 30 07:05:32 EST 1991:
More tweaks for character-valued statement functions: an error
check and an adjustment so a right-hand side of nonconstant length
(e.g., a substring) is handled right.
Thu Jan 31 13:53:44 EST 1991:
Add a test after the cleanup call generated for I/O statements with
ERR= or END= clauses to catch the unlikely event that the cleanup
routine encounters an error.
Tue Feb 5 01:39:36 EST 1991:
Change Mktemp to mktmp (for the benefit of systems so brain-damaged
that they do not distinguish case in external names -- and that for
some reason want to load mktemp). Try to get xsum0.out right this
time (it somehow didn't get updated on 4 Feb. 1991).
Add note to libi77/README about adjusting the interpretation of
RECL= specifiers in OPENs for direct unformatted I/O.
Thu Feb 7 17:24:42 EST 1991:
New option -r casts values of REAL functions, including intrinsics,
to REAL. This only matters for unportable code like
real r
r = asin(1.)
if (r .eq. asin(1.)) ...
[The behavior of such code varies with the Fortran compiler used --
and sometimes is affected by compiler options.] For now, the man page
at the end of f2c.ps is the only part of f2c.ps that reflects this new
option.
Fri Feb 8 18:12:51 EST 1991:
Cast pointer differences passed as arguments to the appropriate type.
This matters, e.g., with MSDOS compilers that yield a long pointer
difference but have int == short.
Disallow nonpositive dimensions.
Fri Feb 15 12:24:15 EST 1991:
Change %d to %ld in sprintf call in putpower in putpcc.c.
Free more memory (e.g. allowing translation of larger Fortran
files under MS-DOS).
Recognize READ (character expression)
as formatted I/O with the format given by the character expression.
Update year in Notice.
Mon Mar 4 15:19:42 EST 1991:
Fix bug in passing the real part of a complex argument to an intrinsic
function. Omit unneeded parentheses in nested calls to intrinsics.
Example:
subroutine foo(x, y)
complex y
x = exp(sin(real(y))) + exp(imag(y))
end
Fri Mar 8 15:05:42 EST 1991:
Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
cases not used by f2c).
Wed Mar 13 02:27:23 EST 1991:
Initialize firstmemblock->next in mem_init in mem.c . [On most
systems it was fortuituously 0, but with System V, -lmalloc could
trip on this missed initialization.]
Wed Mar 13 11:47:42 EST 1991:
Fix a reference to freed memory.
Wed Mar 27 00:42:19 EST 1991:
Fix a memory fault caused by such illegal Fortran as
function foo
x = 3
logical foo ! declaration among executables
foo=.false. ! used to suffer memory fault
end
Fri Apr 5 08:30:31 EST 1991:
Fix loss of % in some format expressions, e.g.
write(*,'(1h%)')
Fix botch introduced 27 March 1991 that caused subroutines with
multiple entry points to have extraneous declarations of ret_val.
Fri Apr 5 12:44:02 EST 1991
Try again to omit extraneous ret_val declarations -- this morning's
fix was sometimes wrong.
Mon Apr 8 13:47:06 EDT 1991:
Arrange for s_rnge to have the right prototype under -A -C .
Wed Apr 17 13:36:03 EDT 1991:
New fatal error message for apparent invocation of a recursive
statement function.
Thu Apr 25 15:13:37 EDT 1991:
F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot
about -i2 when adding NAMELIST.) This required a change to f2c.h
(that only affects NAMELIST I/O under -i2.) Man-page description of
-i2 adjusted to reflect that -i2 stores array lengths in short ints.
Fri Apr 26 02:54:41 EDT 1991:
Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
(file rsne.c).
Tue May 7 09:04:48 EDT 1991:
gram.c added to f2c/src (for folks who have trouble generating it. It
is not in "all from f2c", nor in the list of current timestamps below.)
Thu May 9 02:13:51 EDT 1991:
Omit a trailing space in expr.c (could cause a false xsum value if
a mailer drops the trailing blank).
Thu May 16 13:14:59 EDT 1991:
libi77: increase LEFBL in lio.h to overcome a NeXT bug.
Tweak for compilers that recognize "nested" comments: inside comments,
turn /* into /+ (as well as */ into +/).
Sat May 25 11:44:25 EDT 1991:
libf77: s_rnge: declare line long int rather than int.
Fri May 31 07:51:50 EDT 1991:
libf77: system_: officially return status.
Mon Jun 17 16:52:53 EDT 1991:
Minor tweaks: omit unnecessary declaration of strcmp (that caused
trouble on a system where strcmp was a macro) from misc.c; add
SHELL = /bin/sh to makefiles.
Fix a dereference of null when a CHARACTER*(*) declaration appears
(illegally) after DATA. Complain only once per subroutine about
declarations appearing after DATA.
Mon Jul 1 00:28:13 EDT 1991:
Add test and error message for illegal use of subroutine names, e.g.
SUBROUTINE ZAP(A)
ZAP = A
END
Mon Jul 8 21:49:20 EDT 1991:
Issue a warning about things like
integer i
i = 'abc'
(which is treated as i = ichar('a')). [It might be nice to treat 'abc'
as an integer initialized (in a DATA statement) with 'abc', but
other matters have higher priority.]
Render
i = ichar('A')
as
i = 'A';
rather than
i = 65;
(which assumes ASCII).
Fri Jul 12 07:41:30 EDT 1991:
Note added to README about erroneous definitions of __STDC__ .
Sat Jul 13 13:38:54 EDT 1991:
Fix bugs in double type convesions of complex values, e.g.
sngl(real(...)) or dble(real(...)) (where ... is complex).
Mon Jul 15 13:21:42 EDT 1991:
Fix bug introduced 8 July 1991 that caused erroneous warnings
"ichar([first char. of] char. string) assumed for conversion to numeric"
when a subroutine had an array of character strings as an argument.
Wed Aug 28 01:12:17 EDT 1991:
Omit an unused function in format.c, an unused variable in proc.c .
Under -r8, promote complex to double complex (as the man page claims).
Fri Aug 30 17:19:17 EDT 1991:
f2c.ps updated: slightly expand description of intrinsics and,or,xor,
not; add mention of intrinsics lshift, rshift; add note about f2c
accepting Fortran 90 inline comments (starting with !); update Cobalt
Blue address.
Tue Sep 17 07:17:33 EDT 1991:
libI77: err.c and open.c modified to use modes "rb" and "wb"
when (f)opening unformatted files; README updated to point out
that it may be necessary to change these modes to "r" and "w"
on some non-ANSI systems.
Current timestamps of files in "all from f2c/src", sorted by time,
appear below (mm/dd/year hh:mm:ss). To bring your source up to date,
obtain source files with a timestamp later than the time shown in your
version.c. Note that the time shown in the current version.c is the
timestamp of the source module that immediately follows version.c below:
8/28/1991 0:29:01 xsum0.out
8/28/1991 0:23:26 version.c
8/28/1991 0:07:02 main.c
8/28/1991 0:07:01 gram.dcl
8/28/1991 0:07:01 expr.c
8/28/1991 0:07:00 defs.h
8/13/1991 9:06:09 format.c
8/13/1991 9:04:25 proc.c
7/13/1991 12:58:37 putpcc.c
7/12/1991 7:25:33 README
7/05/1991 7:16:57 intr.c
6/17/1991 16:43:01 gram.head
6/06/1991 0:41:56 makefile
6/05/1991 8:34:09 misc.c
5/16/1991 13:06:06 p1output.c
4/25/1991 13:20:26 f2c.1
4/25/1991 12:56:19 f2c.h
4/25/1991 12:51:27 f2c.1t
4/25/1991 12:10:22 io.c
4/05/1991 7:43:45 mem.c
3/13/1991 11:18:09 output.c
3/08/1991 10:14:45 niceprintf.c
2/15/1991 12:08:26 Notice
2/08/1991 11:29:18 gram.exec
2/08/1991 11:29:18 malloc.c
2/05/1991 0:52:39 exec.c
1/22/1991 19:25:10 lex.c
1/15/1991 1:21:00 equiv.c
12/16/1990 16:46:20 xsum.c
12/07/1990 17:37:08 names.c
11/30/1990 9:47:48 data.c
7/26/1990 10:54:47 parse_args.c
7/26/1990 10:44:26 parse.h
6/19/1990 0:18:23 formatdata.c
5/11/1990 14:17:04 error.c
4/23/1990 17:35:47 sysdep.h
4/23/1990 16:37:50 sysdep.c
4/18/1990 12:25:19 init.c
4/18/1990 12:25:19 pread.c
4/18/1990 12:25:18 cds.c
4/10/1990 0:00:38 put.c
4/06/1990 0:00:57 gram.io
4/05/1990 23:40:09 gram.expr
3/27/1990 16:39:18 names.h
3/27/1990 10:05:15 p1defs.h
3/27/1990 10:05:14 defines.h
2/25/1990 9:04:30 vax.c
2/16/1990 10:37:27 tokens
2/14/1990 2:00:20 format.h
2/14/1990 1:38:46 output.h
2/14/1990 0:54:06 iob.h
2/03/1990 0:58:26 niceprintf.h
1/29/1990 13:26:52 memset.c
1/11/1990 18:02:51 ftypes.h
1/07/1990 1:20:01 usignal.h
11/27/1989 8:27:37 machdefs.h
7/01/1989 11:59:44 pccdefs.h

3
lang/fortran/lib/.distr Normal file
View file

@ -0,0 +1,3 @@
LIST
libF77
libI77

3
lang/fortran/lib/LIST Normal file
View file

@ -0,0 +1,3 @@
LIST
libF77
libI77