From 47621762e2dee2321ca27787ee4435da3c5f94b9 Mon Sep 17 00:00:00 2001 From: Bill Joy Date: Sat, 2 Feb 1980 23:53:09 -0800 Subject: [PATCH] BSD 3 development Work on file usr/src/cmd/f77/data.c Work on file usr/src/cmd/f77/Makefile Work on file usr/src/cmd/f77/compiler Work on file usr/src/cmd/f77/defines Work on file usr/src/cmd/f77/drivedefs Work on file usr/src/cmd/f77/defs Work on file usr/src/cmd/f77/driver.c Work on file usr/src/cmd/f77/equiv.c Work on file usr/src/cmd/f77/error.c Work on file usr/src/cmd/f77/exec.c Work on file usr/src/cmd/f77/expr.c Work on file usr/src/cmd/f77/fio.h Work on file usr/src/cmd/f77/ftypes Work on file usr/src/cmd/f77/gram.c Work on file usr/src/cmd/f77/gram.dcl Work on file usr/src/cmd/f77/gram.exec Work on file usr/src/cmd/f77/gram.expr Work on file usr/src/cmd/f77/gram.head Work on file usr/src/cmd/f77/gram.io Work on file usr/src/cmd/f77/init.c Work on file usr/src/cmd/f77/intr.c Work on file usr/src/cmd/f77/io.c Work on file usr/src/cmd/f77/lex.c Work on file usr/src/cmd/f77/machdefs Work on file usr/src/cmd/f77/misc.c Work on file usr/src/cmd/f77/main.c Work on file usr/src/cmd/f77/pccdefs Work on file usr/src/cmd/f77/proc.c Work on file usr/src/cmd/f77/putpcc.c Work on file usr/src/cmd/f77/put.c Work on file usr/src/cmd/f77/tokdefs Work on file usr/src/cmd/f77/tokens Work on file usr/src/cmd/f77/vax.c Work on file usr/src/cmd/f77/vaxdefs Work on file usr/src/cmd/f77/vaxx.c Synthesized-from: 3bsd --- usr/src/cmd/f77/Makefile | 60 + usr/src/cmd/f77/compiler | 0 usr/src/cmd/f77/data.c | 318 ++++++ usr/src/cmd/f77/defines | 235 ++++ usr/src/cmd/f77/defs | 468 ++++++++ usr/src/cmd/f77/drivedefs | 19 + usr/src/cmd/f77/driver.c | 1203 ++++++++++++++++++++ usr/src/cmd/f77/equiv.c | 300 +++++ usr/src/cmd/f77/error.c | 140 +++ usr/src/cmd/f77/exec.c | 556 +++++++++ usr/src/cmd/f77/expr.c | 2250 +++++++++++++++++++++++++++++++++++++ usr/src/cmd/f77/fio.h | 101 ++ usr/src/cmd/f77/ftypes | 22 + usr/src/cmd/f77/gram.c | 1600 ++++++++++++++++++++++++++ usr/src/cmd/f77/gram.dcl | 340 ++++++ usr/src/cmd/f77/gram.exec | 119 ++ usr/src/cmd/f77/gram.expr | 134 +++ usr/src/cmd/f77/gram.head | 192 ++++ usr/src/cmd/f77/gram.io | 166 +++ usr/src/cmd/f77/init.c | 290 +++++ usr/src/cmd/f77/intr.c | 693 ++++++++++++ usr/src/cmd/f77/io.c | 766 +++++++++++++ usr/src/cmd/f77/lex.c | 911 +++++++++++++++ usr/src/cmd/f77/machdefs | 56 + usr/src/cmd/f77/main.c | 259 +++++ usr/src/cmd/f77/misc.c | 660 +++++++++++ usr/src/cmd/f77/pccdefs | 68 ++ usr/src/cmd/f77/proc.c | 953 ++++++++++++++++ usr/src/cmd/f77/put.c | 299 +++++ usr/src/cmd/f77/putpcc.c | 1519 +++++++++++++++++++++++++ usr/src/cmd/f77/tokdefs | 95 ++ usr/src/cmd/f77/tokens | 95 ++ usr/src/cmd/f77/vax.c | 546 +++++++++ usr/src/cmd/f77/vaxdefs | 56 + usr/src/cmd/f77/vaxx.c | 42 + 35 files changed, 15531 insertions(+) create mode 100644 usr/src/cmd/f77/Makefile create mode 100644 usr/src/cmd/f77/compiler create mode 100644 usr/src/cmd/f77/data.c create mode 100644 usr/src/cmd/f77/defines create mode 100644 usr/src/cmd/f77/defs create mode 100644 usr/src/cmd/f77/drivedefs create mode 100644 usr/src/cmd/f77/driver.c create mode 100644 usr/src/cmd/f77/equiv.c create mode 100644 usr/src/cmd/f77/error.c create mode 100644 usr/src/cmd/f77/exec.c create mode 100644 usr/src/cmd/f77/expr.c create mode 100644 usr/src/cmd/f77/fio.h create mode 100644 usr/src/cmd/f77/ftypes create mode 100644 usr/src/cmd/f77/gram.c create mode 100644 usr/src/cmd/f77/gram.dcl create mode 100644 usr/src/cmd/f77/gram.exec create mode 100644 usr/src/cmd/f77/gram.expr create mode 100644 usr/src/cmd/f77/gram.head create mode 100644 usr/src/cmd/f77/gram.io create mode 100644 usr/src/cmd/f77/init.c create mode 100644 usr/src/cmd/f77/intr.c create mode 100644 usr/src/cmd/f77/io.c create mode 100644 usr/src/cmd/f77/lex.c create mode 100644 usr/src/cmd/f77/machdefs create mode 100644 usr/src/cmd/f77/main.c create mode 100644 usr/src/cmd/f77/misc.c create mode 100644 usr/src/cmd/f77/pccdefs create mode 100644 usr/src/cmd/f77/proc.c create mode 100644 usr/src/cmd/f77/put.c create mode 100644 usr/src/cmd/f77/putpcc.c create mode 100644 usr/src/cmd/f77/tokdefs create mode 100644 usr/src/cmd/f77/tokens create mode 100644 usr/src/cmd/f77/vax.c create mode 100644 usr/src/cmd/f77/vaxdefs create mode 100644 usr/src/cmd/f77/vaxx.c diff --git a/usr/src/cmd/f77/Makefile b/usr/src/cmd/f77/Makefile new file mode 100644 index 0000000000..327c7936b9 --- /dev/null +++ b/usr/src/cmd/f77/Makefile @@ -0,0 +1,60 @@ +# Makefile for a Fortran 77 compiler +# running on the VAX, generating code for the VAX, +# using the second pass of the Portable C compiler as code generator. + +CFL = -DHERE=VAX -DTARGET=VAX -DFAMILY=PCC -DUCBVAXASM + +CFLAGS = -O $(CFL) +LDFLAGS = -i + +OBJECTS = main.o init.o gram.o lex.o proc.o equiv.o data.o \ + expr.o exec.o intr.o io.o misc.o error.o put.o \ + putpcc.o vax.o vaxx.o + +compiler : f77 f77pass1 + touch compiler + +f77 : driver.o vaxx.o + cc -n driver.o vaxx.o -o f77 + @size f77 + +f77pass1 : $(OBJECTS) + @echo LOAD + @$(CC) $(LDFLAGS) $(OBJECTS) -o f77pass1 + @size f77pass1 + +gram.c: gram.head gram.dcl gram.expr gram.exec gram.io tokdefs + ( sed gram.in + $(YACC) $(YFLAGS) gram.in + @echo "(expect 4 shift/reduce)" + mv y.tab.c gram.c + rm gram.in + +tokdefs: tokens + grep -n . tokdefs +lex.o : tokdefs +driver.o $(OBJECTS) : defs defines machdefs ftypes +driver.o : drivedefs +io.o : fio.h + +machdefs : vaxdefs + cp vaxdefs machdefs + +put.o putpcc.o vax.o : pccdefs + +install : /usr/bin/f77 /usr/lib/f77pass1 + +/usr/bin/f77 : f77 + strip f77 + @size f77 /usr/bin/f77 + cp f77 /usr/bin/f77 + +/usr/lib/f77pass1 : f77pass1 + strip f77pass1 + @size f77pass1 /usr/lib/f77pass1 + cp f77pass1 /usr/lib/f77pass1 + +cleanup: + -rm gram.c *.o f77 f77pass1 tokdefs compiler + du diff --git a/usr/src/cmd/f77/compiler b/usr/src/cmd/f77/compiler new file mode 100644 index 0000000000..e69de29bb2 diff --git a/usr/src/cmd/f77/data.c b/usr/src/cmd/f77/data.c new file mode 100644 index 0000000000..8faa4e57d8 --- /dev/null +++ b/usr/src/cmd/f77/data.c @@ -0,0 +1,318 @@ +#include "defs" + +/* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */ + +static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ; + +/* another initializer, called from parser */ +dataval(repp, valp) +register expptr repp, valp; +{ +int i, nrep; +ftnint elen, vlen; +register struct Addrblock *p; +struct Addrblock *nextdata(); + +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, &vlen); + if(p == NULL) + { + err("too many initializers"); + toomanyinit = YES; + goto ret; + } + setdata(p, valp, elen, vlen); + frexpr(p); + } + +ret: + frexpr(valp); +} + + +struct Addrblock *nextdata(elenp, vlenp) +ftnint *elenp, *vlenp; +{ +register struct Impldoblock *ip; +struct Primblock *pp; +register struct Nameblock *np; +register struct Rplblock *rp; +tagptr p; +expptr neltp; +register expptr q; +int skip; +ftnint off; + +while(curdtp) + { + p = (tagptr) (curdtp->datap); + if(p->headblock.tag == TIMPLDO) + { + ip = &(p->impldoblock); + if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) + fatali("bad impldoblock 0%o", ip); + if(ip->isactive) + ip->varvp->const.ci += ip->impdiff; + else + { + q = fixtype(cpexpr(ip->implb)); + if( ! ISICON(q) ) + goto doerr; + ip->varvp = 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->nextp = rpllist; + rpllist = rp; + rp->rplnp = ip->varnp; + rp->rplvp = 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 */ + + popstack(&rpllist); + + frexpr(ip->varvp); + ip->isactive = NO; + curdtp = curdtp->nextp; + goto next; + } + + pp = p; + np = pp->namep; + skip = YES; + + if(p->primblock.argsp==NULL && np->vdim!=NULL) + { /* array initialization */ + q = 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( cpexpr(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 == STGCOMMON) + *vlenp = extsymtab[np->vardesc.varno].maxleng; + else if(np->vstg == STGEQUIV) + *vlenp = eqvclass[np->vardesc.varno].eqvleng; + else { + *vlenp = (np->vtype==TYCHAR ? + np->vleng->constblock.const.ci : typesize[np->vtype]); + if(np->vdim) + *vlenp *= np->vdim->nelt->constblock.const.ci; + } + return(q); + +doerr: + err("nonconstant implied DO parameter"); + frexpr(q); + curdtp = curdtp->nextp; + +next: curdtelt = 0; + } + +return(NULL); +} + + + + + + +LOCAL setdata(varp, valp, elen, vlen) +struct Addrblock *varp; +ftnint elen, vlen; +struct Constblock *valp; +{ +union Constant con; +int i, k; +int stg, type, valtype; +ftnint offset; +register char *s, *t; +char *memname(); +static char varname[XL+2]; + +/* output form of name is padded with blanks and preceded + with a storage class digit +*/ + +stg = varp->vstg; +varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') ); +s = memname(stg, varp->memno); +for(t = varname+1 ; *s ; ) + *t++ = *s++; +while(t < varname+XL+1) + *t++ = ' '; +varname[XL+1] = '\0'; + +offset = varp->memoffset->constblock.const.ci; +type = varp->vtype; +valtype = valp->vtype; +if(type!=TYCHAR && valtype==TYCHAR) + { + if(! ftn66flag) + warn("non-character datum initialized with character string"); + 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 != TYCHAR) + if(valtype == TYUNKNOWN) + con.ci = valp->const.ci; + else consconv(type, &con, valtype, &valp->const); + +k = 1; +switch(type) + { + case TYLOGICAL: + type = tylogical; + case TYSHORT: + case TYLONG: + fprintf(initfile, datafmt, varname, offset, vlen, type); + prconi(initfile, type, con.ci); + break; + + case TYCOMPLEX: + k = 2; + type = TYREAL; + case TYREAL: + goto flpt; + + case TYDCOMPLEX: + k = 2; + type = TYDREAL; + case TYDREAL: + flpt: + + for(i = 0 ; i < k ; ++i) + { + fprintf(initfile, datafmt, varname, offset, vlen, type); + prconr(initfile, type, con.cd[i]); + offset += typesize[type]; + } + break; + + case TYCHAR: + k = valp->vleng->constblock.const.ci; + if(elen < k) + k = elen; + + for(i = 0 ; i < k ; ++i) + { + fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR); + fprintf(initfile, "\t%d\n", + valp->const.ccp[i]); + } + k = elen - valp->vleng->constblock.const.ci; + if(k > 0) + { + fprintf(initfile, datafmt, varname, offset, vlen, TYBLANK); + fprintf(initfile, "\t%d\n", k); + offset += k; + } + break; + + default: + fatali("setdata: impossible type %d", type); + } + +} + + + +frdata(p0) +chainp p0; +{ +register struct Chain *p; +register tagptr q; + +for(p = p0 ; p ; p = p->nextp) + { + q = p->datap; + if(q->headblock.tag == TIMPLDO) + { + if(q->impldoblock.isbusy) + return; /* circular chain completed */ + q->impldoblock.isbusy = YES; + frdata(q->impldoblock.datalist); + free(q); + } + else + frexpr(q); + } + +frchain( &p0); +} diff --git a/usr/src/cmd/f77/defines b/usr/src/cmd/f77/defines new file mode 100644 index 0000000000..288addfa1a --- /dev/null +++ b/usr/src/cmd/f77/defines @@ -0,0 +1,235 @@ +#define INTERDATA 2 +#define GCOS 3 +#define PDP11 4 +#define IBM 5 +#define CMACH 6 +#define VAX 7 + +#define DMR 2 +#define PCC 3 + +#ifndef FAMILY +FAMILY NOT DEFINED !!! +Family = FAMILY +#endif + +#ifndef HERE +HERE NOT DEFINED !!!! +Here = HERE +#endif + +#define M(x) (1<headblock.tag==TCONST && ISINT(z->headblock.vtype)) +#define ISCHAR(z) (z->headblock.vtype==TYCHAR) +#define ISINT(z) ONEOF(z, MSKINT) +#define ISCONST(z) (z->headblock.tag==TCONST) +#define ISERROR(z) (z->headblock.tag==TERROR) +#define ISPLUSOP(z) (z->headblock.tag==TEXPR && z->exprblock.opcode==OPPLUS) +#define ISSTAROP(z) (z->headblock.tag==TEXPR && z->exprblock.opcode==OPSTAR) +#define ISONE(z) (ISICON(z) && z->constblock.const.ci==1) +#define INT(z) ONEOF(z, MSKINT|MSKCHAR) +#define ICON(z) mkintcon( (ftnint)(z) ) +#define CHCON(z) mkstrcon(strlen(z), z) + +#if HERE == PDP11 + /* not enough space in compiler for checks */ +# define NO66(s) +# define NOEXT(s) +#else +# define NO66(s) if(no66flag) err66(s) +# define NOEXT(s) if(noextflag) errext(s) +#endif + +/* round a up to a multiple of b */ +#define roundup(a,b) ( b * ( (a+b-1)/b) ) diff --git a/usr/src/cmd/f77/defs b/usr/src/cmd/f77/defs new file mode 100644 index 0000000000..f5d09089fb --- /dev/null +++ b/usr/src/cmd/f77/defs @@ -0,0 +1,468 @@ +#include + +#ifdef unix +# include +#endif + +#include "ftypes" +#include "defines" +#include "machdefs" + +#define VL 6 + +#define MAXDIM 20 +#define MAXINCLUDES 10 +#define MAXLITERALS 20 +#define MAXCTL 20 +#define MAXHASH 401 +#define MAXSTNO 201 +#define MAXEXT 200 +#define MAXEQUIV 150 +#define MAXLABLIST 125 + +typedef union Expression *expptr; +typedef union Taggedblock *tagptr; +typedef union Chainedblock *chainp; + +extern FILEP infile; +extern FILEP diagfile; +extern FILEP textfile; +extern FILEP asmfile; +extern FILEP initfile; +extern long int headoffset; + +extern char token [ ]; +extern int toklen; +extern int yylval; +extern int lineno; +extern char *infname; +extern int needkwd; +extern struct Labelblock *thislabel; + +extern int maxctl; +extern int maxequiv; +extern int maxstno; +extern int maxhash; +extern int maxext; + +extern flag profileflag; +extern flag optimflag; +extern flag nowarnflag; +extern flag ftn66flag; +extern flag no66flag; +extern flag noextflag; +extern flag shiftcase; +extern flag undeftype; +extern flag shortsubs; +extern flag onetripflag; +extern flag checksubs; +extern flag debugflag; +extern int nerr; +extern int nwarn; +extern int ndata; + +extern int parstate; +extern flag headerdone; +extern int blklevel; +extern flag saveall; +extern flag substars; +extern int impltype[ ]; +extern int implleng[ ]; +extern int implstg[ ]; + +extern int tyint; +extern int tylogical; +extern ftnint typesize[]; +extern int typealign[]; +extern int procno; +extern int proctype; +extern char * procname; +extern int rtvlabel[ ]; +extern int fudgelabel; /* to confuse the pdp11 optimizer */ +extern struct Addrblock *typeaddr; +extern struct Addrblock *retslot; +extern int cxslot; +extern int chslot; +extern int chlgslot; +extern int procclass; +extern ftnint procleng; +extern int nentry; +extern flag multitype; +extern int blklevel; +extern int lastlabno; +extern int lastvarno; +extern int lastargslot; +extern int argloc; +extern ftnint autoleng; +extern ftnint bssleng; +extern int retlabel; +extern int ret0label; +extern int dorange; +extern int regnum[ ]; +extern struct Nameblock *regnamep[ ]; +extern int maxregvar; +extern int highregvar; +extern int nregvar; + +extern chainp templist; +extern int maxdim; +extern chainp holdtemps; +extern struct Entrypoint *entries; +extern struct Rplblock *rpllist; +extern struct Chain *curdtp; +extern ftnint curdtelt; +extern flag toomanyinit; + +extern flag inioctl; +extern int iostmt; +extern struct Addrblock *ioblkp; +extern int nioctl; +extern int nequiv; +extern int eqvstart; /* offset to eqv number to guarantee uniqueness */ +extern int nintnames; +extern int nextnames; + +#ifdef SDB +extern int dbglabel; +extern flag sdbflag; +#endif + +struct Chain + { + chainp nextp; + tagptr datap; + }; + +extern chainp chains; + +struct Headblock + { + unsigned tag:4; + unsigned vtype:4; + unsigned vclass:4; + unsigned vstg:4; + expptr vleng; + } ; + +struct Ctlframe + { + unsigned ctltype:8; + unsigned dostepsign:8; + int ctlabels[4]; + int dolabel; + struct Nameblock *donamep; + expptr domax; + expptr dostep; + }; +#define endlabel ctlabels[0] +#define elselabel ctlabels[1] +#define dobodylabel ctlabels[1] +#define doposlabel ctlabels[2] +#define doneglabel ctlabels[3] +extern struct Ctlframe *ctls; +extern struct Ctlframe *ctlstack; +extern struct Ctlframe *lastctl; + +struct Extsym + { + char extname[XL]; + unsigned extstg:4; + unsigned extsave:1; + unsigned extinit:1; + ptr extp; + ftnint extleng; + ftnint maxleng; + }; + +extern struct Extsym *extsymtab; +extern struct Extsym *nextext; +extern struct Extsym *lastext; + +struct Labelblock + { + int labelno; + unsigned blklevel:8; + unsigned labused:1; + unsigned labinacc:1; + unsigned labdefined:1; + unsigned labtype:2; + ftnint stateno; + }; + +extern struct Labelblock *labeltab; +extern struct Labelblock *labtabend; +extern struct Labelblock *highlabtab; + +struct Entrypoint + { + chainp nextp; + struct Extsym *entryname; + chainp arglist; + int entrylabel; + int typelabel; + ptr enamep; + }; + +struct Primblock + { + unsigned tag:4; + unsigned vtype:4; + struct Nameblock *namep; + struct Listblock *argsp; + expptr fcharp; + expptr lcharp; + }; + + +struct Hashentry + { + int hashval; + struct Nameblock *varp; + }; +extern struct Hashentry *hashtab; +extern struct Hashentry *lasthash; + +struct Intrpacked /* bits for intrinsic function description */ + { + unsigned f1:3; + unsigned f2:4; + unsigned f3:7; + }; + +struct Nameblock + { + unsigned tag:4; + unsigned vtype:4; + unsigned vclass:4; + unsigned vstg:4; + expptr vleng; + char varname[VL]; + unsigned vdovar:1; + unsigned vdcldone:1; + unsigned vadjdim:1; + unsigned vsave:1; + unsigned vprocclass:3; + unsigned vregno:4; + union { + int varno; + chainp vstfdesc; /* points to (formals, expr) pair */ + struct Intrpacked intrdesc; /* bits for intrinsic function */ + } vardesc; + struct Dimblock *vdim; + ftnint voffset; + }; + + +struct Paramblock + { + unsigned tag:4; + unsigned vtype:4; + unsigned vclass:4; + expptr vleng; + char varname[VL]; + ptr paramval; + } ; + + +struct Exprblock + { + unsigned tag:4; + unsigned vtype:4; + unsigned vclass:4; + expptr vleng; + unsigned opcode:6; + expptr leftp; + expptr rightp; + }; + + +union Constant + { + char *ccp; + ftnint ci; + double cd[2]; + }; + +struct Constblock + { + unsigned tag:4; + unsigned vtype:4; + expptr vleng; + union Constant const; + }; + + +struct Listblock + { + unsigned tag:4; + unsigned vtype:4; + chainp listp; + }; + + + +struct Addrblock + { + unsigned tag:4; + unsigned vtype:4; + unsigned vclass:4; + unsigned vstg:4; + expptr vleng; + int memno; + expptr memoffset; + unsigned istemp:1; + unsigned ntempelt:10; + }; + + + +struct Errorblock + { + unsigned tag:4; + unsigned vtype:4; + }; + + +union Expression + { + struct Headblock headblock; + struct Exprblock exprblock; + struct Addrblock addrblock; + struct Constblock constblock; + struct Errorblock errorblock; + struct Listblock listblock; + struct Primblock primblock; + } ; + + + +struct Dimblock + { + int ndim; + expptr nelt; + expptr baseoffset; + expptr basexpr; + struct + { + expptr dimsize; + expptr dimexpr; + } dims[1]; + }; + + +struct Impldoblock + { + unsigned tag:4; + unsigned isactive:1; + unsigned isbusy:1; + struct Nameblock *varnp; + struct Constblock *varvp; + expptr implb; + expptr impub; + expptr impstep; + ftnint impdiff; + ftnint implim; + struct Chain *datalist; + }; + + +struct Rplblock /* name replacement block */ + { + chainp nextp; + struct Nameblock *rplnp; + ptr rplvp; + struct Exprblock *rplxp; + int rpltag; + }; + + + +struct Equivblock + { + ptr equivs; + unsigned eqvinit:1; + long int eqvtop; + long int eqvbottom; + } ; +#define eqvleng eqvtop + +extern struct Equivblock *eqvclass; + + +struct Eqvchain + { + chainp nextp; + ptr eqvitem; + long int eqvoffset; + } ; + +union Chainedblock + { + struct Chain; + struct Entrypoint; + struct Rplblock; + struct Eqvchain; + }; + + + +union Taggedblock + { + struct Headblock headblock; + struct Nameblock nameblock; + struct Paramblock paramblock; + struct Exprblock exprblock; + struct Constblock constblock; + struct Listblock listblock; + struct Addrblock addrblock; + struct Errorblock errorblock; + struct Primblock primblock; + struct Impldoblock impldoblock; + } ; + + + + +struct Literal + { + short littype; + short litnum; + union { + ftnint litival; + double litdval; + struct { + char litclen; /* small integer */ + char litcstr[XL]; + } litcval; + } litval; + }; + +extern struct Literal litpool[ ]; +extern int nliterals; + + + + + +/* popular functions with non integer return values */ + + +int *ckalloc(); +char *varstr(), *nounder(), *varunder(); +char *copyn(), *copys(); +chainp hookup(), mkchain(); +ftnint convci(); +char *convic(); +char *setdoto(); +double convcd(); +struct Nameblock *mkname(); +struct Labelblock *mklabel(); +struct Extsym *mkext(), *newentry(); +struct Exprblock *addrof(), *call1(), *call2(), *call3(), *call4(); +struct Addrblock *builtin(), *mktemp(), *mktmpn(); +struct Addrblock *autovar(), *mklhs(), *mkaddr(), *putconst(), *memversion(); +struct Constblock *mkintcon(); +expptr mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype(); +tagptr cpexpr(), mkprim(); +struct Errorblock *errnode(); +ftnint lmin(), lmax(), iarrlen(); diff --git a/usr/src/cmd/f77/drivedefs b/usr/src/cmd/f77/drivedefs new file mode 100644 index 0000000000..5142ce2318 --- /dev/null +++ b/usr/src/cmd/f77/drivedefs @@ -0,0 +1,19 @@ +/* + Definitions for Fortran 77 Compiler driver + For the VAX, Running on the VAX, + using the second pass of the Portable C compiler as code generator. +*/ + +#if HERE!=VAX || TARGET!=VAX || FAMILY!=PCC + Wrong Definitions File! +#endif + +#define PASS1NAME "/usr/lib/f77pass1" +#define PASS2NAME "/lib/f1" +#define PASS2OPT "/lib/c2" +#define ASMNAME "/bin/as" +#define LDNAME "/bin/ld" +#define FOOTNAME "/lib/crt0.o" +#define PROFFOOT "/lib/mcrt0.o" + +static char *liblist [ ] = { "-lF77", "-lI77", "-lm", "-lc", NULL }; diff --git a/usr/src/cmd/f77/driver.c b/usr/src/cmd/f77/driver.c new file mode 100644 index 0000000000..7fefae3772 --- /dev/null +++ b/usr/src/cmd/f77/driver.c @@ -0,0 +1,1203 @@ +char *xxxvers[] = "\n FORTRAN 77 DRIVER, VERSION 2.00, 7 JANUARY 1980\n"; +#include +#include +#include "defines" +#include "machdefs" +#include "drivedefs" +#include "ftypes" +#include + +static FILEP diagfile = {stderr} ; +static int pid; +static int sigivalue = 0; +static int sigqvalue = 0; +static int sighvalue = 0; +static int sigtvalue = 0; + +static char *pass1name = PASS1NAME ; +static char *pass2name = PASS2NAME ; +static char *asmname = ASMNAME ; +static char *ldname = LDNAME ; +static char *footname = FOOTNAME; +static char *proffoot = PROFFOOT; +static char *macroname = "m4"; +static char *shellname = "/bin/sh"; +static char *aoutname = "a.out" ; + +static char *infname; +static char textfname[15]; +static char asmfname[15]; +static char asmpass2[15]; +static char initfname[15]; +static char sortfname[15]; +static char prepfname[15]; +static char objfdefault[15]; +static char optzfname[15]; +static char setfname[15]; + +static char fflags[50] = "-"; +static char cflags[20] = "-c"; +static char eflags[30] = ""; +static char rflags[30] = ""; +static char lflag[3] = "-x"; +static char *fflagp = fflags+1; +static char *cflagp = cflags+2; +static char *eflagp = eflags; +static char *rflagp = rflags; +static char **loadargs; +static char **loadp; + +static flag erred = NO; +static flag loadflag = YES; +static flag saveasmflag = NO; +static flag profileflag = NO; +static flag optimflag = NO; +static flag debugflag = NO; +static flag verbose = NO; +static flag nofloating = NO; +static flag fortonly = NO; +static flag macroflag = NO; + + +main(argc, argv) +int argc; +char **argv; +{ +int i, c, status; +char *setdoto(), *lastchar(), *lastfield(); +ptr ckalloc(); +register char *s; +char fortfile[20], *t; +char buff[100]; +int intrupt(); + +sigivalue = (int) signal(SIGINT, SIG_IGN) & 01; +sigqvalue = (int) signal(SIGQUIT,SIG_IGN) & 01; +sighvalue = (int) signal(SIGHUP, SIG_IGN) & 01; +sigtvalue = (int) signal(SIGTERM,SIG_IGN) & 01; +enbint(intrupt); + +pid = getpid(); +crfnames(); + +loadargs = (char **) ckalloc( (argc+20) * sizeof(*loadargs) ); +loadargs[1] = "-X"; +loadargs[2] = "-u"; +#if HERE==PDP11 || HERE==VAX + loadargs[3] = "_MAIN__"; +#endif +#if HERE == INTERDATA + loadargs[3] = "main"; +#endif +loadp = loadargs + 4; + +--argc; +++argv; + +while(argc>0 && argv[0][0]=='-' && argv[0][1]!='\0') + { + for(s = argv[0]+1 ; *s ; ++s) switch(*s) + { + case 'T': /* use special passes */ + switch(*++s) + { + case '1': + pass1name = s+1; goto endfor; + case '2': + pass2name = s+1; goto endfor; + case 'a': + asmname = s+1; goto endfor; + case 'l': + ldname = s+1; goto endfor; + case 'F': + footname = s+1; goto endfor; + case 'm': + macroname = s+1; goto endfor; + default: + fatali("bad option -T%c", *s); + } + break; + + case '6': + if(s[1]=='6') + { + *fflagp++ = *s++; + goto copyfflag; + } + else { + fprintf(diagfile, "invalid flag 6%c\n", s[1]); + done(1); + } + + case 'w': + if(s[1]=='6' && s[2]=='6') + { + *fflagp++ = *s++; + *fflagp++ = *s++; + } + + copyfflag: + case 'u': + case 'U': + case 'M': + case '1': + case 'C': + case 'g': + *fflagp++ = *s; + break; + + case 'O': + optimflag = YES; +#if TARGET == INTERDATA + *loadp++ = "-r"; + *loadp++ = "-d"; +#endif + *fflagp++ = 'O'; + if( isdigit(s[1]) ) + *fflagp++ = *++s; + break; + + case 'N': + *fflagp++ = 'N'; + if( oneof(*++s, "qxscn") ) + *fflagp++ = *s++; + else { + fprintf(diagfile, "invalid flag -N%c\n", *s); + done(1); + } + while( isdigit(*s) ) + *fflagp++ = *s++; + *fflagp++ = 'X'; + goto endfor; + + case 'm': + if(s[1] == '4') + ++s; + macroflag = YES; + break; + + case 'S': + saveasmflag = YES; + + case 'c': + loadflag = NO; + break; + + case 'v': + verbose = YES; + break; + + case 'd': + debugflag = YES; + goto copyfflag; + + case 'p': + profileflag = YES; + *cflagp++ = 'p'; + goto copyfflag; + + case 'o': + if( ! strcmp(s, "onetrip") ) + { + *fflagp++ = '1'; + goto endfor; + } + aoutname = *++argv; + --argc; + break; + +#if TARGET == PDP11 + case 'f': + nofloating = YES; + pass2name = NOFLPASS2; + break; +#endif + + case 'F': + fortonly = YES; + loadflag = NO; + break; + + case 'I': + if(s[1]=='2' || s[1]=='4' || s[1]=='s') + { + *fflagp++ = *s++; + goto copyfflag; + } + fprintf(diagfile, "invalid flag -I%c\n", s[1]); + done(1); + + case 'l': /* letter ell--library */ + s[-1] = '-'; + *loadp++ = s-1; + goto endfor; + + case 'E': /* EFL flag argument */ + while( *eflagp++ = *++s) + ; + *eflagp++ = ' '; + goto endfor; + case 'R': + while( *rflagp++ = *++s ) + ; + *rflagp++ = ' '; + goto endfor; + default: + lflag[1] = *s; + *loadp++ = copys(lflag); + break; + } +endfor: + --argc; + ++argv; + } + +*fflagp = '\0'; + +loadargs[0] = ldname; +#if TARGET == PDP11 + if(nofloating) + *loadp++ = (profileflag ? NOFLPROF : NOFLFOOT); + else +#endif +*loadp++ = (profileflag ? proffoot : footname); + +for(i = 0 ; i%s", macroname, infname, prepfname); + if( sys(buff) ) + { + rmf(prepfname); + erred = YES; + break; + } + infname = prepfname; + } + + if(c == 'e') + sprintf(buff, "efl %s %s >%s", eflags, infname, fortfile); + else + sprintf(buff, "ratfor %s %s >%s", rflags, infname, fortfile); + status = sys(buff); + if(macroflag) + rmf(infname); + if(status) + { + erred = YES; + rmf(fortfile); + break; + } + + if( ! fortonly ) + { + infname = argv[i] = lastfield(argv[i]); + *lastchar(infname) = 'f'; + + if( dofort(argv[i]) ) + erred = YES; + else { + if( nodup(t = setdoto(argv[i])) ) + *loadp++ = t; + rmf(fortfile); + } + } + break; + + case 'f': /* Fortran file */ + case 'F': + if( unreadable(argv[i]) ) + erred = YES; + else if( dofort(argv[i]) ) + erred = YES; + else if( nodup(t=setdoto(argv[i])) ) + *loadp++ = t; + break; + + case 'c': /* C file */ + case 's': /* Assembler file */ + if( unreadable(argv[i]) ) + { + erred = YES; + break; + } +#if HERE==PDP11 || HERE==VAX + fprintf(diagfile, "%s:\n", argv[i]); +#endif + sprintf(buff, "cc -c %s", argv[i] ); + if( sys(buff) ) + erred = YES; + else + if( nodup(t = setdoto(argv[i])) ) + *loadp++ = t; + break; + + case 'o': + if( nodup(argv[i]) ) + *loadp++ = argv[i]; + break; + + default: + if( ! strcmp(argv[i], "-o") ) + aoutname = argv[++i]; + else + *loadp++ = argv[i]; + break; + } + +if(loadflag && !erred) + doload(loadargs, loadp); +done(erred); +} + +dofort(s) +char *s; +{ +int retcode; +char buff[200]; + +infname = s; +sprintf(buff, "%s %s %s %s %s %s", + pass1name, fflags, s, asmfname, initfname, textfname); +switch( sys(buff) ) + { + case 1: + goto error; + case 0: + break; + default: + goto comperror; + } + +if(content(initfname) > 0) + if( dodata() ) + goto error; +if( dopass2() ) + goto comperror; +doasm(s); +retcode = 0; + +ret: + rmf(asmfname); + rmf(initfname); + rmf(textfname); + return(retcode); + +error: + fprintf(diagfile, "\nError. No assembly.\n"); + retcode = 1; + goto ret; + +comperror: + fprintf(diagfile, "\ncompiler error.\n"); + retcode = 2; + goto ret; +} + + + + +dopass2() +{ +char buff[100]; + +if(verbose) + fprintf(diagfile, "PASS2."); + +#if FAMILY==DMR + sprintf(buff, "%s %s - %s", pass2name, textfname, asmpass2); + return( sys(buff) ); +#endif + +#if FAMILY == PCC +# if TARGET==INTERDATA + sprintf(buff, "%s -A%s <%s >%s", pass2name, setfname, textfname, asmpass2); +# else + sprintf(buff, "%s <%s >%s", pass2name, textfname, asmpass2); +# endif + return( sys(buff) ); +#endif +} + + + + +doasm(s) +char *s; +{ +register char *lastc; +char *obj; +char buff[200]; + +if(*s == '\0') + s = objfdefault; +lastc = lastchar(s); +obj = setdoto(s); + +#if TARGET==PDP11 || TARGET==VAX +# ifdef PASS2OPT + if(optimflag) + { + sprintf(buff, "%s %s %s", PASS2OPT, asmpass2, optzfname); + if( sys(buff) ) + rmf(optzfname); + else + { + sprintf(buff,"mv %s %s", optzfname, asmpass2); + sys(buff); + } + } +# endif +#endif + +if(saveasmflag) + { + *lastc = 's'; +#if TARGET == INTERDATA + sprintf(buff, "cat %s %s %s >%s",asmfname, setfname, asmpass2, obj); +#else + sprintf(buff, "cat %s %s >%s", asmfname, asmpass2, obj); +#endif + sys(buff); + *lastc = 'o'; + } +else + { + if(verbose) + fprintf(diagfile, " ASM."); +#if TARGET == INTERDATA + sprintf(buff, "%s -o %s %s %s %s", asmname, obj, asmfname, setfname, asmpass2); +#endif + +#if TARGET == VAX + /* vax assembler currently accepts only one input file */ + sprintf(buff, "cat %s >>%s", asmpass2, asmfname); + sys(buff); + sprintf(buff, "%s -o %s %s", asmname, obj, asmfname); +#endif + +#if TARGET == PDP11 + sprintf(buff, "%s -u -o %s %s %s", asmname, obj, asmfname, asmpass2); +#endif + +#if TARGET!=INTERDATA && TARGET!=PDP11 && TARGET!=VAX + sprintf(buff, "%s -o %s %s %s", asmname, obj, asmfname, asmpass2); +#endif + + if( sys(buff) ) + fatal("assembler error"); + if(verbose) + fprintf(diagfile, "\n"); +#if HERE==PDP11 && TARGET!=PDP11 + rmf(obj); +#endif + } + +rmf(asmpass2); +} + + + +doload(v0, v) +register char *v0[], *v[]; +{ +char **p; +int waitpid; + +for(p = liblist ; *p ; *v++ = *p++) + ; + +*v++ = "-o"; +*v++ = aoutname; +*v = NULL; + +if(verbose) + fprintf(diagfile, "LOAD."); +if(debugflag) + { + for(p = v0 ; p') + { + if(t[1] == '>') + { + append = YES; + outname = t+2; + } + else { + append = NO; + outname = t+1; + } + } + else + argv[argc++] = t; + while( !isspace(*t) && *t!='\0' ) + ++t; + if(*t) + { + *t++ = '\0'; + while( isspace(*t) ) + ++t; + } + } + +if(argc == 1) /* no command */ + return(-1); +argv[argc] = 0; + +s = path; +t = "/usr/bin/"; +while(*t) + *s++ = *t++; +for(t = argv[1] ; *s++ = *t++ ; ) + ; +if((waitpid = fork()) == 0) + { + if(inname) + freopen(inname, "r", stdin); + if(outname) + freopen(outname, (append ? "a" : "w"), stdout); + enbint(SIG_DFL); + + texec(path+9, argv); /* command */ + texec(path+4, argv); /* /bin/command */ + texec(path , argv); /* /usr/bin/command */ + + fatalstr("Cannot load %s",path+9); + } + +return( await(waitpid) ); +} + + + + + +#include "errno.h" + +/* modified version from the Shell */ +texec(f, av) +char *f; +char **av; +{ +extern int errno; + +execv(f, av+1); + +if (errno==ENOEXEC) + { + av[1] = f; + execv(shellname, av); + fatal("No shell!"); + } +if (errno==ENOMEM) + fatalstr("%s: too large", f); +} + + + + + + +done(k) +int k; +{ +static int recurs = NO; + +if(recurs == NO) + { + recurs = YES; + rmfiles(); + } +exit(k); +} + + + + + + +enbint(k) +int (*k)(); +{ +if(sigivalue == 0) + signal(SIGINT,k); +if(sigqvalue == 0) + signal(SIGQUIT,k); +if(sighvalue == 0) + signal(SIGHUP,k); +if(sigtvalue == 0) + signal(SIGTERM,k); +} + + + + +intrupt() +{ +done(2); +} + + + +await(waitpid) +int waitpid; +{ +int w, status; + +enbint(SIG_IGN); +while ( (w = wait(&status)) != waitpid) + if(w == -1) + fatal("bad wait code"); +enbint(intrupt); +if(status & 0377) + { + if(status != SIGINT) + fprintf(diagfile, "Termination code %d", status); + done(3); + } +return(status>>8); +} + +/* File Name and File Manipulation Routines */ + +unreadable(s) +register char *s; +{ +register FILE *fp; + +if(fp = fopen(s, "r")) + { + fclose(fp); + return(NO); + } + +else + { + fprintf(diagfile, "Error: Cannot read file %s\n", s); + return(YES); + } +} + + + +clf(p) +FILEP *p; +{ +if(p!=NULL && *p!=NULL && *p!=stdout) + { + if(ferror(*p)) + fatal("writing error"); + fclose(*p); + } +*p = NULL; +} + +rmfiles() +{ +rmf(textfname); +rmf(asmfname); +rmf(initfname); +rmf(asmpass2); +#if TARGET == INTERDATA + rmf(setfname); +#endif +} + + + + + + + + +/* return -1 if file does not exist, 0 if it is of zero length + and 1 if of positive length +*/ +content(filename) +char *filename; +{ +#ifdef VERSION6 + struct stat + { + char cjunk[9]; + char size0; + int size1; + int ijunk[12]; + } buf; +#else +# include +# include + struct stat buf; +#endif + +if(stat(filename,&buf) < 0) + return(-1); +#ifdef VERSION6 + return(buf.size0 || buf.size1); +#else + return( buf.st_size > 0 ); +#endif +} + + + + +crfnames() +{ +fname(textfname, "x"); +fname(asmfname, "s"); +fname(asmpass2, "a"); +fname(initfname, "d"); +fname(sortfname, "S"); +fname(objfdefault, "o"); +fname(prepfname, "p"); +fname(optzfname, "z"); +fname(setfname, "A"); +} + + + + +rmf(fn) +register char *fn; +{ +if(!debugflag && fn!=NULL && *fn!='\0') + unlink(fn); +} + + + + + +LOCAL fname(name, suff) +char *name, *suff; +{ +sprintf(name, "fort%d.%s", pid, suff); +} + + + + +dotchar(s) +register char *s; +{ +for( ; *s ; ++s) + if(s[0]=='.' && s[1]!='\0' && s[2]=='\0') + return( s[1] ); +return(NO); +} + + + +char *lastfield(s) +register char *s; +{ +register char *t; +for(t = s; *s ; ++s) + if(*s == '/') + t = s+1; +return(t); +} + + + +char *lastchar(s) +register char *s; +{ +while(*s) + ++s; +return(s-1); +} + +char *setdoto(s) +register char *s; +{ +*lastchar(s) = 'o'; +return( lastfield(s) ); +} + + + +badfile(s) +char *s; +{ +fatalstr("cannot open intermediate file %s", s); +} + + + +ptr ckalloc(n) +int n; +{ +ptr p, calloc(); + +if( p = calloc(1, (unsigned) n) ) + return(p); + +fatal("out of memory"); +/* NOTREACHED */ +} + + + + + +copyn(n, s) +register int n; +register char *s; +{ +register char *p, *q; + +p = q = (char *) ckalloc(n); +while(n-- > 0) + *q++ = *s++; +return(p); +} + + + +copys(s) +char *s; +{ +return( copyn( strlen(s)+1 , s) ); +} + + + + + +oneof(c,s) +register c; +register char *s; +{ +while( *s ) + if(*s++ == c) + return(YES); +return(NO); +} + + + +nodup(s) +char *s; +{ +register char **p; + +for(p = loadargs ; p < loadp ; ++p) + if( !strcmp(*p, s) ) + return(NO); + +return(YES); +} + + + +static fatal(t) +char *t; +{ +fprintf(diagfile, "Compiler error in file %s: %s\n", infname, t); +if(debugflag) + abort(); +done(1); +exit(1); +} + + + + +static fatali(t,d) +char *t; +int d; +{ +char buff[100]; +sprintf(buff, t, d); +fatal(buff); +} + + + + +static fatalstr(t, s) +char *t, *s; +{ +char buff[100]; +sprintf(buff, t, s); +fatal(buff); +} +err(s) +char *s; +{ +fprintf(diagfile, "Error in file %s: %s\n", infname, s); +} + +LOCAL int nch = 0; +LOCAL FILEP asmfile; +LOCAL FILEP sortfile; + +#include "ftypes" + +static ftnint typesize[NTYPES] + = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG, + 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1}; +static int typealign[NTYPES] + = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE, + ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1}; + +dodata() +{ +char buff[50]; +char varname[XL+1], ovarname[XL+1]; +int status; +flag erred; +ftnint offset, vlen, type; +register ftnint ooffset, ovlen; +ftnint nblank, vchar; +int size, align; +int vargroup; +ftnint totlen, doeven(); + +erred = NO; +ovarname[0] = '\0'; +ooffset = 0; +ovlen = 0; +totlen = 0; +nch = 0; + +sprintf(buff, "sort %s >%s", initfname, sortfname); +if(status = sys(buff)) + fatali("call sort status = %d", status); +if( (sortfile = fopen(sortfname, "r")) == NULL) + badfile(sortfname); +if( (asmfile = fopen(asmfname, "a")) == NULL) + badfile(asmfname); +pruse(asmfile, USEINIT); + +while( rdname(&vargroup, varname) && rdlong(&offset) && rdlong(&vlen) && rdlong(&type) ) + { + size = typesize[type]; + if( strcmp(varname, ovarname) ) + { + prspace(ovlen-ooffset); + strcpy(ovarname, varname); + ooffset = 0; + totlen += ovlen; + ovlen = vlen; + if(vargroup == 0) + align = (type==TYCHAR || type==TYBLANK ? + SZLONG : typealign[type]); + else align = ALIDOUBLE; + totlen = doeven(totlen, align); + if(vargroup == 2) + prcomblock(asmfile, varname); + else + fprintf(asmfile, LABELFMT, varname); + } + if(offset < ooffset) + { + erred = YES; + err("overlapping initializations"); + } + if(offset > ooffset) + { + prspace(offset-ooffset); + ooffset = offset; + } + if(type == TYCHAR) + { + if( rdlong(&vchar) ) + prch( (int) vchar ); + else + fatal("bad intermediate file format"); + } + else if(type == TYBLANK) + { + if( rdlong(&nblank) ) + { + size = nblank; + while( --nblank >= 0) + prch( ' ' ); + } + else + fatal("bad intermediate file format"); + } + else + { + putc('\t', asmfile); + while ( putc( getc(sortfile), asmfile) != '\n') + ; + } + if( (ooffset += size) > ovlen) + { + erred = YES; + err("initialization out of bounds"); + } + } + +prspace(ovlen-ooffset); +totlen = doeven(totlen+ovlen, (ALIDOUBLE>SZLONG ? ALIDOUBLE : SZLONG) ); +clf(&sortfile); +clf(&asmfile); +clf(&sortfile); +rmf(sortfname); +return(erred); +} + + + + +prspace(n) +register ftnint n; +{ +register ftnint m; + +while(nch>0 && n>0) + { + --n; + prch(0); + } +m = SZSHORT * (n/SZSHORT); +if(m > 0) + prskip(asmfile, m); +for(n -= m ; n>0 ; --n) + prch(0); +} + + + + +ftnint doeven(tot, align) +register ftnint tot; +int align; +{ +ftnint new; +new = roundup(tot, align); +prspace(new - tot); +return(new); +} + + + +rdname(vargroupp, name) +int *vargroupp; +register char *name; +{ +register int i, c; + +if( (c = getc(sortfile)) == EOF) + return(NO); +*vargroupp = c - '0'; + +for(i = 0 ; i +#endif + +/* 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, comno, ovarno; +ftnint comoffset, offset, leng; +register struct Equivblock *p; +register struct Eqvchain *q; +struct Primblock *itemp; +register struct Nameblock *np; +expptr offp, suboffset(); +int ns, nsubs(); +chainp cp; + +for(i = 0 ; i < nequiv ; ++i) + { + p = &eqvclass[i]; + p->eqvbottom = p->eqvtop = 0; + comno = -1; + + for(q = p->equivs ; q ; q = q->nextp) + { + itemp = q->eqvitem; + vardcl(np = itemp->namep); + if(itemp->argsp || itemp->fcharp) + { + if(np->vdim!=NULL && np->vdim->ndim>1 && + nsubs(itemp->argsp)==1 ) + { + if(! ftn66flag) + warn("1-dim subscript in EQUIVALENCE"); + cp = NULL; + ns = np->vdim->ndim; + while(--ns > 0) + cp = mkchain( ICON(1), cp); + itemp->argsp->listp->nextp = cp; + } + offp = suboffset(itemp); + } + else offp = ICON(0); + if(ISICON(offp)) + offset = q->eqvoffset = offp->constblock.const.ci; + else { + dclerr("nonconstant subscript in equivalence ", np); + np = NULL; + goto endit; + } + if( (leng = iarrlen(np)) < 0) + { + dclerr("adjustable in equivalence", np); + np = NULL; + goto endit; + } + p->eqvbottom = lmin(p->eqvbottom, -offset); + p->eqvtop = lmax(p->eqvtop, leng-offset); + + switch(np->vstg) + { + case STGUNKNOWN: + case STGBSS: + case STGEQUIV: + break; + + case STGCOMMON: + comno = np->vardesc.varno; + comoffset = np->voffset + offset; + break; + + default: + dclerr("bad storage class in equivalence", np); + np = NULL; + goto endit; + } + endit: + frexpr(offp); + q->eqvitem = np; + } + + if(comno >= 0) + eqvcommon(p, comno, comoffset); + else for(q = p->equivs ; q ; q = q->nextp) + { + if(np = q->eqvitem) + { + inequiv = NO; + if(np->vstg==STGEQUIV) + if( (ovarno = np->vardesc.varno) == i) + { + 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) + eqveqv(i, ovarno, q->eqvoffset + offset); + } + } + } + +for(i = 0 ; i < nequiv ; ++i) + { + p = & eqvclass[i]; + if(p->eqvbottom!=0 || p->eqvtop!=0) /* a live chain */ + { +#ifdef SDB + if(sdbflag) + prstab(NULL, N_BCOMM, 0, 0); +#endif + for(q = p->equivs ; q; q = q->nextp) + { + np = q->eqvitem; + np->voffset -= p->eqvbottom; + if(np->voffset % typealign[np->vtype] != 0) + dclerr("bad alignment forced by equivalence", np); +#ifdef SDB + if(sdbflag) + { + prstssym(np); + prstleng(np, iarrlen(np)); + } +#endif + } + p->eqvtop -= p->eqvbottom; + p->eqvbottom = 0; +#ifdef SDB + if(sdbflag) + prstab(NULL, N_ECOML, 0, memname(STGEQUIV,i) ); +#endif + } + freqchain(p); + } +} + + + + + +/* 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 struct Nameblock *np; +register struct Eqvchain *q; + +if(comoffset + p->eqvbottom < 0) + { + errstr("attempt to extend common %s backward", + nounder(XL, extsymtab[comno].extname) ); + freqchain(p); + return; + } + +if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) + extsymtab[comno].extleng = k; + +#ifdef SDB +if(sdbflag) + prstab( varstr(XL,extsymtab[comno].extname), N_BCOMM,0,0); +#endif + +for(q = p->equivs ; q ; q = q->nextp) + if(np = q->eqvitem) + { + switch(np->vstg) + { + case STGUNKNOWN: + case STGBSS: + np->vstg = STGCOMMON; + np->vardesc.varno = comno; + np->voffset = comoffset - q->eqvoffset; +#ifdef SDB + if(sdbflag) + { + prstssym(np); + prstleng(np, iarrlen(np)); + } +#endif + break; + + case STGEQUIV: + ovarno = np->vardesc.varno; + offq = comoffset - q->eqvoffset - np->voffset; + np->vstg = STGCOMMON; + np->vardesc.varno = comno; + np->voffset = comoffset - q->eqvoffset; + 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: + fatali("eqvcommon: impossible vstg %d", np->vstg); + } + } + +#ifdef SDB +if(sdbflag) + prstab( varstr(XL,extsymtab[comno].extname), N_ECOMM,0,0); +#endif + +freqchain(p); +p->eqvbottom = p->eqvtop = 0; +} + + +/* put all items on ovarno chain on 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 *p0, *p; +register struct Nameblock *np; +struct Eqvchain *q, *q1; + +p0 = eqvclass + nvarno; +p = eqvclass + ovarno; +p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta); +p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta); +p->eqvbottom = p->eqvtop = 0; + +for(q = p->equivs ; q ; q = q1) + { + q1 = q->nextp; + if( (np = q->eqvitem) && np->vardesc.varno==ovarno) + { + q->nextp = p0->equivs; + p0->equivs = q; + q->eqvoffset -= delta; + np->vardesc.varno = nvarno; + np->voffset -= delta; + } + else free(q); + } +p->equivs = NULL; +} + + + + +LOCAL freqchain(p) +register struct Equivblock *p; +{ +register struct Eqvchain *q, *oq; + +for(q = p->equivs ; q ; q = oq) + { + oq = q->nextp; + free(q); + } +p->equivs = NULL; +} + + + + + +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); +} diff --git a/usr/src/cmd/f77/error.c b/usr/src/cmd/f77/error.c new file mode 100644 index 0000000000..19cbf7592b --- /dev/null +++ b/usr/src/cmd/f77/error.c @@ -0,0 +1,140 @@ +#include "defs" + + +warn1(s,t) +char *s, *t; +{ +char buff[100]; +sprintf(buff, s, t); +warn(buff); +} + + +warn(s) +char *s; +{ +if(nowarnflag) + return; +fprintf(diagfile, "Warning on line %d of %s: %s\n", lineno, infname, s); +++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); +} + + +err(s) +char *s; +{ +fprintf(diagfile, "Error on line %d of %s: %s\n", lineno, infname, s); +++nerr; +} + + +yyerror(s) +char *s; +{ err(s); } + + + +dclerr(s, v) +char *s; +struct Nameblock *v; +{ +char buff[100]; + +if(v) + { + sprintf(buff, "Declaration error for %s: %s", varstr(VL, v->varname), 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 %d of %s: %s\n", lineno, infname, t); +if(debugflag) + abort(); +done(3); +exit(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); +} + + +many(s, c) +char *s, c; +{ +char buff[25]; + +sprintf(buff, "Too many %s. Try the -N%c option", s, c); +fatal(buff); +} + + +err66(s) +char *s; +{ +errstr("Fortran 77 feature used: %s", s); +} + + + +errext(s) +char *s; +{ +errstr("F77 compiler extension used: %s", s); +} diff --git a/usr/src/cmd/f77/exec.c b/usr/src/cmd/f77/exec.c new file mode 100644 index 0000000000..cd0078693e --- /dev/null +++ b/usr/src/cmd/f77/exec.c @@ -0,0 +1,556 @@ +#include "defs" + +/* Logical IF codes +*/ + + +exif(p) +expptr p; +{ +pushctl(CTLIF); +ctlstack->elselabel = newlabel(); +putif(p, ctlstack->elselabel); +} + + + +exelif(p) +expptr p; +{ +if(ctlstack->ctltype == CTLIF) + { + if(ctlstack->endlabel == 0) + ctlstack->endlabel = newlabel(); + putgoto(ctlstack->endlabel); + putlabel(ctlstack->elselabel); + ctlstack->elselabel = newlabel(); + putif(p, ctlstack->elselabel); + } + +else execerr("elseif out of place", 0); +} + + + + + +exelse() +{ +if(ctlstack->ctltype==CTLIF) + { + if(ctlstack->endlabel == 0) + ctlstack->endlabel = newlabel(); + putgoto( ctlstack->endlabel ); + putlabel(ctlstack->elselabel); + ctlstack->ctltype = CTLELSE; + } + +else execerr("else out of place", 0); +} + + +exendif() +{ +if(ctlstack->ctltype == CTLIF) + { + putlabel(ctlstack->elselabel); + if(ctlstack->endlabel) + putlabel(ctlstack->endlabel); + popctl(); + } +else if(ctlstack->ctltype == CTLELSE) + { + putlabel(ctlstack->endlabel); + popctl(); + } + +else + execerr("endif out of place", 0); +} + + + +LOCAL pushctl(code) +int code; +{ +register int i; + +if(++ctlstack >= lastctl) + many("loops or if-then-elses", 'c'); +ctlstack->ctltype = code; +for(i = 0 ; i < 4 ; ++i) + ctlstack->ctlabels[i] = 0; +++blklevel; +} + + +LOCAL popctl() +{ +if( ctlstack-- < ctls ) + fatal("control stack empty"); +--blklevel; +} + + + +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; +{ +putgoto(lab->labelno); +} + + + + + + + +exequals(lp, rp) +register struct Primblock *lp; +register expptr rp; +{ +if(lp->tag != TPRIM) + { + err("assignment to a non-variable"); + frexpr(lp); + frexpr(rp); + } +else if(lp->namep->vclass!=CLVAR && lp->argsp) + { + if(parstate >= INEXEC) + err("statement function amid executables"); + else + mkstfunct(lp, rp); + } +else + { + if(parstate < INDATA) + enddcl(); + puteq(mklhs(lp), rp); + } +} + + + +mkstfunct(lp, rp) +struct Primblock *lp; +expptr rp; +{ +register struct Primblock *p; +register struct Nameblock *np; +chainp args; + +np = lp->namep; +if(np->vclass == CLUNKNOWN) + np->vclass = CLPROC; +else + { + dclerr("redeclaration of statement function", np); + return; + } +np->vprocclass = PSTFUNCT; +np->vstg = STGSTFUNCT; +impldcl(np); +args = (lp->argsp ? lp->argsp->listp : NULL); +np->vardesc.vstfdesc = mkchain(args , rp ); + +for( ; args ; args = args->nextp) + if( (p = args->datap)->tag!=TPRIM || + p->argsp || p->fcharp || p->lcharp) + err("non-variable argument in statement function definition"); + else + { + vardcl(args->datap = p->namep); + free(p); + } +} + + + +excall(name, args, nstars, labels) +struct Hashentry *name; +struct Listblock *args; +int nstars; +struct Labelblock *labels[ ]; +{ +register expptr p; + +settype(name, TYSUBR, NULL); +p = mkfunct( mkprim(name, args, NULL, NULL) ); +p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT; +if(nstars > 0) + putcmgo(p, nstars, labels); +else putexpr(p); +} + + + +exstop(stop, p) +int stop; +register expptr p; +{ +char *q; +int n; +struct Constblock *mkstrcon(); + +if(p) + { + if( ! ISCONST(p) ) + { + execerr("pause/stop argument must be constant", 0); + frexpr(p); + p = mkstrcon(0, 0); + } + else if( ISINT(p->constblock.vtype) ) + { + q = convic(p->constblock.const.ci); + n = strlen(q); + if(n > 0) + { + p->constblock.const.ccp = copyn(n, q); + p->constblock.vtype = TYCHAR; + p->constblock.vleng = ICON(n); + } + else + p = mkstrcon(0, 0); + } + else if(p->constblock.vtype != TYCHAR) + { + execerr("pause/stop argument must be integer or string", 0); + p = mkstrcon(0, 0); + } + } +else p = mkstrcon(0, 0); + +putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) ); +} + +/* DO LOOP CODE */ + +#define DOINIT par[0] +#define DOLIMIT par[1] +#define DOINCR par[2] + +#define VARSTEP 0 +#define POSSTEP 1 +#define NEGSTEP 2 + + +exdo(range, spec) +int range; +chainp spec; +{ +register expptr p, q; +expptr *q1; +register struct Nameblock *np; +chainp cp; +register int i; +int dotype, incsign; +struct Addrblock *dovarp, *dostgp; +expptr par[3]; + +pushctl(CTLDO); +dorange = ctlstack->dolabel = range; +np = spec->datap; +ctlstack->donamep = NULL; +if(np->vdovar) + { + errstr("nested loops with variable %s", varstr(VL,np->varname)); + ctlstack->donamep = NULL; + return; + } + +dovarp = mklhs( mkprim(np, 0,0,0) ); +if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) ) + { + err("bad type on do variable"); + return; + } +ctlstack->donamep = np; + +np->vdovar = YES; +if( enregister(np) ) + { + /* stgp points to a storage version, varp to a register version */ + dostgp = dovarp; + dovarp = mklhs( mkprim(np, 0,0,0) ); + } +else + dostgp = NULL; +dotype = dovarp->vtype; + +for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp) + { + p = par[i++] = fixtype(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 = ICON(1); + + case 3: + break; + } + +ctlstack->endlabel = newlabel(); +ctlstack->dobodylabel = newlabel(); + +if( ISCONST(DOLIMIT) ) + ctlstack->domax = mkconv(dotype, DOLIMIT); +else + ctlstack->domax = mktemp(dotype, NULL); + +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 = mktemp(dotype, NULL); + ctlstack->dostepsign = VARSTEP; + ctlstack->doposlabel = newlabel(); + ctlstack->doneglabel = newlabel(); + } + +if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP) + { + puteq(cpexpr(dovarp), cpexpr(DOINIT)); + if( onetripflag ) + frexpr(DOINIT); + else + { + q = mkexpr(OPPLUS, ICON(1), + mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) ); + if(incsign != conssgn(q)) + { + warn("DO range never executed"); + putgoto(ctlstack->endlabel); + } + frexpr(q); + } + } +else if(ctlstack->dostepsign!=VARSTEP && !onetripflag) + { + if( ISCONST(ctlstack->domax) ) + q = cpexpr(ctlstack->domax); + else + q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT); + + q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT); + q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q); + putif(q, ctlstack->endlabel); + } +else + { + if(! ISCONST(ctlstack->domax) ) + puteq( cpexpr(ctlstack->domax), DOLIMIT); + q = DOINIT; + if( ! onetripflag ) + q = mkexpr(OPMINUS, q, + mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) ); + puteq( cpexpr(dovarp), q); + if(onetripflag && ctlstack->dostepsign==VARSTEP) + puteq( cpexpr(ctlstack->dostep), DOINCR); + } + +if(ctlstack->dostepsign == VARSTEP) + { + if(onetripflag) + putgoto(ctlstack->dobodylabel); + else + putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)), + ctlstack->doneglabel ); + putlabel(ctlstack->doposlabel); + putif( mkexpr(OPLE, + mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)), + cpexpr(ctlstack->domax) ), + ctlstack->endlabel); + } +putlabel(ctlstack->dobodylabel); +if(dostgp) + puteq(dostgp, cpexpr(dovarp)); +frexpr(dovarp); +} + + + +enddo(here) +int here; +{ +register struct Ctlframe *q; +register expptr t; +struct Nameblock *np; +struct Addrblock *ap; +register int i; + +while(here == dorange) + { + if(np = ctlstack->donamep) + { + t = mkexpr(OPPLUSEQ, mklhs(mkprim(ctlstack->donamep, 0,0,0)), + cpexpr(ctlstack->dostep) ); + + if(ctlstack->dostepsign == VARSTEP) + { + putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel); + putlabel(ctlstack->doneglabel); + putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel); + } + else + putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT), + t, ctlstack->domax), + ctlstack->dobodylabel); + putlabel(ctlstack->endlabel); + if(ap = memversion(np)) + puteq(ap, mklhs( mkprim(np,0,0,0)) ); + for(i = 0 ; i < 4 ; ++i) + ctlstack->ctlabels[i] = 0; + deregister(ctlstack->donamep); + ctlstack->donamep->vdovar = NO; + frexpr(ctlstack->dostep); + } + + popctl(); + poplab(); + dorange = 0; + for(q = ctlstack ; q>=ctls ; --q) + if(q->ctltype == CTLDO) + { + dorange = q->dolabel; + break; + } + } +} + +exassign(vname, labelval) +struct Nameblock *vname; +struct Labelblock *labelval; +{ +struct Addrblock *p; +struct Constblock *mkaddcon(); + +p = mklhs(mkprim(vname,0,0,0)); +if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) + err("noninteger assign variable"); +else + puteq(p, mkaddcon(labelval->labelno) ); +} + + + +exarif(expr, neglab, zerlab, poslab) +expptr expr; +struct Labelblock *neglab, *zerlab, *poslab; +{ +register int lm, lz, lp; + +lm = neglab->labelno; +lz = zerlab->labelno; +lp = poslab->labelno; +expr = fixtype(expr); + +if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) + { + err("invalid type of arithmetic if expression"); + frexpr(expr); + } +else + { + if(lm == lz) + exar2(OPLE, expr, lm, lp); + else if(lm == lp) + exar2(OPNE, expr, lm, lz); + else if(lz == lp) + exar2(OPGE, expr, lz, lm); + else + prarif(expr, lm, lz, lp); + } +} + + + +LOCAL exar2(op, e, l1, l2) +int op; +expptr e; +int l1, l2; +{ +putif( mkexpr(op, e, ICON(0)), l2); +putgoto(l1); +} + + +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) + { + putforce(TYINT, p); + putgoto(retlabel); + } +else + putgoto(proctype==TYSUBR ? ret0label : retlabel); +} + + + +exasgoto(labvar) +struct Hashentry *labvar; +{ +register struct Addrblock *p; + +p = mklhs( mkprim(labvar,0,0,0) ); +if( ! ISINT(p->vtype) ) + err("assigned goto variable must be integer"); +else + putbranch(p); +} diff --git a/usr/src/cmd/f77/expr.c b/usr/src/cmd/f77/expr.c new file mode 100644 index 0000000000..4bfd1c0e88 --- /dev/null +++ b/usr/src/cmd/f77/expr.c @@ -0,0 +1,2250 @@ +#include "defs" + +/* little routines to create constant blocks */ + +struct Constblock *mkconst(t) +register int t; +{ +register struct Constblock *p; + +p = ALLOC(Constblock); +p->tag = TCONST; +p->vtype = t; +return(p); +} + + +struct Constblock *mklogcon(l) +register int l; +{ +register struct Constblock * p; + +p = mkconst(TYLOGICAL); +p->const.ci = l; +return(p); +} + + + +struct Constblock *mkintcon(l) +ftnint l; +{ +register struct Constblock *p; + +p = mkconst(TYLONG); +p->const.ci = l; +#ifdef MAXSHORT + if(l >= -MAXSHORT && l <= MAXSHORT) + p->vtype = TYSHORT; +#endif +return(p); +} + + + +struct Constblock *mkaddcon(l) +register int l; +{ +register struct Constblock *p; + +p = mkconst(TYADDR); +p->const.ci = l; +return(p); +} + + + +struct Constblock *mkrealcon(t, d) +register int t; +double d; +{ +register struct Constblock *p; + +p = mkconst(t); +p->const.cd[0] = d; +return(p); +} + + +struct Constblock *mkbitcon(shift, leng, s) +int shift; +int leng; +char *s; +{ +register struct Constblock *p; + +p = mkconst(TYUNKNOWN); +p->const.ci = 0; +while(--leng >= 0) + if(*s != ' ') + p->const.ci = (p->const.ci << shift) | hextoi(*s++); +return(p); +} + + + + + +struct Constblock *mkstrcon(l,v) +int l; +register char *v; +{ +register struct Constblock *p; +register char *s; + +p = mkconst(TYCHAR); +p->vleng = ICON(l); +p->const.ccp = s = (char *) ckalloc(l); +while(--l >= 0) + *s++ = *v++; +return(p); +} + + +struct Constblock *mkcxcon(realp,imagp) +register expptr realp, imagp; +{ +int rtype, itype; +register struct Constblock *p; + +rtype = realp->headblock.vtype; +itype = imagp->headblock.vtype; + +if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) + { + p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX ); + if( ISINT(rtype) ) + p->const.cd[0] = realp->constblock.const.ci; + else p->const.cd[0] = realp->constblock.const.cd[0]; + if( ISINT(itype) ) + p->const.cd[1] = imagp->constblock.const.ci; + else p->const.cd[1] = imagp->constblock.const.cd[0]; + } +else + { + err("invalid complex constant"); + p = errnode(); + } + +frexpr(realp); +frexpr(imagp); +return(p); +} + + +struct Errorblock *errnode() +{ +struct Errorblock *p; +p = ALLOC(Errorblock); +p->tag = TERROR; +p->vtype = TYERROR; +return(p); +} + + + + + +expptr mkconv(t, p) +register int t; +register expptr p; +{ +register expptr q; +register int pt; +expptr opconv(); + +if(t==TYUNKNOWN || t==TYERROR) + fatali("mkconv of impossible type %d", t); +pt = p->headblock.vtype; +if(t == pt) + return(p); + +else if( ISCONST(p) && pt!=TYADDR) + { + q = mkconst(t); + consconv(t, &(q->constblock.const), + p->constblock.vtype, &(p->constblock.const) ); + frexpr(p); + } +#if TARGET == PDP11 + else if(ISINT(t) && pt==TYCHAR) + { + q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255)); + if(t == TYLONG) + q = opconv(q, TYLONG); + } +#endif +else + q = opconv(p, t); + +if(t == TYCHAR) + q->constblock.vleng = ICON(1); +return(q); +} + + + +expptr opconv(p, t) +expptr p; +int t; +{ +register expptr q; + +q = mkexpr(OPCONV, p, 0); +q->headblock.vtype = t; +return(q); +} + + + +struct Exprblock *addrof(p) +expptr p; +{ +return( mkexpr(OPADDR, p, NULL) ); +} + + + +tagptr cpexpr(p) +register tagptr p; +{ +register tagptr e; +int tag; +register chainp ep, pp; +ptr cpblock(); + +static int blksize[ ] = + { 0, + sizeof(struct Nameblock), + sizeof(struct Constblock), + sizeof(struct Exprblock), + sizeof(struct Addrblock), + sizeof(struct Primblock), + sizeof(struct Listblock), + sizeof(struct Errorblock) + }; + +if(p == NULL) + return(NULL); + +if( (tag = p->headblock.tag) == TNAME) + return(p); + +e = cpblock( blksize[p->headblock.tag] , p); + +switch(tag) + { + case TCONST: + if(e->constblock.vtype == TYCHAR) + { + e->constblock.const.ccp = + copyn(1+strlen(e->constblock.const.ccp), + e->constblock.const.ccp); + e->constblock.vleng = cpexpr(e->constblock.vleng); + } + case TERROR: + break; + + case TEXPR: + e->exprblock.leftp = cpexpr(p->exprblock.leftp); + e->exprblock.rightp = cpexpr(p->exprblock.rightp); + break; + + case TLIST: + if(pp = p->listblock.listp) + { + ep = e->listblock.listp = mkchain( cpexpr(pp->datap), NULL); + for(pp = pp->nextp ; pp ; pp = pp->nextp) + ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL); + } + break; + + case TADDR: + e->addrblock.vleng = cpexpr(e->addrblock.vleng); + e->addrblock.memoffset = cpexpr(e->addrblock.memoffset); + e->addrblock.istemp = NO; + break; + + case TPRIM: + e->primblock.argsp = cpexpr(e->primblock.argsp); + e->primblock.fcharp = cpexpr(e->primblock.fcharp); + e->primblock.lcharp = cpexpr(e->primblock.lcharp); + break; + + default: + fatali("cpexpr: impossible tag %d", tag); + } + +return(e); +} + +frexpr(p) +register tagptr p; +{ +register chainp q; + +if(p == NULL) + return; + +switch(p->headblock.tag) + { + case TCONST: + if( ISCHAR(p) ) + { + free(p->constblock.const.ccp); + frexpr(p->constblock.vleng); + } + break; + + case TADDR: + if(p->addrblock.istemp) + { + frtemp(p); + return; + } + frexpr(p->addrblock.vleng); + frexpr(p->addrblock.memoffset); + break; + + case TERROR: + break; + + case TNAME: + return; + + case TPRIM: + frexpr(p->primblock.argsp); + frexpr(p->primblock.fcharp); + frexpr(p->primblock.lcharp); + break; + + case TEXPR: + frexpr(p->exprblock.leftp); + if(p->exprblock.rightp) + frexpr(p->exprblock.rightp); + break; + + case TLIST: + for(q = p->listblock.listp ; q ; q = q->nextp) + frexpr(q->datap); + frchain( &(p->listblock.listp) ); + break; + + default: + fatali("frexpr: impossible tag %d", p->headblock.tag); + } + +free(p); +} + +/* fix up types in expression; replace subtrees and convert + names to address blocks */ + +expptr fixtype(p) +register tagptr p; +{ + +if(p == 0) + return(0); + +switch(p->headblock.tag) + { + case TCONST: + if( ! ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR) ) + p = putconst(p); + return(p); + + case TADDR: + p->addrblock.memoffset = fixtype(p->addrblock.memoffset); + return(p); + + case TERROR: + return(p); + + default: + fatali("fixtype: impossible tag %d", p->headblock.tag); + + case TEXPR: + return( fixexpr(p) ); + + case TLIST: + return( p ); + + case TPRIM: + if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) + return( mkfunct(p) ); + else return( mklhs(p) ); + } +} + + + + + +/* special case tree transformations and cleanups of expression trees */ + +expptr fixexpr(p) +register struct Exprblock *p; +{ +expptr lp; +register expptr rp; +register expptr q; +int opcode, ltype, rtype, ptype, mtype; +expptr mkpower(); + +if(p->tag == TERROR) + return(p); +else if(p->tag != TEXPR) + fatali("fixexpr: invalid tag %d", p->tag); +opcode = p->opcode; +lp = p->leftp = fixtype(p->leftp); +ltype = lp->headblock.vtype; +if(opcode==OPASSIGN && lp->headblock.tag!=TADDR) + { + err("left side of assignment must be variable"); + frexpr(p); + return( errnode() ); + } + +if(p->rightp) + { + rp = p->rightp = fixtype(p->rightp); + rtype = rp->headblock.vtype; + } +else + { + rp = NULL; + rtype = 0; + } + +/* force folding if possible */ +if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) + { + q = mkexpr(opcode, lp, rp); + if( ISCONST(q) ) + return(q); + free(q); /* constants did not fold */ + } + +if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) + { + frexpr(p); + return( errnode() ); + } + +switch(opcode) + { + case OPCONCAT: + if(p->vleng == NULL) + p->vleng = mkexpr(OPPLUS, + cpexpr(lp->headblock.vleng), + cpexpr(rp->headblock.vleng) ); + break; + + case OPASSIGN: + case OPPLUSEQ: + case OPSTAREQ: + if(ltype == rtype) + break; + if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) + break; + if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) + break; + if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) +#if FAMILY==PCC + && typesize[ltype]>=typesize[rtype] ) +#else + && typesize[ltype]==typesize[rtype] ) +#endif + break; + p->rightp = fixtype( mkconv(ptype, rp) ); + break; + + case OPSLASH: + if( ISCOMPLEX(rtype) ) + { + p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div", + mkconv(ptype, lp), mkconv(ptype, rp) ); + break; + } + case OPPLUS: + case OPMINUS: + case OPSTAR: + case OPMOD: + if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || + (rtype==TYREAL && ! ISCONST(rp) ) )) + break; + if( ISCOMPLEX(ptype) ) + break; + if(ltype != ptype) + p->leftp = fixtype(mkconv(ptype,lp)); + if(rtype != ptype) + p->rightp = fixtype(mkconv(ptype,rp)); + break; + + case OPPOWER: + return( mkpower(p) ); + + case OPLT: + case OPLE: + case OPGT: + case OPGE: + case OPEQ: + case OPNE: + if(ltype == rtype) + break; + mtype = cktype(OPMINUS, ltype, rtype); + if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) || + (rtype==TYREAL && ! ISCONST(rp)) )) + break; + if( ISCOMPLEX(mtype) ) + break; + if(ltype != mtype) + p->leftp = fixtype(mkconv(mtype,lp)); + if(rtype != mtype) + p->rightp = fixtype(mkconv(mtype,rp)); + break; + + + case OPCONV: + ptype = cktype(OPCONV, p->vtype, ltype); + if(lp->headblock.tag==TEXPR && lp->exprblock.opcode==OPCOMMA) + { + lp->exprblock.rightp = fixtype( mkconv(ptype, lp->exprblock.rightp) ); + free(p); + p = lp; + } + break; + + case OPADDR: + if(lp->headblock.tag==TEXPR && lp->exprblock.opcode==OPADDR) + fatal("addr of addr"); + break; + + case OPCOMMA: + case OPQUEST: + case OPCOLON: + break; + + case OPMIN: + case OPMAX: + ptype = p->vtype; + break; + + default: + break; + } + +p->vtype = ptype; +return(p); +} + +#if SZINT < SZLONG +/* + for efficient subscripting, replace long ints by shorts + in easy places +*/ + +expptr shorten(p) +register expptr p; +{ +register expptr q; + +if(p->headblock.vtype != TYLONG) + return(p); + +switch(p->headblock.tag) + { + case TERROR: + case TLIST: + return(p); + + case TCONST: + case TADDR: + return( mkconv(TYINT,p) ); + + case TEXPR: + break; + + default: + fatali("shorten: invalid tag %d", p->headblock.tag); + } + +switch(p->exprblock.opcode) + { + case OPPLUS: + case OPMINUS: + case OPSTAR: + q = shorten( cpexpr(p->exprblock.rightp) ); + if(q->headblock.vtype == TYINT) + { + p->exprblock.leftp = shorten(p->exprblock.leftp); + if(p->exprblock.leftp->headblock.vtype == TYLONG) + frexpr(q); + else + { + frexpr(p->exprblock.rightp); + p->exprblock.rightp = q; + p->exprblock.vtype = TYINT; + } + } + break; + + case OPNEG: + p->exprblock.leftp = shorten(p->exprblock.leftp); + if(p->exprblock.leftp->headblock.vtype == TYINT) + p->exprblock.vtype = TYINT; + break; + + case OPCALL: + case OPCCALL: + p = mkconv(TYINT,p); + break; + default: + break; + } + +return(p); +} +#endif + +fixargs(doput, p0) +int doput; +struct Listblock *p0; +{ +register chainp p; +register tagptr q, t; +register int qtag; +int nargs; +struct Addrblock *mkscalar(); + +nargs = 0; +if(p0) + for(p = p0->listp ; p ; p = p->nextp) + { + ++nargs; + q = p->datap; + qtag = q->headblock.tag; + if(qtag == TCONST) + { + if(q->constblock.vtype == TYSHORT) + q = mkconv(tyint, q); + if(doput) + p->datap = putconst(q); + else + p->datap = q; + } + else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vclass==CLPROC) + p->datap = mkaddr(q->primblock.namep); + else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vdim!=NULL) + p->datap = mkscalar(q->primblock.namep); + else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vdovar && + (t = memversion(q->primblock.namep)) ) + p->datap = fixtype(t); + else p->datap = fixtype(q); + } +return(nargs); +} + + +struct Addrblock *mkscalar(np) +register struct Nameblock *np; +{ +register struct Addrblock *ap; +register struct Dimblock *dp; + +vardcl(np); +ap = mkaddr(np); + +#if TARGET == VAX + /* on the VAX, prolog causes array arguments + to point at the (0,...,0) element, except when + subscript checking is on + */ + if( !checksubs && np->vstg==STGARG) + { + dp = np->vdim; + frexpr(ap->memoffset); + ap->memoffset = mkexpr(OPSTAR, + (np->vtype==TYCHAR ? + cpexpr(np->vleng) : + (tagptr)ICON(typesize[np->vtype]) ), + cpexpr(dp->baseoffset) ); + } +#endif +return(ap); +} + + + + + +expptr mkfunct(p) +register struct Primblock * p; +{ +struct Entrypoint *ep; +struct Addrblock *ap; +struct Extsym *extp; +register struct Nameblock *np; +register struct Exprblock *q; +struct Exprblock *intrcall(), *stfcall(); +int k, nargs; +int class; + +np = p->namep; +class = np->vclass; + +if(class == CLUNKNOWN) + { + np->vclass = class = CLPROC; + if(np->vstg == STGUNKNOWN) + { + if(k = intrfunct(np->varname)) + { + np->vstg = STGINTR; + np->vardesc.varno = k; + np->vprocclass = PINTRINSIC; + } + else + { + extp = mkext( varunder(VL,np->varname) ); + extp->extstg = STGEXT; + np->vstg = STGEXT; + np->vardesc.varno = extp - extsymtab; + np->vprocclass = PEXTERNAL; + } + } + else if(np->vstg==STGARG) + { + if(np->vtype!=TYCHAR && !ftn66flag) + warn("Dummy procedure not declared EXTERNAL. Code may be wrong."); + np->vprocclass = PEXTERNAL; + } + } + +if(class != CLPROC) + fatali("invalid class code %d for function", class); +if(p->fcharp || p->lcharp) + { + err("no substring of function call"); + goto error; + } +impldcl(np); +nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); + +switch(np->vprocclass) + { + case PEXTERNAL: + ap = mkaddr(np); + call: + q = mkexpr(OPCALL, ap, p->argsp); + if( (q->vtype = np->vtype) == TYUNKNOWN) + { + err("attempt to use untyped function"); + goto error; + } + if(np->vleng) + q->vleng = cpexpr(np->vleng); + break; + + case PINTRINSIC: + q = intrcall(np, p->argsp, nargs); + break; + + case PSTFUNCT: + q = stfcall(np, p->argsp); + break; + + case PTHISPROC: + warn("recursive call"); + for(ep = entries ; ep ; ep = ep->nextp) + if(ep->enamep == np) + break; + if(ep == NULL) + fatal("mkfunct: impossible recursion"); + ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) ); + goto call; + + default: + fatali("mkfunct: impossible vprocclass %d", np->vprocclass); + } +free(p); +return(q); + +error: + frexpr(p); + return( errnode() ); +} + + + +LOCAL struct Exprblock *stfcall(np, actlist) +struct Nameblock *np; +struct Listblock *actlist; +{ +register chainp actuals; +int nargs; +chainp oactp, formals; +int type; +struct Exprblock *q, *rhs; +expptr ap; +register struct Rplblock *rp; +struct Rplblock *tlist; + +if(actlist) + { + actuals = actlist->listp; + free(actlist); + } +else + actuals = NULL; +oactp = actuals; + +nargs = 0; +tlist = NULL; +if( (type = np->vtype) == TYUNKNOWN) + { + err("attempt to use untyped statement function"); + q = errnode(); + goto ret; + } +formals = np->vardesc.vstfdesc->datap; +rhs = np->vardesc.vstfdesc->nextp; + +/* copy actual arguments into temporaries */ +while(actuals!=NULL && formals!=NULL) + { + rp = ALLOC(Rplblock); + rp->rplnp = q = formals->datap; + ap = fixtype(actuals->datap); + if(q->vtype==ap->headblock.vtype && q->vtype!=TYCHAR + && (ap->headblock.tag==TCONST || ap->headblock.tag==TADDR) ) + { + rp->rplvp = ap; + rp->rplxp = NULL; + rp->rpltag = ap->headblock.tag; + } + else { + rp->rplvp = mktemp(q->vtype, q->vleng); + rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) ); + if( (rp->rpltag = rp->rplxp->tag) == TERROR) + err("disagreement of argument types in statement function call"); + } + rp->nextp = tlist; + tlist = rp; + actuals = actuals->nextp; + formals = formals->nextp; + ++nargs; + } + +if(actuals!=NULL || formals!=NULL) + err("statement function definition and argument list differ"); + +/* + now push down names involved in formal argument list, then + evaluate rhs of statement function definition in this environment +*/ +rpllist = hookup(tlist, rpllist); +q = mkconv(type, fixtype(cpexpr(rhs)) ); + +/* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ +while(--nargs >= 0) + { + if(rpllist->rplxp) + q = mkexpr(OPCOMMA, rpllist->rplxp, q); + rp = rpllist->nextp; + frexpr(rpllist->rplvp); + free(rpllist); + rpllist = rp; + } + +ret: + frchain( &oactp ); + return(q); +} + + + + +struct Addrblock *mklhs(p) +register struct Primblock * p; +{ +register struct Addrblock *s; +expptr suboffset(); +struct Nameblock *np; +register struct Rplblock *rp; +int regn; + +/* first fixup name */ + +if(p->tag != TPRIM) + return(p); +np = p->namep; + +/* is name on the replace list? */ + +for(rp = rpllist ; rp ; rp = rp->nextp) + { + if(np == rp->rplnp) + { + if(rp->rpltag == TNAME) + { + np = p->namep = rp->rplvp; + break; + } + else return( cpexpr(rp->rplvp) ); + } + } + +/* is variable a DO index in a register ? */ + +if(np->vdovar && ( (regn = inregister(np)) >= 0) ) + if(np->vtype == TYERROR) + return( errnode() ); + else + { + s = ALLOC(Addrblock); + s->tag = TADDR; + s->vstg = STGREG; + s->vtype = TYIREG; + s->memno = regn; + s->memoffset = ICON(0); + return(s); + } + +vardcl(np); +s = mkaddr(np); +s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) ); +frexpr(p->argsp); +p->argsp = NULL; + +/* now do substring part */ + +if(p->fcharp || p->lcharp) + { + if(np->vtype != TYCHAR) + errstr("substring of noncharacter %s", varstr(VL,np->varname)); + else { + if(p->lcharp == NULL) + p->lcharp = cpexpr(s->vleng); + if(p->fcharp) + s->vleng = mkexpr(OPMINUS, p->lcharp, + mkexpr(OPMINUS, p->fcharp, ICON(1) )); + else { + frexpr(s->vleng); + s->vleng = p->lcharp; + } + } + } + +s->vleng = fixtype( s->vleng ); +s->memoffset = fixtype( s->memoffset ); +free(p); +return(s); +} + + + + + +deregister(np) +struct Nameblock *np; +{ +if(nregvar>0 && regnamep[nregvar-1]==np) + { + --nregvar; +#if FAMILY == DMR + putnreg(); +#endif + } +} + + + + +struct Addrblock *memversion(np) +register struct Nameblock *np; +{ +register struct Addrblock *s; + +if(np->vdovar==NO || (inregister(np)<0) ) + return(NULL); +np->vdovar = NO; +s = mklhs( mkprim(np, 0,0,0) ); +np->vdovar = YES; +return(s); +} + + + +inregister(np) +register struct Nameblock *np; +{ +register int i; + +for(i = 0 ; i < nregvar ; ++i) + if(regnamep[i] == np) + return( regnum[i] ); +return(-1); +} + + + + +enregister(np) +struct Nameblock *np; +{ +if( inregister(np) >= 0) + return(YES); +if(nregvar >= maxregvar) + return(NO); +vardcl(np); +if( ONEOF(np->vtype, MSKIREG) ) + { + regnamep[nregvar++] = np; + if(nregvar > highregvar) + highregvar = nregvar; +#if FAMILY == DMR + putnreg(); +#endif + return(YES); + } +else + return(NO); +} + + + + +expptr suboffset(p) +register struct Primblock *p; +{ +int n; +expptr size; +chainp cp; +expptr offp, prod; +expptr subcheck(); +struct Dimblock *dimp; +expptr sub[MAXDIM+1]; +register struct Nameblock *np; + +np = p->namep; +offp = ICON(0); +n = 0; +if(p->argsp) + for(cp = p->argsp->listp ; cp ; cp = cp->nextp) + { + sub[n++] = fixtype(cpexpr(cp->datap)); + if(n > maxdim) + { + erri("more than %d subscripts", maxdim); + break; + } + } + +dimp = np->vdim; +if(n>0 && dimp==NULL) + err("subscripts on scalar variable"); +else if(dimp && dimp->ndim!=n) + errstr("wrong number of subscripts on %s", + varstr(VL, np->varname) ); +else if(n > 0) + { + prod = sub[--n]; + while( --n >= 0) + prod = mkexpr(OPPLUS, sub[n], + mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); +#if TARGET == VAX + if(checksubs || np->vstg!=STGARG) + prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); +#else + prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); +#endif + if(checksubs) + prod = subcheck(np, prod); + if(np->vtype == TYCHAR) + size = cpexpr(np->vleng); + else size = ICON( typesize[np->vtype] ); + prod = mkexpr(OPSTAR, prod, size); + offp = mkexpr(OPPLUS, offp, prod); + } + +if(p->fcharp && np->vtype==TYCHAR) + offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) )); + +return(offp); +} + + + + +expptr subcheck(np, p) +struct Nameblock *np; +register expptr p; +{ +struct Dimblock *dimp; +expptr t, checkvar, checkcond, badcall; + +dimp = np->vdim; +if(dimp->nelt == NULL) + return(p); /* don't check arrays with * bounds */ +checkvar = NULL; +checkcond = NULL; +if( ISICON(p) ) + { + if(p->constblock.const.ci < 0) + goto badsub; + if( ISICON(dimp->nelt) ) + if(p->constblock.const.ci < dimp->nelt->constblock.const.ci) + return(p); + else + goto badsub; + } +if(p->headblock.tag==TADDR && p->addrblock.vstg==STGREG) + { + checkvar = cpexpr(p); + t = p; + } +else { + checkvar = mktemp(p->headblock.vtype, NULL); + t = mkexpr(OPASSIGN, cpexpr(checkvar), p); + } +checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); +if( ! ISICON(p) ) + checkcond = mkexpr(OPAND, checkcond, + mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); + +badcall = call4(p->headblock.vtype, "s_rnge", mkstrcon(VL, np->varname), + mkconv(TYLONG, cpexpr(checkvar)), + mkstrcon(XL, procname), ICON(lineno)); +badcall->exprblock.opcode = OPCCALL; +p = mkexpr(OPQUEST, checkcond, + mkexpr(OPCOLON, checkvar, badcall)); + +return(p); + +badsub: + frexpr(p); + errstr("subscript on variable %s out of range", varstr(VL,np->varname)); + return ( ICON(0) ); +} + + + + +struct Addrblock *mkaddr(p) +register struct Nameblock *p; +{ +struct Extsym *extp; +register struct Addrblock *t; +struct Addrblock *intraddr(); + +switch( p->vstg) + { + case STGUNKNOWN: + if(p->vclass != CLPROC) + break; + extp = mkext( varunder(VL, p->varname) ); + extp->extstg = STGEXT; + p->vstg = STGEXT; + p->vardesc.varno = extp - extsymtab; + p->vprocclass = PEXTERNAL; + + case STGCOMMON: + case STGEXT: + case STGBSS: + case STGINIT: + case STGEQUIV: + case STGARG: + case STGLENG: + case STGAUTO: + t = ALLOC(Addrblock); + t->tag = TADDR; + if(p->vclass==CLPROC && p->vprocclass==PTHISPROC) + t->vclass = CLVAR; + else + t->vclass = p->vclass; + t->vtype = p->vtype; + t->vstg = p->vstg; + t->memno = p->vardesc.varno; + t->memoffset = ICON(p->voffset); + if(p->vleng) + t->vleng = cpexpr(p->vleng); + return(t); + + case STGINTR: + return( intraddr(p) ); + + } +/*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass); +fatali("mkaddr: impossible storage tag %d", p->vstg); +/* NOTREACHED */ +} + + + + +mkarg(type, argno) +int type, argno; +{ +register struct Addrblock *p; + +p = ALLOC(Addrblock); +p->tag = TADDR; +p->vtype = type; +p->vclass = CLVAR; +p->vstg = (type==TYLENG ? STGLENG : STGARG); +p->memno = argno; +return(p); +} + + + + +tagptr mkprim(v, args, lstr, rstr) +register union + { + struct Paramblock paramblock; + struct Nameblock nameblock; + struct Headblock headblock; + } *v; +struct Listblock *args; +expptr lstr, rstr; +{ +register struct Primblock *p; + +if(v->headblock.vclass == CLPARAM) + { + if(args || lstr || rstr) + { + errstr("no qualifiers on parameter name %s", + varstr(VL,v->paramblock.varname)); + frexpr(args); + frexpr(lstr); + frexpr(rstr); + frexpr(v); + return( errnode() ); + } + return( cpexpr(v->paramblock.paramval) ); + } + +p = ALLOC(Primblock); +p->tag = TPRIM; +p->vtype = v->nameblock.vtype; +p->namep = v; +p->argsp = args; +p->fcharp = lstr; +p->lcharp = rstr; +return(p); +} + + + +vardcl(v) +register struct Nameblock *v; +{ +int nelt; +struct Dimblock *t; +struct Addrblock *p; +expptr neltp; + +if(v->vdcldone) return; + +if(v->vtype == TYUNKNOWN) + impldcl(v); +if(v->vclass == CLUNKNOWN) + v->vclass = CLVAR; +else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) + { + dclerr("used as variable", v); + return; + } +if(v->vstg==STGUNKNOWN) + v->vstg = implstg[ letter(v->varname[0]) ]; + +switch(v->vstg) + { + case STGBSS: + v->vardesc.varno = ++lastvarno; + break; + case STGAUTO: + if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) + break; + nelt = 1; + if(t = v->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) + nelt = neltp->constblock.const.ci; + else + dclerr("adjustable automatic array", v); + p = autovar(nelt, v->vtype, v->vleng); + v->voffset = p->memoffset->constblock.const.ci; + frexpr(p); + break; + + default: + break; + } +v->vdcldone = YES; +} + + + + +impldcl(p) +register struct Nameblock *p; +{ +register int k; +int type, leng; + +if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) + return; +if(p->vtype == TYUNKNOWN) + { + k = letter(p->varname[0]); + type = impltype[ k ]; + leng = implleng[ k ]; + if(type == TYUNKNOWN) + { + if(p->vclass == CLPROC) + return; + dclerr("attempt to use undefined variable", p); + type = TYERROR; + leng = 1; + } + settype(p, type, leng); + } +} + + + + +LOCAL letter(c) +register int c; +{ +if( isupper(c) ) + c = tolower(c); +return(c - 'a'); +} + +#define ICONEQ(z, c) (ISICON(z) && z->constblock.const.ci==c) +#define COMMUTE { e = lp; lp = rp; rp = e; } + + +expptr mkexpr(opcode, lp, rp) +int opcode; +register expptr lp, rp; +{ +register struct Exprblock *e, *e1; +int etype; +int ltype, rtype; +int ltag, rtag; +expptr fold(); + +ltype = lp->headblock.vtype; +ltag = lp->headblock.tag; +if(rp && opcode!=OPCALL && opcode!=OPCCALL) + { + rtype = rp->headblock.vtype; + rtag = rp->headblock.tag; + } +else rtype = 0; + +etype = cktype(opcode, ltype, rtype); +if(etype == TYERROR) + goto error; + +switch(opcode) + { + /* check for multiplication by 0 and 1 and addition to 0 */ + + case OPSTAR: + if( ISCONST(lp) ) + COMMUTE + + if( ISICON(rp) ) + { + if(rp->constblock.const.ci == 0) + goto retright; + goto mulop; + } + break; + + case OPSLASH: + case OPMOD: + if( ICONEQ(rp, 0) ) + { + err("attempted division by zero"); + rp = ICON(1); + break; + } + if(opcode == OPMOD) + break; + + + mulop: + if( ISICON(rp) ) + { + if(rp->constblock.const.ci == 1) + goto retleft; + + if(rp->constblock.const.ci == -1) + { + frexpr(rp); + return( mkexpr(OPNEG, lp, 0) ); + } + } + + if( ISSTAROP(lp) && ISICON(lp->exprblock.rightp) ) + { + if(opcode == OPSTAR) + e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); + else if(ISICON(rp) && + (lp->exprblock.rightp->constblock.const.ci % + rp->constblock.const.ci) == 0) + e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); + else break; + + e1 = lp->exprblock.leftp; + free(lp); + return( mkexpr(OPSTAR, e1, e) ); + } + break; + + + case OPPLUS: + if( ISCONST(lp) ) + COMMUTE + goto addop; + + case OPMINUS: + if( ICONEQ(lp, 0) ) + { + frexpr(lp); + return( mkexpr(OPNEG, rp, 0) ); + } + + if( ISCONST(rp) ) + { + opcode = OPPLUS; + consnegop(rp); + } + + addop: + if( ISICON(rp) ) + { + if(rp->constblock.const.ci == 0) + goto retleft; + if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) + { + e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); + e1 = lp->exprblock.leftp; + free(lp); + return( mkexpr(OPPLUS, e1, e) ); + } + } + break; + + + case OPPOWER: + break; + + case OPNEG: + if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) + { + e = lp->exprblock.leftp; + free(lp); + return(e); + } + break; + + case OPNOT: + if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) + { + e = lp->exprblock.leftp; + free(lp); + return(e); + } + break; + + case OPCALL: + case OPCCALL: + etype = ltype; + if(rp!=NULL && rp->listblock.listp==NULL) + { + free(rp); + rp = NULL; + } + break; + + case OPAND: + case OPOR: + if( ISCONST(lp) ) + COMMUTE + + if( ISCONST(rp) ) + { + if(rp->constblock.const.ci == 0) + if(opcode == OPOR) + goto retleft; + else + goto retright; + else if(opcode == OPOR) + goto retright; + else + goto retleft; + } + case OPEQV: + case OPNEQV: + + case OPBITAND: + case OPBITOR: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + + case OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + + case OPCONCAT: + break; + case OPMIN: + case OPMAX: + + case OPASSIGN: + case OPPLUSEQ: + case OPSTAREQ: + + case OPCONV: + case OPADDR: + + case OPCOMMA: + case OPQUEST: + case OPCOLON: + break; + + default: + fatali("mkexpr: impossible opcode %d", opcode); + } + +e = ALLOC(Exprblock); +e->tag = TEXPR; +e->opcode = opcode; +e->vtype = etype; +e->leftp = lp; +e->rightp = rp; +if(ltag==TCONST && (rp==0 || rtag==TCONST) ) + e = fold(e); +return(e); + +retleft: + frexpr(rp); + return(lp); + +retright: + frexpr(lp); + return(rp); + +error: + frexpr(lp); + if(rp && opcode!=OPCALL && opcode!=OPCCALL) + frexpr(rp); + return( errnode() ); +} + +#define ERR(s) { errs = s; goto error; } + +cktype(op, lt, rt) +register int op, lt, rt; +{ +char *errs; + +if(lt==TYERROR || rt==TYERROR) + goto error1; + +if(lt==TYUNKNOWN) + return(TYUNKNOWN); +if(rt==TYUNKNOWN) + if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR) + return(TYUNKNOWN); + +switch(op) + { + case OPPLUS: + case OPMINUS: + case OPSTAR: + case OPSLASH: + case OPPOWER: + case OPMOD: + if( ISNUMERIC(lt) && ISNUMERIC(rt) ) + return( maxtype(lt, rt) ); + ERR("nonarithmetic operand of arithmetic operator") + + case OPNEG: + if( ISNUMERIC(lt) ) + return(lt); + ERR("nonarithmetic operand of negation") + + case OPNOT: + if(lt == TYLOGICAL) + return(TYLOGICAL); + ERR("NOT of nonlogical") + + case OPAND: + case OPOR: + case OPEQV: + case OPNEQV: + if(lt==TYLOGICAL && rt==TYLOGICAL) + return(TYLOGICAL); + ERR("nonlogical operand of logical operator") + + case OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) + { + if(lt != rt) + ERR("illegal comparison") + } + + else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) + { + if(op!=OPEQ && op!=OPNE) + ERR("order comparison of complex data") + } + + else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) + ERR("comparison of nonarithmetic data") + return(TYLOGICAL); + + case OPCONCAT: + if(lt==TYCHAR && rt==TYCHAR) + return(TYCHAR); + ERR("concatenation of nonchar data") + + case OPCALL: + case OPCCALL: + return(lt); + + case OPADDR: + return(TYADDR); + + case OPCONV: + if(rt == 0) + return(0); + if(lt==TYCHAR && ISINT(rt) ) + return(TYCHAR); + case OPASSIGN: + case OPPLUSEQ: + case OPSTAREQ: + if( ISINT(lt) && rt==TYCHAR) + return(lt); + if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) + if(op!=OPASSIGN || lt!=rt) + { +/* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */ +/* debug fatal("impossible conversion. possible compiler bug"); */ + ERR("impossible conversion") + } + return(lt); + + case OPMIN: + case OPMAX: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + return(lt); + + case OPCOMMA: + case OPQUEST: + case OPCOLON: + return(rt); + + default: + fatali("cktype: impossible opcode %d", op); + } +error: err(errs); +error1: return(TYERROR); +} + +LOCAL expptr fold(e) +register struct Exprblock *e; +{ +struct Constblock *p; +#ifdef VERSION6 + expptr lp, rp; +#else + register expptr lp, rp; +#endif +int etype, mtype, ltype, rtype, opcode; +int i, ll, lr; +char *q, *s; +union Constant lcon, rcon; + +opcode = e->opcode; +etype = e->vtype; + +lp = e->leftp; +ltype = lp->headblock.vtype; +rp = e->rightp; + +if(rp == 0) + switch(opcode) + { + case OPNOT: + lp->constblock.const.ci = ! lp->constblock.const.ci; + return(lp); + + case OPBITNOT: + lp->constblock.const.ci = ~ lp->constblock.const.ci; + return(lp); + + case OPNEG: + consnegop(lp); + return(lp); + + case OPCONV: + case OPADDR: + return(e); + + default: + fatali("fold: invalid unary operator %d", opcode); + } + +rtype = rp->headblock.vtype; + +p = ALLOC(Constblock); +p->tag = TCONST; +p->vtype = etype; +p->vleng = e->vleng; + +switch(opcode) + { + case OPCOMMA: + case OPQUEST: + case OPCOLON: + return(e); + + case OPAND: + p->const.ci = lp->constblock.const.ci && + rp->constblock.const.ci; + break; + + case OPOR: + p->const.ci = lp->constblock.const.ci || + rp->constblock.const.ci; + break; + + case OPEQV: + p->const.ci = lp->constblock.const.ci == + rp->constblock.const.ci; + break; + + case OPNEQV: + p->const.ci = lp->constblock.const.ci != + rp->constblock.const.ci; + break; + + case OPBITAND: + p->const.ci = lp->constblock.const.ci & + rp->constblock.const.ci; + break; + + case OPBITOR: + p->const.ci = lp->constblock.const.ci | + rp->constblock.const.ci; + break; + + case OPBITXOR: + p->const.ci = lp->constblock.const.ci ^ + rp->constblock.const.ci; + break; + + case OPLSHIFT: + p->const.ci = lp->constblock.const.ci << + rp->constblock.const.ci; + break; + + case OPRSHIFT: + p->const.ci = lp->constblock.const.ci >> + rp->constblock.const.ci; + break; + + case OPCONCAT: + ll = lp->constblock.vleng->constblock.const.ci; + lr = rp->constblock.vleng->constblock.const.ci; + p->const.ccp = q = (char *) ckalloc(ll+lr); + p->vleng = ICON(ll+lr); + s = lp->constblock.const.ccp; + for(i = 0 ; i < ll ; ++i) + *q++ = *s++; + s = rp->constblock.const.ccp; + for(i = 0; i < lr; ++i) + *q++ = *s++; + break; + + + case OPPOWER: + if( ! ISINT(rtype) ) + return(e); + conspower(&(p->const), lp, rp->constblock.const.ci); + break; + + + default: + if(ltype == TYCHAR) + { + lcon.ci = cmpstr(lp->constblock.const.ccp, + rp->constblock.const.ccp, + lp->constblock.vleng->constblock.const.ci, + rp->constblock.vleng->constblock.const.ci); + rcon.ci = 0; + mtype = tyint; + } + else { + mtype = maxtype(ltype, rtype); + consconv(mtype, &lcon, ltype, &(lp->constblock.const) ); + consconv(mtype, &rcon, rtype, &(rp->constblock.const) ); + } + consbinop(opcode, mtype, &(p->const), &lcon, &rcon); + break; + } + +frexpr(e); +return(p); +} + + + +/* assign constant l = r , doing coercion */ + +consconv(lt, lv, rt, rv) +int lt, rt; +register union Constant *lv, *rv; +{ +switch(lt) + { + case TYCHAR: + *(lv->ccp = ckalloc(1)) = rv->ci; + break; + + case TYSHORT: + case TYLONG: + if(rt == TYCHAR) + lv->ci = rv->ccp[0]; + else if( ISINT(rt) ) + lv->ci = rv->ci; + else lv->ci = rv->cd[0]; + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + switch(rt) + { + case TYSHORT: + case TYLONG: + /* fall through and do real assignment of + first element + */ + case TYREAL: + case TYDREAL: + lv->cd[1] = 0; break; + case TYCOMPLEX: + case TYDCOMPLEX: + lv->cd[1] = rv->cd[1]; break; + } + + case TYREAL: + case TYDREAL: + if( ISINT(rt) ) + lv->cd[0] = rv->ci; + else lv->cd[0] = rv->cd[0]; + break; + + case TYLOGICAL: + lv->ci = rv->ci; + break; + } +} + + + +consnegop(p) +register struct Constblock *p; +{ +switch(p->vtype) + { + case TYSHORT: + case TYLONG: + p->const.ci = - p->const.ci; + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + p->const.cd[1] = - p->const.cd[1]; + /* fall through and do the real parts */ + case TYREAL: + case TYDREAL: + p->const.cd[0] = - p->const.cd[0]; + break; + default: + fatali("consnegop: impossible type %d", p->vtype); + } +} + + + +LOCAL conspower(powp, ap, n) +register union Constant *powp; +struct Constblock *ap; +ftnint n; +{ +register int type; +union Constant x; + +switch(type = ap->vtype) /* pow = 1 */ + { + case TYSHORT: + case TYLONG: + powp->ci = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + powp->cd[1] = 0; + case TYREAL: + case TYDREAL: + powp->cd[0] = 1; + break; + default: + fatali("conspower: invalid type %d", type); + } + +if(n == 0) + return; +if(n < 0) + { + if( ISINT(type) ) + { + err("integer ** negative power "); + return; + } + n = - n; + consbinop(OPSLASH, type, &x, powp, &(ap->const)); + } +else + consbinop(OPSTAR, type, &x, powp, &(ap->const)); + +for( ; ; ) + { + if(n & 01) + consbinop(OPSTAR, type, powp, powp, &x); + if(n >>= 1) + consbinop(OPSTAR, type, &x, &x, &x); + else + break; + } +} + + + +/* do constant operation cp = a op b */ + + +LOCAL consbinop(opcode, type, cp, ap, bp) +int opcode, type; +register union Constant *ap, *bp, *cp; +{ +int k; +double temp; + +switch(opcode) + { + case OPPLUS: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci + bp->ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ap->cd[1] + bp->cd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ap->cd[0] + bp->cd[0]; + break; + } + break; + + case OPMINUS: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci - bp->ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ap->cd[1] - bp->cd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ap->cd[0] - bp->cd[0]; + break; + } + break; + + case OPSTAR: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci * bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ap->cd[0] * bp->cd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + temp = ap->cd[0] * bp->cd[0] - + ap->cd[1] * bp->cd[1] ; + cp->cd[1] = ap->cd[0] * bp->cd[1] + + ap->cd[1] * bp->cd[0] ; + cp->cd[0] = temp; + break; + } + break; + case OPSLASH: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci / bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ap->cd[0] / bp->cd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + zdiv(cp,ap,bp); + break; + } + break; + + case OPMOD: + if( ISINT(type) ) + { + cp->ci = ap->ci % bp->ci; + break; + } + else + fatal("inline mod of noninteger"); + + default: /* relational ops */ + switch(type) + { + case TYSHORT: + case TYLONG: + if(ap->ci < bp->ci) + k = -1; + else if(ap->ci == bp->ci) + k = 0; + else k = 1; + break; + case TYREAL: + case TYDREAL: + if(ap->cd[0] < bp->cd[0]) + k = -1; + else if(ap->cd[0] == bp->cd[0]) + k = 0; + else k = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if(ap->cd[0] == bp->cd[0] && + ap->cd[1] == bp->cd[1] ) + k = 0; + else k = 1; + break; + } + + switch(opcode) + { + case OPEQ: + cp->ci = (k == 0); + break; + case OPNE: + cp->ci = (k != 0); + break; + case OPGT: + cp->ci = (k == 1); + break; + case OPLT: + cp->ci = (k == -1); + break; + case OPGE: + cp->ci = (k >= 0); + break; + case OPLE: + cp->ci = (k <= 0); + break; + } + break; + } +} + + + + +conssgn(p) +register expptr p; +{ +if( ! ISCONST(p) ) + fatal( "sgn(nonconstant)" ); + +switch(p->headblock.vtype) + { + case TYSHORT: + case TYLONG: + if(p->constblock.const.ci > 0) return(1); + if(p->constblock.const.ci < 0) return(-1); + return(0); + + case TYREAL: + case TYDREAL: + if(p->constblock.const.cd[0] > 0) return(1); + if(p->constblock.const.cd[0] < 0) return(-1); + return(0); + + case TYCOMPLEX: + case TYDCOMPLEX: + return(p->constblock.const.cd[0]!=0 || p->constblock.const.cd[1]!=0); + + default: + fatali( "conssgn(type %d)", p->constblock.vtype); + } +/* NOTREACHED */ +} + +char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" }; + + +LOCAL expptr mkpower(p) +register struct Exprblock *p; +{ +register expptr q, lp, rp; +int ltype, rtype, mtype; + +lp = p->leftp; +rp = p->rightp; +ltype = lp->headblock.vtype; +rtype = rp->headblock.vtype; + +if(ISICON(rp)) + { + if(rp->constblock.const.ci == 0) + { + frexpr(p); + if( ISINT(ltype) ) + return( ICON(1) ); + else + return( putconst( mkconv(ltype, ICON(1))) ); + } + if(rp->constblock.const.ci < 0) + { + if( ISINT(ltype) ) + { + frexpr(p); + err("integer**negative"); + return( errnode() ); + } + rp->constblock.const.ci = - rp->constblock.const.ci; + p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp)); + } + if(rp->constblock.const.ci == 1) + { + frexpr(rp); + free(p); + return(lp); + } + + if( ONEOF(ltype, MSKINT|MSKREAL) ) + { + p->vtype = ltype; + return(p); + } + } +if( ISINT(rtype) ) + { + if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) + q = call2(TYSHORT, "pow_hh", lp, rp); + else { + if(ltype == TYSHORT) + { + ltype = TYLONG; + lp = mkconv(TYLONG,lp); + } + q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp)); + } + } +else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) + q = call2(mtype, "pow_dd", + mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); +else { + q = call2(TYDCOMPLEX, "pow_zz", + mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); + if(mtype == TYCOMPLEX) + q = mkconv(TYCOMPLEX, q); + } +free(p); +return(q); +} + + + +/* Complex Division. Same code as in Runtime Library +*/ + +struct dcomplex { double dreal, dimag; }; + + +LOCAL zdiv(c, a, b) +register struct dcomplex *a, *b, *c; +{ +double ratio, den; +double abr, abi; + +if( (abr = b->dreal) < 0.) + abr = - abr; +if( (abi = b->dimag) < 0.) + abi = - abi; +if( abr <= abi ) + { + if(abi == 0) + fatal("complex division by zero"); + ratio = b->dreal / b->dimag ; + den = b->dimag * (1 + ratio*ratio); + c->dreal = (a->dreal*ratio + a->dimag) / den; + c->dimag = (a->dimag*ratio - a->dreal) / den; + } + +else + { + ratio = b->dimag / b->dreal ; + den = b->dreal * (1 + ratio*ratio); + c->dreal = (a->dreal + a->dimag*ratio) / den; + c->dimag = (a->dimag - a->dreal*ratio) / den; + } + +} diff --git a/usr/src/cmd/f77/fio.h b/usr/src/cmd/f77/fio.h new file mode 100644 index 0000000000..1ebe1f44bc --- /dev/null +++ b/usr/src/cmd/f77/fio.h @@ -0,0 +1,101 @@ +#include +typedef long ftnint; +typedef ftnint flag; +typedef long ftnlen; +/*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; +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; + long uinode; + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag uprnt; + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; +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; + +extern int errno; +extern flag init; +extern cilist *elist; /*active external io list*/ +extern flag reading,external,sequential,formatted; +extern int (*getn)(),(*putn)(); /*for formatted io*/ +extern FILE *cf; /*current file*/ +extern unit *curunit; /*current unit*/ +extern unit units[]; +#define err(f,n,s) {if(f) errno= n; else fatal(n,s); return(n);} + +/*Table sizes*/ +#define MXUNIT 10 + +extern int recpos; /*position in current record*/ diff --git a/usr/src/cmd/f77/ftypes b/usr/src/cmd/f77/ftypes new file mode 100644 index 0000000000..17e53a580c --- /dev/null +++ b/usr/src/cmd/f77/ftypes @@ -0,0 +1,22 @@ + +/* variable types + * 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 NTYPES (TYERROR+1) +#define TYBLANK TYSUBR diff --git a/usr/src/cmd/f77/gram.c b/usr/src/cmd/f77/gram.c new file mode 100644 index 0000000000..bff12ad4c4 --- /dev/null +++ b/usr/src/cmd/f77/gram.c @@ -0,0 +1,1600 @@ +# define SEOS 1 +# define SCOMMENT 2 +# define SLABEL 3 +# define SUNKNOWN 4 +# define SHOLLERITH 5 +# define SICON 6 +# define SRCON 7 +# define SDCON 8 +# define SBITCON 9 +# define SOCTCON 10 +# define SHEXCON 11 +# define STRUE 12 +# define SFALSE 13 +# define SNAME 14 +# define SNAMEEQ 15 +# define SFIELD 16 +# define SSCALE 17 +# define SINCLUDE 18 +# define SLET 19 +# define SASSIGN 20 +# define SAUTOMATIC 21 +# define SBACKSPACE 22 +# define SBLOCK 23 +# define SCALL 24 +# define SCHARACTER 25 +# define SCLOSE 26 +# define SCOMMON 27 +# define SCOMPLEX 28 +# define SCONTINUE 29 +# define SDATA 30 +# define SDCOMPLEX 31 +# define SDIMENSION 32 +# define SDO 33 +# define SDOUBLE 34 +# define SELSE 35 +# define SELSEIF 36 +# define SEND 37 +# define SENDFILE 38 +# define SENDIF 39 +# define SENTRY 40 +# define SEQUIV 41 +# define SEXTERNAL 42 +# define SFORMAT 43 +# define SFUNCTION 44 +# define SGOTO 45 +# define SASGOTO 46 +# define SCOMPGOTO 47 +# define SARITHIF 48 +# define SLOGIF 49 +# define SIMPLICIT 50 +# define SINQUIRE 51 +# define SINTEGER 52 +# define SINTRINSIC 53 +# define SLOGICAL 54 +# define SOPEN 55 +# define SPARAM 56 +# define SPAUSE 57 +# define SPRINT 58 +# define SPROGRAM 59 +# define SPUNCH 60 +# define SREAD 61 +# define SREAL 62 +# define SRETURN 63 +# define SREWIND 64 +# define SSAVE 65 +# define SSTATIC 66 +# define SSTOP 67 +# define SSUBROUTINE 68 +# define STHEN 69 +# define STO 70 +# define SUNDEFINED 71 +# define SWRITE 72 +# define SLPAR 73 +# define SRPAR 74 +# define SEQUALS 75 +# define SCOLON 76 +# define SCOMMA 77 +# define SCURRENCY 78 +# define SPLUS 79 +# define SMINUS 80 +# define SSTAR 81 +# define SSLASH 82 +# define SPOWER 83 +# define SCONCAT 84 +# define SAND 85 +# define SOR 86 +# define SNEQV 87 +# define SEQV 88 +# define SNOT 89 +# define SEQ 90 +# define SLT 91 +# define SGT 92 +# define SLE 93 +# define SGE 94 +# define SNE 95 + +# line 97 "gram.in" +# include "defs" + +#ifdef SDB +# include +char *stabline(); +# ifdef UCBVAXASM + char *stabdline(); +# endif +#endif + +static int nstars; +static int ndim; +static int vartype; +static ftnint varleng; +static struct { ptr lb, ub; } dims[MAXDIM+1]; +static struct Labelblock *labarray[MAXLABLIST]; +static int lastwasbranch = NO; +static int thiswasbranch = NO; +extern ftnint yystno; + +ftnint convci(); +double convcd(); +struct Addrblock *nextdata(), *mkbitcon(); +struct Constblock *mklogcon(), *mkaddcon(), *mkrealcon(); +struct Constblock *mkstrcon(), *mkcxcon(); +struct Listblock *mklist(); +struct Listblock *mklist(); +struct Impldoblock *mkiodo(); +struct Extsym *comblock(); + +#define yyclearin yychar = -1 +#define yyerrok yyerrflag = 0 +extern int yychar; +extern short yyerrflag; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#ifndef YYSTYPE +#define YYSTYPE int +#endif +YYSTYPE yylval, yyval; +# define YYERRCODE 256 +short yyexca[] ={ +-1, 1, + 0, -1, + -2, 0, +-1, 20, + 1, 31, + -2, 205, +-1, 24, + 1, 35, + -2, 205, +-1, 144, + 1, 219, + -2, 170, +-1, 162, + 1, 238, + 77, 238, + -2, 170, +-1, 219, + 76, 156, + -2, 123, +-1, 233, + 73, 205, + -2, 202, +-1, 258, + 1, 257, + -2, 127, +-1, 262, + 1, 266, + 77, 266, + -2, 129, +-1, 324, + 76, 157, + -2, 125, +-1, 335, + 1, 240, + 14, 240, + 73, 240, + 77, 240, + -2, 171, +-1, 386, + 90, 0, + 91, 0, + 92, 0, + 93, 0, + 94, 0, + 95, 0, + -2, 137, +-1, 410, + 1, 260, + 77, 260, + -2, 127, +-1, 412, + 1, 262, + 77, 262, + -2, 127, +-1, 414, + 1, 264, + 77, 264, + -2, 127, +-1, 461, + 77, 260, + -2, 127, + }; +# define YYNPROD 271 +# define YYLAST 1253 +short yyact[]={ + + 209, 334, 228, 432, 431, 430, 333, 424, 375, 423, + 259, 253, 374, 240, 294, 280, 265, 260, 224, 277, + 182, 190, 178, 296, 110, 189, 5, 17, 115, 96, + 172, 200, 251, 193, 257, 114, 188, 113, 302, 186, + 429, 247, 122, 171, 112, 428, 100, 292, 100, 98, + 102, 300, 301, 302, 107, 152, 153, 154, 155, 245, + 246, 247, 150, 151, 100, 124, 125, 126, 127, 468, + 129, 287, 261, 149, 466, 149, 286, 156, 157, 300, + 301, 302, 308, 307, 306, 305, 304, 123, 309, 311, + 310, 313, 312, 314, 206, 446, 492, 156, 157, 300, + 301, 302, 308, 307, 306, 305, 304, 208, 309, 311, + 310, 313, 312, 314, 114, 279, 113, 91, 199, 152, + 153, 154, 155, 227, 174, 175, 150, 151, 100, 156, + 157, 426, 92, 93, 94, 478, 173, 95, 403, 210, + 230, 232, 100, 477, 473, 211, 149, 181, 407, 244, + 149, 489, 100, 156, 157, 245, 246, 247, 248, 444, + 149, 97, 445, 217, 220, 216, 148, 215, 346, 212, + 97, 149, 418, 156, 157, 245, 246, 247, 248, 417, + 147, 416, 147, 347, 266, 267, 268, 227, 222, 421, + 143, 380, 422, 156, 157, 226, 203, 271, 272, 283, + 264, 255, 409, 210, 299, 252, 274, 273, 225, 229, + 229, 282, 275, 176, 404, 493, 397, 403, 288, 279, + 394, 291, 322, 290, 377, 372, 299, 378, 330, 367, + 299, 361, 368, 320, 362, 336, 328, 244, 337, 329, + 149, 353, 352, 351, 256, 149, 149, 149, 149, 149, + 244, 244, 196, 147, 205, 165, 108, 147, 106, 262, + 262, 105, 299, 332, 158, 160, 164, 147, 104, 103, + 244, 101, 395, 379, 355, 298, 218, 316, 147, 4, + 483, 356, 318, 319, 482, 348, 357, 358, 349, 350, + 360, 321, 324, 219, 327, 380, 359, 481, 474, 299, + 316, 480, 475, 366, 331, 470, 396, 392, 454, 371, + 402, 281, 236, 179, 289, 339, 249, 299, 234, 299, + 299, 231, 299, 363, 238, 299, 250, 221, 299, 219, + 187, 202, 299, 198, 159, 135, 316, 269, 149, 244, + 299, 100, 244, 244, 244, 244, 244, 147, 400, 100, + 326, 405, 147, 147, 147, 147, 147, 451, 262, 408, + 335, 376, 411, 413, 415, 156, 157, 245, 246, 247, + 248, 433, 382, 383, 384, 385, 386, 387, 388, 389, + 390, 391, 420, 299, 299, 299, 299, 299, 299, 299, + 299, 299, 299, 447, 371, 201, 442, 144, 453, 162, + 255, 456, 225, 419, 131, 458, 338, 244, 192, 457, + 100, 341, 342, 343, 344, 345, 197, 89, 29, 258, + 258, 408, 6, 99, 242, 237, 299, 411, 413, 415, + 433, 111, 465, 460, 459, 467, 78, 469, 425, 77, + 462, 463, 464, 76, 75, 147, 262, 262, 262, 299, + 117, 299, 448, 450, 161, 472, 299, 476, 471, 317, + 156, 157, 300, 301, 302, 434, 74, 73, 229, 433, + 455, 72, 487, 486, 484, 57, 50, 223, 437, 490, + 299, 48, 317, 46, 45, 42, 299, 449, 31, 299, + 303, 325, 491, 323, 494, 425, 99, 99, 99, 99, + 195, 177, 373, 194, 406, 365, 180, 207, 183, 184, + 185, 262, 262, 262, 364, 435, 370, 369, 354, 156, + 157, 245, 246, 247, 434, 128, 284, 229, 52, 183, + 213, 214, 479, 35, 293, 109, 25, 437, 24, 485, + 23, 437, 22, 21, 20, 233, 488, 235, 19, 276, + 130, 88, 9, 156, 157, 300, 301, 302, 308, 307, + 306, 8, 229, 434, 309, 311, 310, 313, 312, 314, + 152, 153, 154, 155, 7, 3, 437, 150, 151, 100, + 146, 99, 146, 2, 278, 1, 0, 0, 0, 0, + 152, 153, 154, 155, 0, 0, 0, 150, 151, 100, + 0, 111, 0, 295, 297, 0, 410, 412, 414, 0, + 0, 0, 0, 401, 0, 191, 0, 183, 156, 157, + 300, 301, 302, 308, 307, 306, 305, 304, 0, 309, + 311, 310, 313, 312, 314, 0, 191, 0, 227, 0, + 0, 0, 0, 0, 156, 157, 226, 0, 0, 452, + 0, 0, 0, 146, 210, 0, 0, 146, 227, 0, + 0, 0, 0, 0, 156, 157, 340, 146, 254, 0, + 0, 461, 412, 414, 210, 0, 0, 0, 146, 0, + 0, 0, 0, 152, 153, 154, 155, 183, 0, 0, + 150, 151, 100, 317, 0, 285, 399, 0, 0, 0, + 191, 156, 157, 300, 301, 302, 308, 307, 306, 305, + 304, 0, 309, 311, 310, 313, 312, 314, 0, 0, + 0, 156, 157, 300, 301, 302, 308, 307, 0, 0, + 0, 398, 309, 311, 310, 313, 312, 314, 156, 157, + 245, 246, 247, 248, 0, 0, 0, 146, 0, 0, + 0, 239, 146, 146, 146, 146, 146, 156, 157, 270, + 254, 0, 0, 254, 254, 0, 0, 278, 156, 157, + 300, 301, 302, 308, 0, 436, 0, 443, 0, 0, + 393, 0, 0, 295, 0, 156, 157, 300, 301, 302, + 308, 307, 306, 305, 304, 191, 309, 311, 310, 313, + 312, 314, 0, 0, 156, 157, 300, 301, 302, 308, + 0, 0, 0, 0, 443, 309, 311, 310, 313, 312, + 314, 443, 443, 443, 152, 153, 154, 155, 0, 0, + 0, 150, 151, 100, 436, 0, 0, 0, 436, 152, + 153, 154, 155, 0, 0, 146, 150, 151, 100, 243, + 0, 381, 0, 0, 0, 254, 156, 157, 300, 301, + 302, 308, 307, 306, 305, 304, 0, 309, 311, 310, + 313, 312, 314, 436, 0, 0, 427, 0, 0, 0, + 191, 152, 153, 154, 155, 0, 0, 0, 150, 151, + 100, 0, 227, 0, 0, 0, 0, 0, 156, 157, + 315, 0, 0, 0, 12, 0, 0, 239, 210, 0, + 0, 0, 0, 156, 157, 241, 0, 254, 10, 53, + 43, 70, 82, 14, 58, 67, 87, 36, 63, 44, + 40, 65, 69, 30, 64, 33, 32, 11, 84, 34, + 18, 39, 37, 27, 16, 54, 55, 56, 47, 51, + 41, 85, 61, 38, 66, 86, 28, 59, 81, 13, + 90, 79, 62, 49, 83, 26, 71, 60, 15, 0, + 0, 68, 80, 0, 0, 152, 153, 154, 155, 0, + 0, 0, 150, 151, 100, 0, 0, 0, 0, 0, + 0, 116, 0, 119, 120, 121, 0, 0, 0, 0, + 0, 0, 0, 0, 132, 133, 0, 0, 134, 0, + 136, 137, 138, 0, 0, 139, 140, 141, 0, 142, + 152, 153, 154, 155, 0, 0, 0, 150, 151, 100, + 0, 0, 0, 0, 0, 0, 0, 0, 166, 167, + 168, 169, 170, 227, 152, 153, 154, 155, 0, 156, + 157, 150, 151, 100, 0, 0, 0, 0, 0, 210, + 0, 152, 153, 154, 155, 441, 440, 439, 150, 151, + 100, 0, 0, 0, 0, 0, 152, 153, 154, 155, + 0, 0, 0, 150, 151, 100, 0, 0, 263, 0, + 0, 0, 0, 0, 156, 157, 0, 0, 0, 0, + 0, 0, 0, 0, 210, 0, 0, 152, 153, 154, + 155, 0, 204, 0, 150, 151, 100, 0, 156, 157, + 53, 43, 0, 82, 0, 58, 0, 87, 210, 438, + 44, 0, 0, 0, 0, 156, 157, 0, 0, 84, + 0, 0, 0, 0, 239, 0, 54, 55, 56, 47, + 156, 157, 85, 0, 0, 0, 86, 0, 59, 81, + 0, 0, 79, 0, 49, 83, 0, 0, 60, 0, + 118, 0, 0, 80, 0, 145, 0, 152, 153, 154, + 155, 156, 157, 163, 150, 151, 100, 70, 0, 0, + 0, 67, 0, 0, 63, 0, 0, 65, 69, 0, + 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 61, 0, + 66, 0, 0, 0, 0, 0, 0, 0, 62, 0, + 0, 0, 71, 0, 0, 0, 0, 68, 0, 0, + 0, 0, 0, 0, 0, 145, 0, 0, 0, 0, + 0, 156, 157 }; +short yypact[]={ + +-1000, 23, 421, 900,-1000,-1000,-1000,-1000,-1000,-1000, + 412,-1000,-1000,-1000,-1000,-1000,-1000, 93, 396, 194, + 192, 191, 184, 181, 84, 179, 32,-1000,-1000,-1000, +-1000,1101,-1000,-1000,-1000, 6,-1000,-1000,-1000,-1000, +-1000,-1000, 396,-1000,-1000,-1000,-1000,-1000, 262,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000,-1000,1172, 261,1102, 261, 178,-1000,-1000,-1000, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, +-1000, 396, 396, 396, 396,-1000, 396,-1000, 240,-1000, +-1000, 396, -47, 396, 396, 396, 257, 335,-1000, 175, +-1000,-1000,-1000,-1000, 402, 260, 389,-1000,-1000, 258, +-1000,-1000,-1000,1039, 32, 396, 396, 257, 335,-1000, + 201, 256, 389,-1000, 254, 114, 970, 970, 248, 389, + 396, 245, 396,-1000,-1000, 834,-1000,-1000, 659,1071, +-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, 834, + 128, 167,-1000,-1000,1015,1015,-1000,-1000,-1000,-1000, + 678,-1000,-1000,-1000, 240, 240, 396,-1000,-1000, 138, + 238, 84,-1000, 238,-1000,-1000,-1000, 396,-1000, -6, +-1000,-1000, 335,-1000, 241,1166, 32, -35, 396, 396, +-1000,-1000, 970, 18, 819,-1000,-1000,-1000,-1000, 970, + 970,-1000, 396,-1000,-1000,-1000,-1000,-1000, 970, 970, + 280, 970,-1000, 162,-1000, 18, 389, 970,-1000, 18, +-1000, 970,-1000, 84, 389,-1000, 286, 161,-1000,1071, +-1000,-1000, 585,-1000,1071,1071,1071,1071,1071, -42, + 94, 106, 327,-1000,-1000, 327, 327,-1000, 166, 165, + 164, 18,-1000,1015,-1000,-1000,-1000,-1000,-1000, 659, +-1000,-1000,-1000, 240, 238,-1000, 157,-1000,-1000,-1000, + 6,-1000, 396,-1000, 155,-1000,-1000, 335, 148, 347, +-1000,-1000,-1000, 150,-1000, 198,-1000, 116, 777, 970, + 970, 970, 970, 970, 970, 970, 970, 970, 970,-1000, +-1000,-1000,-1000,-1000,-1000, 233, 706, 143, -45, 725, +-1000, 18, 196, 232, 18, 139, 396, 622,-1000, 565, +-1000, 539, 237, 140,-1000,-1000,-1000, 834, 74, 18, +-1000, -22, -42, -42, -42, 440,-1000, 327, 106, 125, + 106,1015,1015,1015, 104, 102, 95,-1000,-1000,-1000, + 6,-1000, 34,-1000, 115, 50,-1000,-1000, 396, -37, +1056,-1000, 335, 85,-1000, 15,-1000,-1000, 396, 970, + 970, 288, -30, -45, -45, -45, 689, 474, 474, 642, + 725, 381,-1000,-1000, 970, 970, 235, 970,-1000, 389, +-1000,-1000, 389, 389, 84,-1000, 659,-1000,-1000, 327, +-1000,-1000,-1000,-1000,-1000,-1000,1015,1015,1015,-1000, +-1000,-1000, 50,-1000,-1000, -2,-1000,-1000,-1000,1056, +-1000,-1000, -12, 876,-1000,-1000,-1000,-1000, 970,-1000, +-1000,-1000, 231, 220,-1000, 347, 347,-1000, 18, 67, + 18,-1000, 224, 228, 970, 18, 66, 61,-1000, 970, + 227, 224, 223, 210, 206,-1000, 50,-1000,1056,-1000, +-1000,-1000,-1000, 970,-1000,-1000, 75, 389,-1000, 18, +-1000,-1000,-1000,-1000,-1000, 18,-1000,-1000, 18, 970, + 19, 141, 389,-1000,-1000 }; +short yypgo[]={ + + 0, 585, 583, 575, 574, 561, 552, 551, 960, 117, + 43, 30, 22, 27, 404, 549, 19, 548, 544, 543, + 542, 540, 538, 536, 535, 28, 534, 29, 15, 42, + 533, 528, 72, 20, 44, 39, 526, 507, 525, 36, + 25, 517, 516, 5, 4, 3, 0, 94, 515, 24, + 14, 21, 23, 514, 505, 9, 7, 6, 1, 31, + 33, 503, 502, 500, 12, 8, 493, 491, 254, 107, + 490, 2, 166, 324, 418, 488, 487, 485, 484, 483, + 481, 477, 476, 18, 475, 471, 190, 467, 466, 454, + 32, 444, 34, 443, 439, 16, 436, 425, 13, 424, + 11, 10, 17 }; +short yyr1[]={ + + 0, 1, 1, 2, 2, 2, 2, 2, 2, 2, + 3, 4, 4, 4, 4, 4, 4, 9, 11, 14, + 10, 10, 12, 12, 12, 15, 15, 16, 16, 7, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 17, 17, 13, 30, 31, 31, 31, 31, 31, + 31, 31, 31, 31, 31, 31, 29, 29, 29, 18, + 18, 18, 18, 34, 34, 19, 19, 20, 20, 21, + 21, 35, 36, 36, 22, 22, 38, 39, 42, 41, + 41, 43, 43, 44, 44, 44, 44, 24, 24, 49, + 49, 26, 26, 50, 33, 51, 51, 40, 40, 28, + 28, 54, 53, 53, 55, 55, 56, 56, 57, 57, + 58, 59, 23, 23, 60, 63, 61, 62, 62, 64, + 64, 65, 25, 66, 66, 67, 67, 32, 32, 32, + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, + 68, 68, 68, 68, 46, 46, 70, 70, 70, 70, + 70, 70, 37, 37, 37, 37, 71, 71, 45, 45, + 69, 69, 69, 69, 69, 69, 47, 48, 48, 48, + 72, 72, 73, 73, 73, 73, 73, 73, 73, 73, + 6, 6, 6, 6, 6, 6, 6, 75, 52, 74, + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, + 77, 78, 78, 78, 78, 27, 27, 80, 81, 81, + 83, 83, 82, 82, 76, 76, 8, 79, 84, 84, + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, + 85, 94, 94, 94, 87, 96, 96, 96, 89, 89, + 86, 86, 97, 97, 98, 98, 98, 98, 99, 88, + 91, 93, 93, 90, 90, 100, 100, 92, 92, 92, + 102, 102, 102, 102, 102, 102, 101, 101, 101, 101, + 95 }; +short yyr2[]={ + + 0, 0, 3, 2, 2, 2, 3, 3, 2, 1, + 1, 3, 3, 4, 4, 5, 3, 0, 1, 1, + 0, 1, 0, 2, 3, 1, 3, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, + 5, 6, 5, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 0, 2, 4, 3, + 4, 5, 3, 1, 3, 3, 3, 3, 3, 3, + 3, 3, 1, 3, 3, 3, 0, 4, 0, 2, + 3, 1, 3, 1, 2, 1, 1, 1, 3, 1, + 1, 1, 3, 3, 2, 1, 5, 1, 3, 0, + 3, 0, 2, 3, 1, 3, 1, 1, 1, 3, + 1, 1, 3, 3, 4, 0, 2, 1, 3, 1, + 3, 1, 0, 0, 1, 1, 3, 1, 3, 1, + 1, 1, 3, 3, 3, 3, 2, 3, 3, 3, + 3, 3, 2, 3, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 6, 4, 9, 0, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 5, 1, 1, 1, + 1, 3, 1, 1, 3, 3, 3, 3, 2, 3, + 1, 4, 2, 2, 6, 2, 2, 5, 3, 4, + 5, 2, 1, 1, 10, 1, 3, 4, 3, 3, + 1, 3, 3, 7, 7, 0, 1, 3, 1, 3, + 1, 2, 1, 1, 1, 3, 0, 1, 2, 2, + 2, 2, 2, 3, 4, 4, 2, 3, 1, 3, + 3, 1, 1, 1, 3, 1, 1, 1, 1, 1, + 3, 3, 1, 3, 1, 1, 2, 2, 1, 3, + 3, 4, 4, 1, 3, 1, 5, 1, 1, 1, + 3, 3, 3, 3, 3, 3, 1, 5, 5, 5, + 0 }; +short yychk[]={ + +-1000, -1, -2, -3, 256, 3, 1, -4, -5, -6, + 18, 37, 4, 59, 23, 68, 44, -13, 40, -17, + -18, -19, -20, -21, -22, -23, 65, 43, 56, -74, + 33, -75, 36, 35, 39, -30, 27, 42, 53, 41, + 30, 50, -77, 20, 29, -78, -79, 48, -80, 63, + -82, 49, -31, 19, 45, 46, 47, -84, 24, 57, + 67, 52, 62, 28, 34, 31, 54, 25, 71, 32, + 21, 66, -85, -87, -88, -91, -93, -94, -96, 61, + 72, 58, 22, 64, 38, 51, 55, 26, -7, 5, + -8, -9, -9, -9, -9, 44, -27, 77, -11, -14, + 14, 77, -27, 77, 77, 77, 77, -27, 77, -24, + -49, -14, -34, 84, 82, -25, -8, -74, 69, -8, + -8, -8, -29, 81, -25, -25, -25, -25, -38, -25, + -37, -14, -8, -8, -8, 73, -8, -8, -8, -8, + -8, -8, -8, -86, -73, 73, -37, -69, -72, -46, + 12, 13, 5, 6, 7, 8, 79, 80, -86, 73, + -86, -89, -73, 81, -86, 77, -8, -8, -8, -8, + -8, -10, -11, -10, -11, -11, -9, -14, -12, 73, + -14, -34, -33, -14, -14, -14, -35, 73, -39, -40, + -51, -37, 73, -60, -61, -63, 77, 14, 73, -58, + -59, 6, 73, -32, 73, -68, -47, -37, -69, -46, + 89, -33, -34, -14, -14, -35, -39, -60, 75, 73, + -59, 73, 74, -81, -83, -32, 81, 73, -71, -32, + -71, 73, -58, -14, 73, -14, -72, -97, -73, 73, + -98, 81, -99, 15, -46, 81, 82, 83, 84, -72, + -72, -90, 77,-100, -37, 73, 77, -92, -68,-101, +-102, -32, -47, 73, -92, -95, -95, -95, -95, -72, + 81, -12, -12, -11, -25, 74, -15, -16, -14, 81, + -28, 73, -27, -28, -36, -37, 82, 77, -40, 73, + -13, -49, 82, -26, -50, -14, -52, -14, -32, -46, + 81, 82, 83, -70, 88, 87, 86, 85, 84, 90, + 92, 91, 94, 93, 95, 81, -32, -68, -32, -32, + -33, -32, -71, -66, -32, -67, 70, -32, 74, 77, + -58, -32, -27, -57, -58, 74, 74, 77, -72, -32, + 81, -72, -72, -72, -72, -72, 74, 77, -90, -90, + -90, 77, 77, 77, -68,-101,-102, -95, -95, -12, + -28, 74, 77, -29, -53, -54, -33, 74, 77, -41, + -42, -51, 77, -62, -64, -65, 14, 74, 77, 75, + 75, 74, -32, -32, -32, -32, -32, -32, -32, -32, + -32, -32, 74, 74, 77, 76, 74, 77, -14, 74, + -83, 74, 73, 77, 74, -98, -72, 74,-100, 77, + -68,-101, -68,-101, -68,-101, 77, 77, 77, -29, + -16, 74, 77, -55, -56, -32, 81, -37, 82, 77, + -43, -44, -45, -46, -47, -48, -14, -69, 73, 11, + 10, 9, -52, -14, 74, 77, 80, -50, -32, -76, + -32, 69, -68, -71, 73, -32, -58, -57, -58, -27, + -52, -68, -52, -52, -52, -55, 76, -43, 81, -45, + 74, -64, -65, 77, 74, 74, -71, 77, 74, -32, + 74, 74, 74, 74, -56, -32, -44, -45, -32, 76, + -58, -71, 77, 74, -58 }; +short yydef[]={ + + 1, -2, 0, 0, 9, 10, 2, 3, 4, 5, + 0, 216, 8, 17, 17, 17, 17, 205, 0, 30, + -2, 32, 33, 34, -2, 36, 37, 39, 122, 180, + 216, 0, 216, 216, 216, 56, 122, 122, 122, 122, + 76, 122, 0, 216, 216, 192, 193, 216, 195, 216, + 216, 216, 44, 200, 216, 216, 216, 217, 216, 212, + 213, 45, 46, 47, 48, 49, 50, 51, 52, 53, + 54, 55, 0, 0, 0, 0, 228, 216, 216, 216, + 216, 216, 231, 232, 233, 235, 236, 237, 6, 29, + 7, 20, 20, 0, 0, 17, 0, 206, 22, 18, + 19, 0, 0, 206, 0, 0, 0, 0, 115, 38, + 87, 89, 90, 63, 0, 0, 0, 182, 183, 0, + 185, 186, 43, 0, 0, 0, 0, 0, 0, 115, + 0, 152, 0, 191, 0, 0, 156, 156, 0, 0, + 0, 0, 0, 218, -2, 0, 172, 173, 0, 0, + 160, 161, 162, 163, 164, 165, 144, 145, 220, 0, + 221, 222, -2, 239, 226, 0, 270, 270, 270, 270, + 0, 11, 21, 12, 22, 22, 0, 122, 16, 0, + 99, 205, 62, 99, 66, 68, 70, 0, 75, 0, + 97, 95, 0, 113, 0, 0, 0, 0, 0, 0, + 110, 111, 0, 57, 0, 127, 129, 130, 131, 0, + 0, 59, 0, 65, 67, 69, 74, 112, 0, -2, + 0, 0, 196, 0, 208, 210, 0, 0, 198, 157, + 199, 0, 201, -2, 0, 207, 244, 0, 170, 0, + 242, 245, 0, 248, 0, 0, 0, 0, 0, 178, + 244, 223, 0, 253, 255, 0, 0, 227, -2, 258, + 259, 0, -2, 0, 229, 230, 234, 249, 250, 270, + 270, 13, 14, 22, 99, 23, 0, 25, 27, 28, + 56, 101, 0, 94, 0, 72, 78, 0, 0, 0, + 116, 88, 64, 0, 91, 0, 181, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 146, + 147, 148, 149, 150, 151, 0, 0, 127, 136, 142, + 60, 189, 0, 0, -2, 124, 0, 0, 197, 0, + 211, 0, 0, 0, 108, -2, 241, 0, 0, 246, + 247, 174, 175, 176, 177, 179, 240, 0, 225, 0, + 224, 0, 0, 0, 127, 0, 0, 251, 252, 15, + 56, 24, 0, 42, 0, 0, 61, 71, 0, 0, + 0, 98, 0, 0, 117, 119, 121, 40, 0, 0, + 0, 0, 132, 133, 134, 135, -2, 138, 139, 140, + 141, 143, 58, 128, 0, 156, 154, 0, 190, 0, + 209, 187, 0, 0, 205, 243, 244, 171, 254, 0, + -2, 261, -2, 263, -2, 265, 0, 0, 0, 41, + 26, 100, 0, 102, 104, 107, 106, 73, 77, 0, + 79, 81, 83, 0, 85, 86, 158, 159, 0, 167, + 168, 169, 0, 152, 114, 0, 0, 92, 93, 188, + 214, 184, 127, 0, 156, 126, 0, 0, 109, 0, + 0, -2, 0, 0, 0, 103, 0, 80, 0, 84, + 96, 118, 120, 0, 166, 153, 0, 0, 203, 204, + 256, 267, 268, 269, 105, 107, 82, 83, 215, 156, + 0, 0, 0, 155, 194 }; +# +# define YYFLAG -1000 +# define YYERROR goto yyerrlab +# define YYACCEPT return(0) +# define YYABORT return(1) + +/* parser for yacc output */ + +#ifdef YYDEBUG +int yydebug = 0; /* 1 for debugging */ +#endif +YYSTYPE yyv[YYMAXDEPTH]; /* where the values are stored */ +int yychar = -1; /* current input token number */ +int yynerrs = 0; /* number of errors */ +short yyerrflag = 0; /* error recovery flag */ + +yyparse() { + + short yys[YYMAXDEPTH]; + short yyj, yym; + register YYSTYPE *yypvt; + register short yystate, *yyps, yyn; + register YYSTYPE *yypv; + register short *yyxi; + + yystate = 0; + yychar = -1; + yynerrs = 0; + yyerrflag = 0; + yyps= &yys[-1]; + yypv= &yyv[-1]; + + yystack: /* put a state and value onto the stack */ + +#ifdef YYDEBUG + if( yydebug ) printf( "state %d, char 0%o\n", yystate, yychar ); +#endif + if( ++yyps> &yys[YYMAXDEPTH] ) { yyerror( "yacc stack overflow" ); return(1); } + *yyps = yystate; + ++yypv; + *yypv = yyval; + + yynewstate: + + yyn = yypact[yystate]; + + if( yyn<= YYFLAG ) goto yydefault; /* simple state */ + + if( yychar<0 ) if( (yychar=yylex())<0 ) yychar=0; + if( (yyn += yychar)<0 || yyn >= YYLAST ) goto yydefault; + + if( yychk[ yyn=yyact[ yyn ] ] == yychar ){ /* valid shift */ + yychar = -1; + yyval = yylval; + yystate = yyn; + if( yyerrflag > 0 ) --yyerrflag; + goto yystack; + } + + yydefault: + /* default state action */ + + if( (yyn=yydef[yystate]) == -2 ) { + if( yychar<0 ) if( (yychar=yylex())<0 ) yychar = 0; + /* look through exception table */ + + for( yyxi=yyexca; (*yyxi!= (-1)) || (yyxi[1]!=yystate) ; yyxi += 2 ) ; /* VOID */ + + while( *(yyxi+=2) >= 0 ){ + if( *yyxi == yychar ) break; + } + if( (yyn = yyxi[1]) < 0 ) return(0); /* accept */ + } + + if( yyn == 0 ){ /* error */ + /* error ... attempt to resume parsing */ + + switch( yyerrflag ){ + + case 0: /* brand new error */ + + yyerror( "syntax error" ); + yyerrlab: + ++yynerrs; + + case 1: + case 2: /* incompletely recovered error ... try again */ + + yyerrflag = 3; + + /* find a state where "error" is a legal shift action */ + + while ( yyps >= yys ) { + yyn = yypact[*yyps] + YYERRCODE; + if( yyn>= 0 && yyn < YYLAST && yychk[yyact[yyn]] == YYERRCODE ){ + yystate = yyact[yyn]; /* simulate a shift of "error" */ + goto yystack; + } + yyn = yypact[*yyps]; + + /* the current yyps has no shift onn "error", pop stack */ + +#ifdef YYDEBUG + if( yydebug ) printf( "error recovery pops state %d, uncovers %d\n", *yyps, yyps[-1] ); +#endif + --yyps; + --yypv; + } + + /* there is no state on the stack with an error shift ... abort */ + + yyabort: + return(1); + + + case 3: /* no shift yet; clobber input char */ + +#ifdef YYDEBUG + if( yydebug ) printf( "error recovery discards char %d\n", yychar ); +#endif + + if( yychar == 0 ) goto yyabort; /* don't discard EOF, quit */ + yychar = -1; + goto yynewstate; /* try again in the same state */ + + } + + } + + /* reduction by production yyn */ + +#ifdef YYDEBUG + if( yydebug ) printf("reduce %d\n",yyn); +#endif + yyps -= yyr2[yyn]; + yypvt = yypv; + yypv -= yyr2[yyn]; + yyval = yypv[1]; + yym=yyn; + /* consult goto table to find next state */ + yyn = yyr1[yyn]; + yyj = yypgo[yyn] + *yyps + 1; + if( yyj>=YYLAST || yychk[ yystate = yyact[yyj] ] != -yyn ) yystate = yyact[yypgo[yyn]]; + switch(yym){ + +case 3: +# line 151 "gram.in" +{ lastwasbranch = NO; } break; +case 5: +# line 154 "gram.in" +{ if(yypvt[-1] && (yypvt[-1]->labelno==dorange)) + enddo(yypvt[-1]->labelno); + if(lastwasbranch && thislabel==NULL) + warn("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + if(yypvt[-1]) + { + if(yypvt[-1]->labtype == LABFORMAT) + err("label already that of a format"); + else + yypvt[-1]->labtype = LABEXEC; + } + } break; +case 6: +# line 169 "gram.in" +{ doinclude( yypvt[-0] ); } break; +case 7: +# line 171 "gram.in" +{ lastwasbranch = NO; endproc(); } break; +case 8: +# line 173 "gram.in" +{ execerr("unclassifiable statement", 0); flline(); } break; +case 9: +# line 175 "gram.in" +{ flline(); needkwd = NO; inioctl = NO; + yyerrok; yyclearin; } break; +case 10: +# line 180 "gram.in" +{ +#ifdef SDB + char buff[10]; + if( sdbflag ) + { +# ifdef UCBVAXASM + p2pass( stabdline(N_SLINE, lineno) ); +# else + sprintf(buff,"LL%d", ++dbglabel); + p2pass( stabline(0, N_SLINE, lineno, buff) ); + p2pi("LL%d:\n", dbglabel); +# endif + } +#endif + + if(yystno != 0) + { + yyval = thislabel = mklabel(yystno); + if( ! headerdone ) + puthead(NULL, procclass); + if(thislabel->labdefined) + execerr("label %s already defined", + convic(thislabel->stateno) ); + else { + if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=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) + putlabel(thislabel->labelno); + } + } + else yyval = thislabel = NULL; + } break; +case 11: +# line 219 "gram.in" +{startproc(yypvt[-0], CLMAIN); } break; +case 12: +# line 221 "gram.in" +{ if(yypvt[-0]) NO66("named BLOCKDATA"); + startproc(yypvt[-0], CLBLOCK); } break; +case 13: +# line 224 "gram.in" +{ entrypt(CLPROC, TYSUBR, (ftnint) 0, yypvt[-1], yypvt[-0]); } break; +case 14: +# line 226 "gram.in" +{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypvt[-1], yypvt[-0]); } break; +case 15: +# line 228 "gram.in" +{ entrypt(CLPROC, yypvt[-4], varleng, yypvt[-1], yypvt[-0]); } break; +case 16: +# line 230 "gram.in" +{ if(parstate==OUTSIDE || procclass==CLMAIN + || procclass==CLBLOCK) + execerr("misplaced entry statement", 0); + entrypt(CLENTRY, 0, (ftnint) 0, yypvt[-1], yypvt[-0]); + } break; +case 17: +# line 238 "gram.in" +{ newproc(); } break; +case 18: +# line 242 "gram.in" +{ yyval = newentry(yypvt[-0]); } break; +case 19: +# line 246 "gram.in" +{ yyval = mkname(toklen, token); } break; +case 20: +# line 249 "gram.in" +{ yyval = NULL; } break; +case 22: +# line 254 "gram.in" +{ yyval = 0; } break; +case 23: +# line 256 "gram.in" +{ NO66(" () argument list"); + yyval = 0; } break; +case 24: +# line 259 "gram.in" +{yyval = yypvt[-1]; } break; +case 25: +# line 263 "gram.in" +{ yyval = (yypvt[-0] ? mkchain(yypvt[-0],0) : 0 ); } break; +case 26: +# line 265 "gram.in" +{ if(yypvt[-0]) yypvt[-2] = yyval = hookup(yypvt[-2], mkchain(yypvt[-0],0)); } break; +case 27: +# line 269 "gram.in" +{ if(yypvt[-0]->vstg!=STGUNKNOWN && yypvt[-0]->vstg!=STGARG) + dclerr("name declared as argument after use", yypvt[-0]); + yypvt[-0]->vstg = STGARG; + } break; +case 28: +# line 274 "gram.in" +{ NO66("altenate return argument"); + yyval = 0; substars = YES; } break; +case 29: +# line 281 "gram.in" +{ + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + yyval = s; + } break; +case 37: +# line 296 "gram.in" +{ NO66("SAVE statement"); + saveall = YES; } break; +case 38: +# line 299 "gram.in" +{ NO66("SAVE statement"); } break; +case 39: +# line 301 "gram.in" +{ fmtstmt(thislabel); setfmt(thislabel); } break; +case 40: +# line 303 "gram.in" +{ NO66("PARAMETER statement"); } break; +case 41: +# line 307 "gram.in" +{ settype(yypvt[-3], yypvt[-5], yypvt[-0]); + if(ndim>0) setbound(yypvt[-3],ndim,dims); + } break; +case 42: +# line 311 "gram.in" +{ settype(yypvt[-2], yypvt[-4], yypvt[-0]); + if(ndim>0) setbound(yypvt[-2],ndim,dims); + } break; +case 43: +# line 317 "gram.in" +{ varleng = yypvt[-0]; } break; +case 44: +# line 321 "gram.in" +{ varleng = (yypvt[-0]<0 || yypvt[-0]==TYLONG ? 0 : typesize[yypvt[-0]]); } break; +case 45: +# line 324 "gram.in" +{ yyval = TYLONG; } break; +case 46: +# line 325 "gram.in" +{ yyval = TYREAL; } break; +case 47: +# line 326 "gram.in" +{ yyval = TYCOMPLEX; } break; +case 48: +# line 327 "gram.in" +{ yyval = TYDREAL; } break; +case 49: +# line 328 "gram.in" +{ NOEXT("DOUBLE COMPLEX statement"); yyval = TYDCOMPLEX; } break; +case 50: +# line 329 "gram.in" +{ yyval = TYLOGICAL; } break; +case 51: +# line 330 "gram.in" +{ NO66("CHARACTER statement"); yyval = TYCHAR; } break; +case 52: +# line 331 "gram.in" +{ yyval = TYUNKNOWN; } break; +case 53: +# line 332 "gram.in" +{ yyval = TYUNKNOWN; } break; +case 54: +# line 333 "gram.in" +{ NOEXT("AUTOMATIC statement"); yyval = - STGAUTO; } break; +case 55: +# line 334 "gram.in" +{ NOEXT("STATIC statement"); yyval = - STGBSS; } break; +case 56: +# line 338 "gram.in" +{ yyval = varleng; } break; +case 57: +# line 340 "gram.in" +{ + NO66("length specification *n"); + if( ! ISICON(yypvt[-0]) ) + { + yyval = 0; + dclerr("length must be an integer constant", 0); + } + else yyval = yypvt[-0]->const.ci; + } break; +case 58: +# line 350 "gram.in" +{ NO66("length specification *(*)"); yyval = 0; } break; +case 59: +# line 354 "gram.in" +{ incomm( yyval = comblock(0, 0) , yypvt[-0] ); } break; +case 60: +# line 356 "gram.in" +{ yyval = yypvt[-1]; incomm(yypvt[-1], yypvt[-0]); } break; +case 61: +# line 358 "gram.in" +{ yyval = yypvt[-2]; incomm(yypvt[-2], yypvt[-0]); } break; +case 62: +# line 360 "gram.in" +{ incomm(yypvt[-2], yypvt[-0]); } break; +case 63: +# line 364 "gram.in" +{ yyval = comblock(0, 0); } break; +case 64: +# line 366 "gram.in" +{ yyval = comblock(toklen, token); } break; +case 65: +# line 370 "gram.in" +{ setext(yypvt[-0]); } break; +case 66: +# line 372 "gram.in" +{ setext(yypvt[-0]); } break; +case 67: +# line 376 "gram.in" +{ NO66("INTRINSIC statement"); setintr(yypvt[-0]); } break; +case 68: +# line 378 "gram.in" +{ setintr(yypvt[-0]); } break; +case 71: +# line 386 "gram.in" +{ + struct Equivblock *p; + if(nequiv >= MAXEQUIV) + many("equivalences", 'q'); + p = & eqvclass[nequiv++]; + p->eqvinit = 0; + p->eqvbottom = 0; + p->eqvtop = 0; + p->equivs = yypvt[-1]; + } break; +case 72: +# line 399 "gram.in" +{ yyval = ALLOC(Eqvchain); yyval->eqvitem = yypvt[-0]; } break; +case 73: +# line 401 "gram.in" +{ yyval = ALLOC(Eqvchain); yyval->eqvitem = yypvt[-0]; yyval->nextp = yypvt[-2]; } break; +case 76: +# line 409 "gram.in" +{ if(parstate == OUTSIDE) + { + newproc(); + startproc(0, CLMAIN); + } + if(parstate < INDATA) + { + enddcl(); + parstate = INDATA; + } + } break; +case 77: +# line 423 "gram.in" +{ ftnint junk; + if(nextdata(&junk,&junk) != NULL) + { + err("too few initializers"); + curdtp = NULL; + } + frdata(yypvt[-3]); + frrpl(); + } break; +case 78: +# line 434 "gram.in" +{ toomanyinit = NO; } break; +case 81: +# line 439 "gram.in" +{ dataval(NULL, yypvt[-0]); } break; +case 82: +# line 441 "gram.in" +{ dataval(yypvt[-2], yypvt[-0]); } break; +case 84: +# line 446 "gram.in" +{ if( yypvt[-1]==OPMINUS && ISCONST(yypvt[-0]) ) + consnegop(yypvt[-0]); + yyval = yypvt[-0]; + } break; +case 89: +# line 459 "gram.in" +{ int k; + yypvt[-0]->vsave = 1; + k = yypvt[-0]->vstg; + if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) + dclerr("can only save static variables", yypvt[-0]); + } break; +case 90: +# line 466 "gram.in" +{ yypvt[-0]->extsave = 1; } break; +case 93: +# line 474 "gram.in" +{ if(yypvt[-2]->vclass == CLUNKNOWN) + { yypvt[-2]->vclass = CLPARAM; + yypvt[-2]->paramval = yypvt[-0]; + } + else dclerr("cannot make %s parameter", yypvt[-2]); + } break; +case 94: +# line 483 "gram.in" +{ if(ndim>0) setbounds(yypvt[-1], ndim, dims); } break; +case 95: +# line 487 "gram.in" +{ ptr np; + vardcl(np = yypvt[-0]->namep); + if(np->vstg == STGBSS) + np->vstg = STGINIT; + else 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) + dclerr("inconsistent storage classes", np); + yyval = mkchain(yypvt[-0], 0); + } break; +case 96: +# line 500 "gram.in" +{ chainp p; struct Impldoblock *q; + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + q->varnp = yypvt[-1]->datap; + p = yypvt[-1]->nextp; + if(p) { q->implb = p->datap; p = p->nextp; } + if(p) { q->impub = p->datap; p = p->nextp; } + if(p) { q->impstep = p->datap; p = p->nextp; } + frchain( & (yypvt[-1]) ); + yyval = mkchain(q, 0); + q->datalist = hookup(yypvt[-3], yyval); + } break; +case 97: +# line 515 "gram.in" +{ curdtp = yypvt[-0]; curdtelt = 0; } break; +case 98: +# line 517 "gram.in" +{ yyval = hookup(yypvt[-2], yypvt[-0]); } break; +case 99: +# line 521 "gram.in" +{ ndim = 0; } break; +case 101: +# line 525 "gram.in" +{ ndim = 0; } break; +case 104: +# line 530 "gram.in" +{ if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = 0; + dims[ndim].ub = yypvt[-0]; + } + ++ndim; + } break; +case 105: +# line 539 "gram.in" +{ if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = yypvt[-2]; + dims[ndim].ub = yypvt[-0]; + } + ++ndim; + } break; +case 106: +# line 550 "gram.in" +{ yyval = 0; } break; +case 108: +# line 555 "gram.in" +{ nstars = 1; labarray[0] = yypvt[-0]; } break; +case 109: +# line 557 "gram.in" +{ if(nstars < MAXLABLIST) labarray[nstars++] = yypvt[-0]; } break; +case 110: +# line 561 "gram.in" +{ + if(yypvt[-0] == 0) + execerr("illegal label", 0); + else { + if(yypvt[-0]->labinacc) + warn1("illegal branch to inner block, statement %s", + convic( (ftnint) (yypvt[-0]->stateno) )); + else if(yypvt[-0]->labdefined == NO) + yypvt[-0]->blklevel = blklevel; + yypvt[-0]->labused = YES; + if(yypvt[-0]->labtype == LABFORMAT) + err("may not branch to a format"); + else + yypvt[-0]->labtype = LABEXEC; + } + } break; +case 111: +# line 580 "gram.in" +{ yyval = mklabel( convci(toklen, token) ); } break; +case 112: +# line 584 "gram.in" +{ NO66("IMPLICIT statement"); } break; +case 115: +# line 591 "gram.in" +{ needkwd = 1; } break; +case 116: +# line 592 "gram.in" +{ vartype = yypvt[-0]; } break; +case 119: +# line 600 "gram.in" +{ setimpl(vartype, varleng, yypvt[-0], yypvt[-0]); } break; +case 120: +# line 602 "gram.in" +{ setimpl(vartype, varleng, yypvt[-2], yypvt[-0]); } break; +case 121: +# line 606 "gram.in" +{ if(toklen!=1 || token[0]<'a' || token[0]>'z') + { + dclerr("implicit item must be single letter", 0); + yyval = 0; + } + else yyval = token[0]; + } break; +case 122: +# line 616 "gram.in" +{ switch(parstate) + { + case OUTSIDE: newproc(); + startproc(0, CLMAIN); + case INSIDE: parstate = INDCL; + case INDCL: break; + + default: + dclerr("declaration among executables", 0); + } + } break; +case 123: +# line 629 "gram.in" +{ yyval = 0; } break; +case 125: +# line 634 "gram.in" +{ yyval = mkchain(yypvt[-0], 0); } break; +case 126: +# line 636 "gram.in" +{ yyval = hookup(yypvt[-2], mkchain(yypvt[-0],0) ); } break; +case 128: +# line 641 "gram.in" +{ yyval = yypvt[-1]; } break; +case 132: +# line 648 "gram.in" +{ yyval = mkexpr(yypvt[-1], yypvt[-2], yypvt[-0]); } break; +case 133: +# line 650 "gram.in" +{ yyval = mkexpr(OPSTAR, yypvt[-2], yypvt[-0]); } break; +case 134: +# line 652 "gram.in" +{ yyval = mkexpr(OPSLASH, yypvt[-2], yypvt[-0]); } break; +case 135: +# line 654 "gram.in" +{ yyval = mkexpr(OPPOWER, yypvt[-2], yypvt[-0]); } break; +case 136: +# line 656 "gram.in" +{ if(yypvt[-1] == OPMINUS) + yyval = mkexpr(OPNEG, yypvt[-0], 0); + else yyval = yypvt[-0]; + } break; +case 137: +# line 661 "gram.in" +{ yyval = mkexpr(yypvt[-1], yypvt[-2], yypvt[-0]); } break; +case 138: +# line 663 "gram.in" +{ NO66(".EQV. operator"); + yyval = mkexpr(OPEQV, yypvt[-2],yypvt[-0]); } break; +case 139: +# line 666 "gram.in" +{ NO66(".NEQV. operator"); + yyval = mkexpr(OPNEQV, yypvt[-2], yypvt[-0]); } break; +case 140: +# line 669 "gram.in" +{ yyval = mkexpr(OPOR, yypvt[-2], yypvt[-0]); } break; +case 141: +# line 671 "gram.in" +{ yyval = mkexpr(OPAND, yypvt[-2], yypvt[-0]); } break; +case 142: +# line 673 "gram.in" +{ yyval = mkexpr(OPNOT, yypvt[-0], 0); } break; +case 143: +# line 675 "gram.in" +{ NO66("concatenation operator //"); + yyval = mkexpr(OPCONCAT, yypvt[-2], yypvt[-0]); } break; +case 144: +# line 679 "gram.in" +{ yyval = OPPLUS; } break; +case 145: +# line 680 "gram.in" +{ yyval = OPMINUS; } break; +case 146: +# line 683 "gram.in" +{ yyval = OPEQ; } break; +case 147: +# line 684 "gram.in" +{ yyval = OPGT; } break; +case 148: +# line 685 "gram.in" +{ yyval = OPLT; } break; +case 149: +# line 686 "gram.in" +{ yyval = OPGE; } break; +case 150: +# line 687 "gram.in" +{ yyval = OPLE; } break; +case 151: +# line 688 "gram.in" +{ yyval = OPNE; } break; +case 152: +# line 692 "gram.in" +{ yyval = mkprim(yypvt[-0], 0, 0, 0); } break; +case 153: +# line 694 "gram.in" +{ NO66("substring operator :"); + yyval = mkprim(yypvt[-5], 0, yypvt[-3], yypvt[-1]); } break; +case 154: +# line 697 "gram.in" +{ yyval = mkprim(yypvt[-3], mklist(yypvt[-1]), 0, 0); } break; +case 155: +# line 699 "gram.in" +{ NO66("substring operator :"); + yyval = mkprim(yypvt[-8], mklist(yypvt[-6]), yypvt[-3], yypvt[-1]); } break; +case 156: +# line 704 "gram.in" +{ yyval = 0; } break; +case 158: +# line 709 "gram.in" +{ if(yypvt[-0]->vclass == CLPARAM) + yyval = cpexpr(yypvt[-0]->paramval); + } break; +case 160: +# line 715 "gram.in" +{ yyval = mklogcon(1); } break; +case 161: +# line 716 "gram.in" +{ yyval = mklogcon(0); } break; +case 162: +# line 717 "gram.in" +{ yyval = mkstrcon(toklen, token); } break; +case 163: +# line 718 "gram.in" + { yyval = mkintcon( convci(toklen, token) ); } break; +case 164: +# line 719 "gram.in" + { yyval = mkrealcon(TYREAL, convcd(toklen, token)); } break; +case 165: +# line 720 "gram.in" + { yyval = mkrealcon(TYDREAL, convcd(toklen, token)); } break; +case 166: +# line 724 "gram.in" +{ yyval = mkcxcon(yypvt[-3],yypvt[-1]); } break; +case 167: +# line 728 "gram.in" +{ NOEXT("hex constant"); + yyval = mkbitcon(4, toklen, token); } break; +case 168: +# line 731 "gram.in" +{ NOEXT("octal constant"); + yyval = mkbitcon(3, toklen, token); } break; +case 169: +# line 734 "gram.in" +{ NOEXT("binary constant"); + yyval = mkbitcon(1, toklen, token); } break; +case 171: +# line 740 "gram.in" +{ yyval = yypvt[-1]; } break; +case 174: +# line 746 "gram.in" +{ yyval = mkexpr(yypvt[-1], yypvt[-2], yypvt[-0]); } break; +case 175: +# line 748 "gram.in" +{ yyval = mkexpr(OPSTAR, yypvt[-2], yypvt[-0]); } break; +case 176: +# line 750 "gram.in" +{ yyval = mkexpr(OPSLASH, yypvt[-2], yypvt[-0]); } break; +case 177: +# line 752 "gram.in" +{ yyval = mkexpr(OPPOWER, yypvt[-2], yypvt[-0]); } break; +case 178: +# line 754 "gram.in" +{ if(yypvt[-1] == OPMINUS) + yyval = mkexpr(OPNEG, yypvt[-0], 0); + else yyval = yypvt[-0]; + } break; +case 179: +# line 759 "gram.in" +{ NO66("concatenation operator //"); + yyval = mkexpr(OPCONCAT, yypvt[-2], yypvt[-0]); } break; +case 181: +# line 764 "gram.in" +{ + if(yypvt[-1]->labdefined) + execerr("no backward DO loops", 0); + yypvt[-1]->blklevel = blklevel+1; + exdo(yypvt[-1]->labelno, yypvt[-0]); + } break; +case 182: +# line 771 "gram.in" +{ exendif(); thiswasbranch = NO; } break; +case 184: +# line 774 "gram.in" +{ exelif(yypvt[-2]); lastwasbranch = NO; } break; +case 185: +# line 776 "gram.in" +{ exelse(); lastwasbranch = NO; } break; +case 186: +# line 778 "gram.in" +{ exendif(); lastwasbranch = NO; } break; +case 187: +# line 782 "gram.in" +{ exif(yypvt[-1]); } break; +case 188: +# line 786 "gram.in" +{ yyval = mkchain(yypvt[-2], yypvt[-0]); } break; +case 189: +# line 790 "gram.in" +{ exequals(yypvt[-2], yypvt[-0]); } break; +case 190: +# line 792 "gram.in" +{ exassign(yypvt[-0], yypvt[-2]); } break; +case 193: +# line 796 "gram.in" +{ inioctl = NO; } break; +case 194: +# line 798 "gram.in" +{ exarif(yypvt[-6], yypvt[-4], yypvt[-2], yypvt[-0]); thiswasbranch = YES; } break; +case 195: +# line 800 "gram.in" +{ excall(yypvt[-0], 0, 0, labarray); } break; +case 196: +# line 802 "gram.in" +{ excall(yypvt[-2], 0, 0, labarray); } break; +case 197: +# line 804 "gram.in" +{ if(nstars < MAXLABLIST) + excall(yypvt[-3], mklist(yypvt[-1]), nstars, labarray); + else + err("too many alternate returns"); + } break; +case 198: +# line 810 "gram.in" +{ exreturn(yypvt[-0]); thiswasbranch = YES; } break; +case 199: +# line 812 "gram.in" +{ exstop(yypvt[-2], yypvt[-0]); thiswasbranch = yypvt[-2]; } break; +case 200: +# line 816 "gram.in" +{ if(parstate == OUTSIDE) + { + newproc(); + startproc(0, CLMAIN); + } + } break; +case 201: +# line 825 "gram.in" +{ exgoto(yypvt[-0]); thiswasbranch = YES; } break; +case 202: +# line 827 "gram.in" +{ exasgoto(yypvt[-0]); thiswasbranch = YES; } break; +case 203: +# line 829 "gram.in" +{ exasgoto(yypvt[-4]); thiswasbranch = YES; } break; +case 204: +# line 831 "gram.in" +{ if(nstars < MAXLABLIST) + putcmgo(fixtype(yypvt[-0]), nstars, labarray); + else + err("computed GOTO list too long"); + } break; +case 207: +# line 843 "gram.in" +{ nstars = 0; yyval = yypvt[-0]; } break; +case 208: +# line 847 "gram.in" +{ yyval = (yypvt[-0] ? mkchain(yypvt[-0],0) : 0); } break; +case 209: +# line 849 "gram.in" +{ if(yypvt[-0]) + if(yypvt[-2]) yyval = hookup(yypvt[-2], mkchain(yypvt[-0],0)); + else yyval = mkchain(yypvt[-0],0); + } break; +case 211: +# line 857 "gram.in" +{ if(nstarsvtype == TYCHAR) + { + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, yypvt[-1]); + } + else + ioclause(IOSUNIT, yypvt[-1]); + endioctl(); + } break; +case 241: +# line 958 "gram.in" +{ endioctl(); } break; +case 244: +# line 966 "gram.in" +{ ioclause(IOSPOSITIONAL, yypvt[-0]); } break; +case 245: +# line 968 "gram.in" +{ ioclause(IOSPOSITIONAL, NULL); } break; +case 246: +# line 970 "gram.in" +{ ioclause(yypvt[-1], yypvt[-0]); } break; +case 247: +# line 972 "gram.in" +{ ioclause(yypvt[-1], NULL); } break; +case 248: +# line 976 "gram.in" +{ yyval = iocname(); } break; +case 249: +# line 980 "gram.in" +{ iostmt = IOREAD; } break; +case 250: +# line 984 "gram.in" +{ iostmt = IOWRITE; } break; +case 251: +# line 988 "gram.in" +{ + iostmt = IOWRITE; + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, yypvt[-1]); + endioctl(); + } break; +case 252: +# line 995 "gram.in" +{ + iostmt = IOWRITE; + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, NULL); + endioctl(); + } break; +case 253: +# line 1004 "gram.in" +{ yyval = mkchain(yypvt[-0],0); } break; +case 254: +# line 1006 "gram.in" +{ yyval = hookup(yypvt[-2], mkchain(yypvt[-0],0)); } break; +case 256: +# line 1011 "gram.in" +{ yyval = mkiodo(yypvt[-1],yypvt[-3]); } break; +case 257: +# line 1015 "gram.in" +{ yyval = mkchain(yypvt[-0], 0); } break; +case 258: +# line 1017 "gram.in" +{ yyval = mkchain(yypvt[-0], 0); } break; +case 260: +# line 1022 "gram.in" +{ yyval = mkchain(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 261: +# line 1024 "gram.in" +{ yyval = mkchain(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 262: +# line 1026 "gram.in" +{ yyval = mkchain(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 263: +# line 1028 "gram.in" +{ yyval = mkchain(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 264: +# line 1030 "gram.in" +{ yyval = hookup(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 265: +# line 1032 "gram.in" +{ yyval = hookup(yypvt[-2], mkchain(yypvt[-0], 0) ); } break; +case 267: +# line 1037 "gram.in" +{ yyval = mkiodo(yypvt[-1], mkchain(yypvt[-3], 0) ); } break; +case 268: +# line 1039 "gram.in" +{ yyval = mkiodo(yypvt[-1], mkchain(yypvt[-3], 0) ); } break; +case 269: +# line 1041 "gram.in" +{ yyval = mkiodo(yypvt[-1], yypvt[-3]); } break; +case 270: +# line 1045 "gram.in" +{ startioctl(); } break; + } + goto yystack; /* stack new state and value */ + + } diff --git a/usr/src/cmd/f77/gram.dcl b/usr/src/cmd/f77/gram.dcl new file mode 100644 index 0000000000..f4de2bba79 --- /dev/null +++ b/usr/src/cmd/f77/gram.dcl @@ -0,0 +1,340 @@ +spec: dcl + | common + | external + | intrinsic + | equivalence + | data + | implicit + | 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 dims lengspec + { settype($3, $1, $6); + if(ndim>0) setbound($3,ndim,dims); + } + | dcl SCOMMA name dims lengspec + { settype($3, $1, $5); + if(ndim>0) setbound($3,ndim,dims); + } + ; + +type: typespec lengspec + { varleng = $2; } + ; + +typespec: typename + { varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]); } + ; + +typename: SINTEGER { $$ = TYLONG; } + | SREAL { $$ = TYREAL; } + | SCOMPLEX { $$ = TYCOMPLEX; } + | SDOUBLE { $$ = TYDREAL; } + | SDCOMPLEX { 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 expr + { + NO66("length specification *n"); + if( ! ISICON($2) ) + { + $$ = 0; + dclerr("length must be an integer constant", 0); + } + else $$ = $2->const.ci; + } + | SSTAR SLPAR SSTAR SRPAR + { NO66("length specification *(*)"); $$ = 0; } + ; + +common: SCOMMON in_dcl var + { incomm( $$ = comblock(0, 0) , $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(0, 0); } + | SSLASH SNAME SSLASH + { $$ = comblock(toklen, 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'); + p = & eqvclass[nequiv++]; + p->eqvinit = 0; + p->eqvbottom = 0; + p->eqvtop = 0; + p->equivs = $2; + } + ; + +equivlist: lhs + { $$ = ALLOC(Eqvchain); $$->eqvitem = $1; } + | equivlist SCOMMA lhs + { $$ = ALLOC(Eqvchain); $$->eqvitem = $3; $$->nextp = $1; } + ; + +data: SDATA in_data datalist + | data opt_comma datalist + ; + +in_data: + { if(parstate == OUTSIDE) + { + newproc(); + startproc(0, CLMAIN); + } + if(parstate < INDATA) + { + enddcl(); + parstate = INDATA; + } + } + ; + +datalist: datavarlist SSLASH vallist SSLASH + { ftnint junk; + if(nextdata(&junk,&junk) != NULL) + { + err("too few initializers"); + curdtp = NULL; + } + frdata($1); + frrpl(); + } + ; + +vallist: { toomanyinit = NO; } val + | vallist SCOMMA val + ; + +val: value + { dataval(NULL, $1); } + | simple SSTAR value + { dataval($1, $3); } + ; + +value: simple + | addop simple + { if( $1==OPMINUS && ISCONST($2) ) + consnegop($2); + $$ = $2; + } + | complex_const + | bit_const + ; + +savelist: saveitem + | savelist SCOMMA saveitem + ; + +saveitem: name + { int k; + $1->vsave = 1; + k = $1->vstg; + if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) + dclerr("can only save static variables", $1); + } + | comblock + { $1->extsave = 1; } + ; + +paramlist: paramitem + | paramlist SCOMMA paramitem + ; + +paramitem: name SEQUALS expr + { if($1->vclass == CLUNKNOWN) + { $1->vclass = CLPARAM; + $1->paramval = $3; + } + else dclerr("cannot make %s parameter", $1); + } + ; + +var: name dims + { if(ndim>0) setbounds($1, ndim, dims); } + ; + +datavar: lhs + { ptr np; + vardcl(np = $1->namep); + if(np->vstg == STGBSS) + np->vstg = STGINIT; + else 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) + dclerr("inconsistent storage classes", np); + $$ = mkchain($1, 0); + } + | SLPAR datavarlist SCOMMA dospec SRPAR + { chainp p; struct Impldoblock *q; + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + q->varnp = $4->datap; + p = $4->nextp; + if(p) { q->implb = p->datap; p = p->nextp; } + if(p) { q->impub = p->datap; p = p->nextp; } + if(p) { q->impstep = p->datap; p = p->nextp; } + frchain( & ($4) ); + $$ = mkchain(q, 0); + q->datalist = hookup($2, $$); + } + ; + +datavarlist: datavar + { 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: labelval + { + if($1 == 0) + execerr("illegal label", 0); + else { + if($1->labinacc) + warn1("illegal branch to inner block, statement %s", + convic( (ftnint) ($1->stateno) )); + else if($1->labdefined == NO) + $1->blklevel = blklevel; + $1->labused = YES; + if($1->labtype == LABFORMAT) + err("may not branch to a format"); + else + $1->labtype = LABEXEC; + } + } + ; + +labelval: SICON + { $$ = mklabel( convci(toklen, token) ); } + ; + +implicit: SIMPLICIT in_dcl implist + { NO66("IMPLICIT statement"); } + | implicit SCOMMA implist + ; + +implist: imptype SLPAR letgroups SRPAR + ; + +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", 0); + $$ = 0; + } + else $$ = token[0]; + } + ; + +in_dcl: + { switch(parstate) + { + case OUTSIDE: newproc(); + startproc(0, CLMAIN); + case INSIDE: parstate = INDCL; + case INDCL: break; + + default: + dclerr("declaration among executables", 0); + } + } + ; diff --git a/usr/src/cmd/f77/gram.exec b/usr/src/cmd/f77/gram.exec new file mode 100644 index 0000000000..0df96df6cb --- /dev/null +++ b/usr/src/cmd/f77/gram.exec @@ -0,0 +1,119 @@ +exec: iffable + | SDO end_spec label dospec + { + if($3->labdefined) + execerr("no backward DO loops", 0); + $3->blklevel = blklevel+1; + exdo($3->labelno, $4); + } + | 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($1, $3); } + ; + +iffable: let lhs SEQUALS expr + { exequals($2, $4); } + | SASSIGN end_spec labelval 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, 0, 0, labarray); } + | call SLPAR SRPAR + { excall($1, 0, 0, labarray); } + | call SLPAR callarglist SRPAR + { if(nstars < MAXLABLIST) + excall($1, mklist($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; } + ; + +let: SLET + { if(parstate == OUTSIDE) + { + newproc(); + startproc(0, 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(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($1,0) : 0); } + | callarglist SCOMMA callarg + { if($3) + if($1) $$ = hookup($1, mkchain($3,0)); + else $$ = mkchain($3,0); + } + ; + +callarg: expr + | SSTAR label + { if(nstarsvclass == CLPARAM) + $$ = cpexpr($1->paramval); + } + | simple_const + ; + +simple_const: STRUE { $$ = mklogcon(1); } + | SFALSE { $$ = mklogcon(0); } + | SHOLLERITH { $$ = mkstrcon(toklen, token); } + | SICON = { $$ = mkintcon( convci(toklen, token) ); } + | SRCON = { $$ = mkrealcon(TYREAL, convcd(toklen, token)); } + | SDCON = { $$ = mkrealcon(TYDREAL, convcd(toklen, token)); } + ; + +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, 0); + else $$ = $2; + } + | fexpr SCONCAT fexpr + { NO66("concatenation operator //"); + $$ = mkexpr(OPCONCAT, $1, $3); } + ; diff --git a/usr/src/cmd/f77/gram.head b/usr/src/cmd/f77/gram.head new file mode 100644 index 0000000000..ea2c3a7213 --- /dev/null +++ b/usr/src/cmd/f77/gram.head @@ -0,0 +1,192 @@ +%{ +# include "defs" + +#ifdef SDB +# include +char *stabline(); +# ifdef UCBVAXASM + char *stabdline(); +# endif +#endif + +static int nstars; +static int ndim; +static int vartype; +static ftnint varleng; +static struct { ptr lb, ub; } dims[MAXDIM+1]; +static struct Labelblock *labarray[MAXLABLIST]; +static int lastwasbranch = NO; +static int thiswasbranch = NO; +extern ftnint yystno; + +ftnint convci(); +double convcd(); +struct Addrblock *nextdata(), *mkbitcon(); +struct Constblock *mklogcon(), *mkaddcon(), *mkrealcon(); +struct Constblock *mkstrcon(), *mkcxcon(); +struct Listblock *mklist(); +struct Listblock *mklist(); +struct Impldoblock *mkiodo(); +struct Extsym *comblock(); + +%} + +/* Specify precedences and associativies. */ + +%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 + +%% + +program: + | program stat SEOS + ; + +stat: thislabel entry + { lastwasbranch = NO; } + | thislabel spec + | thislabel exec + { 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; + } + } + | thislabel SINCLUDE filename + { doinclude( $3 ); } + | thislabel SEND end_spec + { lastwasbranch = NO; endproc(); } + | thislabel SUNKNOWN + { execerr("unclassifiable statement", 0); flline(); }; + | error + { flline(); needkwd = NO; inioctl = NO; + yyerrok; yyclearin; } + ; + +thislabel: SLABEL + { +#ifdef SDB + char buff[10]; + if( sdbflag ) + { +# ifdef UCBVAXASM + p2pass( stabdline(N_SLINE, lineno) ); +# else + sprintf(buff,"LL%d", ++dbglabel); + p2pass( stabline(0, N_SLINE, lineno, buff) ); + p2pi("LL%d:\n", dbglabel); +# endif + } +#endif + + if(yystno != 0) + { + $$ = thislabel = mklabel(yystno); + if( ! headerdone ) + puthead(NULL, procclass); + if(thislabel->labdefined) + execerr("label %s already defined", + convic(thislabel->stateno) ); + else { + if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=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) + putlabel(thislabel->labelno); + } + } + else $$ = thislabel = NULL; + } + ; + +entry: SPROGRAM new_proc progname + {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", 0); + entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); + } + ; + +new_proc: + { newproc(); } + ; + +entryname: name + { $$ = newentry($1); } + ; + +name: SNAME + { $$ = mkname(toklen, token); } + ; + +progname: { $$ = NULL; } + | entryname + ; + +arglist: + { $$ = 0; } + | SLPAR SRPAR + { NO66(" () argument list"); + $$ = 0; } + | SLPAR args SRPAR + {$$ = $2; } + ; + +args: arg + { $$ = ($1 ? mkchain($1,0) : 0 ); } + | args SCOMMA arg + { if($3) $1 = $$ = hookup($1, mkchain($3,0)); } + ; + +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"); + $$ = 0; substars = YES; } + ; + + + +filename: SHOLLERITH + { + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + $$ = s; + } + ; diff --git a/usr/src/cmd/f77/gram.io b/usr/src/cmd/f77/gram.io new file mode 100644 index 0000000000..b7cd639f54 --- /dev/null +++ b/usr/src/cmd/f77/gram.io @@ -0,0 +1,166 @@ + /* Input/Output Statements */ + +io: io1 + { endio(); } + ; + +io1: iofmove ioctl + | iofmove unpar_fexpr + { ioclause(IOSUNIT, $2); endioctl(); } + | iofctl ioctl + | read ioctl + { doio(NULL); } + | read infmt + { doio(NULL); } + | read ioctl inlist + { doio($3); } + | read infmt SCOMMA inlist + { doio($4); } + | read ioctl SCOMMA inlist + { doio($4); } + | write ioctl + { doio(NULL); } + | write ioctl outlist + { doio($3); } + | print + { doio(NULL); } + | print SCOMMA outlist + { doio($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, NULL); + ioclause(IOSFMT, $1); + endioctl(); + } + | SSTAR + { + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, NULL); + endioctl(); + } + ; + +ioctl: SLPAR fexpr SRPAR + { if($2->vtype == TYCHAR) + { + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, $2); + } + else + ioclause(IOSUNIT, $2); + endioctl(); + } + | SLPAR ctllist SRPAR + { endioctl(); } + ; + +ctllist: ioclause + | ctllist SCOMMA ioclause + ; + +ioclause: fexpr + { ioclause(IOSPOSITIONAL, $1); } + | SSTAR + { ioclause(IOSPOSITIONAL, NULL); } + | nameeq expr + { ioclause($1, $2); } + | nameeq SSTAR + { ioclause($1, NULL); } + ; + +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, NULL); + ioclause(IOSFMT, $3); + endioctl(); + } + | SPRINT end_spec SSTAR in_ioctl + { + iostmt = IOWRITE; + ioclause(IOSUNIT, NULL); + ioclause(IOSFMT, NULL); + endioctl(); + } + ; + +inlist: inelt + { $$ = mkchain($1,0); } + | inlist SCOMMA inelt + { $$ = hookup($1, mkchain($3,0)); } + ; + +inelt: lhs + | SLPAR inlist SCOMMA dospec SRPAR + { $$ = mkiodo($4,$2); } + ; + +outlist: uexpr + { $$ = mkchain($1, 0); } + | other + { $$ = mkchain($1, 0); } + | out2 + ; + +out2: uexpr SCOMMA uexpr + { $$ = mkchain($1, mkchain($3, 0) ); } + | uexpr SCOMMA other + { $$ = mkchain($1, mkchain($3, 0) ); } + | other SCOMMA uexpr + { $$ = mkchain($1, mkchain($3, 0) ); } + | other SCOMMA other + { $$ = mkchain($1, mkchain($3, 0) ); } + | out2 SCOMMA uexpr + { $$ = hookup($1, mkchain($3, 0) ); } + | out2 SCOMMA other + { $$ = hookup($1, mkchain($3, 0) ); } + ; + +other: complex_const + | SLPAR uexpr SCOMMA dospec SRPAR + { $$ = mkiodo($4, mkchain($2, 0) ); } + | SLPAR other SCOMMA dospec SRPAR + { $$ = mkiodo($4, mkchain($2, 0) ); } + | SLPAR out2 SCOMMA dospec SRPAR + { $$ = mkiodo($4, $2); } + ; + +in_ioctl: + { startioctl(); } + ; diff --git a/usr/src/cmd/f77/init.c b/usr/src/cmd/f77/init.c new file mode 100644 index 0000000000..8506abb7d9 --- /dev/null +++ b/usr/src/cmd/f77/init.c @@ -0,0 +1,290 @@ +#include "defs" + + +FILEP infile = { stdin }; +FILEP diagfile = { stderr }; + +FILEP textfile; +FILEP asmfile; +FILEP initfile; +long int headoffset; + +char token[200]; +int toklen; +int lineno; +char *infname; +int needkwd; +struct Labelblock *thislabel = NULL; +flag nowarnflag = NO; +flag ftn66flag = NO; +flag no66flag = NO; +flag noextflag = NO; +flag profileflag = NO; +flag optimflag = NO; +flag shiftcase = YES; +flag undeftype = NO; +flag shortsubs = YES; +flag onetripflag = NO; +flag checksubs = NO; +flag debugflag = NO; +int nerr; +int nwarn; +int ndata; + +flag saveall; +flag substars; +int parstate = OUTSIDE; +flag headerdone = NO; +int blklevel; +int impltype[26]; +int implleng[26]; +int implstg[26]; + +int tyint = TYLONG ; +int tylogical = TYLONG; +ftnint typesize[NTYPES] + = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG, + 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1}; +int typealign[NTYPES] + = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE, + ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1}; +int procno; +int proctype = TYUNKNOWN; +char *procname; +int rtvlabel[NTYPES]; +int fudgelabel; +struct Addrblock *typeaddr; +struct Addrblock *retslot; +int cxslot = -1; +int chslot = -1; +int chlgslot = -1; +int procclass = CLUNKNOWN; +int nentry; +flag multitype; +ftnint procleng; +int lastlabno = 10; +int lastvarno; +int lastargslot; +int argloc; +ftnint autoleng; +ftnint bssleng = 0; +int retlabel; +int ret0label; + +int maxctl = MAXCTL; +struct Ctlframe *ctls; +struct Ctlframe *ctlstack; +struct Ctlframe *lastctl; + +struct Nameblock *regnamep[MAXREGVAR]; +int highregvar; +int nregvar; + +int maxext = MAXEXT; +struct Extsym *extsymtab; +struct Extsym *nextext; +struct Extsym *lastext; + +int maxequiv = MAXEQUIV; +struct Equivblock *eqvclass; + +int maxhash = MAXHASH; +struct Hashentry *hashtab; +struct Hashentry *lasthash; + +int maxstno = MAXSTNO; +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 = NULL; +chainp holdtemps = NULL; +int dorange = 0; +struct Entrypoint *entries = NULL; + +chainp chains = NULL; + +flag inioctl; +struct Addrblock *ioblkp; +int iostmt; +int nioctl; +int nequiv = 0; +int eqvstart = 0; +int nintnames = 0; +int nextnames = 0; + +#ifdef SDB +int dbglabel = 0; +flag sdbflag = NO; +#endif + +struct Literal litpool[MAXLITERALS]; +int nliterals; + + + +fileinit() +{ +procno = 0; +lastlabno = 10; +lastvarno = 0; +nliterals = 0; +nerr = 0; +ndata = 0; + +ctls = ALLOCN(maxctl, Ctlframe); +extsymtab = ALLOCN(maxext, Extsym); +eqvclass = ALLOCN(maxequiv, Equivblock); +hashtab = ALLOCN(maxhash, Hashentry); +labeltab = ALLOCN(maxstno, Labelblock); + +ctlstack = ctls - 1; +lastctl = ctls + maxctl; +nextext = extsymtab; +lastext = extsymtab + maxext; +lasthash = hashtab + maxhash; +labtabend = labeltab + maxstno; +highlabtab = labeltab; +} + + + + + +procinit() +{ +register struct Nameblock *p; +register struct Dimblock *q; +register struct Hashentry *hp; +register struct Labelblock *lp; +struct Chain *cp; +int i; + +pruse(asmfile, USECONST); +#if FAMILY == PCC + p2pass(USETEXT); +#endif +parstate = OUTSIDE; +headerdone = NO; +blklevel = 1; +saveall = NO; +substars = NO; +nwarn = 0; +thislabel = NULL; +needkwd = 0; + +++procno; +proctype = TYUNKNOWN; +procname = "MAIN_ "; +procclass = CLUNKNOWN; +nentry = 0; +multitype = NO; +typeaddr = NULL; +retslot = NULL; +cxslot = -1; +chslot = -1; +chlgslot = -1; +procleng = 0; +blklevel = 1; +lastargslot = 0; +#if TARGET==PDP11 + autoleng = 6; +#else + autoleng = 0; +#endif + +for(lp = labeltab ; lp < labtabend ; ++lp) + lp->stateno = 0; + +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(q); + } + free(p); + hp->varp = NULL; + } +nintnames = 0; +highlabtab = labeltab; + +ctlstack = ctls - 1; +for(cp = templist ; cp ; cp = cp->nextp) + free(cp->datap); +frchain(&templist); +holdtemps = NULL; +dorange = 0; +nregvar = 0; +highregvar = 0; +entries = NULL; +rpllist = NULL; +inioctl = NO; +ioblkp = NULL; +eqvstart += nequiv; +nequiv = 0; + +for(i = 0 ; i c2) + { + sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); + err(buff); + } +else + if(type < 0) + for(i = c1 ; i<=c2 ; ++i) + implstg[i-'a'] = - type; + else + { + type = lengtype(type, (int) length); + if(type != TYCHAR) + length = 0; + for(i = c1 ; i<=c2 ; ++i) + { + impltype[i-'a'] = type; + implleng[i-'a'] = length; + } + } +} diff --git a/usr/src/cmd/f77/intr.c b/usr/src/cmd/f77/intr.c new file mode 100644 index 0000000000..cba5a49dbd --- /dev/null +++ b/usr/src/cmd/f77/intr.c @@ -0,0 +1,693 @@ +#include "defs" + +extern ftnint intcon[14]; +extern double realcon[6]; + +union + { + int ijunk; + struct Intrpacked bits; + } packed; + +struct Intrbits + { + int intrgroup /* :3 */; + int intrstuff /* result type or number of generics */; + int intrno /* :7 */; + }; + +LOCAL struct Intrblock + { + char intrfname[VL]; + struct Intrbits intrval; + } intrtab[ ] = +{ +"int", { INTRCONV, TYLONG }, +"real", { INTRCONV, TYREAL }, +"dble", { INTRCONV, TYDREAL }, +"cmplx", { INTRCONV, TYCOMPLEX }, +"dcmplx", { INTRCONV, TYDCOMPLEX }, +"ifix", { INTRCONV, TYLONG }, +"idint", { INTRCONV, TYLONG }, +"float", { INTRCONV, TYREAL }, +"dfloat", { INTRCONV, TYDREAL }, +"sngl", { INTRCONV, TYREAL }, +"ichar", { INTRCONV, TYLONG }, +"char", { INTRCONV, TYCHAR }, + +"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 }, +"zabs", { INTRSPEC, TYDREAL, 13 }, + +"mod", { INTRGEN, 4, 14 }, +"amod", { INTRSPEC, TYREAL, 16 }, +"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 }, +"dimag", { INTRSPEC, TYDREAL, 32 }, + +"conjg", { INTRGEN, 2, 33 }, +"dconjg", { INTRSPEC, TYDCOMPLEX, 34 }, + +"sqrt", { INTRGEN, 4, 35 }, +"dsqrt", { INTRSPEC, TYDREAL, 36 }, +"csqrt", { INTRSPEC, TYCOMPLEX, 37 }, +"zsqrt", { INTRSPEC, TYDCOMPLEX, 38 }, + +"exp", { INTRGEN, 4, 39 }, +"dexp", { INTRSPEC, TYDREAL, 40 }, +"cexp", { INTRSPEC, TYCOMPLEX, 41 }, +"zexp", { INTRSPEC, TYDCOMPLEX, 42 }, + +"log", { INTRGEN, 4, 43 }, +"alog", { INTRSPEC, TYREAL, 43 }, +"dlog", { INTRSPEC, TYDREAL, 44 }, +"clog", { INTRSPEC, TYCOMPLEX, 45 }, +"zlog", { INTRSPEC, TYDCOMPLEX, 46 }, + +"log10", { INTRGEN, 2, 47 }, +"alog10", { INTRSPEC, TYREAL, 47 }, +"dlog10", { INTRSPEC, TYDREAL, 48 }, + +"sin", { INTRGEN, 4, 49 }, +"dsin", { INTRSPEC, TYDREAL, 50 }, +"csin", { INTRSPEC, TYCOMPLEX, 51 }, +"zsin", { INTRSPEC, TYDCOMPLEX, 52 }, + +"cos", { INTRGEN, 4, 53 }, +"dcos", { INTRSPEC, TYDREAL, 54 }, +"ccos", { INTRSPEC, TYCOMPLEX, 55 }, +"zcos", { INTRSPEC, TYDCOMPLEX, 56 }, + +"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}, + +"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 }, + +"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; + char rtype; + char nargs; + char spxname[XL]; + 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" } +} ; + +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 } +}; + +/* For each machine, two arrays must be initialized. +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 + +the realcons should probably be filled in in binary if TARGET==HERE +*/ + +char callbyvalue[ ][XL] = + { + "sqrt", + "exp", + "log", + "sin", + "cos", + "tan", + "asin", + "acos", + "atan", + "atan2", + "sinh", + "cosh", + "tanh" + }; + +struct Exprblock *intrcall(np, argsp, nargs) +struct Nameblock *np; +struct Listblock *argsp; +int nargs; +{ +int i, rettype; +struct Addrblock *ap; +register struct Specblock *sp; +struct Exprblock *q, *inline(); +register struct Chain *cp; +struct Constblock *mkcxcon(), *mkrealcon(); +register struct Incstblock *cstp; +expptr 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) + { +/* TEMPORARY */ ep = cp->datap; +/* TEMPORARY */ if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) +/* TEMPORARY */ cp->datap = 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, argsp->listp->datap, NULL); + } + else + { + if(nargs != 2) + goto badnargs; + q = mkexpr(op, argsp->listp->datap, + argsp->listp->nextp->datap); + } + frchain( &(argsp->listp) ); + free(argsp); + return(q); + + case INTRCONV: + rettype = f2field; + if(rettype == TYLONG) + rettype = tyint; + if( ISCOMPLEX(rettype) && nargs==2) + { + expptr qr, qi; + qr = argsp->listp->datap; + qi = 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) + q = mkconv(rettype, argsp->listp->datap); + else goto badnargs; + + q->vtype = rettype; + frchain(&(argsp->listp)); + free(argsp); + return(q); + + + case INTRCNST: + cstp = consttab + f3field; + for(i=0 ; iatype == 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"); + } + + case INTRGEN: + sp = spectab + f3field; + if(no66flag) + if(sp->atype == mtype) + goto specfunct; + else err66("generic function"); + + for(i=0; iatype == mtype) + goto specfunct; + else + ++sp; + goto badtype; + + case INTRSPEC: + sp = spectab + f3field; + specfunct: + if(tyint==TYLONG && sp->rtype==TYSHORT + && (sp+1)->atype==sp->atype) + ++sp; + + if(nargs != sp->nargs) + goto badnargs; + if(mtype != sp->atype) + goto badtype; + fixargs(YES, argsp); + if(q = inline(sp-spectab, mtype, argsp->listp)) + { + frchain( &(argsp->listp) ); + free(argsp); + } + else if(sp->othername) + { + ap = builtin(sp->rtype, + varstr(XL, callbyvalue[sp->othername-1]) ); + q = fixexpr( mkexpr(OPCCALL, ap, argsp) ); + } + else + { + ap = builtin(sp->rtype, varstr(XL, sp->spxname) ); + q = fixexpr( mkexpr(OPCALL, ap, argsp) ); + } + 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), argsp, NULL); + + q->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", + varstr(VL,np->varname) ); + goto bad; + +badtype: + errstr("bad argument type to intrinsic %s", varstr(VL, np->varname) ); + +bad: + return( errnode() ); +} + + + + +intrfunct(s) +char s[VL]; +{ +register struct Intrblock *p; +char nm[VL]; +register int i; + +for(i = 0 ; iintrval.intrgroup!=INTREND ; ++p) + { + if( eqn(VL, nm, p->intrfname) ) + { + packed.bits.f1 = p->intrval.intrgroup; + packed.bits.f2 = p->intrval.intrstuff; + packed.bits.f3 = p->intrval.intrno; + return(packed.ijunk); + } + } + +return(0); +} + + + + + +struct Addrblock *intraddr(np) +struct Nameblock *np; +{ +struct Addrblock *q; +register struct Specblock *sp; +int f3field; + +if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) + fatalstr("intraddr: %s is not intrinsic", varstr(VL,np->varname)); +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, varstr(XL,sp->spxname) ); + return(q); + + case INTRCONV: + case INTRMIN: + case INTRMAX: + case INTRBOOL: + case INTRCNST: + bad: + errstr("cannot pass %s as actual", + varstr(VL,np->varname)); + return( errnode() ); + } +fatali("intraddr: impossible f1=%d\n", packed.bits.f1); +/* NOTREACHED */ +} + + + + + +struct Exprblock *inline(fno, type, args) +int fno; +int type; +struct Chain *args; +{ +register struct Exprblock *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 = args->datap) ) + { + t = q; + q = NULL; + } + else + t = mktemp(type); + t1 = mkexpr(OPQUEST, mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)), + mkexpr(OPCOLON, cpexpr(t), + mkexpr(OPNEG, cpexpr(t), NULL) )); + if(q) + t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); + frexpr(t); + return(t1); + + case 26: /* dprod */ + q = mkexpr(OPSTAR, mkconv(TYDREAL,args->datap), args->nextp->datap); + return(q); + + case 27: /* len of character string */ + q = cpexpr(args->datap->vleng); + frexpr(args->datap); + return(q); + + case 14: /* half-integer mod */ + case 15: /* mod */ + return( mkexpr(OPMOD, args->datap, args->nextp->datap) ); + } +return(NULL); +} diff --git a/usr/src/cmd/f77/io.c b/usr/src/cmd/f77/io.c new file mode 100644 index 0000000000..67d794935c --- /dev/null +++ b/usr/src/cmd/f77/io.c @@ -0,0 +1,766 @@ +/* Routines to generate code for I/O statements. + Some corrections and improvements due to David Wasley, U. C. Berkeley +*/ + +/* TEMPORARY */ +#define TYIOINT TYLONG +#define SZIOINT SZLONG + +#include "defs" + + +LOCAL char ioroutine[XL+1]; + +LOCAL int ioendlab; +LOCAL int ioerrlab; +LOCAL int endbit; +LOCAL int jumplab; +LOCAL int skiplab; +LOCAL int ioformatted; + +#define UNFORMATTED 0 +#define FORMATTED 1 +#define LISTDIRECTED 2 + +#define V(z) ioc[z].iocval + +#define IOALL 07777 + +LOCAL struct Ioclist + { + char *iocname; + int iotype; + expptr iocval; + } ioc[ ] = + { + { "", 0 }, + { "unit", IOALL }, + { "fmt", M(IOREAD) | M(IOWRITE) }, + { "err", IOALL }, + { "end", M(IOREAD) }, + { "iostat", IOALL }, + { "rec", M(IOREAD) | M(IOWRITE) }, + { "recl", M(IOOPEN) | M(IOINQUIRE) }, + { "file", M(IOOPEN) | M(IOINQUIRE) }, + { "status", M(IOOPEN) | M(IOCLOSE) }, + { "access", M(IOOPEN) | M(IOINQUIRE) }, + { "form", M(IOOPEN) | M(IOINQUIRE) }, + { "blank", M(IOOPEN) | M(IOINQUIRE) }, + { "exist", M(IOINQUIRE) }, + { "opened", M(IOINQUIRE) }, + { "number", M(IOINQUIRE) }, + { "named", M(IOINQUIRE) }, + { "name", M(IOINQUIRE) }, + { "sequential", M(IOINQUIRE) }, + { "direct", M(IOINQUIRE) }, + { "formatted", M(IOINQUIRE) }, + { "unformatted", M(IOINQUIRE) }, + { "nextrec", M(IOINQUIRE) } + } ; + +#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) +#define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR + +#define IOSUNIT 1 +#define IOSFMT 2 +#define IOSERR 3 +#define IOSEND 4 +#define IOSIOSTAT 5 +#define IOSREC 6 +#define IOSRECL 7 +#define IOSFILE 8 +#define IOSSTATUS 9 +#define IOSACCESS 10 +#define IOSFORM 11 +#define IOSBLANK 12 +#define IOSEXIST 13 +#define IOSOPENED 14 +#define IOSNUMBER 15 +#define IOSNAMED 16 +#define IOSNAME 17 +#define IOSSEQUENTIAL 18 +#define IOSDIRECT 19 +#define IOSFORMATTED 20 +#define IOSUNFORMATTED 21 +#define IOSNEXTREC 22 + +#define IOSTP V(IOSIOSTAT) + + +/* offsets in generated structures */ + +#define SZFLAG SZIOINT + +/* offsets for external READ and WRITE statements */ + +#define XERR 0 +#define XUNIT SZFLAG +#define XEND SZFLAG + SZIOINT +#define XFMT 2*SZFLAG + SZIOINT +#define XREC 2*SZFLAG + SZIOINT + SZADDR +#define XRLEN 2*SZFLAG + 2*SZADDR +#define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT + +/* offsets for internal READ and WRITE statements */ + +#define XIERR 0 +#define XIUNIT SZFLAG +#define XIEND SZFLAG + SZADDR +#define XIFMT 2*SZFLAG + SZADDR +#define XIRLEN 2*SZFLAG + 2*SZADDR +#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT +#define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT + +/* offsets for OPEN statements */ + +#define XFNAME SZFLAG + SZIOINT +#define XFNAMELEN SZFLAG + SZIOINT + SZADDR +#define XSTATUS SZFLAG + 2*SZIOINT + SZADDR +#define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR +#define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR +#define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR +#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR + +/* offset for CLOSE statement */ + +#define XCLSTATUS SZFLAG + SZIOINT + +/* offsets for INQUIRE statement */ + +#define XFILE SZFLAG + SZIOINT +#define XFILELEN SZFLAG + SZIOINT + SZADDR +#define XEXISTS SZFLAG + 2*SZIOINT + SZADDR +#define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR +#define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR +#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR +#define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR +#define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR +#define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR +#define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR +#define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR +#define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR +#define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR +#define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR +#define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR +#define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR +#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR +#define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR +#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR +#define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR +#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR +#define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR +#define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR +#define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR + +fmtstmt(lp) +register struct Labelblock *lp; +{ +if(lp == NULL) + { + execerr("unlabeled format statement" , 0); + return(-1); + } +if(lp->labtype == LABUNKNOWN) + { + lp->labtype = LABFORMAT; + lp->labelno = newlabel(); + } +else if(lp->labtype != LABFORMAT) + { + execerr("bad format number", 0); + return(-1); + } +return(lp->labelno); +} + + + +setfmt(lp) +struct Labelblock *lp; +{ +ftnint n; +char *s, *lexline(); + +s = lexline(&n); +preven(ALILONG); +prlabel(asmfile, lp->labelno); +putstr(asmfile, s, n); +flline(); +} + + + +startioctl() +{ +register int i; + +inioctl = YES; +nioctl = 0; +ioformatted = UNFORMATTED; +for(i = 1 ; i<=NIOS ; ++i) + V(i) = NULL; +} + + + +endioctl() +{ +int i; +expptr p; + +inioctl = NO; +if(ioblkp == NULL) + ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, NULL); + +/* set up for error recovery */ + +ioerrlab = ioendlab = skiplab = jumplab = 0; + +if(p = V(IOSEND)) + if(ISICON(p)) + ioendlab = mklabel(p->constblock.const.ci)->labelno; + else + err("bad end= clause"); + +if(p = V(IOSERR)) + if(ISICON(p)) + ioerrlab = mklabel(p->constblock.const.ci)->labelno; + else + err("bad err= clause"); + +if(IOSTP) + if(IOSTP->headblock.tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) + { + err("iostat must be an integer variable"); + frexpr(IOSTP); + IOSTP = NULL; + } + +if(iostmt == IOREAD) + { + if(IOSTP) + { + if(ioerrlab && ioendlab && ioerrlab==ioendlab) + jumplab = ioerrlab; + else + skiplab = jumplab = newlabel(); + } + else { + if(ioerrlab && ioendlab && ioerrlab!=ioendlab) + { + IOSTP = mktemp(TYINT, NULL); + skiplab = jumplab = newlabel(); + } + else + jumplab = (ioerrlab ? ioerrlab : ioendlab); + } + } +else if(iostmt == IOWRITE) + { + if(IOSTP && !ioerrlab) + skiplab = jumplab = newlabel(); + else + jumplab = ioerrlab; + } +else + jumplab = ioerrlab; + +ioset(TYIOINT, XERR, ICON(IOSTP!=NULL || ioerrlab!=0) ); +endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ + +switch(iostmt) + { + case IOOPEN: + dofopen(); break; + + case IOCLOSE: + dofclose(); break; + + case IOINQUIRE: + dofinquire(); break; + + case IOBACKSPACE: + dofmove("f_back"); break; + + case IOREWIND: + dofmove("f_rew"); break; + + case IOENDFILE: + dofmove("f_end"); break; + + case IOREAD: + case IOWRITE: + startrw(); break; + + default: + fatali("impossible iostmt %d", iostmt); + } +for(i = 1 ; i<=NIOS ; ++i) + if(i!=IOSIOSTAT && V(i)!=NULL) + frexpr(V(i)); +} + + + +iocname() +{ +register int i; +int found, mask; + +found = 0; +mask = M(iostmt); +for(i = 1 ; i <= NIOS ; ++i) + if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) + if(ioc[i].iotype & mask) + return(i); + else found = i; +if(found) + errstr("invalid control %s for statement", ioc[found].iocname); +else + errstr("unknown iocontrol %s", varstr(toklen, token) ); +return(IOSBAD); +} + + +ioclause(n, p) +register int n; +register expptr p; +{ +struct Ioclist *iocp; + +++nioctl; +if(n == IOSBAD) + return; +if(n == IOSPOSITIONAL) + { + if(nioctl > IOSFMT) + { + err("illegal positional iocontrol"); + return; + } + n = nioctl; + } + +if(p == NULL) + { + if(n == IOSUNIT) + p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); + else if(n != IOSFMT) + { + err("illegal * iocontrol"); + return; + } + } +if(n == IOSFMT) + ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); + +iocp = & ioc[n]; +if(iocp->iocval == NULL) + { + if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) ) + p = fixtype(p); + iocp->iocval = p; +} +else + errstr("iocontrol %s repeated", iocp->iocname); +} + +/* io list item */ + +doio(list) +chainp list; +{ +struct Exprblock *call0(); +doiolist(list); +ioroutine[0] = 'e'; +putiocall( call0(TYINT, ioroutine) ); +} + + + + + +LOCAL doiolist(p0) +chainp p0; +{ +chainp p; +register tagptr q; +register expptr qe; +register struct Nameblock *qn; +struct Addrblock *tp, *mkscalar(); +int range; + +for (p = p0 ; p ; p = p->nextp) + { + q = p->datap; + if(q->headblock.tag == TIMPLDO) + { + exdo(range=newlabel(), q->impldoblock.varnp); + doiolist(q->impldoblock.datalist); + enddo(range); + free(q); + } + else { + if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL + && q->primblock.namep->vdim!=NULL) + { + vardcl(qn = q->primblock.namep); + if(qn->vdim->nelt) + putio( fixtype(cpexpr(qn->vdim->nelt)), + mkscalar(qn) ); + else + err("attempt to i/o array of unknown size"); + } + else if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL && + (qe = memversion(q->primblock.namep)) ) + putio(ICON(1),qe); + else if( (qe = fixtype(cpexpr(q)))->headblock.tag==TADDR) + putio(ICON(1), qe); + else if(qe->headblock.vtype != TYERROR) + { + if(iostmt == IOWRITE) + { + tp = mktemp(qe->headblock.vtype, qe->headblock.vleng); + puteq( cpexpr(tp), qe); + putio(ICON(1), tp); + } + else + err("non-left side in READ list"); + } + frexpr(q); + } + } +frchain( &p0 ); +} + + + + + +LOCAL putio(nelt, addr) +expptr nelt; +register expptr addr; +{ +int type; +register struct Exprblock *q; + +type = addr->headblock.vtype; +if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) + { + nelt = mkexpr(OPSTAR, ICON(2), nelt); + type -= (TYCOMPLEX-TYREAL); + } + +/* pass a length with every item. for noncharacter data, fake one */ +if(type != TYCHAR) + { + if( ISCONST(addr) ) + addr = putconst(addr); + addr->headblock.vtype = TYCHAR; + addr->headblock.vleng = ICON( typesize[type] ); + } + +nelt = fixtype( mkconv(TYLENG,nelt) ); +if(ioformatted == LISTDIRECTED) + q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr); +else + q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"), + nelt, addr); +putiocall(q); +} + + + + +endio() +{ +if(skiplab) + { + putlabel(skiplab); + if(ioendlab) + putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab); + if(ioerrlab) + putif( mkexpr( ( (iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ), + cpexpr(IOSTP), ICON(0)) , ioerrlab); + } +if(IOSTP) + frexpr(IOSTP); +} + + + +LOCAL putiocall(q) +register struct Exprblock *q; +{ +if(IOSTP) + { + q->vtype = TYINT; + q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q)); + } + +if(jumplab) + putif( mkexpr(OPEQ, q, ICON(0) ), jumplab); +else + putexpr(q); +} + + +startrw() +{ +register expptr p; +register struct Nameblock *np; +register struct Addrblock *unitp, *nump; +struct Constblock *mkaddcon(); +int k, fmtoff; +int intfile, sequential; + +intfile = NO; +if(p = V(IOSUNIT)) + { + if( ISINT(p->headblock.vtype) ) + ioset(TYIOINT, XUNIT, cpexpr(p) ); + else if(p->headblock.vtype == TYCHAR) + { + intfile = YES; + if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL && + (np = p->primblock.namep)->vdim!=NULL) + { + vardcl(np); + if(np->vdim->nelt) + nump = cpexpr(np->vdim->nelt); + else + { + err("attempt to use internal unit array of unknown size"); + nump = ICON(1); + } + unitp = mkscalar(np); + } + else { + nump = ICON(1); + unitp = fixtype(cpexpr(p)); + } + ioset(TYIOINT, XIRNUM, nump); + ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); + ioset(TYADDR, XIUNIT, addrof(unitp) ); + } + } +else + err("bad unit specifier"); + +sequential = YES; +if(p = V(IOSREC)) + if( ISINT(p->headblock.vtype) ) + { + ioset(TYIOINT, (intfile ? XIREC : XREC), cpexpr(p) ); + sequential = NO; + } + else + err("bad REC= clause"); + +if(iostmt == IOREAD) + ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); + +fmtoff = (intfile ? XIFMT : XFMT); + +if(p = V(IOSFMT)) + { + if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL) + { + vardcl(np = p->primblock.namep); + if(np->vdim) + { + ioset(TYADDR, fmtoff, addrof(mkscalar(np)) ); + goto endfmt; + } + if( ISINT(np->vtype) ) + { + ioset(TYADDR, fmtoff, p); + goto endfmt; + } + } + p = V(IOSFMT) = fixtype(p); + if(p->headblock.vtype == TYCHAR) + ioset(TYADDR, fmtoff, addrof(cpexpr(p)) ); + else if( ISICON(p) ) + { + if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 ) + ioset(TYADDR, fmtoff, mkaddcon(k) ); + else + ioformatted = UNFORMATTED; + } + else { + err("bad format descriptor"); + ioformatted = UNFORMATTED; + } + } +else + ioset(TYADDR, fmtoff, ICON(0) ); + +endfmt: + if(intfile && ioformatted==UNFORMATTED) + err("unformatted internal I/O not allowed"); + if(!sequential && ioformatted==LISTDIRECTED) + err("direct list-directed I/O not allowed"); + +ioroutine[0] = 's'; +ioroutine[1] = '_'; +ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w'); +ioroutine[3] = (sequential ? 's' : 'd'); +ioroutine[4] = "ufl" [ioformatted]; +ioroutine[5] = (intfile ? 'i' : 'e'); +ioroutine[6] = '\0'; +putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) )); +} + + + +LOCAL dofopen() +{ +register expptr p; + +if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + ioset(TYIOINT, XUNIT, cpexpr(p) ); +else + err("bad unit in open"); +if( (p = V(IOSFILE)) ) + if(p->headblock.vtype == TYCHAR) + ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); + else + err("bad file in open"); + +iosetc(XFNAME, p); + +if(p = V(IOSRECL)) + if( ISINT(p->headblock.vtype) ) + ioset(TYIOINT, XRECLEN, cpexpr(p) ); + else + err("bad recl"); +else + ioset(TYIOINT, XRECLEN, ICON(0) ); + +iosetc(XSTATUS, V(IOSSTATUS)); +iosetc(XACCESS, V(IOSACCESS)); +iosetc(XFORMATTED, V(IOSFORM)); +iosetc(XBLANK, V(IOSBLANK)); + +putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) )); +} + + +LOCAL dofclose() +{ +register expptr p; + +if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + { + ioset(TYIOINT, XUNIT, cpexpr(p) ); + iosetc(XCLSTATUS, V(IOSSTATUS)); + putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) ); + } +else + err("bad unit in close statement"); +} + + +LOCAL dofinquire() +{ +register expptr p; +if(p = V(IOSUNIT)) + { + if( V(IOSFILE) ) + err("inquire by unit or by file, not both"); + ioset(TYIOINT, XUNIT, cpexpr(p) ); + } +else if( ! V(IOSFILE) ) + err("must inquire by unit or by file"); +iosetlc(IOSFILE, XFILE, XFILELEN); +iosetip(IOSEXISTS, XEXISTS); +iosetip(IOSOPENED, XOPEN); +iosetip(IOSNUMBER, XNUMBER); +iosetip(IOSNAMED, XNAMED); +iosetlc(IOSNAME, XNAME, XNAMELEN); +iosetlc(IOSACCESS, XQACCESS, XQACCLEN); +iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); +iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); +iosetlc(IOSFORM, XFORM, XFORMLEN); +iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); +iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); +iosetip(IOSRECL, XQRECL); +iosetip(IOSNEXTREC, XNEXTREC); +iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); + +putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); +} + + + +LOCAL dofmove(subname) +char *subname; +{ +register expptr p; + +if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) + { + ioset(TYIOINT, XUNIT, cpexpr(p) ); + putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); + } +else + err("bad unit in I/O motion statement"); +} + + + +LOCAL ioset(type, offset, p) +int type, offset; +expptr p; +{ +register struct Addrblock *q; + +q = cpexpr(ioblkp); +q->vtype = type; +q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) ); +puteq(q, p); +} + + + + +LOCAL iosetc(offset, p) +int offset; +register expptr p; +{ +if(p == NULL) + ioset(TYADDR, offset, ICON(0) ); +else if(p->headblock.vtype == TYCHAR) + ioset(TYADDR, offset, addrof(cpexpr(p) )); +else + err("non-character control clause"); +} + + + +LOCAL iosetip(i, offset) +int i, offset; +{ +register expptr p; + +if(p = V(i)) + if(p->headblock.tag==TADDR && + ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) + ioset(TYADDR, offset, addrof(cpexpr(p)) ); + else + errstr("impossible inquire parameter %s", ioc[i].iocname); +else + ioset(TYADDR, offset, ICON(0) ); +} + + + +LOCAL iosetlc(i, offp, offl) +int i, offp, offl; +{ +register expptr p; +if( (p = V(i)) && p->headblock.vtype==TYCHAR) + ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); +iosetc(offp, p); +} diff --git a/usr/src/cmd/f77/lex.c b/usr/src/cmd/f77/lex.c new file mode 100644 index 0000000000..16b5cdc53b --- /dev/null +++ b/usr/src/cmd/f77/lex.c @@ -0,0 +1,911 @@ +#include "defs" +#include "tokdefs" + +# define BLANK ' ' +# define MYQUOTE (2) +# define SEOF 0 + +/* card types */ + +# define STEOF 1 +# define STINITIAL 2 +# define STCONTINUE 3 + +/* lex states */ + +#define NEWSTMT 1 +#define FIRSTTOKEN 2 +#define OTHERTOKEN 3 +#define RETEOS 4 + + +LOCAL int stkey; +ftnint yystno; +LOCAL long int stno; +LOCAL long int nxtstno; +LOCAL int parlev; +LOCAL int expcom; +LOCAL int expeql; +LOCAL char *nextch; +LOCAL char *lastch; +LOCAL char *nextcd = NULL; +LOCAL char *endcd; +LOCAL int prevlin; +LOCAL int thislin; +LOCAL int code; +LOCAL int lexstate = NEWSTMT; +LOCAL char s[1390]; +LOCAL char *send = s+20*66; +LOCAL int nincl = 0; + +struct Inclfile + { + struct Inclfile *inclnext; + FILEP inclfp; + char *inclname; + int incllno; + char *incllinp; + int incllen; + int inclcode; + ftnint inclstno; + } ; + +LOCAL struct Inclfile *inclp = NULL; +LOCAL struct Keylist { char *keyname; int keyval; char notinf66; } ; +LOCAL struct Punctlist { char punchar; int punval; }; +LOCAL struct Fmtlist { char fmtchar; int fmtval; }; +LOCAL struct Dotlist { char *dotname; int dotval; }; +LOCAL struct Keylist *keystart[26], *keyend[26]; + + + + +inilex(name) +char *name; +{ +nincl = 0; +inclp = NULL; +doinclude(name); +lexstate = NEWSTMT; +return(NO); +} + + + +/* throw away the rest of the current line */ +flline() +{ +lexstate = RETEOS; +} + + + +char *lexline(n) +ftnint *n; +{ +*n = (lastch - nextch) + 1; +return(nextch); +} + + + + + +doinclude(name) +char *name; +{ +FILEP fp; +struct Inclfile *t; + +if(inclp) + { + inclp->incllno = thislin; + inclp->inclcode = code; + inclp->inclstno = nxtstno; + if(nextcd) + inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd); + else + inclp->incllinp = 0; + } +nextcd = NULL; + +if(++nincl >= MAXINCLUDE) + fatal("includes nested too deep"); +if(name[0] == '\0') + fp = stdin; +else + fp = fopen(name, "r"); +if( fp ) + { + t = inclp; + inclp = ALLOC(Inclfile); + inclp->inclnext = t; + prevlin = thislin = 0; + infname = inclp->inclname = name; + infile = inclp->inclfp = fp; + } +else + { + fprintf(diagfile, "Cannot open file %s", name); + done(1); + } +} + + + + +LOCAL popinclude() +{ +struct Inclfile *t; +register char *p; +register int k; + +if(infile != stdin) + clf(&infile); +free(infname); + +--nincl; +t = inclp->inclnext; +free(inclp); +inclp = t; +if(inclp == NULL) + return(NO); + +infile = inclp->inclfp; +infname = inclp->inclname; +prevlin = thislin = inclp->incllno; +code = inclp->inclcode; +stno = nxtstno = inclp->inclstno; +if(inclp->incllinp) + { + endcd = nextcd = s; + k = inclp->incllen; + p = inclp->incllinp; + while(--k >= 0) + *endcd++ = *p++; + free(inclp->incllinp); + } +else + nextcd = NULL; +return(YES); +} + + + + +yylex() +{ +static int tokno; + + switch(lexstate) + { +case NEWSTMT : /* need a new statement */ + if(getcds() == STEOF) + return(SEOF); + crunch(); + tokno = 0; + lexstate = FIRSTTOKEN; + yystno = stno; + stno = nxtstno; + toklen = 0; + return(SLABEL); + +first: +case FIRSTTOKEN : /* first step on a statement */ + analyz(); + lexstate = OTHERTOKEN; + tokno = 1; + return(stkey); + +case OTHERTOKEN : /* return next token */ + if(nextch > lastch) + goto reteos; + ++tokno; + if((stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) goto first; + if(stkey==SASSIGN && tokno==3 && nextch s) + { + q = nextcd; + p = s; + while(q < endcd) + *p++ = *q++; + endcd = p; + } + for(nextcd = endcd ; + nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ; + nextcd = endcd ) + ; + nextch = s; + lastch = nextcd - 1; + if(nextcd >= send) + nextcd = NULL; + lineno = prevlin; + prevlin = thislin; + return(STINITIAL); +} + +LOCAL getcd(b) +register char *b; +{ +register int c; +register char *p, *bend; +int speclin; +static char a[6]; +static char *aend = a+6; + +top: + endcd = b; + bend = b+66; + speclin = NO; + + if( (c = getc(infile)) == '&') + { + a[0] = BLANK; + a[5] = 'x'; + speclin = YES; + bend = send; + } + else if(c=='c' || c=='C' || c=='*') + { + while( (c = getc(infile)) != '\n') + if(c == EOF) + return(STEOF); + ++thislin; + goto top; + } + + else if(c != EOF) + { + /* a tab in columns 1-6 skips to column 7 */ + ungetc(c, infile); + for(p=a; p lastch) + { + err("unbalanced quotes; closing quote supplied"); + break; + } + if(*i == quote) + if(iprvstr) /* test for Hollerith strings */ + { + if( ! isdigit(j[-1])) goto copychar; + nh = j[-1] - '0'; + ten = 10; + j1 = prvstr - 1; + if (j1j1; -- j0) + { + if( ! isdigit(*j0 ) ) break; + nh += ten * (*j0-'0'); + ten*=10; + } + if(j0 <= j1) goto copychar; +/* a hollerith must be preceded by a punctuation mark. + '*' is possible only as repetition factor in a data statement + not, in particular, in character*2h +*/ + + if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' && + *j0!=',' && *j0!='=' && *j0!='.') + goto copychar; + if(i+nh > lastch) + { + erri("%dH too big", nh); + nh = lastch - i; + } + j0[1] = MYQUOTE; /* special marker */ + j = j0 + 1; + while(nh-- > 0) + { + if(*++i == '\\') + switch(*++i) + { + case 't': + *i = '\t'; break; + case 'b': + *i = '\b'; break; + case 'n': + *i = '\n'; break; + case 'f': + *i = '\f'; break; + case '0': + *i = '\0'; break; + default: + break; + } + *++j = *i; + } + j[1] = MYQUOTE; + j+=2; + prvstr = j; + } + else { + if(*i == '(') ++parlev; + else if(*i == ')') --parlev; + else if(parlev == 0) + if(*i == '=') expeql = 1; + else if(*i == ',') expcom = 1; +copychar: /*not a string or space -- copy, shifting case if necessary */ + if(shiftcase && isupper(*i)) + *j++ = tolower(*i); + else *j++ = *i; + } + } +lastch = j - 1; +nextch = s; +} + +LOCAL analyz() +{ +register char *i; + + if(parlev != 0) + { + err("unbalanced parentheses, statement skipped"); + stkey = SUNKNOWN; + return; + } + if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') + { +/* assignment or if statement -- look at character after balancing paren */ + parlev = 1; + for(i=nextch+3 ; i<=lastch; ++i) + if(*i == (MYQUOTE)) + { + while(*++i != MYQUOTE) + ; + } + else if(*i == '(') + ++parlev; + else if(*i == ')') + { + if(--parlev == 0) + break; + } + if(i >= lastch) + stkey = SLOGIF; + else if(i[1] == '=') + stkey = SLET; + else if( isdigit(i[1]) ) + stkey = SARITHIF; + else stkey = SLOGIF; + if(stkey != SLET) + nextch += 2; + } + else if(expeql) /* may be an assignment */ + { + if(expcom && nextch=nextch) + if(nextch[0]=='(') + stkey = SCOMPGOTO; + else if(isalpha(nextch[0])) + stkey = SASGOTO; + } + parlev = 0; +} + + + +LOCAL getkwd() +{ +register char *i, *j; +register struct Keylist *pk, *pend; +int k; + +if(! isalpha(nextch[0]) ) + return(SUNKNOWN); +k = nextch[0] - 'a'; +if(pk = keystart[k]) + for(pend = keyend[k] ; pk<=pend ; ++pk ) + { + i = pk->keyname; + j = nextch; + while(*++i==*++j && *i!='\0') + ; + if(*i=='\0' && j<=lastch+1) + { + nextch = j; + if(no66flag && pk->notinf66) + errstr("Not a Fortran 66 keyword: %s", + pk->keyname); + return(pk->keyval); + } + } +return(SUNKNOWN); +} + + + +initkey() +{ +extern struct Keylist keys[]; +register struct Keylist *p; +register int i,j; + +for(i = 0 ; i<26 ; ++i) + keystart[i] = NULL; + +for(p = keys ; p->keyname ; ++p) + { + j = p->keyname[0] - 'a'; + if(keystart[j] == NULL) + keystart[j] = p; + keyend[j] = p; + } +} + +LOCAL gettok() +{ +int havdot, havexp, havdbl; +int radix; +extern struct Punctlist puncts[]; +struct Punctlist *pp; +extern struct Fmtlist fmts[]; +extern struct Dotlist dots[]; +struct Dotlist *pd; + +char *i, *j, *n1, *p; + + if(*nextch == (MYQUOTE)) + { + ++nextch; + p = token; + while(*nextch != MYQUOTE) + *p++ = *nextch++; + ++nextch; + toklen = p - token; + *p = '\0'; + return (SHOLLERITH); + } +/* + if(stkey == SFORMAT) + { + for(pf = fmts; pf->fmtchar; ++pf) + { + if(*nextch == pf->fmtchar) + { + ++nextch; + if(pf->fmtval == SLPAR) + ++parlev; + else if(pf->fmtval == SRPAR) + --parlev; + return(pf->fmtval); + } + } + if( isdigit(*nextch) ) + { + p = token; + *p++ = *nextch++; + while(nextch<=lastch && isdigit(*nextch) ) + *p++ = *nextch++; + toklen = p - token; + *p = '\0'; + if(nextch<=lastch && *nextch=='p') + { + ++nextch; + return(SSCALE); + } + else return(SICON); + } + if( isalpha(*nextch) ) + { + p = token; + *p++ = *nextch++; + while(nextch<=lastch && + (*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) )) + *p++ = *nextch++; + toklen = p - token; + *p = '\0'; + return(SFIELD); + } + goto badchar; + } +/* Not a format statement */ + +if(needkwd) + { + needkwd = 0; + return( getkwd() ); + } + + for(pp=puncts; pp->punchar; ++pp) + if(*nextch == pp->punchar) + { + if( (*nextch=='*' || *nextch=='/') && + nextchpunval; + if(yylval==SLPAR) + ++parlev; + else if(yylval==SRPAR) + --parlev; + ++nextch; + } + return(yylval); + } + if(*nextch == '.') + if(nextch >= lastch) goto badchar; + else if(isdigit(nextch[1])) goto numconst; + else { + for(pd=dots ; (j=pd->dotname) ; ++pd) + { + for(i=nextch+1 ; i<=lastch ; ++i) + if(*i != *j) break; + else if(*i != '.') ++j; + else { + nextch = i+1; + return(pd->dotval); + } + } + goto badchar; + } + if( isalpha(*nextch) ) + { + p = token; + *p++ = *nextch++; + while(nextch<=lastch) + if( isalpha(*nextch) || isdigit(*nextch) ) + *p++ = *nextch++; + else break; + toklen = p - token; + *p = '\0'; + if(inioctl && nextch<=lastch && *nextch=='=') + { + ++nextch; + return(SNAMEEQ); + } + if(toklen>=8 && eqn(8, token, "function") && + nextch VL) + { + char buff[30]; + sprintf(buff, "name %s too long, truncated to %d", + token, VL); + err(buff); + toklen = VL; + token[6] = '\0'; + } + if(toklen==1 && *nextch==MYQUOTE) + { + switch(token[0]) + { + case 'z': case 'Z': + case 'x': case 'X': + radix = 16; break; + case 'o': case 'O': + radix = 8; break; + case 'b': case 'B': + radix = 2; break; + default: + err("bad bit identifier"); + return(SNAME); + } + ++nextch; + for(p = token ; *nextch!=MYQUOTE ; ) + if( hextoi(*p++ = *nextch++) >= radix) + { + err("invalid binary character"); + break; + } + ++nextch; + toklen = p - token; + return( radix==16 ? SHEXCON : (radix==8 ? SOCTCON : SBITCON) ); + } + return(SNAME); + } + if( ! isdigit(*nextch) ) goto badchar; +numconst: + havdot = NO; + havexp = NO; + havdbl = NO; + for(n1 = nextch ; nextch<=lastch ; ++nextch) + { + if(*nextch == '.') + if(havdot) break; + else if(nextch+2<=lastch && isalpha(nextch[1]) + && isalpha(nextch[2])) + break; + else havdot = YES; + else if(*nextch=='d' || *nextch=='e') + { + p = nextch; + havexp = YES; + if(*nextch == 'd') + havdbl = YES; + if(nextch + +#ifdef SDB +# include +#endif + + +main(argc, argv) +int argc; +char **argv; +{ +char *s; +int k, retcode, *ip; +FILEP opf(); +int flovflo(); + +#define DONE(c) { retcode = c; goto finis; } + +signal(SIGFPE, flovflo); /* catch overflows */ + +#if HERE == PDP11 + ldfps(01200); /* trap on overflow */ +#endif + + + +--argc; +++argv; + +while(argc>0 && argv[0][0]=='-') + { + for(s = argv[0]+1 ; *s ; ++s) switch(*s) + { + case 'w': + if(s[1]=='6' && s[2]=='6') + { + ftn66flag = YES; + s += 2; + } + else + nowarnflag = YES; + break; + + case 'U': + shiftcase = NO; + break; + + case 'u': + undeftype = YES; + break; + + case 'O': + optimflag = YES; + if( isdigit(s[1]) ) + { + k = *++s - '0'; + if(k > MAXREGVAR) + { + warn1("-O%d: too many register variables", k); + maxregvar = MAXREGVAR; + } + else + maxregvar = k; + } + break; + + case 'd': + debugflag = YES; + break; + + case 'p': + profileflag = YES; + break; + + case 'C': + checksubs = YES; + break; + + case '6': + no66flag = YES; + noextflag = YES; + break; + + case '1': + onetripflag = YES; + break; + +#ifdef SDB + case 'g': + sdbflag = YES; + break; +#endif + + case 'N': + switch(*++s) + { + case 'q': + ip = &maxequiv; goto getnum; + case 'x': + ip = &maxext; goto getnum; + case 's': + ip = &maxstno; goto getnum; + case 'c': + ip = &maxctl; goto getnum; + case 'n': + ip = &maxhash; goto getnum; + + default: + fatali("invalid flag -N%c", *s); + } + getnum: + k = 0; + while( isdigit(*++s) ) + k = 10*k + (*s - '0'); + if(k <= 0) + fatal("Table size too small"); + *ip = k; + break; + + case 'I': + if(*++s == '2') + tyint = TYSHORT; + else if(*s == '4') + { + shortsubs = NO; + tyint = TYLONG; + } + else if(*s == 's') + shortsubs = YES; + else + fatali("invalid flag -I%c\n", *s); + tylogical = tyint; + break; + + default: + fatali("invalid flag %c\n", *s); + } + --argc; + ++argv; + } + +if(argc != 4) + fatali("arg count %d", argc); +asmfile = opf(argv[1]); +initfile = opf(argv[2]); +textfile = opf(argv[3]); + +initkey(); +if(inilex( copys(argv[0]) )) + DONE(1); +fprintf(diagfile, "%s:\n", argv[0]); + +#ifdef SDB +for(s = argv[0] ; ; s += 8) + { + prstab(s,N_SO,0,0); + if( strlen(s) < 8 ) + break; + } +#endif + +fileinit(); +procinit(); +if(k = yyparse()) + { + fprintf(diagfile, "Bad parse, return code %d\n", k); + DONE(1); + } +if(nerr > 0) + DONE(1); +if(parstate != OUTSIDE) + { + warn("missing END statement"); + endproc(); + } +doext(); +preven(ALIDOUBLE); +prtail(); +#if FAMILY==PCC + puteof(); +#endif + +if(nerr > 0) + DONE(1); +DONE(0); + + +finis: + done(retcode); + return(retcode); +} + + + +done(k) +int k; +{ +static int recurs = NO; + +if(recurs == NO) + { + recurs = YES; + clfiles(); + } +exit(k); +} + + +LOCAL FILEP opf(fn) +char *fn; +{ +FILEP fp; +if( fp = fopen(fn, "w") ) + return(fp); + +fatalstr("cannot open intermediate file %s", fn); +/* NOTREACHED */ +} + + + +LOCAL clfiles() +{ +clf(&textfile); +clf(&asmfile); +clf(&initfile); +} + + +clf(p) +FILEP *p; +{ +if(p!=NULL && *p!=NULL && *p!=stdout) + { + if(ferror(*p)) + fatal("writing error"); + fclose(*p); + } +*p = NULL; +} + + + + +flovflo() +{ +err("floating exception during constant evaluation"); +#if HERE == VAX + fatal("vax cannot recover from floating exception"); + /* vax returns a reserved operand that generates + an illegal operand fault on next instruction, + which if ignored causes an infinite loop. + */ +#endif +signal(SIGFPE, flovflo); +} diff --git a/usr/src/cmd/f77/misc.c b/usr/src/cmd/f77/misc.c new file mode 100644 index 0000000000..a40f181558 --- /dev/null +++ b/usr/src/cmd/f77/misc.c @@ -0,0 +1,660 @@ +#include "defs" + + + +cpn(n, a, b) +register int n; +register char *a, *b; +{ +while(--n >= 0) + *b++ = *a++; +} + + + +eqn(n, a, b) +register int n; +register char *a, *b; +{ +while(--n >= 0) + if(*a++ != *b++) + return(NO); +return(YES); +} + + + + + + + +cmpstr(a, b, la, lb) /* compare two strings */ +register char *a, *b; +ftnint la, lb; +{ +register char *aend, *bend; +aend = a + la; +bend = b + lb; + + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return(' ' - *b); + else + ++b; + } + +else + { + while(b < bend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else + ++a; + } +return(0); +} + + + + + +chainp hookup(x,y) +register chainp x, y; +{ +register chainp p; + +if(x == NULL) + return(y); + +for(p = x ; p->nextp ; p = p->nextp) + ; +p->nextp = y; +return(x); +} + + + +struct Listblock *mklist(p) +chainp p; +{ +register struct Listblock *q; + +q = ALLOC(Listblock); +q->tag = TLIST; +q->listp = p; +return(q); +} + + +chainp mkchain(p,q) +register int p, q; +{ +register chainp r; + +if(chains) + { + r = chains; + chains = chains->nextp; + } +else + r = ALLOC(Chain); + +r->datap = p; +r->nextp = q; +return(r); +} + + + +char * varstr(n, s) +register int n; +register char *s; +{ +register int i; +static char name[XL+1]; + +for(i=0; i= 0) + *q++ = *s++; +return(p); +} + + + +char *copys(s) +char *s; +{ +return( copyn( strlen(s)+1 , s) ); +} + + + +ftnint convci(n, s) +register int n; +register char *s; +{ +ftnint sum; +sum = 0; +while(n-- > 0) + sum = 10*sum + (*s++ - '0'); +return(sum); +} + +char *convic(n) +ftnint n; +{ +static char s[20]; +register char *t; + +s[19] = '\0'; +t = s+19; + +do { + *--t = '0' + n%10; + n /= 10; + } while(n > 0); + +return(t); +} + + + +double convcd(n, s) +int n; +register char *s; +{ +double atof(); +char v[100]; +register char *t; +if(n > 90) + { + err("too many digits in floating constant"); + n = 90; + } +for(t = v ; n-- > 0 ; s++) + *t++ = (*s=='d' ? 'e' : *s); +*t = '\0'; +return( atof(v) ); +} + + + +struct Nameblock *mkname(l, s) +int l; +register char *s; +{ +struct Hashentry *hp; +int hash; +register struct Nameblock *q; +register int i; +char n[VL]; + +hash = 0; +for(i = 0 ; ivarp) + if( hash==hp->hashval && eqn(VL,n,q->varname) ) + return(q); + else if(++hp >= lasthash) + hp = hashtab; + +if(++nintnames >= MAXHASH-1) + many("names", 'n'); +hp->varp = q = ALLOC(Nameblock); +hp->hashval = hash; +q->tag = TNAME; +cpn(VL, n, q->varname); +return(q); +} + + + +struct Labelblock *mklabel(l) +ftnint l; +{ +register struct Labelblock *lp; + +if(l <= 0) + return(NULL); + +for(lp = labeltab ; lp < highlabtab ; ++lp) + if(lp->stateno == l) + return(lp); + +if(++highlabtab > labtabend) + many("statement numbers", 's'); + +lp->stateno = l; +lp->labelno = newlabel(); +lp->blklevel = 0; +lp->labused = NO; +lp->labdefined = NO; +lp->labinacc = NO; +lp->labtype = LABUNKNOWN; +return(lp); +} + + +newlabel() +{ +return( ++lastlabno ); +} + + +/* find or put a name in the external symbol table */ + +struct Extsym *mkext(s) +char *s; +{ +int i; +register char *t; +char n[XL]; +struct Extsym *p; + +i = 0; +t = n; +while(iextname)) + return( p ); + +if(nextext >= lastext) + many("external symbols", 'x'); + +cpn(XL, n, nextext->extname); +nextext->extstg = STGUNKNOWN; +nextext->extsave = NO; +nextext->extp = 0; +nextext->extleng = 0; +nextext->maxleng = 0; +nextext->extinit = NO; +return( nextext++ ); +} + + + + + + + + +struct Addrblock *builtin(t, s) +int t; +char *s; +{ +register struct Extsym *p; +register struct Addrblock *q; + +p = mkext(s); +if(p->extstg == STGUNKNOWN) + p->extstg = STGEXT; +else if(p->extstg != STGEXT) + { + errstr("improper use of builtin %s", s); + return(0); + } + +q = ALLOC(Addrblock); +q->tag = TADDR; +q->vtype = t; +q->vclass = CLPROC; +q->vstg = STGEXT; +q->memno = p - extsymtab; +return(q); +} + + + +frchain(p) +register chainp *p; +{ +register chainp q; + +if(p==0 || *p==0) + return; + +for(q = *p; q->nextp ; q = q->nextp) + ; +q->nextp = chains; +chains = *p; +*p = 0; +} + + +ptr cpblock(n,p) +register int n; +register char * p; +{ +register char *q; +ptr q0; + +q = q0 = ckalloc(n); +while(n-- > 0) + *q++ = *p++; +return(q0); +} + + + +max(a,b) +int a,b; +{ +return( a>b ? a : b); +} + + +ftnint lmax(a, b) +ftnint a, b; +{ +return( a>b ? a : b); +} + +ftnint lmin(a, b) +ftnint a, b; +{ +return(a < b ? a : b); +} + + + + +maxtype(t1, t2) +int t1, t2; +{ +int t; + +t = max(t1, t2); +if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) + t = TYDCOMPLEX; +return(t); +} + + + +/* return log base 2 of n if n a power of 2; otherwise -1 */ +#if FAMILY == PCC +log2(n) +ftnint n; +{ +int k; + +/* trick based on binary representation */ + +if(n<=0 || (n & (n-1))!=0) + return(-1); + +for(k = 0 ; n >>= 1 ; ++k) + ; +return(k); +} +#endif + + + +frrpl() +{ +struct Rplblock *rp; + +while(rpllist) + { + rp = rpllist->nextp; + free(rpllist); + rpllist = rp; + } +} + + +popstack(p) +register chainp *p; +{ +register chainp q; + +if(p==NULL || *p==NULL) + fatal("popstack: stack empty"); +q = (*p)->nextp; +free(*p); +*p = q; +} + + + +struct Exprblock *callk(type, name, args) +int type; +char *name; +chainp args; +{ +register struct Exprblock *p; + +p = mkexpr(OPCALL, builtin(type,name), args); +p->vtype = type; +return(p); +} + + + +struct Exprblock *call4(type, name, arg1, arg2, arg3, arg4) +int type; +char *name; +expptr arg1, arg2, arg3, arg4; +{ +struct Listblock *args; +args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, mkchain(arg4, NULL)) ) ) ); +return( callk(type, name, args) ); +} + + + + +struct Exprblock *call3(type, name, arg1, arg2, arg3) +int type; +char *name; +expptr arg1, arg2, arg3; +{ +struct Listblock *args; +args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, NULL) ) ) ); +return( callk(type, name, args) ); +} + + + + + +struct Exprblock *call2(type, name, arg1, arg2) +int type; +char *name; +expptr arg1, arg2; +{ +struct Listblock *args; + +args = mklist( mkchain(arg1, mkchain(arg2, NULL) ) ); +return( callk(type,name, args) ); +} + + + + +struct Exprblock *call1(type, name, arg) +int type; +char *name; +expptr arg; +{ +return( callk(type,name, mklist(mkchain(arg,0)) )); +} + + +struct Exprblock *call0(type, name) +int type; +char *name; +{ +return( callk(type, name, NULL) ); +} + + + +struct Impldoblock *mkiodo(dospec, list) +chainp dospec, list; +{ +register struct Impldoblock *q; + +q = ALLOC(Impldoblock); +q->tag = TIMPLDO; +q->varnp = dospec; +q->datalist = list; +return(q); +} + + + + +ptr ckalloc(n) +register int n; +{ +register ptr p; +ptr calloc(); + +if( p = calloc(1, (unsigned) n) ) + return(p); + +fatal("out of memory"); +/* NOTREACHED */ +} + + + + + +isaddr(p) +register expptr p; +{ +if(p->headblock.tag == TADDR) + return(YES); +if(p->headblock.tag == TEXPR) + switch(p->exprblock.opcode) + { + case OPCOMMA: + return( isaddr(p->exprblock.rightp) ); + + case OPASSIGN: + case OPPLUSEQ: + return( isaddr(p->exprblock.leftp) ); + } +return(NO); +} + + + + + +addressable(p) +register expptr p; +{ +switch(p->headblock.tag) + { + case TCONST: + return(YES); + + case TADDR: + return( addressable(p->addrblock.memoffset) ); + + default: + return(NO); + } +} + + + +hextoi(c) +register int c; +{ +register char *p; +static char p0[17] = "0123456789abcdef"; + +for(p = p0 ; *p ; ++p) + if(*p == c) + return( p-p0 ); +return(16); +} diff --git a/usr/src/cmd/f77/pccdefs b/usr/src/cmd/f77/pccdefs new file mode 100644 index 0000000000..a5c903f586 --- /dev/null +++ b/usr/src/cmd/f77/pccdefs @@ -0,0 +1,68 @@ +#define P2BAD -1 +#define P2NAME 2 +#define P2ICON 4 +#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 + +#if TARGET==PDP11 +# define P2SHORT 4 +# define P2INT 4 +# define P2LONG 5 +#else +# define P2SHORT 3 +# define P2INT 4 +# define P2LONG 4 +#endif + +#define P2CHAR 2 +#define P2REAL 6 +#define P2DREAL 7 +#define P2PTR 020 +#define P2FUNCT 040 diff --git a/usr/src/cmd/f77/proc.c b/usr/src/cmd/f77/proc.c new file mode 100644 index 0000000000..bca826ef02 --- /dev/null +++ b/usr/src/cmd/f77/proc.c @@ -0,0 +1,953 @@ +#include "defs" + +#ifdef SDB +# include +char *stabline(); +#endif + +/* start a new procedure */ + +newproc() +{ +if(parstate != OUTSIDE) + { + execerr("missing end statement", 0); + endproc(); + } + +parstate = INSIDE; +procclass = CLMAIN; /* default */ +} + + + +/* end of procedure. generate variables, epilogs, and prologs */ + +endproc() +{ +struct Labelblock *lp; + +if(parstate < INDATA) + enddcl(); +if(ctlstack >= ctls) + err("DO loop or BLOCK IF not closed"); +for(lp = labeltab ; lp < labtabend ; ++lp) + if(lp->stateno!=0 && lp->labdefined==NO) + errstr("missing statement number %s", convic(lp->stateno) ); + +epicode(); +procode(); +dobss(); +prdbginfo(); + +#if FAMILY == PCC + putbracket(); +#endif + +procinit(); /* clean up for next procedure */ +} + + + +/* End of declaration section of procedure. Allocate storage. */ + +enddcl() +{ +register struct Entrypoint *p; + +parstate = INEXEC; +docommon(); +doequiv(); +docomleng(); +for(p = entries ; p ; p = p->nextp) + doentry(p); +} + +/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ + +/* Main program or Block data */ + +startproc(progname, class) +struct Extsym * progname; +int class; +{ +register struct Entrypoint *p; +char buff[10]; + +p = ALLOC(Entrypoint); +if(class == CLMAIN) + puthead("MAIN__", CLMAIN); +else + puthead(NULL, CLBLOCK); +if(class == CLMAIN) + newentry( mkname(5, "MAIN_") ); +p->entryname = progname; +p->entrylabel = newlabel(); +entries = p; + +procclass = class; +retlabel = newlabel(); +fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); +if(progname) + fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) ); +fprintf(diagfile, ":\n"); +#ifdef SDB +if(sdbflag && class==CLMAIN) + { + sprintf(buff, "L%d", p->entrylabel); + prstab("MAIN_", N_FUN, lineno, buff); + p2pass( stabline("MAIN_", N_FNAME, 0, 0) ); + if(progname) + { + prstab(nounder(XL,progname->extname), N_ENTRY, lineno,buff); +/* p2pass(stabline(nounder(XL,progname->extname),N_FNAME,0,0)); */ + } + } +#endif +} + +/* subroutine or function statement */ + +struct Extsym *newentry(v) +register struct Nameblock *v; +{ +register struct Extsym *p; + +p = mkext( varunder(VL, v->varname) ); + +if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) + { + if(p == 0) + dclerr("invalid entry name", v); + else dclerr("external name already used", v); + return(0); + } +v->vstg = STGAUTO; +v->vprocclass = PTHISPROC; +v->vclass = CLPROC; +p->extstg = STGEXT; +p->extinit = YES; +return(p); +} + + +entrypt(class, type, length, entry, args) +int class, type; +ftnint length; +struct Extsym *entry; +chainp args; +{ +register struct Nameblock *q; +register struct Entrypoint *p; +char buff[10]; + +if(class != CLENTRY) + puthead( varstr(XL, procname = entry->extname), class); +if(class == CLENTRY) + fprintf(diagfile, " entry "); +fprintf(diagfile, " %s:\n", nounder(XL, entry->extname)); +q = mkname(VL, nounder(XL,entry->extname) ); + +if( (type = lengtype(type, (int) length)) != TYCHAR) + length = 0; +if(class == CLPROC) + { + procclass = CLPROC; + proctype = type; + procleng = length; + + retlabel = newlabel(); + if(type == TYSUBR) + ret0label = newlabel(); + } + +p = ALLOC(Entrypoint); +entries = hookup(entries, p); +p->entryname = entry; +p->arglist = args; +p->entrylabel = newlabel(); +p->enamep = q; + +#ifdef SDB +if(sdbflag) + { + sprintf(buff, "L%d", p->entrylabel); + prstab(nounder(XL, entry->extname), + (class==CLENTRY ? N_ENTRY : N_FUN), + lineno, buff); + if(class != CLENTRY) + p2pass( stabline( nounder(XL,entry->extname), N_FNAME, 0, 0) ); + } +#endif + +if(class == CLENTRY) + { + class = CLPROC; + if(proctype == TYSUBR) + type = TYSUBR; + } + +q->vclass = class; +q->vprocclass = PTHISPROC; +settype(q, type, (int) length); +/* hold all initial entry points till end of declarations */ +if(parstate >= INDATA) + doentry(p); +} + +/* generate epilogs */ + +LOCAL epicode() +{ +register int i; + +if(procclass==CLPROC) + { + if(proctype==TYSUBR) + { + putlabel(ret0label); + if(substars) + putforce(TYINT, ICON(0) ); + putlabel(retlabel); + goret(TYSUBR); + } + else { + putlabel(retlabel); + if(multitypes) + { + typeaddr = autovar(1, TYADDR, NULL); + putbranch( cpexpr(typeaddr) ); + for(i = 0; i < NTYPES ; ++i) + if(rtvlabel[i] != 0) + { + putlabel(rtvlabel[i]); + retval(i); + } + } + else + retval(proctype); + } + } + +else if(procclass != CLBLOCK) + { + putlabel(retlabel); + goret(TYSUBR); + } +} + + +/* generate code to return value of type t */ + +LOCAL retval(t) +register int t; +{ +register struct Addrblock *p; + +switch(t) + { + case TYCHAR: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + + case TYLOGICAL: + t = tylogical; + case TYADDR: + case TYSHORT: + case TYLONG: + p = cpexpr(retslot); + p->vtype = t; + putforce(t, p); + break; + + case TYREAL: + case TYDREAL: + p = cpexpr(retslot); + p->vtype = t; + putforce(t, p); + break; + + default: + fatali("retval: impossible type %d", t); + } +goret(t); +} + + +/* Allocate extra argument array if needed. Generate prologs. */ + +LOCAL procode() +{ +register struct Entrypoint *p; +struct Addrblock *argvec; + +#if TARGET==GCOS + argvec = autovar(lastargslot/SZADDR, TYADDR, NULL); +#else + if(lastargslot>0 && nentry>1) +#if TARGET == VAX + argvec = autovar(1 + lastargslot/SZADDR, TYADDR, NULL); +#else + argvec = autovar(lastargslot/SZADDR, TYADDR, NULL); +#endif + else + argvec = NULL; +#endif + + +#if TARGET == PDP11 + /* for the optimizer */ + if(fudgelabel) + putlabel(fudgelabel); +#endif + +for(p = entries ; p ; p = p->nextp) + prolog(p, argvec); + +#if FAMILY == PCC + putrbrack(procno); +#endif + +prendproc(); +} + +/* + manipulate argument lists (allocate argument slot positions) + * keep track of return types and labels + */ + +LOCAL doentry(ep) +struct Entrypoint *ep; +{ +register int type; +register struct Nameblock *np; +chainp p; +register struct Nameblock *q; + +++nentry; +if(procclass == CLMAIN) + { + putlabel(ep->entrylabel); + return; + } +else if(procclass == CLBLOCK) + return; + +impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) ); +type = np->vtype; +if(proctype == TYUNKNOWN) + if( (proctype = type) == TYCHAR) + procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) 0); + +if(proctype == TYCHAR) + { + if(type != TYCHAR) + err("noncharacter entry of character function"); + else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) 0) != procleng) + err("mismatched character entry lengths"); + } +else if(type == TYCHAR) + err("character entry of noncharacter function"); +else if(type != proctype) + multitype = YES; +if(rtvlabel[type] == 0) + rtvlabel[type] = newlabel(); +ep->typelabel = rtvlabel[type]; + +if(type == TYCHAR) + { + if(chslot < 0) + { + chslot = nextarg(TYADDR); + chlgslot = nextarg(TYLENG); + } + np->vstg = STGARG; + np->vardesc.varno = chslot; + if(procleng == 0) + np->vleng = mkarg(TYLENG, chlgslot); + } +else if( ISCOMPLEX(type) ) + { + np->vstg = STGARG; + if(cxslot < 0) + cxslot = nextarg(TYADDR); + np->vardesc.varno = cxslot; + } +else if(type != TYSUBR) + { + if(nentry == 1) + retslot = autovar(1, TYDREAL, NULL); + np->vstg = STGAUTO; + np->voffset = retslot->memoffset->constblock.const.ci; + } + +for(p = ep->arglist ; p ; p = p->nextp) + if(! ((q = p->datap)->vdcldone) ) + q->vardesc.varno = nextarg(TYADDR); + +for(p = ep->arglist ; p ; p = p->nextp) + if(! ((q = p->datap)->vdcldone) ) + { + impldcl(q); + q->vdcldone = YES; +#ifdef SDB + if(sdbflag) + prstab(varstr(VL,q->varname), N_PSYM, + stabtype(q), + convic(q->vardesc.varno + ARGOFFSET) ); +#endif + if(q->vtype == TYCHAR) + { + if(q->vleng == NULL) /* character*(*) */ + q->vleng = mkarg(TYLENG, nextarg(TYLENG) ); + else if(nentry == 1) + nextarg(TYLENG); + } + else if(q->vclass==CLPROC && nentry==1) + nextarg(TYLENG) ; + } + +putlabel(ep->entrylabel); +} + + + +LOCAL nextarg(type) +int type; +{ +int k; +k = lastargslot; +lastargslot += typesize[type]; +return(k); +} + +/* generate variable references */ + +LOCAL dobss() +{ +register struct Hashentry *p; +register struct Nameblock *q; +register int i; +int align; +ftnint leng, iarrl; +char *memname(); +int qstg, qclass, qtype; + +pruse(asmfile, USEBSS); + +for(p = hashtab ; pvarp) + { + qstg = q->vstg; + qtype = q->vtype; + qclass = q->vclass; + +#ifdef SDB + if(sdbflag&&qclass==CLVAR&&(qstg==STGBSS||qstg==STGINIT)) + { + prstab(varstr(VL,q->varname), N_LCSYM, + stabtype(q), memname(qstg,q->vardesc.varno) ); + prstleng(q, iarrlen(q)); + } +#endif + + if( (qclass==CLUNKNOWN && qstg!=STGARG) || + (qclass==CLVAR && qstg==STGUNKNOWN) ) + warn1("local variable %s never used", varstr(VL,q->varname) ); + else if(qclass==CLVAR && qstg==STGBSS) + { + align = (qtype==TYCHAR ? ALILONG : typealign[qtype]); + if(bssleng % align != 0) + { + bssleng = roundup(bssleng, align); + preven(align); + } + prlocvar(memname(STGBSS,q->vardesc.varno), iarrl = iarrlen(q) ); + bssleng += iarrl; + } + else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG) + mkext(varunder(VL, q->varname)) ->extstg = STGEXT; + + if(qclass==CLVAR && qstg!=STGARG) + { + if(q->vdim && !ISICON(q->vdim->nelt) ) + dclerr("adjustable dimension on non-argument", q); + if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng))) + dclerr("adjustable leng on nonargument", q); + } + } + +for(i = 0 ; i < nequiv ; ++i) + if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 ) + { + bssleng = roundup(bssleng, ALIDOUBLE); + preven(ALIDOUBLE); + prlocvar( memname(STGEQUIV, i), leng); + bssleng += leng; + } +} + + + + +doext() +{ +struct Extsym *p; + +for(p = extsymtab ; pextname), p->maxleng, p->extinit); +} + + + + +ftnint iarrlen(q) +register struct Nameblock *q; +{ +ftnint leng; + +leng = typesize[q->vtype]; +if(leng <= 0) + return(-1); +if(q->vdim) + if( ISICON(q->vdim->nelt) ) + leng *= q->vdim->nelt->constblock.const.ci; + else return(-1); +if(q->vleng) + if( ISICON(q->vleng) ) + leng *= q->vleng->constblock.const.ci; + else return(-1); +return(leng); +} + +LOCAL docommon() +{ +register struct Extsym *p; +register chainp q; +struct Dimblock *t; +expptr neltp; +register struct Nameblock *v; +ftnint size; +int type; + +for(p = extsymtab ; pextstg==STGCOMMON) + { +#ifdef SDB + if(sdbflag) + prstab(NULL, N_BCOMM, 0, 0); +#endif + for(q = p->extp ; q ; q = q->nextp) + { + v = q->datap; + if(v->vdcldone == NO) + vardcl(v); + type = v->vtype; + if(p->extleng % typealign[type] != 0) + { + dclerr("common alignment", v); + p->extleng = roundup(p->extleng, typealign[type]); + } + v->voffset = p->extleng; + v->vardesc.varno = p - extsymtab; + if(type == TYCHAR) + size = v->vleng->constblock.const.ci; + else size = typesize[type]; + if(t = v->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) + size *= neltp->constblock.const.ci; + else + dclerr("adjustable array in common", v); + p->extleng += size; +#ifdef SDB + if(sdbflag) + { + prstssym(v); + prstleng(v, size); + } +#endif + } + + frchain( &(p->extp) ); +#ifdef SDB + if(sdbflag) + prstab(varstr(XL,p->extname), N_ECOMM, 0, 0); +#endif + } +} + + + + + +LOCAL docomleng() +{ +register struct Extsym *p; + +for(p = extsymtab ; p < nextext ; ++p) + if(p->extstg == STGCOMMON) + { + if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng + && !eqn(XL,"_BLNK__ ",p->extname) ) + warn1("incompatible lengths for common block %s", + nounder(XL, p->extname) ); + if(p->maxleng < p->extleng) + p->maxleng = p->extleng; + p->extleng = 0; + } +} + + + + +/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ + +frtemp(p) +struct Addrblock *p; +{ +holdtemps = mkchain(p, holdtemps); +} + + + + +/* allocate an automatic variable slot */ + +struct Addrblock *autovar(nelt, t, lengp) +register int nelt, t; +expptr lengp; +{ +ftnint leng; +register struct Addrblock *q; + +if(t == TYCHAR) + if( ISICON(lengp) ) + leng = lengp->constblock.const.ci; + else { + fatal("automatic variable of nonconstant length"); + } +else + leng = typesize[t]; +autoleng = roundup( autoleng, typealign[t]); + +q = ALLOC(Addrblock); +q->tag = TADDR; +q->vtype = t; +if(t == TYCHAR) + q->vleng = ICON(leng); +q->vstg = STGAUTO; +q->ntempelt = nelt; +#if TARGET==PDP11 || TARGET==VAX + /* stack grows downward */ + autoleng += nelt*leng; + q->memoffset = ICON( - autoleng ); +#else + q->memoffset = ICON( autoleng ); + autoleng += nelt*leng; +#endif + +return(q); +} + + +struct Addrblock *mktmpn(nelt, type, lengp) +int nelt; +register int type; +expptr lengp; +{ +ftnint leng; +chainp p, oldp; +register struct Addrblock *q; + +if(type==TYUNKNOWN || type==TYERROR) + fatali("mktmpn: invalid type %d", type); + +if(type==TYCHAR) + if( ISICON(lengp) ) + leng = lengp->constblock.const.ci; + else { + err("adjustable length"); + return( errnode() ); + } +for(oldp = &templist ; p = oldp->nextp ; oldp = p) + { + q = p->datap; + if(q->vtype==type && q->ntempelt==nelt && + (type!=TYCHAR || q->vleng->constblock.const.ci==leng) ) + { + oldp->nextp = p->nextp; + free(p); + return(q); + } + } +q = autovar(nelt, type, lengp); +q->istemp = YES; +return(q); +} + + + + +struct Addrblock *mktemp(type, lengp) +int type; +expptr lengp; +{ +return( mktmpn(1,type,lengp) ); +} + +/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ + +struct Extsym *comblock(len, s) +register int len; +register char *s; +{ +struct Extsym *p; + +if(len == 0) + { + s = BLANKCOMMON; + len = strlen(s); + } +p = mkext( varunder(len, s) ); +if(p->extstg == STGUNKNOWN) + p->extstg = STGCOMMON; +else if(p->extstg != STGCOMMON) + { + errstr("%s cannot be a common block name", s); + return(0); + } + +return( p ); +} + + +incomm(c, v) +struct Extsym *c; +struct Nameblock *v; +{ +if(v->vstg != STGUNKNOWN) + dclerr("incompatible common declaration", v); +else + { + v->vstg = STGCOMMON; + c->extp = hookup(c->extp, mkchain(v,NULL) ); + } +} + + + + +settype(v, type, length) +register struct Nameblock * v; +register int type; +register int length; +{ +if(type == TYUNKNOWN) + return; + +if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) + { + v->vtype = TYSUBR; + frexpr(v->vleng); + } +else if(type < 0) /* storage class set */ + { + if(v->vstg == STGUNKNOWN) + v->vstg = - type; + else if(v->vstg != -type) + dclerr("incompatible storage declarations", v); + } +else if(v->vtype == TYUNKNOWN) + { + if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0) + v->vleng = ICON(length); + } +else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) ) + dclerr("incompatible type declarations", v); +} + + + + + +lengtype(type, length) +register int type; +register int length; +{ +switch(type) + { + case TYREAL: + if(length == 8) + return(TYDREAL); + if(length == 4) + goto ret; + break; + + case TYCOMPLEX: + if(length == 16) + return(TYDCOMPLEX); + if(length == 8) + goto ret; + break; + + case TYSHORT: + case TYDREAL: + case TYDCOMPLEX: + case TYCHAR: + case TYUNKNOWN: + case TYSUBR: + case TYERROR: + goto ret; + + case TYLOGICAL: + if(length == typesize[TYLOGICAL]) + goto ret; + break; + + case TYLONG: + if(length == 0) + return(tyint); + if(length == 2) + return(TYSHORT); + if(length == 4) + goto ret; + break; + default: + fatali("lengtype: invalid type %d", type); + } + +if(length != 0) + err("incompatible type-length combination"); + +ret: + return(type); +} + + + + + +setintr(v) +register struct Nameblock * v; +{ +register int k; + +if(v->vstg == STGUNKNOWN) + v->vstg = STGINTR; +else if(v->vstg!=STGINTR) + dclerr("incompatible use of intrinsic function", v); +if(v->vclass==CLUNKNOWN) + v->vclass = CLPROC; +if(v->vprocclass == PUNKNOWN) + v->vprocclass = PINTRINSIC; +else if(v->vprocclass != PINTRINSIC) + dclerr("invalid intrinsic declaration", v); +if(k = intrfunct(v->varname)) + v->vardesc.varno = k; +else + dclerr("unknown intrinsic function", v); +} + + + +setext(v) +register struct Nameblock * v; +{ +if(v->vclass == CLUNKNOWN) + v->vclass = CLPROC; +else if(v->vclass != CLPROC) + dclerr("invalid external declaration", v); + +if(v->vprocclass == PUNKNOWN) + v->vprocclass = PEXTERNAL; +else if(v->vprocclass != PEXTERNAL) + dclerr("invalid external declaration", v); +} + + + + +/* create dimensions block for array variable */ + +setbound(v, nd, dims) +register struct Nameblock * v; +int nd; +struct { expptr lb, ub; } dims[ ]; +{ +register expptr q, t; +register struct Dimblock *p; +int i; + +if(v->vclass == CLUNKNOWN) + v->vclass = CLVAR; +else if(v->vclass != CLVAR) + { + dclerr("only variables may be arrays", v); + return; + } + +v->vdim = p = (struct Dimblock *) ckalloc(sizeof(int) + (3+2*nd)*sizeof(expptr) ); +p->ndim = nd; +p->nelt = ICON(1); + +for(i=0 ; inelt); + p->nelt = NULL; + } + else + err("only last bound may be asterisk"); + p->dims[i].dimsize = ICON(1);; + p->dims[i].dimexpr = NULL; + } + else + { + if(dims[i].lb) + { + q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); + q = mkexpr(OPPLUS, q, ICON(1) ); + } + if( ISCONST(q) ) + { + p->dims[i].dimsize = q; + p->dims[i].dimexpr = NULL; + } + else { + p->dims[i].dimsize = autovar(1, tyint, NULL); + p->dims[i].dimexpr = q; + } + if(p->nelt) + p->nelt = mkexpr(OPSTAR, p->nelt, + cpexpr(p->dims[i].dimsize) ); + } + } + +q = dims[nd-1].lb; +if(q == NULL) + q = ICON(1); + +for(i = nd-2 ; i>=0 ; --i) + { + t = dims[i].lb; + if(t == NULL) + t = ICON(1); + if(p->dims[i].dimsize) + q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); + } + +if( ISCONST(q) ) + { + p->baseoffset = q; + p->basexpr = NULL; + } +else + { + p->baseoffset = autovar(1, tyint, NULL); + p->basexpr = q; + } +} diff --git a/usr/src/cmd/f77/put.c b/usr/src/cmd/f77/put.c new file mode 100644 index 0000000000..00d91fb6fd --- /dev/null +++ b/usr/src/cmd/f77/put.c @@ -0,0 +1,299 @@ +/* + * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH + * JOHNSON AND RITCHIE FAMILIES OF SECOND PASSES +*/ + +#include "defs" + +#if FAMILY == PCC +# include "pccdefs" +#else +# include "dmrdefs" +#endif + +/* +char *ops [ ] = + { + "??", "+", "-", "*", "/", "**", "-", + "OR", "AND", "EQV", "NEQV", "NOT", + "CONCAT", + "<", "==", ">", "<=", "!=", ">=", + " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ", + " , ", " ? ", " : " + " abs ", " min ", " max ", " addr ", " indirect ", + " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", + }; +*/ + +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, + P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, + P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT + }; + + +int types2 [ ] = + { + P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL, +#if TARGET == INTERDATA + P2BAD, P2BAD, P2LONG, P2CHAR, P2INT, P2BAD +#else + P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD +#endif + }; + + +setlog() +{ +types2[TYLOGICAL] = types2[tylogical]; +typesize[TYLOGICAL] = typesize[tylogical]; +typealign[TYLOGICAL] = typealign[tylogical]; +} + + +putex1(p) +expptr p; +{ +putx( fixtype(p) ); +templist = hookup(templist, holdtemps); +holdtemps = NULL; +} + + + + + +putassign(lp, rp) +expptr lp, rp; +{ +putx( fixexpr( mkexpr(OPASSIGN, lp, rp) )); +} + + + + +puteq(lp, rp) +expptr lp, rp; +{ +putexpr( mkexpr(OPASSIGN, lp, rp) ); +} + + + + +/* put code for a *= b */ + +putsteq(a, b) +expptr a, b; +{ +putx( fixexpr( mkexpr(OPSTAREQ, cpexpr(a), cpexpr(b)) )); +} + + + + + +struct Addrblock *realpart(p) +register struct Addrblock *p; +{ +register struct Addrblock *q; + +q = cpexpr(p); +if( ISCOMPLEX(p->vtype) ) + q->vtype += (TYREAL-TYCOMPLEX); +return(q); +} + + + + +struct Addrblock *imagpart(p) +register struct Addrblock *p; +{ +register struct Addrblock *q; +struct Constblock *mkrealcon(); + +if( ISCOMPLEX(p->vtype) ) + { + q = cpexpr(p); + q->vtype += (TYREAL-TYCOMPLEX); + q->memoffset = mkexpr(OPPLUS, q->memoffset, ICON(typesize[q->vtype])); + } +else + q = mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , 0.0); +return(q); +} + +struct Addrblock *putconst(p) +register struct Constblock *p; +{ +register struct Addrblock *q; +struct Literal *litp, *lastlit; +int i, k, type; +int litflavor; + +if( p->tag != TCONST ) + fatali("putconst: bad tag %d", p->tag); + +q = ALLOC(Addrblock); +q->tag = TADDR; +type = p->vtype; +q->vtype = ( type==TYADDR ? TYINT : type ); +q->vleng = cpexpr(p->vleng); +q->vstg = STGCONST; +q->memno = newlabel(); +q->memoffset = ICON(0); + +/* check for value in literal pool, and update pool if necessary */ + +switch(type = p->vtype) + { + case TYCHAR: + if(p->vleng->constblock.const.ci > XL) + break; /* too long for literal table */ + litflavor = 1; + goto loop; + + case TYREAL: + case TYDREAL: + litflavor = 2; + goto loop; + + case TYLOGICAL: + type = tylogical; + case TYSHORT: + case TYLONG: + litflavor = 3; + + loop: + lastlit = litpool + nliterals; + for(litp = litpool ; litplittype) switch(litflavor) + { + case 1: + if(p->vleng->constblock.const.ci != litp->litval.litcval.litclen) + break; + if(! eqn( (int) p->vleng->constblock.const.ci, p->const.ccp, + litp->litval.litcval.litcstr) ) + break; + + ret: + q->memno = litp->litnum; + frexpr(p); + return(q); + + case 2: + if(p->const.cd[0] == litp->litval.litdval) + goto ret; + break; + + case 3: + if(p->const.ci == litp->litval.litival) + goto ret; + break; + } + if(nliterals < MAXLITERALS) + { + ++nliterals; + litp->littype = type; + litp->litnum = q->memno; + switch(litflavor) + { + case 1: + litp->litval.litcval.litclen = + p->vleng->constblock.const.ci; + cpn( (int) litp->litval.litcval.litclen, + p->const.ccp, + litp->litval.litcval.litcstr); + break; + + case 2: + litp->litval.litdval = p->const.cd[0]; + break; + + case 3: + litp->litval.litival = p->const.ci; + break; + } + } + default: + break; + } + +preven(typealign[ type==TYCHAR ? TYLONG : type ]); +prlabel(asmfile, q->memno); + +k = 1; +switch(type) + { + case TYLOGICAL: + case TYSHORT: + case TYLONG: + prconi(asmfile, type, p->const.ci); + break; + + case TYCOMPLEX: + k = 2; + case TYREAL: + type = TYREAL; + goto flpt; + + case TYDCOMPLEX: + k = 2; + case TYDREAL: + type = TYDREAL; + + flpt: + for(i = 0 ; i < k ; ++i) + prconr(asmfile, type, p->const.cd[i]); + break; + + case TYCHAR: + putstr(asmfile, p->const.ccp, p->vleng->constblock.const.ci); + break; + + case TYADDR: + prcona(asmfile, p->const.ci); + break; + + default: + fatali("putconst: bad type %d", p->vtype); + } + +frexpr(p); +return( q ); +} + +/* + * put out a character string constant. begin every one on + * a long integer boundary, and pad with nulls + */ +putstr(fp, s, n) +FILEP fp; +char *s; +ftnint n; +{ +int b[SZSHORT]; +int i; + +i = 0; +while(--n >= 0) + { + b[i++] = *s++; + if(i == SZSHORT) + { + prchars(fp, b); + i = 0; + } + } + +while(i < SZSHORT) + b[i++] = '\0'; +prchars(fp, b); +} diff --git a/usr/src/cmd/f77/putpcc.c b/usr/src/cmd/f77/putpcc.c new file mode 100644 index 0000000000..93131750d6 --- /dev/null +++ b/usr/src/cmd/f77/putpcc.c @@ -0,0 +1,1519 @@ +/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */ +/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ +#if FAMILY != PCC + WRONG put FULE !!!! +#endif + +#include "defs" +#include "pccdefs" +struct Addrblock *imagpart(); + +#define FOUR 4 +extern int ops2[]; +extern int types2[]; + +#define P2BUFFMAX 128 +static long int p2buff[P2BUFFMAX]; +static long int *p2bufp = &p2buff[0]; +static long int *p2bufend = &p2buff[P2BUFFMAX]; + + +puthead(s, class) +char *s; +int class; +{ +char buff[100]; +#if TARGET == VAX + if(s) + p2ps("\t.globl\t_%s", s); +#endif +/* put out fake copy of left bracket line, to be redone later */ +if( ! headerdone ) + { +#if FAMILY == PCC + p2flush(); +#endif + headoffset = ftell(textfile); + prhead(textfile); + headerdone = YES; + p2triple(P2STMT, (strlen(infname)+FOUR-1)/FOUR, 0); + p2str(infname); +#if TARGET == PDP11 + /* fake jump to start the optimizer */ + if(class != CLBLOCK) + putgoto( fudgelabel = newlabel() ); +#endif + } +} + + + + + +/* It is necessary to precede each procedure with a "left bracket" + * line that tells pass 2 how many register variables and how + * much automatic space is required for the function. This compiler + * does not know how much automatic space is needed until the + * entire procedure has been processed. Therefore, "puthead" + * is called at the begining to record the current location in textfile, + * then to put out a placeholder left bracket line. This procedure + * repositions the file and rewrites that line, then puts the + * file pointer back to the end of the file. + */ + +putbracket() +{ +long int hereoffset; + +#if FAMILY == PCC + p2flush(); +#endif +hereoffset = ftell(textfile); +if(fseek(textfile, headoffset, 0)) + fatal("fseek failed"); +prhead(textfile); +if(fseek(textfile, hereoffset, 0)) + fatal("fseek failed 2"); +} + + + + +putrbrack(k) +int k; +{ +p2op(P2RBRACKET, k); +} + + + +putnreg() +{ +} + + + + + + +puteof() +{ +p2op(P2EOF, 0); +p2flush(); +} + + + +putstmt() +{ +p2triple(P2STMT, 0, lineno); +} + + + + +/* put out code for if( ! p) goto l */ +putif(p,l) +register expptr p; +int l; +{ +register int k; + +if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL) + { + if(k != TYERROR) + err("non-logical expression in IF statement"); + frexpr(p); + } +else + { + putex1(p); + p2icon( (long int) l , P2INT); + p2op(P2CBRANCH, 0); + putstmt(); + } +} + + + + + +/* put out code for goto l */ +putgoto(label) +int label; +{ +p2triple(P2GOTO, 1, label); +putstmt(); +} + + +/* branch to address constant or integer variable */ +putbranch(p) +register struct Addrblock *p; +{ +putex1(p); +p2op(P2GOTO, P2INT); +putstmt(); +} + + + +/* put out label l: */ +putlabel(label) +int label; +{ +p2op(P2LABEL, label); +} + + + + +putexpr(p) +expptr p; +{ +putex1(p); +putstmt(); +} + + + + +putcmgo(index, nlab, labs) +expptr index; +int nlab; +struct Labelblock *labs[]; +{ +int i, labarray, skiplabel; + +if(! ISINT(index->headblock.vtype) ) + { + execerr("computed goto index must be integer", NULL); + return; + } + +#if TARGET == VAX + /* use special case instruction */ + vaxgoto(index, nlab, labs); +#else + labarray = newlabel(); + preven(ALIADDR); + prlabel(asmfile, labarray); + prcona(asmfile, (ftnint) (skiplabel = newlabel()) ); + for(i = 0 ; i < nlab ; ++i) + if( labs[i] ) + prcona(asmfile, (ftnint)(labs[i]->labelno) ); + prcmgoto(index, nlab, skiplabel, labarray); + putlabel(skiplabel); +#endif +} + +putx(p) +expptr p; +{ +struct Addrblock *putcall(), *putcx1(), *realpart(); +char *memname(); +int opc; +int ncomma; +int type, k; + +switch(p->headblock.tag) + { + case TERROR: + free(p); + break; + + case TCONST: + switch(type = p->constblock.vtype) + { + case TYLOGICAL: + type = tyint; + case TYLONG: + case TYSHORT: + p2icon(p->constblock.const.ci, types2[type]); + free(p); + break; + + case TYADDR: + p2triple(P2ICON, 1, P2INT|P2PTR); + p2word(0L); + p2name(memname(STGCONST, + (int) p->constblock.const.ci) ); + free(p); + break; + + default: + putx( putconst(p) ); + break; + } + break; + + case TEXPR: + switch(opc = p->exprblock.opcode) + { + case OPCALL: + case OPCCALL: + if( ISCOMPLEX(p->exprblock.vtype) ) + putcxop(p); + else putcall(p); + break; + + case OPMIN: + case OPMAX: + putmnmx(p); + break; + + + case OPASSIGN: + if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) + || ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) + frexpr( putcxeq(p) ); + else if( ISCHAR(p) ) + putcheq(p); + else + goto putopp; + break; + + case OPEQ: + case OPNE: + if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || + ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) + { + putcxcmp(p); + break; + } + case OPLT: + case OPLE: + case OPGT: + case OPGE: + if(ISCHAR(p->exprblock.leftp)) + putchcmp(p); + else + goto putopp; + break; + + case OPPOWER: + putpower(p); + break; + + case OPSTAR: +#if FAMILY == PCC + /* m * (2**k) -> m<exprblock.leftp->headblock.vtype) && + ISICON(p->exprblock.rightp) && + ( (k = log2(p->exprblock.rightp->constblock.const.ci))>0) ) + { + p->exprblock.opcode = OPLSHIFT; + frexpr(p->exprblock.rightp); + p->exprblock.rightp = ICON(k); + goto putopp; + } +#endif + + case OPMOD: + goto putopp; + case OPPLUS: + case OPMINUS: + case OPSLASH: + case OPNEG: + if( ISCOMPLEX(p->exprblock.vtype) ) + putcxop(p); + else goto putopp; + break; + + case OPCONV: + if( ISCOMPLEX(p->exprblock.vtype) ) + putcxop(p); + else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) + { + ncomma = 0; + putx( mkconv(p->exprblock.vtype, + realpart(putcx1(p->exprblock.leftp, + &ncomma)))); + putcomma(ncomma, p->exprblock.vtype, NO); + free(p); + } + else goto putopp; + break; + + case OPNOT: + case OPOR: + case OPAND: + case OPEQV: + case OPNEQV: + case OPADDR: + case OPPLUSEQ: + case OPSTAREQ: + case OPCOMMA: + case OPQUEST: + case OPCOLON: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + putopp: + putop(p); + break; + + default: + fatali("putx: invalid opcode %d", opc); + } + break; + + case TADDR: + putaddr(p, YES); + break; + + default: + fatali("putx: impossible tag %d", p->headblock.tag); + } +} + + + +LOCAL putop(p) +expptr p; +{ +int k; +expptr lp, tp; +int pt, lt; +int comma; + +switch(p->exprblock.opcode) /* check for special cases and rewrite */ + { + case OPCONV: + pt = p->exprblock.vtype; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + while(p->headblock.tag==TEXPR && + p->exprblock.opcode==OPCONV && + ( (ISREAL(pt)&&ISREAL(lt)) || + (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) + { +#if SZINT < SZLONG + if(lp->headblock.tag != TEXPR) + { + if(pt==TYINT && lt==TYLONG) + break; + if(lt==TYINT && pt==TYLONG) + break; + } +#endif + +#if TARGET == VAX + if(pt==TYDREAL && lt==TYREAL) + { + if(lp->headblock.tag==TEXPR && + lp->exprblock.opcode==OPCONV && + lp->exprblock.leftp->headblock.vtype==TYDREAL) + { + putx(lp->exprblock.leftp); + p2op(P2CONV, P2REAL); + p2op(P2CONV, P2DREAL); + free(p); + return; + } + else break; + } +#endif + + if(lt==TYCHAR && lp->headblock.tag==TEXPR && + lp->exprblock.opcode==OPCALL) + { + p->exprblock.leftp = putcall(lp); + putop(p); + putcomma(1, pt, NO); + free(p); + return; + } + free(p); + p = lp; + pt = lt; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + } + if(p->headblock.tag==TEXPR && p->exprblock.opcode==OPCONV) + break; + putx(p); + return; + + case OPADDR: + comma = NO; + lp = p->exprblock.leftp; + if(lp->headblock.tag != TADDR) + { + tp = mktemp(lp->headblock.vtype, lp->headblock.vleng); + putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); + lp = tp; + comma = YES; + } + putaddr(lp, NO); + if(comma) + putcomma(1, TYINT, NO); + free(p); + return; + } + +if( (k = ops2[p->exprblock.opcode]) <= 0) + fatali("putop: invalid opcode %d", p->exprblock.opcode); +putx(p->exprblock.leftp); +if(p->exprblock.rightp) + putx(p->exprblock.rightp); +p2op(k, types2[p->exprblock.vtype]); + +if(p->exprblock.vleng) + frexpr(p->exprblock.vleng); +free(p); +} + +putforce(t, p) +int t; +expptr p; +{ +p = mkconv(t, fixtype(p)); +putx(p); +p2op(P2FORCE, + (t==TYSHORT ? P2SHORT : (t==TYLONG ? P2LONG : P2DREAL)) ); +putstmt(); +} + + + +LOCAL putpower(p) +expptr p; +{ +expptr base; +struct Addrblock *t1, *t2; +ftnint k; +int type; +int ncomma; + +if(!ISICON(p->exprblock.rightp) || + (k = p->exprblock.rightp->constblock.const.ci)<2) + fatal("putpower: bad call"); +base = p->exprblock.leftp; +type = base->headblock.vtype; +t1 = mktemp(type, NULL); +t2 = NULL; +ncomma = 1; +putassign(cpexpr(t1), cpexpr(base) ); + +for( ; (k&1)==0 && k>2 ; k>>=1 ) + { + ++ncomma; + putsteq(t1, t1); + } + +if(k == 2) + putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ); +else + { + t2 = mktemp(type, NULL); + ++ncomma; + putassign(cpexpr(t2), cpexpr(t1)); + + for(k>>=1 ; k>1 ; k>>=1) + { + ++ncomma; + putsteq(t1, t1); + if(k & 1) + { + ++ncomma; + putsteq(t2, t1); + } + } + putx( mkexpr(OPSTAR, cpexpr(t2), + mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) )); + } +putcomma(ncomma, type, NO); +frexpr(t1); +if(t2) + frexpr(t2); +frexpr(p); +} + + + + +LOCAL struct Addrblock *intdouble(p, ncommap) +struct Addrblock *p; +int *ncommap; +{ +register struct Addrblock *t; + +t = mktemp(TYDREAL, NULL); +++*ncommap; +putassign(cpexpr(t), p); +return(t); +} + + + + + +LOCAL putcxeq(p) +register struct Exprblock *p; +{ +register struct Addrblock *lp, *rp; +int ncomma; + +ncomma = 0; +lp = putcx1(p->leftp, &ncomma); +rp = putcx1(p->rightp, &ncomma); +putassign(realpart(lp), realpart(rp)); +if( ISCOMPLEX(p->vtype) ) + { + ++ncomma; + putassign(imagpart(lp), imagpart(rp)); + } +putcomma(ncomma, TYREAL, NO); +frexpr(rp); +free(p); +return(lp); +} + + + +LOCAL putcxop(p) +expptr p; +{ +struct Addrblock *putcx1(); +int ncomma; + +ncomma = 0; +putaddr( putcx1(p, &ncomma), NO); +putcomma(ncomma, TYINT, NO); +} + + + +LOCAL struct Addrblock *putcx1(p, ncommap) +register expptr p; +int *ncommap; +{ +struct Addrblock *q, *lp, *rp; +register struct Addrblock *resp; +int opcode; +int ltype, rtype; +struct Constblock *mkrealcon(); + +if(p == NULL) + return(NULL); + +switch(p->headblock.tag) + { + case TCONST: + if( ISCOMPLEX(p->constblock.vtype) ) + p = putconst(p); + return( p ); + + case TADDR: + if( ! addressable(p) ) + { + ++*ncommap; + resp = mktemp(tyint, NULL); + putassign( cpexpr(resp), p->addrblock.memoffset ); + p->addrblock.memoffset = resp; + } + return( p ); + + case TEXPR: + if( ISCOMPLEX(p->exprblock.vtype) ) + break; + ++*ncommap; + resp = mktemp(TYDREAL, NO); + putassign( cpexpr(resp), p); + return(resp); + + default: + fatali("putcx1: bad tag %d", p->headblock.tag); + } + +opcode = p->exprblock.opcode; +if(opcode==OPCALL || opcode==OPCCALL) + { + ++*ncommap; + return( putcall(p) ); + } +else if(opcode == OPASSIGN) + { + ++*ncommap; + return( putcxeq(p) ); + } +resp = mktemp(p->exprblock.vtype, NULL); +if(lp = putcx1(p->exprblock.leftp, ncommap) ) + ltype = lp->headblock.vtype; +if(rp = putcx1(p->headblock.rightp, ncommap) ) + rtype = rp->headblock.vtype; + +switch(opcode) + { + case OPCOMMA: + frexpr(resp); + resp = rp; + rp = NULL; + break; + + case OPNEG: + putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), NULL) ); + putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL) ); + *ncommap += 2; + break; + + case OPPLUS: + case OPMINUS: + putassign( realpart(resp), + mkexpr(opcode, realpart(lp), realpart(rp) )); + if(rtype < TYCOMPLEX) + putassign( imagpart(resp), imagpart(lp) ); + else if(ltype < TYCOMPLEX) + { + if(opcode == OPPLUS) + putassign( imagpart(resp), imagpart(rp) ); + else putassign( imagpart(resp), + mkexpr(OPNEG, imagpart(rp), NULL) ); + } + else + putassign( imagpart(resp), + mkexpr(opcode, imagpart(lp), imagpart(rp) )); + + *ncommap += 2; + break; + + case OPSTAR: + if(ltype < TYCOMPLEX) + { + if( ISINT(ltype) ) + lp = intdouble(lp, ncommap); + putassign( realpart(resp), + mkexpr(OPSTAR, cpexpr(lp), realpart(rp) )); + putassign( imagpart(resp), + mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) )); + } + else if(rtype < TYCOMPLEX) + { + if( ISINT(rtype) ) + rp = intdouble(rp, ncommap); + putassign( realpart(resp), + mkexpr(OPSTAR, cpexpr(rp), realpart(lp) )); + putassign( imagpart(resp), + mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) )); + } + else { + putassign( realpart(resp), mkexpr(OPMINUS, + mkexpr(OPSTAR, realpart(lp), realpart(rp)), + mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) )); + putassign( imagpart(resp), mkexpr(OPPLUS, + mkexpr(OPSTAR, realpart(lp), imagpart(rp)), + mkexpr(OPSTAR, imagpart(lp), realpart(rp)) )); + } + *ncommap += 2; + break; + + case OPSLASH: + /* fixexpr has already replaced all divisions + * by a complex by a function call + */ + if( ISINT(rtype) ) + rp = intdouble(rp, ncommap); + putassign( realpart(resp), + mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) ); + putassign( imagpart(resp), + mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) ); + *ncommap += 2; + break; + + case OPCONV: + putassign( realpart(resp), realpart(lp) ); + if( ISCOMPLEX(lp->vtype) ) + q = imagpart(lp); + else if(rp != NULL) + q = realpart(rp); + else + q = mkrealcon(TYDREAL, 0.0); + putassign( imagpart(resp), q); + *ncommap += 2; + break; + + default: + fatali("putcx1 of invalid opcode %d", opcode); + } + +frexpr(lp); +frexpr(rp); +free(p); +return(resp); +} + + + + +LOCAL putcxcmp(p) +register struct Exprblock *p; +{ +int opcode; +int ncomma; +register struct Addrblock *lp, *rp; +struct Exprblock *q; + +ncomma = 0; +opcode = p->opcode; +lp = putcx1(p->leftp, &ncomma); +rp = putcx1(p->rightp, &ncomma); + +q = mkexpr( opcode==OPEQ ? OPAND : OPOR , + mkexpr(opcode, realpart(lp), realpart(rp)), + mkexpr(opcode, imagpart(lp), imagpart(rp)) ); +putx( fixexpr(q) ); +putcomma(ncomma, TYINT, NO); + +free(lp); +free(rp); +free(p); +} + +LOCAL struct Addrblock *putch1(p, ncommap) +register expptr p; +int * ncommap; +{ +register struct Addrblock *t; +struct Addrblock *mktemp(), *putconst(); + +switch(p->headblock.tag) + { + case TCONST: + return( putconst(p) ); + + case TADDR: + return(p); + + case TEXPR: + ++*ncommap; + + switch(p->exprblock.opcode) + { + case OPCALL: + case OPCCALL: + t = putcall(p); + break; + + case OPCONCAT: + t = mktemp(TYCHAR, cpexpr(p->exprblock.vleng) ); + putcat( cpexpr(t), p ); + break; + + case OPCONV: + if(!ISICON(p->exprblock.vleng) + || p->exprblock.vleng->constblock.const.ci!=1 + || ! INT(p->exprblock.leftp->headblock.vtype) ) + fatal("putch1: bad character conversion"); + t = mktemp(TYCHAR, ICON(1) ); + putop( mkexpr(OPASSIGN, cpexpr(t), p) ); + break; + default: + fatali("putch1: invalid opcode %d", + p->exprblock.opcode); + } + return(t); + + default: + fatali("putch1: bad tag %d", p->tag); + } +/* NOTREACHED */ +} + + + + +LOCAL putchop(p) +expptr p; +{ +int ncomma; + +ncomma = 0; +putaddr( putch1(p, &ncomma) , NO ); +putcomma(ncomma, TYCHAR, YES); +} + + + + +LOCAL putcheq(p) +register struct Exprblock *p; +{ +int ncomma; + +ncomma = 0; +if( p->rightp->headblock.tag==TEXPR && p->rightp->exprblock.opcode==OPCONCAT ) + putcat(p->leftp, p->rightp); +else if( ISONE(p->leftp->headblock.vleng) && ISONE(p->rightp->headblock.vleng) ) + { + putaddr( putch1(p->leftp, &ncomma) , YES ); + putaddr( putch1(p->rightp, &ncomma) , YES ); + putcomma(ncomma, TYINT, NO); + p2op(P2ASSIGN, P2CHAR); + } +else + { + putx( call2(TYINT, "s_copy", p->leftp, p->rightp) ); + putcomma(ncomma, TYINT, NO); + } + +frexpr(p->vleng); +free(p); +} + + + + +LOCAL putchcmp(p) +register struct Exprblock *p; +{ +int ncomma; + +ncomma = 0; +if(ISONE(p->leftp->headblock.vleng) && ISONE(p->rightp->headblock.vleng) ) + { + putaddr( putch1(p->leftp, &ncomma) , YES ); + putaddr( putch1(p->rightp, &ncomma) , YES ); + p2op(ops2[p->opcode], P2CHAR); + free(p); + putcomma(ncomma, TYINT, NO); + } +else + { + p->leftp = call2(TYINT,"s_cmp", p->leftp, p->rightp); + p->rightp = ICON(0); + putop(p); + } +} + + + + + +LOCAL putcat(lhs, rhs) +register struct Addrblock *lhs; +register expptr rhs; +{ +int n, ncomma; +struct Addrblock *lp, *cp; + +ncomma = 0; +n = ncat(rhs); +lp = mktmpn(n, TYLENG, NULL); +cp = mktmpn(n, TYADDR, NULL); + +n = 0; +putct1(rhs, lp, cp, &n, &ncomma); + +putx( call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n)) ) ); +putcomma(ncomma, TYINT, NO); +} + + + + + +LOCAL ncat(p) +register expptr p; +{ +if(p->headblock.tag==TEXPR && p->exprblock.opcode==OPCONCAT) + return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) ); +else return(1); +} + + + + +LOCAL putct1(q, lp, cp, ip, ncommap) +register expptr q; +register struct Addrblock *lp, *cp; +int *ip, *ncommap; +{ +int i; +struct Addrblock *lp1, *cp1; + +if(q->headblock.tag==TEXPR && q->exprblock.opcode==OPCONCAT) + { + putct1(q->exprblock.leftp, lp, cp, ip, ncommap); + putct1(q->exprblock.rightp, lp, cp , ip, ncommap); + frexpr(q->exprblock.vleng); + free(q); + } +else + { + i = (*ip)++; + lp1 = cpexpr(lp); + lp1->memoffset = mkexpr(OPPLUS, lp1->memoffset, ICON(i*SZLENG)); + cp1 = cpexpr(cp); + cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR)); + putassign( lp1, cpexpr(q->headblock.vleng) ); + putassign( cp1, addrof(putch1(q,ncommap)) ); + *ncommap += 2; + } +} + +LOCAL putaddr(p, indir) +register struct Addrblock *p; +int indir; +{ +int type, type2, funct; +ftnint offset, simoffset(); +expptr offp, shorten(); + +if( ISERROR(p) || (p->memoffset!=NULL && ISERROR(p->memoffset)) ) + { + frexpr(p); + return; + } + +type = p->vtype; +type2 = types2[type]; +funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0); + +offp = (p->memoffset ? cpexpr(p->memoffset) : NULL); + + +#if (FUDGEOFFSET != 1) +if(offp) + offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp); +#endif + +offset = simoffset( &offp ); +#if SZINT < SZLONG + if(offp) + if(shortsubs) + offp = shorten(offp); + else + offp = mkconv(TYINT, offp); +#else + if(offp) + offp = mkconv(TYINT, offp); +#endif + +switch(p->vstg) + { + case STGAUTO: + if(indir && !offp) + { + p2oreg(offset, AUTOREG, type2); + break; + } + + if(!indir && !offp && !offset) + { + p2reg(AUTOREG, type2 | P2PTR); + break; + } + + p2reg(AUTOREG, type2 | P2PTR); + if(offp) + { + putx(offp); + if(offset) + p2icon(offset, P2INT); + } + else + p2icon(offset, P2INT); + if(offp && offset) + p2op(P2PLUS, type2 | P2PTR); + p2op(P2PLUS, type2 | P2PTR); + if(indir) + p2op(P2INDIRECT, type2); + break; + + case STGARG: + p2oreg( +#ifdef ARGOFFSET + ARGOFFSET + +#endif + (ftnint) (FUDGEOFFSET*p->memno), + ARGREG, type2 | P2PTR | funct ); + + if(offp) + putx(offp); + if(offset) + p2icon(offset, P2INT); + if(offp && offset) + p2op(P2PLUS, type2 | P2PTR); + if(offp || offset) + p2op(P2PLUS, type2 | P2PTR); + if(indir) + p2op(P2INDIRECT, type2); + break; + + case STGLENG: + if(indir) + { + p2oreg( +#ifdef ARGOFFSET + ARGOFFSET + +#endif + (ftnint) (FUDGEOFFSET*p->memno), + ARGREG, type2 ); + } + else { + p2reg(ARGREG, type2 | P2PTR ); + p2icon( +#ifdef ARGOFFSET + ARGOFFSET + +#endif + (ftnint) (FUDGEOFFSET*p->memno), P2INT); + p2op(P2PLUS, type2 | P2PTR ); + } + break; + + + case STGBSS: + case STGINIT: + case STGEXT: + case STGCOMMON: + case STGEQUIV: + case STGCONST: + if(offp) + { + putx(offp); + putmem(p, P2ICON, offset); + p2op(P2PLUS, type2 | P2PTR); + if(indir) + p2op(P2INDIRECT, type2); + } + else + putmem(p, (indir ? P2NAME : P2ICON), offset); + + break; + + case STGREG: + if(indir) + p2reg(p->memno, type2); + else + fatal("attempt to take address of a register"); + break; + + default: + fatali("putaddr: invalid vstg %d", p->vstg); + } +frexpr(p); +} + + + + +LOCAL putmem(p, class, offset) +expptr p; +int class; +ftnint offset; +{ +int type2; +int funct; +char *name, *memname(); + +funct = (p->headblock.vclass==CLPROC ? P2FUNCT<<2 : 0); +type2 = types2[p->headblock.vtype]; +if(p->headblock.vclass == CLPROC) + type2 |= (P2FUNCT<<2); +name = memname(p->addrblock.vstg, p->addrblock.memno); +if(class == P2ICON) + { + p2triple(P2ICON, name[0]!='\0', type2|P2PTR); + p2word(offset); + if(name[0]) + p2name(name); + } +else + { + p2triple(P2NAME, offset!=0, type2); + if(offset != 0) + p2word(offset); + p2name(name); + } +} + + + +LOCAL struct Addrblock *putcall(p) +struct Exprblock *p; +{ +chainp arglist, charsp, cp; +int n, first; +struct Addrblock *t; +struct Exprblock *q; +struct Exprblock *fval; +int type, type2, ctype, indir; + +type2 = types2[type = p->vtype]; +charsp = NULL; +indir = (p->opcode == OPCCALL); +n = 0; +first = YES; + +if(p->rightp) + { + arglist = p->rightp->listblock.listp; + free(p->rightp); + } +else + arglist = NULL; + +for(cp = arglist ; cp ; cp = cp->nextp) + if(indir) + ++n; + else { + q = cp->datap; + if(q->tag == TCONST) + cp->datap = q = putconst(q); + if( ISCHAR(q) ) + { + charsp = hookup(charsp, mkchain(cpexpr(q->vleng), 0) ); + n += 2; + } + else if(q->vclass == CLPROC) + { + charsp = hookup(charsp, mkchain( ICON(0) , 0)); + n += 2; + } + else + n += 1; + } + +if(type == TYCHAR) + { + if( ISICON(p->vleng) ) + { + fval = mktemp(TYCHAR, p->vleng); + n += 2; + } + else { + err("adjustable character function"); + return; + } + } +else if( ISCOMPLEX(type) ) + { + fval = mktemp(type, NULL); + n += 1; + } +else + fval = NULL; + +ctype = (fval ? P2INT : type2); +putaddr(p->leftp, NO); + +if(fval) + { + first = NO; + putaddr( cpexpr(fval), NO); + if(type==TYCHAR) + { + putx( mkconv(TYLENG,p->vleng) ); + p2op(P2LISTOP, type2); + } + } + +for(cp = arglist ; cp ; cp = cp->nextp) + { + q = cp->datap; + if(q->tag==TADDR && (indir || q->vstg!=STGREG) ) + putaddr(q, indir && q->vtype!=TYCHAR); + else if( ISCOMPLEX(q->vtype) ) + putcxop(q); + else if (ISCHAR(q) ) + putchop(q); + else if( ! ISERROR(q) ) + { + if(indir) + putx(q); + else { + t = mktemp(q->vtype, q->vleng); + putassign( cpexpr(t), q ); + putaddr(t, NO); + putcomma(1, q->vtype, YES); + } + } + if(first) + first = NO; + else + p2op(P2LISTOP, type2); + } + +if(arglist) + frchain(&arglist); +for(cp = charsp ; cp ; cp = cp->nextp) + { + putx( mkconv(TYLENG,cp->datap) ); + p2op(P2LISTOP, type2); + } +frchain(&charsp); +p2op(n>0 ? P2CALL : P2CALL0 , ctype); +free(p); +return(fval); +} + + + +LOCAL putmnmx(p) +register struct Exprblock *p; +{ +int op, type; +int ncomma; +struct Exprblock *qp; +chainp p0, p1; +struct Addrblock *sp, *tp; + +type = p->vtype; +op = (p->opcode==OPMIN ? OPLT : OPGT ); +p0 = p->leftp->listblock.listp; +free(p->leftp); +free(p); + +sp = mktemp(type, NULL); +tp = mktemp(type, NULL); +qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp)); +qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp); +qp = fixexpr(qp); + +ncomma = 1; +putassign( cpexpr(sp), p0->datap ); + +for(p1 = p0->nextp ; p1 ; p1 = p1->nextp) + { + ++ncomma; + putassign( cpexpr(tp), p1->datap ); + if(p1->nextp) + { + ++ncomma; + putassign( cpexpr(sp), cpexpr(qp) ); + } + else + putx(qp); + } + +putcomma(ncomma, type, NO); +frtemp(sp); +frtemp(tp); +frchain( &p0 ); +} + + + + +LOCAL putcomma(n, type, indir) +int n, type, indir; +{ +type = types2[type]; +if(indir) + type |= P2PTR; +while(--n >= 0) + p2op(P2COMOP, type); +} + + + + +ftnint simoffset(p0) +expptr *p0; +{ +ftnint offset, prod; +register expptr p, lp, rp; + +offset = 0; +p = *p0; +if(p == NULL) + return(0); + +if( ! ISINT(p->headblock.vtype) ) + return(0); + +if(p->headblock.tag==TEXPR && p->exprblock.opcode==OPSTAR) + { + lp = p->exprblock.leftp; + rp = p->exprblock.rightp; + if(ISICON(rp) && lp->headblock.tag==TEXPR && + lp->exprblock.opcode==OPPLUS && ISICON(lp->exprblock.rightp)) + { + p->exprblock.opcode = OPPLUS; + lp->opcode = OPSTAR; + prod = rp->constblock.const.ci * + lp->exprblock.rightp->constblock.const.ci; + lp->exprblock.rightp->constblock.const.ci = rp->constblock.const.ci; + rp->constblock.const.ci = prod; + } + } + +if(p->headblock.tag==TEXPR && p->exprblock.opcode==OPPLUS && + ISICON(p->exprblock.rightp)) + { + rp = p->exprblock.rightp; + lp = p->exprblock.leftp; + offset += rp->constblock.const.ci; + frexpr(rp); + free(p); + *p0 = lp; + } + +if(p->headblock.tag == TCONST) + { + offset += p->constblock.const.ci; + frexpr(p); + *p0 = NULL; + } + +return(offset); +} + + + + + +p2op(op, type) +int op, type; +{ +p2triple(op, 0, type); +} + +p2icon(offset, type) +ftnint offset; +int type; +{ +p2triple(P2ICON, 0, type); +p2word(offset); +} + + + + +p2oreg(offset, reg, type) +ftnint offset; +int reg, type; +{ +p2triple(P2OREG, reg, type); +p2word(offset); +p2name(""); +} + + + + +p2reg(reg, type) +int reg, type; +{ +p2triple(P2REG, reg, type); +} + + + +p2pi(s, i) +char *s; +int i; +{ +char buff[100]; +sprintf(buff, s, i); +p2pass(buff); +} + + + +p2pij(s, i, j) +char *s; +int i, j; +{ +char buff[100]; +sprintf(buff, s, i, j); +p2pass(buff); +} + + + + +p2ps(s, t) +char *s, *t; +{ +char buff[100]; +sprintf(buff, s, t); +p2pass(buff); +} + + + + +p2pass(s) +char *s; +{ +p2triple(P2PASS, (strlen(s) + FOUR-1)/FOUR, 0); +p2str(s); +} + + + + +p2str(s) +register char *s; +{ +union { long int word; char str[FOUR]; } u; +register int i; + +i = 0; +u.word = 0; +while(*s) + { + u.str[i++] = *s++; + if(i == FOUR) + { + p2word(u.word); + u.word = 0; + i = 0; + } + } +if(i > 0) + p2word(u.word); +} + + + + +p2triple(op, var, type) +int op, var, type; +{ +register long word; +word = op | (var<<8); +word |= ( (long int) type) <<16; +p2word(word); +} + + + + +p2name(s) +char *s; +{ +int i; +union { long int word[2]; char str[8]; } u; + +u.word[0] = u.word[1] = 0; +for(i = 0 ; i<8 && *s ; ++i) + u.str[i] = *s++; +p2word(u.word[0]); +p2word(u.word[1]); +} + + + + +p2word(w) +long int w; +{ +*p2bufp++ = w; +if(p2bufp >= p2bufend) + p2flush(); +} + + + +p2flush() +{ +if(p2bufp > p2buff) + write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int)); +p2bufp = p2buff; +} diff --git a/usr/src/cmd/f77/tokdefs b/usr/src/cmd/f77/tokdefs new file mode 100644 index 0000000000..2984d4076e --- /dev/null +++ b/usr/src/cmd/f77/tokdefs @@ -0,0 +1,95 @@ +#define SEOS 1 +#define SCOMMENT 2 +#define SLABEL 3 +#define SUNKNOWN 4 +#define SHOLLERITH 5 +#define SICON 6 +#define SRCON 7 +#define SDCON 8 +#define SBITCON 9 +#define SOCTCON 10 +#define SHEXCON 11 +#define STRUE 12 +#define SFALSE 13 +#define SNAME 14 +#define SNAMEEQ 15 +#define SFIELD 16 +#define SSCALE 17 +#define SINCLUDE 18 +#define SLET 19 +#define SASSIGN 20 +#define SAUTOMATIC 21 +#define SBACKSPACE 22 +#define SBLOCK 23 +#define SCALL 24 +#define SCHARACTER 25 +#define SCLOSE 26 +#define SCOMMON 27 +#define SCOMPLEX 28 +#define SCONTINUE 29 +#define SDATA 30 +#define SDCOMPLEX 31 +#define SDIMENSION 32 +#define SDO 33 +#define SDOUBLE 34 +#define SELSE 35 +#define SELSEIF 36 +#define SEND 37 +#define SENDFILE 38 +#define SENDIF 39 +#define SENTRY 40 +#define SEQUIV 41 +#define SEXTERNAL 42 +#define SFORMAT 43 +#define SFUNCTION 44 +#define SGOTO 45 +#define SASGOTO 46 +#define SCOMPGOTO 47 +#define SARITHIF 48 +#define SLOGIF 49 +#define SIMPLICIT 50 +#define SINQUIRE 51 +#define SINTEGER 52 +#define SINTRINSIC 53 +#define SLOGICAL 54 +#define SOPEN 55 +#define SPARAM 56 +#define SPAUSE 57 +#define SPRINT 58 +#define SPROGRAM 59 +#define SPUNCH 60 +#define SREAD 61 +#define SREAL 62 +#define SRETURN 63 +#define SREWIND 64 +#define SSAVE 65 +#define SSTATIC 66 +#define SSTOP 67 +#define SSUBROUTINE 68 +#define STHEN 69 +#define STO 70 +#define SUNDEFINED 71 +#define SWRITE 72 +#define SLPAR 73 +#define SRPAR 74 +#define SEQUALS 75 +#define SCOLON 76 +#define SCOMMA 77 +#define SCURRENCY 78 +#define SPLUS 79 +#define SMINUS 80 +#define SSTAR 81 +#define SSLASH 82 +#define SPOWER 83 +#define SCONCAT 84 +#define SAND 85 +#define SOR 86 +#define SNEQV 87 +#define SEQV 88 +#define SNOT 89 +#define SEQ 90 +#define SLT 91 +#define SGT 92 +#define SLE 93 +#define SGE 94 +#define SNE 95 diff --git a/usr/src/cmd/f77/tokens b/usr/src/cmd/f77/tokens new file mode 100644 index 0000000000..3868cea4e8 --- /dev/null +++ b/usr/src/cmd/f77/tokens @@ -0,0 +1,95 @@ +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 +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 diff --git a/usr/src/cmd/f77/vax.c b/usr/src/cmd/f77/vax.c new file mode 100644 index 0000000000..f5b722c0b3 --- /dev/null +++ b/usr/src/cmd/f77/vax.c @@ -0,0 +1,546 @@ +#include "defs" + +#ifdef SDB +# include +extern int types2[]; +#endif + +#include "pccdefs" + +/* + PDP11-780/VAX - SPECIFIC ROUTINES +*/ + + +int maxregvar = MAXREGVAR; +int regnum[] = { 11, 10, 9, 8, 7, 6 } ; +static int regmask[] = { 0, 0x800, 0xc00, 0xe00, 0xf00, 0xf80, 0xfc0 }; + + + +ftnint intcon[14] = + { 2, 2, 2, 2, + 15, 31, 24, 56, + -128, -128, 127, 127, + 32767, 2147483647 }; + +#if HERE == VAX + /* then put in constants in octal */ +long realcon[6][2] = + { + { 0200, 0 }, + { 0200, 0 }, + { 037777677777, 0 }, + { 037777677777, 037777777777 }, + { 032200, 0 }, + { 022200, 0 } + }; +#else +double realcon[6] = + { + 2.9387358771e-39, + 2.938735877055718800e-39 + 1.7014117332e+38, + 1.701411834604692250e+38 + 5.960464e-8, + 1.38777878078144567e-17, + }; +#endif + + + + +prsave() +{ +int proflab; +p2pi("\t.word\t0x%x", regmask[highregvar]); /* register variable mask */ +if(profileflag) + { + proflab = newlabel(); + fprintf(asmfile, "L%d:\t.space\t4\n", proflab); + p2pi("\tmovab\tL%d,r0", proflab); + p2pass("\tjsb\tmcount"); + } +p2pi("\tsubl2\t$.F%d,sp", procno); +} + + + +goret(type) +int type; +{ +p2pass("\tret"); +} + + + + +/* + * move argument slot arg1 (relative to ap) + * to slot arg2 (relative to ARGREG) + */ + +mvarg(type, arg1, arg2) +int type, arg1, arg2; +{ +p2pij("\tmovl\t%d(ap),%d(fp)", arg1+ARGOFFSET, arg2+argloc); +} + + + + +prlabel(fp, k) +FILEP fp; +int k; +{ +fprintf(fp, "L%d:\n", k); +} + + + +prconi(fp, type, n) +FILEP fp; +int type; +ftnint n; +{ +fprintf(fp, "\t%s\t%ld\n", (type==TYSHORT ? ".word" : ".long"), n); +} + + + +prcona(fp, a) +FILEP fp; +ftnint a; +{ +fprintf(fp, "\t.long\tL%ld\n", a); +} + + + +#ifndef vax +prconr(fp, type, x) +FILEP fp; +int type; +float x; +{ +fprintf(fp, "\t%s\t0f%e\n", (type==TYREAL ? ".float" : ".double"), x); +} +#endif + +#ifdef vax +prconr(fp, type, x) +FILEP fp; +int type; +double x; +{ +long int *n; +n = &x; /* nonportable cheat */ +if(type == TYREAL) + fprintf(fp, "\t.long\t0x%X\n", n[0]); +else + fprintf(fp, "\t.long\t0x%X,0x%X\n", n[0], n[1]); +} +#endif + + + + + + + +preven(k) +int k; +{ +register int lg; + +if(k > 4) + lg = 3; +else if(k > 2) + lg = 2; +else if(k > 1) + lg = 1; +else + return; +fprintf(asmfile, "\t.align\t%d\n", lg); +} + + + +vaxgoto(index, nlab, labs) +expptr index; +register int nlab; +struct Labelblock *labs[]; +{ +register int i; +register int arrlab; + +putforce(TYINT, index); +p2pi("\tcasel\tr0,$1,$%d", nlab-1); +p2pi("L%d:", arrlab = newlabel() ); +for(i = 0; i< nlab ; ++i) + if( labs[i] ) + p2pij("\t.word\tL%d-L%d", labs[i]->labelno, arrlab); +} + + +prarif(p, neg, zer, pos) +expptr p; +int neg, zer, pos; +{ +putforce(p->headblock.vtype, p); +if( ISINT(p->headblock.vtype) ) + p2pass("\ttstl\tr0"); +else + p2pass("\ttstd\tr0"); +p2pi("\tjlss\tL%d", neg); +p2pi("\tjeql\tL%d", zer); +p2pi("\tjbr\tL%d", pos); +} + + + + +char *memname(stg, mem) +int stg, mem; +{ +static char s[20]; + +switch(stg) + { + case STGCOMMON: + case STGEXT: + sprintf(s, "_%s", varstr(XL, extsymtab[mem].extname) ); + break; + + case STGBSS: + case STGINIT: + sprintf(s, "v.%d", mem); + break; + + case STGCONST: + sprintf(s, "L%d", mem); + break; + + case STGEQUIV: + sprintf(s, "q.%d", mem+eqvstart); + break; + + default: + fatali("memname: invalid vstg %d", stg); + } +return(s); +} + + + + +prlocvar(s, len) +char *s; +ftnint len; +{ +fprintf(asmfile, "\t.lcomm\t%s,%ld\n", s, len); +} + + + +prext(name, leng, init) +char *name; +ftnint leng; +int init; +{ +if(leng == 0) + fprintf(asmfile, "\t.globl\t_%s\n", name); +else + fprintf(asmfile, "\t.comm\t_%s,%ld\n", name, leng); +} + + + + + +prendproc() +{ +} + + + + +prtail() +{ +} + + + + + +prolog(ep, argvec) +struct Entrypoint *ep; +struct Addrblock *argvec; +{ +int i, argslot, proflab; +int size; +register chainp p; +register struct Nameblock *q; +register struct Dimblock *dp; +expptr tp; + +if(procclass == CLMAIN) + p2pass( "_MAIN__:" ); +if(ep->entryname) + p2ps("_%s:", varstr(XL, ep->entryname->extname)); +if(procclass == CLBLOCK) + return; +prsave(); +if(argvec) + { + argloc = argvec->memoffset->constblock.const.ci + SZINT; + /* first slot holds count */ + if(proctype == TYCHAR) + { + mvarg(TYADDR, 0, chslot); + mvarg(TYLENG, SZADDR, chlgslot); + argslot = SZADDR + SZLENG; + } + else if( ISCOMPLEX(proctype) ) + { + mvarg(TYADDR, 0, cxslot); + argslot = SZADDR; + } + else + argslot = 0; + + for(p = ep->arglist ; p ; p =p->nextp) + { + q = p->datap; + mvarg(TYADDR, argslot, q->vardesc.varno); + argslot += SZADDR; + } + for(p = ep->arglist ; p ; p = p->nextp) + { + q = p->datap; + if(q->vtype==TYCHAR || q->vclass==CLPROC) + { + if(q->vleng && q->vleng->headblock.tag!=TCONST) + mvarg(TYLENG, argslot, + q->vleng->nameblock.vardesc.varno); + argslot += SZLENG; + } + } + p2pi("\taddl3\t$%d,fp,ap", argloc-ARGOFFSET); + p2pi("\tmovl\t$%d,(ap)\n", lastargslot/SZADDR); + } + +for(p = ep->arglist ; p ; p = p->nextp) + { + q = p->datap; + if(dp = q->vdim) + { + for(i = 0 ; i < dp->ndim ; ++i) + if(dp->dims[i].dimexpr) + puteq( fixtype(cpexpr(dp->dims[i].dimsize)), + fixtype(cpexpr(dp->dims[i].dimexpr))); + size = typesize[ q->vtype ]; + if(q->vtype == TYCHAR) + if( ISICON(q->vleng) ) + size *= q->vleng->constblock.const.ci; + else + size = -1; + + /* on VAX, get more efficient subscripting if subscripts + have zero-base, so fudge the argument pointers for arrays. + Not done if array bounds are being checked. + */ + if(dp->basexpr) + puteq( cpexpr(fixtype(dp->baseoffset)), + cpexpr(fixtype(dp->basexpr))); + + if(! checksubs) + { + if(dp->basexpr) + { + if(size > 0) + tp = ICON(size); + else + tp = cpexpr(q->vleng); + putforce(TYINT, + fixtype( mkexpr(OPSTAR, tp, + cpexpr(dp->baseoffset)) )); + p2pi("\tsubl2\tr0,%d(ap)", + p->datap->nameblock.vardesc.varno + + ARGOFFSET); + } + else if(dp->baseoffset->constblock.const.ci != 0) + { + char buff[25]; + if(size > 0) + { + sprintf(buff, "\tsubl2\t$%ld,%d(ap)", + dp->baseoffset->constblock.const.ci * size, + p->datap->nameblock.vardesc.varno + + ARGOFFSET); + } + else { + putforce(TYINT, mkexpr(OPSTAR, cpexpr(dp->baseoffset), + cpexpr(q->vleng) )); + sprintf(buff, "\tsubl2\tr0,%d(ap)", + p->datap->nameblock.vardesc.varno + + ARGOFFSET); + } + p2pass(buff); + } + } + } + } + +if(typeaddr) + puteq( cpexpr(typeaddr), mkaddcon(ep->typelabel) ); +/* replace to avoid long jump problem +putgoto(ep->entrylabel); +*/ +p2pi("\tjmp\tL%d", ep->entrylabel); +} + + + + +prhead(fp) +FILEP fp; +{ +#if FAMILY==PCC + p2triple(P2LBRACKET, ARGREG-highregvar, procno); + p2word( (long) (BITSPERCHAR*autoleng) ); + p2flush(); +#endif +} + + + +prdbginfo() +{ +} + +#ifdef SDB + + +# ifdef UCBVAXASM + char *stabdline(code, type) + int code; + int type; + { + static char buff[30]; + + sprintf(buff, "\t.stabd\t0%o,0,0%o\n", code, type); + return(buff); + } +# endif + + +prstab(s, code, type, loc) +char *s, *loc; +int code, type; +{ +char * stabline(); + +if(sdbflag) + fprintf(asmfile, stabline(s,code,type,loc) ); +} + + + +char *stabline(s, code, type, loc) +register char *s; +int code; +int type; +char *loc; +{ +static char buff[50] = "\t.stab\t\t"; +register char *t; +register int i = 0; + +#ifdef UCBVAXASM +t = buff + 8; +if(s == NULL) + buff[6] = 'n'; /* .stabn line */ +else + { + buff[6] = 's'; /* .stabs line */ + *t++ = '"'; + while(*s!='\0' && *s!=' ' && i<8) + { + *t++ = *s++; + ++i; + } + *t++ = '"'; + *t++ = ','; + } + +#else + t = buff + 7; + if(s) + while( *s!='\0' && *s!=' ' && i<8 ) + { + *t++ = '\''; + *t++ = *s++; + *t++ = ','; + ++i; + } + for( ; i<8 ; ++i) + { + *t++ = '0'; + *t++ = ','; + } +#endif + + +sprintf(t, "0%o,0,0%o,%s\n", code, type, (loc? loc : "0") ); +return(buff); +} + + + +prstleng(np, leng) +register struct Nameblock *np; +ftnint leng; +{ +ftnint iarrlen(); + +prstab( varstr(XL,np->varname), N_LENG, 0, convic(leng) ); +} + + + +stabtype(p) +register struct Nameblock *p; +{ +register int type; +register int shift; +type = types2[p->vtype]; +if(p->vdim) + { + type |= 060; /* .stab code for array */ + shift = 2; + } +else if(p->vclass == CLPROC) + { + type |= 040; /* .stab code for function */ + shift = 2; + } +else + shift = 0; + +if(p->vstg == STGARG) + type |= (020 << shift); /* code for pointer-to */ + +return(type); +} + + + + +prstssym(np) +register struct Nameblock *np; +{ +prstab(varstr(VL,np->varname), N_SSYM, + stabtype(np), convic(np->voffset) ); +} +#endif diff --git a/usr/src/cmd/f77/vaxdefs b/usr/src/cmd/f77/vaxdefs new file mode 100644 index 0000000000..928022810a --- /dev/null +++ b/usr/src/cmd/f77/vaxdefs @@ -0,0 +1,56 @@ +#ifndef TARGET +TARGET NOT DEFINED !!! +#endif +#if TARGET!=VAX +Target= TARGET OUT OF RANGE!! +#endif + +#ifndef FAMILY +FAMILY NOT DEFINED!!! +#endif +#if FAMILY!=PCC && FAMILY!=DMR +Family = FAMILY OUT OF RANGE +#endif + +#define SDB 1 + +#define TYLENG TYLONG + +#define TYINT TYLONG +#define SZADDR 4 +#define SZSHORT 2 +#define SZINT 4 + +#define SZLONG 4 +#define SZLENG SZLONG + +#define ALIADDR SZADDR +#define ALISHORT SZSHORT +#define ALILONG 4 +#define ALIDOUBLE 4 +#define ALIINT ALILONG +#define ALILENG ALILONG + +#define AUTOREG 13 +#define ARGREG 12 +#define CARGREG 12 +#define ARGOFFSET 4 +#define SAVESPACE 40 + + +#define FUDGEOFFSET 1 +#define BITSPERCHAR 8 +#define XL 8 + +#define USETEXT ".text" +#define USECONST ".data\t0" +#define USEBSS ".data\t1" +#define USEINIT ".data\t2" + +#define BLANKCOMMON "_BLNK_" + +#define LABELFMT "%s:\n" + +#define MAXREGVAR 4 +#define TYIREG TYLONG +#define MSKIREG (M(TYSHORT)|M(TYLONG)) diff --git a/usr/src/cmd/f77/vaxx.c b/usr/src/cmd/f77/vaxx.c new file mode 100644 index 0000000000..e58123fdb3 --- /dev/null +++ b/usr/src/cmd/f77/vaxx.c @@ -0,0 +1,42 @@ +#include +#include "defines" +#include "machdefs" + + + +prchars(fp, s) +FILEP fp; +int *s; +{ + +fprintf(fp, ".byte 0%o,0%o\n", s[0], s[1]); +} + + + +pruse(fp, s) +FILEP fp; +char *s; +{ +fprintf(fp, "\t%s\n", s); +} + + + +prskip(fp, k) +FILEP fp; +ftnint k; +{ +fprintf(fp, "\t.space\t%ld\n", k); +} + + + + + +prcomblock(fp, name) +FILEP fp; +char *name; +{ +fprintf(fp, LABELFMT, name); +} -- 2.20.1