From 0d57d6f5b835a23d0e3a1a0ac933b74d10474bec Mon Sep 17 00:00:00 2001 From: Tom London Date: Thu, 16 Nov 1978 21:41:16 -0500 Subject: [PATCH] Bell 32V development Work on file usr/src/cmd/f77/defs Work on file usr/src/cmd/f77/defines Work on file usr/src/cmd/f77/drivedefs Work on file usr/src/cmd/f77/ftypes Work on file usr/src/cmd/f77/scjdefs Work on file usr/src/cmd/f77/fio.h Work on file usr/src/cmd/f77/tokens Work on file usr/src/cmd/f77/driver.c Work on file usr/src/cmd/f77/main.c Work on file usr/src/cmd/f77/proc.c Work on file usr/src/cmd/f77/init.c Work on file usr/src/cmd/f77/gram.head Work on file usr/src/cmd/f77/gram.dcl Work on file usr/src/cmd/f77/gram.expr Work on file usr/src/cmd/f77/gram.exec Work on file usr/src/cmd/f77/gram.io Work on file usr/src/cmd/f77/equiv.c Work on file usr/src/cmd/f77/data.c Work on file usr/src/cmd/f77/expr.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/misc.c Work on file usr/src/cmd/f77/error.c Work on file usr/src/cmd/f77/put.c Work on file usr/src/cmd/f77/vax.c Work on file usr/src/cmd/f77/vaxx.c Work on file usr/src/cmd/f77/vaxdefs Co-Authored-By: John Reiser Synthesized-from: 32v --- usr/src/cmd/f77/data.c | 316 ++++++ usr/src/cmd/f77/defines | 241 ++++ usr/src/cmd/f77/defs | 440 ++++++++ usr/src/cmd/f77/drivedefs | 29 + usr/src/cmd/f77/driver.c | 1106 +++++++++++++++++++ usr/src/cmd/f77/equiv.c | 264 +++++ usr/src/cmd/f77/error.c | 95 ++ usr/src/cmd/f77/expr.c | 2171 +++++++++++++++++++++++++++++++++++++ usr/src/cmd/f77/fio.h | 101 ++ usr/src/cmd/f77/ftypes | 21 + usr/src/cmd/f77/gram.dcl | 318 ++++++ usr/src/cmd/f77/gram.exec | 111 ++ usr/src/cmd/f77/gram.expr | 125 +++ usr/src/cmd/f77/gram.head | 155 +++ usr/src/cmd/f77/gram.io | 156 +++ usr/src/cmd/f77/init.c | 256 +++++ usr/src/cmd/f77/intr.c | 560 ++++++++++ usr/src/cmd/f77/io.c | 734 +++++++++++++ usr/src/cmd/f77/main.c | 180 +++ usr/src/cmd/f77/misc.c | 660 +++++++++++ usr/src/cmd/f77/proc.c | 888 +++++++++++++++ usr/src/cmd/f77/put.c | 296 +++++ usr/src/cmd/f77/scjdefs | 68 ++ usr/src/cmd/f77/tokens | 95 ++ usr/src/cmd/f77/vax.c | 355 ++++++ usr/src/cmd/f77/vaxdefs | 54 + usr/src/cmd/f77/vaxx.c | 42 + 27 files changed, 9837 insertions(+) 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/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.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/main.c create mode 100644 usr/src/cmd/f77/misc.c 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/scjdefs 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/data.c b/usr/src/cmd/f77/data.c new file mode 100644 index 0000000000..3ac8b331f1 --- /dev/null +++ b/usr/src/cmd/f77/data.c @@ -0,0 +1,316 @@ +#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 struct constblock *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->const.ci >= 0) + nrep = repp->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; +struct constblock *mkintcon(); + +while(curdtp) + { + p = curdtp->datap; + if(p->tag == TIMPLDO) + { + ip = p; + if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) + fatal1("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->const.ci; + frexpr(q); + } + else + ip->impdiff = 1; + + q = fixtype(cpexpr(ip->impub)); + if(! ISICON(q)) + goto doerr; + ip->implim = q->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->argsp==NULL && np->vdim!=NULL) + { /* array initialization */ + q = mkaddr(np); + off = typesize[np->vtype] * curdtelt; + if(np->vtype == TYCHAR) + off *= np->vleng->const.ci; + q->memoffset = mkexpr(OPPLUS, q->memoffset, mkintcon(off) ); + if( (neltp = np->vdim->nelt) && ISCONST(neltp)) + { + if(++curdtelt < neltp->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->vtype == TYCHAR) + if(ISICON(q->vleng)) + *elenp = q->vleng->const.ci; + else { + err("initialization of string of nonconstant length"); + continue; + } + else *elenp = typesize[q->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->const.ci : typesize[np->vtype]); + if(np->vdim) + *vlenp *= np->vdim->nelt->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->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->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->const.ci; + while( k-- > 0) + { + fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR); + fprintf(initfile, "\t%d\n", ' '); + } + break; + + default: + fatal1("setdata: impossible type %d", type); + } + +} + + + +frdata(p0) +chainp p0; +{ +register chainp p; +register tagptr q; + +for(p = p0 ; p ; p = p->nextp) + { + q = p->datap; + if(q->tag == TIMPLDO) + { + if(q->isbusy) + return; /* circular chain completed */ + q->isbusy = YES; + frdata(q->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..cb44024413 --- /dev/null +++ b/usr/src/cmd/f77/defines @@ -0,0 +1,241 @@ +#define INTERDATA 2 +#define GCOS 3 +#define PDP11 4 +#define IBM 5 +#define CMACH 6 +#define VAX 7 + +#define DMR 2 +#define SCJ 3 + +#define BINARY 2 +#define ASCII 3 + +#define PREFIX 2 +#define POSTFIX 3 + +#ifndef FAMILY +FAMILY NOT DEFINED !!! +Family = FAMILY +#endif + +#ifndef HERE +HERE NOT DEFINED !!!! +Here = HERE +#endif + +#ifndef OUTPUT +OUTPUT NOT DEFINED!!!! +Output = OUTPUT +#endif + +#ifndef POLISH +POLISH NOT DEFINED !!! +Polish = POLISH +#endif + +#define M(x) (1<tag==TCONST && ISINT(z->vtype)) +#define ISCHAR(z) (z->vtype==TYCHAR) +#define ISINT(z) ONEOF(z, MSKINT) +#define ISCONST(z) (z->tag==TCONST) +#define ISERROR(z) (z->tag==TERROR) +#define ISPLUSOP(z) (z->tag==TEXPR && z->opcode==OPPLUS) +#define ISSTAROP(z) (z->tag==TEXPR && z->opcode==OPSTAR) +#define ISONE(z) (ISICON(z) && z->const.ci==1) +#define INT(z) ONEOF(z, MSKINT|MSKCHAR) +#define ICON(z) mkintcon( (ftnint)(z) ) +#define CHCON(z) mkstrcon(strlen(z), z) + +/* 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..a4e1f8f8b1 --- /dev/null +++ b/usr/src/cmd/f77/defs @@ -0,0 +1,440 @@ +#include + +#ifdef unix +# include +#endif + +#include "ftypes" +#include "defines" +#include "locdefs" + +#define VL 6 + +#define MAXINCLUDES 10 +#define MAXLITERALS 20 +#define MAXCTL 20 +#define MAXHASH 401 +#define MAXSTNO 201 +#define MAXEXT 200 +#define MAXEQUIV 150 +#define MAXLABLIST 100 + +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 flag profileflag; +extern flag optimflag; +extern flag nowarnflag; +extern flag ftn66flag; +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 chainp holdtemps; +extern struct entrypoint *entries; +extern struct rplblock *rpllist; +extern chainp 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 nintnames; +extern int nextnames; + +struct chain + { + chainp nextp; + tagptr datap; + }; + +extern chainp chains; + +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; + int 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 exprblock; + struct addrblock; + struct constblock; + struct errorblock; + struct listblock; + struct 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; + chainp 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 nameblock; + struct paramblock; + struct exprblock; + struct constblock; + struct listblock; + struct addrblock; + struct errorblock; + struct primblock; + struct 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(); diff --git a/usr/src/cmd/f77/drivedefs b/usr/src/cmd/f77/drivedefs new file mode 100644 index 0000000000..a330f9d0b3 --- /dev/null +++ b/usr/src/cmd/f77/drivedefs @@ -0,0 +1,29 @@ +/* + Driver for Fortran 77 Compiler + For the VAX, Running on the VAX, + Using the Ritchie C compiler's second pass +*/ + +#if HERE!=VAX || TARGET!=VAX || FAMILY!=SCJ + Wrong Definitions File! +#endif + +#define PASS1NAME "/usr/lib/f77pass1" +#define PASS2NAME "/lib/f1" +#define PASS2OPT "/lib/c2" +#define NOFLPASS2 "/lib/fc1" +#define ASMNAME "/bin/as" +#define LDNAME "/bin/ld" +#define FOOTNAME "/lib/crt0.o" +#define PROFFOOT "/lib/mcrt0.o" +#define NOFLFOOT "/lib/fcrt0.o" +#define NOFLPROFFOOT "/lib/fmcrt0.o" + +static char *liblist [ ] = + { + "-lF77", + "-lI77", + "-lm", + "-lc", + "-l", + NULL }; diff --git a/usr/src/cmd/f77/driver.c b/usr/src/cmd/f77/driver.c new file mode 100644 index 0000000000..bfcc268fcb --- /dev/null +++ b/usr/src/cmd/f77/driver.c @@ -0,0 +1,1106 @@ +char *xxxvers[] = "\n FORTRAN 77 DRIVER, VERSION 1.11, 28 JULY 1978\n"; +#include +#include +#include "defines" +#include "locdefs" +#include "drivedefs" +#include "ftypes" +#include + +static FILEP diagfile = {stderr} ; +static int pid; +static int sigivalue = 0; +static int sigqvalue = 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[30] = "-"; +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 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, 1) & 01; +sigqvalue = (int) signal(SIGQUIT,1) & 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: + fatal1("bad option -T%c", *s); + } + break; + + case 'w': + if(s[1]=='6' && s[2]=='6') + { + *fflagp++ = *s++; + *fflagp++ = *s++; + } + + copyfflag: + case 'u': + case 'U': + case 'M': + case '1': + case 'C': + *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 '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; + } + +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) )) + { + rmf(prepfname); + 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) + { + loadflag = NO; + rmf(fortfile); + break; + } + + if( ! fortonly ) + { + infname = argv[i] = lastfield(argv[i]); + *lastchar(infname) = 'f'; + + if( dofort(argv[i]) ) + loadflag = NO; + else { + if( nodup(t = setdoto(argv[i])) ) + *loadp++ = t; + rmf(fortfile); + } + } + break; + + case 'f': /* Fortran file */ + case 'F': + if( unreadable(argv[i]) ) + break; + if( dofort(argv[i]) ) + loadflag = NO; + else if( nodup(t=setdoto(argv[i])) ) + *loadp++ = t; + break; + + case 'c': /* C file */ + case 's': /* Assembler file */ + if( unreadable(argv[i]) ) + break; +#if HERE==PDP11 || HERE==VAX + fprintf(diagfile, "%s:\n", argv[i]); +#endif + sprintf(buff, "cc -c %s", argv[i] ); + if( sys(buff) ) + loadflag = NO; + 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) + doload(loadargs, loadp); +done(0); +} + +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 == SCJ +# 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) + { + if( sys(sprintf(buff, "%s %s %s", PASS2OPT, asmpass2, optzfname)) ) + rmf(optzfname); + else + sys(sprintf(buff,"mv %s %s", optzfname, asmpass2)); + } +#endif +#endif + +if(saveasmflag) + { + *lastc = 's'; +#if TARGET == INTERDATA + sys( sprintf(buff, "cat %s %s %s >%s", + asmfname, setfname, asmpass2, obj) ); +#else + sys( sprintf(buff, "cat %s %s >%s", + asmfname, asmpass2, obj) ); +#endif + *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 */ + sys(sprintf(buff, "cat %s >>%s", asmpass2, asmfname)); + 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 */ + + fatal1("Cannot load %s",path+9); + } + +return( await(waitpid) ); +} + + + + + +#include + +/* 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) + fatal1("%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); +} + + + + +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); + loadflag = NO; + 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; +{ +#include +#include +struct stat buf; +if(stat(filename,&buf) < 0) + return(-1); +else + return( buf.st_size > 0 ); +} + + + + +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; +{ +fatal1("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) ); +} + + + + + +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 fatal1(t,d) +char *t, *d; +{ +char buff[100]; +fatal( sprintf(buff, t, d) ); +} + + + + +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 vchar; +int size, align; +int vargroup; +ftnint totlen, doeven(); + +erred = NO; +ovarname[0] = '\0'; +ooffset = 0; +ovlen = 0; +totlen = 0; +nch = 0; + +if(status = sys( sprintf(buff, "sort %s >%s", initfname, sortfname) ) ) + fatal1("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 ? 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) ) + fatal("bad intermediate file format"); + prch( (int) vchar ); + } + 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 ; ieqvbottom = 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->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) + { + 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); + } + p->eqvtop -= p->eqvbottom; + p->eqvbottom = 0; + } + 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) + { + err1("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; + +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; + 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: + fatal1("eqvcommon: impossible vstg %d", np->vstg); + } + } + +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..7cfa33b9e4 --- /dev/null +++ b/usr/src/cmd/f77/error.c @@ -0,0 +1,95 @@ +#include "defs" + + +warn1(s,t) +char *s, *t; +{ +char buff[100]; +warn( sprintf(buff, s, t) ); +} + + +warn(s) +char *s; +{ +if(nowarnflag) + return; +fprintf(diagfile, "Warning on line %d of %s: %s\n", lineno, infname, s); +++nwarn; +} + + + +err2(s,t,u) +char *s, *t, *u; +{ +char buff[100]; +err( sprintf(buff, s, t, u) ); +} + + +err1(s,t) +char *s, *t; +{ +char buff[100]; +err( sprintf(buff, s, t) ); +} + + +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) + err( sprintf(buff, "Declaration error for %s: %s", varstr(VL, v->varname), s) ); +else + err1("Declaration error %s", s); +} + + + +execerr(s, n) +char *s, *n; +{ +char buf1[100], buf2[100]; + +sprintf(buf1, "Execution error %s", s); +err( sprintf(buf2, buf1, n) ); +} + + +fatal(t) +char *t; +{ +fprintf(diagfile, "Compiler error line %d of %s: %s\n", lineno, infname, t); +if(debugflag) + abort(); +done(3); +exit(3); +} + + + + +fatal1(t,d) +char *t, *d; +{ +char buff[100]; +fatal( sprintf(buff, t, d) ); +} diff --git a/usr/src/cmd/f77/expr.c b/usr/src/cmd/f77/expr.c new file mode 100644 index 0000000000..992c87a783 --- /dev/null +++ b/usr/src/cmd/f77/expr.c @@ -0,0 +1,2171 @@ +#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->vtype; +itype = imagp->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->const.ci; + else p->const.cd[0] = realp->const.cd[0]; + if( ISINT(itype) ) + p->const.cd[1] = imagp->const.ci; + else p->const.cd[1] = imagp->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; + +if(t==TYUNKNOWN || t==TYERROR) + fatal1("mkconv of impossible type %d", t); +if(t == p->vtype) + return(p); + +else if( ISCONST(p) && p->vtype!=TYADDR) + { + q = mkconst(t); + consconv(t, &(q->const), p->vtype, &(p->const)); + frexpr(p); + } +else + { + q = mkexpr(OPCONV, p, 0); + q->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->tag) == TNAME) + return(p); + +e = cpblock( blksize[p->tag] , p); + +switch(tag) + { + case TCONST: + if(e->vtype == TYCHAR) + { + e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp); + e->vleng = cpexpr(e->vleng); + } + case TERROR: + break; + + case TEXPR: + e->leftp = cpexpr(p->leftp); + e->rightp = cpexpr(p->rightp); + break; + + case TLIST: + if(pp = p->listp) + { + ep = e->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->vleng = cpexpr(e->vleng); + e->memoffset = cpexpr(e->memoffset); + e->istemp = NO; + break; + + case TPRIM: + e->argsp = cpexpr(e->argsp); + e->fcharp = cpexpr(e->fcharp); + e->lcharp = cpexpr(e->lcharp); + break; + + default: + fatal1("cpexpr: impossible tag %d", tag); + } + +return(e); +} + +frexpr(p) +register tagptr p; +{ +register chainp q; + +if(p == NULL) + return; + +switch(p->tag) + { + case TCONST: + if( ISCHAR(p) ) + { + free(p->const.ccp); + frexpr(p->vleng); + } + break; + + case TADDR: + if(p->istemp) + { + frtemp(p); + return; + } + frexpr(p->vleng); + frexpr(p->memoffset); + break; + + case TERROR: + break; + + case TNAME: + return; + + case TPRIM: + frexpr(p->argsp); + frexpr(p->fcharp); + frexpr(p->lcharp); + break; + + case TEXPR: + frexpr(p->leftp); + if(p->rightp) + frexpr(p->rightp); + break; + + case TLIST: + for(q = p->listp ; q ; q = q->nextp) + frexpr(q->datap); + frchain( &(p->listp) ); + break; + + default: + fatal1("frexpr: impossible tag %d", p->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->tag) + { + case TCONST: + if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) ) + p = putconst(p); + return(p); + + case TADDR: + p->memoffset = fixtype(p->memoffset); + return(p); + + case TERROR: + return(p); + + default: + fatal1("fixtype: impossible tag %d", p->tag); + + case TEXPR: + return( fixexpr(p) ); + + case TLIST: + return( p ); + + case TPRIM: + if(p->argsp && p->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) + fatal1("fixexpr: invalid tag %d", p->tag); +opcode = p->opcode; +lp = p->leftp = fixtype(p->leftp); +ltype = lp->vtype; +if(opcode==OPASSIGN && lp->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->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->vleng), + cpexpr(rp->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==SCJ + && 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->tag==TEXPR && lp->opcode==OPCOMMA) + { + lp->rightp = fixtype( mkconv(ptype, lp->rightp) ); + free(p); + p = lp; + } + break; + + case OPADDR: + if(lp->tag==TEXPR && lp->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->vtype != TYLONG) + return(p); + +switch(p->tag) + { + case TERROR: + case TLIST: + return(p); + + case TCONST: + case TADDR: + return( mkconv(TYINT,p) ); + + case TEXPR: + break; + + default: + fatal1("shorten: invalid tag %d", p->tag); + } + +switch(p->opcode) + { + case OPPLUS: + case OPMINUS: + case OPSTAR: + q = shorten( cpexpr(p->rightp) ); + if(q->vtype == TYINT) + { + p->leftp = shorten(p->leftp); + if(p->leftp->vtype == TYLONG) + frexpr(q); + else + { + frexpr(p->rightp); + p->rightp = q; + p->vtype = TYINT; + } + } + break; + + case OPNEG: + p->leftp = shorten(p->leftp); + if(p->leftp->vtype == TYINT) + p->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 *mkaddr(); + +nargs = 0; +if(p0) + for(p = p0->listp ; p ; p = p->nextp) + { + ++nargs; + q = p->datap; + qtag = q->tag; + if(qtag == TCONST) + { + if(q->vtype == TYSHORT) + q = mkconv(tyint, q); + if(doput) + p->datap = putconst(q); + else + p->datap = q; + } + else if(qtag==TPRIM && q->argsp==0 && q->namep->vclass==CLPROC) + p->datap = mkaddr(q->namep); + else if(qtag==TPRIM && q->argsp==0 && q->namep->vdim!=NULL) + p->datap = mkscalar(q->namep); + else if(qtag==TPRIM && q->argsp==0 && q->namep->vdovar && + (t = memversion(q->namep)) ) + p->datap = fixtype(t); + else p->datap = fixtype(q); + } +return(nargs); +} + + +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, 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 *mkext(), *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) + fatal1("invalid class code 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); + q->vtype = np->vtype; + 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: + fatal1("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; +type = np->vtype; +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->vtype && q->vtype!=TYCHAR + && (ap->tag==TCONST || ap->tag==TADDR) ) + { + rp->rplvp = ap; + rp->rplxp = NULL; + rp->rpltag = ap->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; + } + +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) + err1("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[8]; +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 > 7) + { + err("more than 7 subscripts"); + break; + } + } + +dimp = np->vdim; +if(n>0 && dimp==NULL) + err("subscripts on scalar variable"); +else if(dimp && dimp->ndim!=n) + err1("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->const.ci < 0) + goto badsub; + if( ISICON(dimp->nelt) ) + if(p->const.ci < dimp->nelt->const.ci) + return(p); + else + goto badsub; + } +if(p->tag==TADDR && p->vstg==STGREG) + { + checkvar = cpexpr(p); + t = p; + } +else { + checkvar = mktemp(p->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->vtype, "s_rnge", mkstrcon(VL, np->varname), + mkconv(TYLONG, cpexpr(checkvar)), + mkstrcon(XL, procname), ICON(lineno)); +badcall->opcode = OPCCALL; +p = mkexpr(OPQUEST, checkcond, + mkexpr(OPCOLON, checkvar, badcall)); + +return(p); + +badsub: + frexpr(p); + err1("subscript on variable %s out of range", varstr(VL,np->varname)); + return ( ICON(0) ); +} + + + + +struct addrblock *mkaddr(p) +register struct nameblock *p; +{ +struct extsym *mkext(), *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; + 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); +fatal1("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; struct nameblock; } *v; +struct listblock *args; +expptr lstr, rstr; +{ +register struct primblock *p; + +if(v->vclass == CLPARAM) + { + if(args || lstr || rstr) + { + err1("no qualifiers on parameter name", varstr(VL,v->varname)); + frexpr(args); + frexpr(lstr); + frexpr(rstr); + frexpr(v); + return( errnode() ); + } + return( cpexpr(v->paramval) ); + } + +p = ALLOC(primblock); +p->tag = TPRIM; +p->vtype = v->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->const.ci; + else + dclerr("adjustable automatic array", v); + p = autovar(nelt, v->vtype, v->vleng); + v->voffset = p->memoffset->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->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->vtype; +ltag = lp->tag; +if(rp && opcode!=OPCALL && opcode!=OPCCALL) + { + rtype = rp->vtype; + rtag = rp->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->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->const.ci == 1) + goto retleft; + + if(rp->const.ci == -1) + { + frexpr(rp); + return( mkexpr(OPNEG, lp, 0) ); + } + } + + if( ISSTAROP(lp) && ISICON(lp->rightp) ) + { + if(opcode == OPSTAR) + e = mkexpr(OPSTAR, lp->rightp, rp); + else if(ISICON(rp) && lp->rightp->const.ci % rp->const.ci == 0) + e = mkexpr(OPSLASH, lp->rightp, rp); + else break; + + e1 = lp->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->const.ci == 0) + goto retleft; + if( ISPLUSOP(lp) && ISICON(lp->rightp) ) + { + e = mkexpr(OPPLUS, lp->rightp, rp); + e1 = lp->leftp; + free(lp); + return( mkexpr(OPPLUS, e1, e) ); + } + } + break; + + + case OPPOWER: + break; + + case OPNEG: + if(ltag==TEXPR && lp->opcode==OPNEG) + { + e = lp->leftp; + free(lp); + return(e); + } + break; + + case OPNOT: + if(ltag==TEXPR && lp->opcode==OPNOT) + { + e = lp->leftp; + free(lp); + return(e); + } + break; + + case OPCALL: + case OPCCALL: + etype = ltype; + if(rp!=NULL && rp->listp==NULL) + { + free(rp); + rp = NULL; + } + break; + + case OPAND: + case OPOR: + if( ISCONST(lp) ) + COMMUTE + + if( ISCONST(rp) ) + { + if(rp->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: + fatal1("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); + 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: + fatal1("cktype: impossible opcode %d", op); + } +error: err(errs); +error1: return(TYERROR); +} + +LOCAL expptr fold(e) +register struct exprblock *e; +{ +struct constblock *p; +register expptr lp, rp; +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->vtype; +rp = e->rightp; + +if(rp == 0) + switch(opcode) + { + case OPNOT: + lp->const.ci = ! lp->const.ci; + return(lp); + + case OPBITNOT: + lp->const.ci = ~ lp->const.ci; + return(lp); + + case OPNEG: + consnegop(lp); + return(lp); + + case OPCONV: + case OPADDR: + return(e); + + default: + fatal1("fold: invalid unary operator %d", opcode); + } + +rtype = rp->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->const.ci && rp->const.ci; + break; + + case OPOR: + p->const.ci = lp->const.ci || rp->const.ci; + break; + + case OPEQV: + p->const.ci = lp->const.ci == rp->const.ci; + break; + + case OPNEQV: + p->const.ci = lp->const.ci != rp->const.ci; + break; + + case OPBITAND: + p->const.ci = lp->const.ci & rp->const.ci; + break; + + case OPBITOR: + p->const.ci = lp->const.ci | rp->const.ci; + break; + + case OPBITXOR: + p->const.ci = lp->const.ci ^ rp->const.ci; + break; + + case OPLSHIFT: + p->const.ci = lp->const.ci << rp->const.ci; + break; + + case OPRSHIFT: + p->const.ci = lp->const.ci >> rp->const.ci; + break; + + case OPCONCAT: + ll = lp->vleng->const.ci; + lr = rp->vleng->const.ci; + p->const.ccp = q = (char *) ckalloc(ll+lr); + p->vleng = ICON(ll+lr); + s = lp->const.ccp; + for(i = 0 ; i < ll ; ++i) + *q++ = *s++; + s = rp->const.ccp; + for(i = 0; i < lr; ++i) + *q++ = *s++; + break; + + + case OPPOWER: + if( ! ISINT(rtype) ) + return(e); + conspower(&(p->const), lp, rp->const.ci); + break; + + + default: + if(ltype == TYCHAR) + { + lcon.ci = cmpstr(lp->const.ccp, rp->const.ccp, + lp->vleng->const.ci, rp->vleng->const.ci); + rcon.ci = 0; + mtype = tyint; + } + else { + mtype = maxtype(ltype, rtype); + consconv(mtype, &lcon, ltype, &(lp->const) ); + consconv(mtype, &rcon, rtype, &(rp->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 TYSHORT: + case TYLONG: + 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: + fatal1("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: + fatal1("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->vtype) + { + case TYSHORT: + case TYLONG: + if(p->const.ci > 0) return(1); + if(p->const.ci < 0) return(-1); + return(0); + + case TYREAL: + case TYDREAL: + if(p->const.cd[0] > 0) return(1); + if(p->const.cd[0] < 0) return(-1); + return(0); + + case TYCOMPLEX: + case TYDCOMPLEX: + return(p->const.cd[0]!=0 || p->const.cd[1]!=0); + + default: + fatal1( "conssgn(type %d)", p->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->vtype; +rtype = rp->vtype; + +if(ISICON(rp)) + { + if(rp->const.ci == 0) + { + frexpr(p); + if( ISINT(ltype) ) + return( ICON(1) ); + else + return( putconst( mkconv(ltype, ICON(1))) ); + } + if(rp->const.ci < 0) + { + if( ISINT(ltype) ) + { + frexpr(p); + err("integer**negative"); + return( errnode() ); + } + rp->const.ci = - rp->const.ci; + p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp)); + } + if(rp->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) + 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..8cb28b386c --- /dev/null +++ b/usr/src/cmd/f77/ftypes @@ -0,0 +1,21 @@ + +/* 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) diff --git a/usr/src/cmd/f77/gram.dcl b/usr/src/cmd/f77/gram.dcl new file mode 100644 index 0000000000..7fd6b1928c --- /dev/null +++ b/usr/src/cmd/f77/gram.dcl @@ -0,0 +1,318 @@ +spec: dcl + | common + | external + | intrinsic + | equivalence + | data + | implicit + | SSAVE + { saveall = YES; } + | SSAVE savelist + | SFORMAT + { fmtstmt(thislabel); setfmt(thislabel); } + | SPARAM in_dcl SLPAR paramlist SRPAR + ; + +dcl: type name in_dcl lengspec dims + { settype($2, $1, $4); + if(ndim>0) setbound($2,ndim,dims); + } + | dcl SCOMMA name lengspec dims + { settype($3, $1, $4); + 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 { $$ = TYDCOMPLEX; } + | SLOGICAL { $$ = TYLOGICAL; } + | SCHARACTER { $$ = TYCHAR; } + | SUNDEFINED { $$ = TYUNKNOWN; } + | SDIMENSION { $$ = TYUNKNOWN; } + | SAUTOMATIC { $$ = - STGAUTO; } + | SSTATIC { $$ = - STGBSS; } + ; + +lengspec: + { $$ = varleng; } + | SSTAR expr + { + if( ! ISICON($2) ) + { + $$ = 0; + dclerr("length must be an integer constant", 0); + } + else $$ = $2->const.ci; + } + | SSTAR SLPAR SSTAR SRPAR + { $$ = 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 + { 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) + fatal("too many equivalences"); + 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 + { dims[ndim].lb = 0; + dims[ndim].ub = $1; + ++ndim; + } + | expr SCOLON ubound + { dims[ndim].lb = $1; + dims[ndim].ub = $3; + ++ndim; + } + ; + +ubound: SSTAR + { $$ = 0; } + | expr + ; + +labellist: label + { nstars = 1; labarray[0] = $1; } + | labellist SCOMMA label + { labarray[nstars++] = $3; } + ; + +label: labelval + { 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; + } + ; + +labelval: SICON + { $$ = mklabel( convci(toklen, token) ); } + ; + +implicit: SIMPLICIT in_dcl implist + | 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..b2d33ef06b --- /dev/null +++ b/usr/src/cmd/f77/gram.exec @@ -0,0 +1,111 @@ +exec: iffable + | SDO end_spec label dospec + { + if($3->labdefined) + execerr("no backward DO loops"); + $3->blklevel = blklevel+1; + exdo($3->labelno, $4); + } + | logif iffable + { exendif(); thiswasbranch = NO; } + | logif STHEN + | SELSEIF end_spec SLPAR expr SRPAR STHEN + { exelif($4); } + | SELSE end_spec + { exelse(); } + | SENDIF end_spec + { exendif(); } + ; + +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 + { excall($1, mklist($3), nstars, labarray); } + | 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 + { putcmgo(fixtype($7), nstars, labarray); } + ; + +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 + { labarray[nstars++] = $2; $$ = 0; } + ; + +stop: SPAUSE + { $$ = 0; } + | SSTOP + { $$ = 1; } + ; + +exprlist: expr + { $$ = mkchain($1, 0); } + | exprlist SCOMMA expr + { $$ = hookup($1, mkchain($3,0) ); } + ; + +end_spec: + { if(parstate == OUTSIDE) + { + newproc(); + startproc(0, CLMAIN); + } + if(parstate < INDATA) enddcl(); + } + ; diff --git a/usr/src/cmd/f77/gram.expr b/usr/src/cmd/f77/gram.expr new file mode 100644 index 0000000000..4491d0be21 --- /dev/null +++ b/usr/src/cmd/f77/gram.expr @@ -0,0 +1,125 @@ +funarglist: + { $$ = 0; } + | funargs + ; + +funargs: expr + { $$ = mkchain($1, 0); } + | funargs SCOMMA expr + { $$ = hookup($1, mkchain($3,0) ); } + ; + + +expr: uexpr + | SLPAR expr SRPAR { $$ = $2; } + | complex_const + ; + +uexpr: lhs + | simple_const + | expr addop expr %prec SPLUS + { $$ = mkexpr($2, $1, $3); } + | expr SSTAR expr + { $$ = mkexpr(OPSTAR, $1, $3); } + | expr SSLASH expr + { $$ = mkexpr(OPSLASH, $1, $3); } + | expr SPOWER expr + { $$ = mkexpr(OPPOWER, $1, $3); } + | addop expr %prec SSTAR + { if($1 == OPMINUS) + $$ = mkexpr(OPNEG, $2, 0); + else $$ = $2; + } + | expr relop expr %prec SEQ + { $$ = mkexpr($2, $1, $3); } + | expr SEQV expr + { $$ = mkexpr(OPEQV, $1,$3); } + | expr SNEQV expr + { $$ = mkexpr(OPNEQV, $1, $3); } + | expr SOR expr + { $$ = mkexpr(OPOR, $1, $3); } + | expr SAND expr + { $$ = mkexpr(OPAND, $1, $3); } + | SNOT expr + { $$ = mkexpr(OPNOT, $2, 0); } + | expr SCONCAT expr + { $$ = mkexpr(OPCONCAT, $1, $3); } + ; + +addop: SPLUS { $$ = OPPLUS; } + | SMINUS { $$ = OPMINUS; } + ; + +relop: SEQ { $$ = OPEQ; } + | SGT { $$ = OPGT; } + | SLT { $$ = OPLT; } + | SGE { $$ = OPGE; } + | SLE { $$ = OPLE; } + | SNE { $$ = OPNE; } + ; + +lhs: name + { $$ = mkprim($1, 0, 0, 0); } + | name SLPAR opt_expr SCOLON opt_expr SRPAR + { $$ = mkprim($1, 0, $3, $5); } + | name SLPAR funarglist SRPAR + { $$ = mkprim($1, mklist($3), 0, 0); } + | name SLPAR funarglist SRPAR SLPAR opt_expr SCOLON opt_expr SRPAR + { $$ = mkprim($1, mklist($3), $6, $8); } + ; + +opt_expr: + { $$ = 0; } + | expr + ; + +simple: name + { if($1->vclass == 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 + { $$ = mkbitcon(4, toklen, token); } + | SOCTCON + { $$ = mkbitcon(3, toklen, token); } + | SBITCON + { $$ = 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 + { $$ = 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..2455cbf7e0 --- /dev/null +++ b/usr/src/cmd/f77/gram.head @@ -0,0 +1,155 @@ +%{ +#include "defs" + +static int nstars; +static int ndim; +static int vartype; +static ftnint varleng; +static struct { ptr lb, ub; } dims[8]; +static struct labelblock *labarray[100]; +static int lastwasbranch = NO; +static int thiswasbranch = NO; +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) + warn1("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + } + | 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 + { + if($1) + { + $$ = thislabel = mklabel( (ftnint) $1); + if( ! headerdone ) + puthead(); + 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 + { 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 + { $$ = 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 + { $1->vstg = STGARG; } + | SSTAR + { $$ = 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..469214c7f0 --- /dev/null +++ b/usr/src/cmd/f77/gram.io @@ -0,0 +1,156 @@ + /* Input/Output Statements */ + +io: io1 + { endio(); } + ; + +io1: iofmove ioctl + | iofmove unpar_fexpr + { ioclause(IOSUNIT, $2); endioctl(); } + | iofctl ioctl + | read ioctl + { 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 = IOREWIND; } + | 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 + { ioclause(IOSUNIT, $2); endioctl(); } + | SLPAR ctllist SRPAR + { endioctl(); } + ; + +ctllist: ioclause SCOMMA 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..9a148f3ec8 --- /dev/null +++ b/usr/src/cmd/f77/init.c @@ -0,0 +1,256 @@ +#include "defs" + + +FILEP infile = { stdin }; +FILEP diagfile = { stderr }; + +FILEP textfile; +FILEP asmfile; +FILEP initfile; +long int headoffset; + +char token[100]; +int toklen; +int lineno; +char *infname; +int needkwd; +struct labelblock *thislabel = NULL; +flag nowarnflag = NO; +flag ftn66flag = 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; +struct ctlframe ctls[MAXCTL]; +struct ctlframe *ctlstack = ctls-1; +struct ctlframe *lastctl = ctls+MAXCTL ; + +struct nameblock *regnamep[MAXREGVAR]; +int highregvar; +int nregvar; + +struct extsym extsymtab[MAXEXT]; +struct extsym *nextext = extsymtab; +struct extsym *lastext = extsymtab+MAXEXT; + +struct equivblock eqvclass[MAXEQUIV]; +struct hashentry hashtab[MAXHASH]; +struct hashentry *lasthash = hashtab+MAXHASH; + +struct labelblock labeltab[MAXSTNO]; +struct labelblock *labtabend = labeltab+MAXSTNO; +struct labelblock *highlabtab = labeltab; +struct rplblock *rpllist = NULL; +chainp 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 nintnames = 0; +int nextnames = 0; + +struct literal litpool[MAXLITERALS]; +int nliterals; + + + +fileinit() +{ +procno = 0; +lastlabno = 10; +lastvarno = 0; +nextext = extsymtab; +nliterals = 0; +nerr = 0; +ndata = 0; +} + + + + + +procinit() +{ +register struct nameblock *p; +register struct dimblock *q; +register struct hashentry *hp; +register struct labelblock *lp; +chainp cp; +int i; + +pruse(asmfile, USECONST); +#if FAMILY == SCJ + 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; +nequiv = 0; + +for(i = 0 ; i c2) + err( sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2) ); +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..2922d48c60 --- /dev/null +++ b/usr/src/cmd/f77/intr.c @@ -0,0 +1,560 @@ +#include "defs" + +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}, + +"" }; + + +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" } +} ; + + + + + + +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 chainp cp; +struct constblock *mkcxcon(); +expptr ep; +int mtype; +int op; + +packed.ijunk = np->vardesc.varno; +if(nargs == 0) + goto badnargs; + +mtype = 0; +for(cp = argsp->listp ; cp ; cp = cp->nextp) + { +/* TEMPORARY */ ep = cp->datap; +/* TEMPORARY */ if( ISCONST(ep) && ep->vtype==TYSHORT ) +/* TEMPORARY */ cp->datap = mkconv(tyint, ep); + mtype = maxtype(mtype, ep->vtype); + } + +switch(packed.bits.f1) + { + case INTRBOOL: + op = packed.bits.f3; + 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 = packed.bits.f2; + 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 INTRGEN: + sp = spectab + packed.bits.f3; + for(i=0; iatype == mtype) + goto specfunct; + else + ++sp; + goto badtype; + + case INTRSPEC: + sp = spectab + packed.bits.f3; + if(tyint==TYLONG && sp->rtype==TYSHORT) + ++sp; + + specfunct: + 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( (packed.bits.f1==INTRMIN ? OPMIN : OPMAX), argsp, NULL); + + q->vtype = mtype; + rettype = packed.bits.f2; + if(rettype == TYLONG) + rettype = tyint; + else if(rettype == TYUNKNOWN) + rettype = mtype; + return( mkconv(rettype, q) ); + + default: + fatal1("intrcall: bad intrgroup %d", packed.bits.f1); + } +badnargs: + err1("bad number of arguments to intrinsic %s", + varstr(VL,np->varname) ); + goto bad; + +badtype: + err1("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; +struct specblock *sp; + +if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) + fatal1("intraddr: %s is not intrinsic", varstr(VL,np->varname)); +packed.ijunk = np->vardesc.varno; + +switch(packed.bits.f1) + { + case INTRGEN: + /* imag, log, and log10 arent specific functions */ + if(packed.bits.f3==31 || packed.bits.f3==43 || packed.bits.f3==47) + goto bad; + + case INTRSPEC: + sp = spectab + packed.bits.f3; + 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: + bad: + err1("cannot pass %s as actual", + varstr(VL,np->varname)); + return( errnode() ); + } +fatal1("intraddr: impossible f1=%d\n", packed.bits.f1); +/* NOTREACHED */ +} + + + + + +struct exprblock *inline(fno, type, args) +int fno; +int type; +chainp 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, args->datap, args->nextp->datap); + q->vtype = TYDREAL; + 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..f7b8157c2f --- /dev/null +++ b/usr/src/cmd/f77/io.c @@ -0,0 +1,734 @@ +/* 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 IOSOPENEDED 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 + +#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 + +#define XIFMT 2*SZFLAG + SZADDR +#define XIEND SZFLAG + SZADDR +#define XIUNIT SZFLAG + +#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 + +#define XCLSTATUS SZFLAG + SZIOINT + +#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; +ioerrlab = 0; +ioformatted = UNFORMATTED; +for(i = 1 ; i<=NIOS ; ++i) + V(i) = NULL; +} + + + +endioctl() +{ +int i; +expptr p; +struct labelblock *mklabel(); + +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->const.ci)->labelno; + else + err("bad end= clause"); + +if(p = V(IOSERR)) + if(ISICON(p)) + ioerrlab = mklabel(p->const.ci)->labelno; + else + err("bad err= clause"); + +if(IOSTP==NULL && ioerrlab!=0 && ioendlab!=0 && ioerrlab!=ioendlab) + IOSTP = mktemp(TYINT, NULL); + +if(IOSTP != NULL) + if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->vtype) ) + { + err("iostat must be an integer variable"); + frexpr(IOSTP); + IOSTP = NULL; + } + +if(IOSTP) + { + if( (iostmt==IOREAD || iostmt==IOWRITE) && + (ioerrlab!=ioendlab || ioerrlab==0) ) + jumplab = skiplab = newlabel(); + else + jumplab = ioerrlab; + } +else + { + jumplab = ioerrlab; + if(ioendlab) + jumplab = ioendlab; + } + +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: + fatal1("impossible iostmt %d", iostmt); + } +for(i = 1 ; i<=NIOS ; ++i) + if(i!=IOSIOSTAT || (iostmt!=IOREAD && iostmt!=IOWRITE) ) + 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) + err1("invalid control %s for statement", ioc[found].iocname); +else + err1("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->vtype!=TYCHAR) ) ) + p = fixtype(p); + iocp->iocval = p; +} +else + err1("iocontrol %s repeated", iocp->iocname); +} + +/* io list item */ + +doio(list) +chainp list; +{ +struct exprblock *call0(); +doiolist(list); +ioroutine[0] = 'e'; +putiocall( call0(TYINT, ioroutine) ); +frexpr(IOSTP); +} + + + + + +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->tag == TIMPLDO) + { + exdo(range=newlabel(), q->varnp); + doiolist(q->datalist); + enddo(range); + free(q); + } + else { + if(q->tag==TPRIM && q->argsp==NULL && q->namep->vdim!=NULL) + { + vardcl(qn = q->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->tag==TPRIM && q->argsp==NULL && (qe = memversion(q->namep)) ) + putio(ICON(1),qe); + else if( (qe = fixtype(cpexpr(q)))->tag==TADDR) + putio(ICON(1), qe); + else if(qe->vtype != TYERROR) + { + if(iostmt == IOWRITE) + { + tp = mktemp(qe->vtype, qe->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; +struct exprblock *call2(), *call3(); + +type = addr->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->vtype = TYCHAR; + addr->vleng = ICON( typesize[type] ); + } + +nelt = fixtype( mkconv(TYLENG,nelt) ); +if(ioformatted == LISTDIRECTTED) + 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; + + +sequential = YES; +if(p = V(IOSREC)) + if( ISINT(p->vtype) ) + { + ioset(TYIOINT, XREC, cpexpr(p) ); + sequential = NO; + } + else + err("bad REC= clause"); + +intfile = NO; +if(p = V(IOSUNIT)) + { + if( ISINT(p->vtype) ) + ioset(TYIOINT, XUNIT, cpexpr(p) ); + else if(p->vtype == TYCHAR) + { + intfile = YES; + if(p->tag==TPRIM && p->argsp==NULL && (np = p->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, XRNUM, nump); + ioset(TYIOINT, XRLEN, cpexpr(unitp->vleng) ); + ioset(TYADDR, XUNIT, addrof(unitp) ); + } + } +else + err("bad unit specifier"); + +if(iostmt == IOREAD) + ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); + +fmtoff = (intfile ? XIFMT : XFMT); + +if(p = V(IOSFMT)) + { + if(p->tag==TPRIM && p->argsp==NULL) + { + vardcl(np = p->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->vtype == TYCHAR) + ioset(TYADDR, fmtoff, addrof(cpexpr(p)) ); + else if( ISICON(p) ) + { + if( (k = fmtstmt( mklabel(p->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: + + +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->vtype) ) + ioset(TYIOINT, XUNIT, cpexpr(p) ); +else + err("bad unit in open"); +if( (p = V(IOSFILE)) && p->vtype==TYCHAR) + { + ioset(TYIOINT, XFNAMELEN, cpexpr(p->vleng) ); + iosetc(XFNAME, p); + } +else + err("bad file in open"); + +if(p = V(IOSRECL)) + if( ISINT(p->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->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); + +putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); +} + + + +LOCAL dofmove(subname) +char *subname; +{ +register expptr p; + +if( (p = V(IOSUNIT)) && ISINT(p->vtype) ) + { + ioset(TYIOINT, XUNIT, cpexpr(p) ); + putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); + } +else + err("bad unit in move 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->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->tag==TADDR && ONEOF(p->vtype, M(TYLONG)|M(TYLOGICAL)) ) + ioset(TYADDR, offset, addrof(cpexpr(p)) ); + else + err1("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->vtype==TYCHAR) + ioset(TYIOINT, offl, cpexpr(p->vleng) ); +iosetc(offp, p); +} diff --git a/usr/src/cmd/f77/main.c b/usr/src/cmd/f77/main.c new file mode 100644 index 0000000000..d475cad2e4 --- /dev/null +++ b/usr/src/cmd/f77/main.c @@ -0,0 +1,180 @@ +char *xxxvers[] = "\nFORTRAN 77 PASS 1, VERSION 1.16, 3 NOVEMBER 1978\n"; + +#include "defs" + + +main(argc, argv) +int argc; +char **argv; +{ +char *s; +int k, retcode; +FILEP opf(); + +#define DONE(c) { retcode = c; goto finis; } + +--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 '1': + onetripflag = YES; + break; + + case 'I': + if(*++s == '2') + tyint = TYSHORT; + else if(*s == '4') + { + shortsubs = NO; + tyint = TYLONG; + } + else if(*s == 's') + shortsubs = YES; + else + fatal1("invalid flag -I%c\n", *s); + tylogical = tyint; + break; + + default: + fatal1("invalid flag %c\n", *s); + } + --argc; + ++argv; + } + +if(argc != 4) + fatal1("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]); +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==SCJ + puteof(); +#endif +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); + +fatal1("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; +} + diff --git a/usr/src/cmd/f77/misc.c b/usr/src/cmd/f77/misc.c new file mode 100644 index 0000000000..648fd33e8d --- /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) + fatal("hash table full"); +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(0); + +for(lp = labeltab ; lp < highlabtab ; ++lp) + if(lp->stateno == l) + return(lp); + +if(++highlabtab >= labtabend) + fatal("too many statement numbers"); + +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) + fatal("too many external symbols"); + +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) + { + err1("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 == SCJ +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->tag == TADDR) + return(YES); +if(p->tag == TEXPR) + switch(p->opcode) + { + case OPCOMMA: + return( isaddr(p->rightp) ); + + case OPASSIGN: + case OPPLUSEQ: + return( isaddr(p->leftp) ); + } +return(NO); +} + + + + + +addressable(p) +register expptr p; +{ +switch(p->tag) + { + case TCONST: + return(YES); + + case TADDR: + return( addressable(p->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/proc.c b/usr/src/cmd/f77/proc.c new file mode 100644 index 0000000000..007aaa26d1 --- /dev/null +++ b/usr/src/cmd/f77/proc.c @@ -0,0 +1,888 @@ +#include "defs" + +/* 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) + err1("missing statement number %s", convic(lp->stateno) ); + +epicode(); +procode(); +dobss(); +prdbginfo(); + +#if FAMILY == SCJ + 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(); +#if TARGET == PDP11 +/* fake jump to start the optimizer */ +if(procclass != CLBLOCK) + putgoto( fudgelabel = newlabel() ); +#endif +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; + +p = ALLOC(entrypoint); +if(class == CLMAIN) + puthead("MAIN__"); +else + puthead(NULL); +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"); +} + +/* subroutine or function statement */ + +struct extsym *newentry(v) +register struct nameblock *v; +{ +register struct extsym *p; +struct extsym *mkext(); + +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; + +if(class != CLENTRY) + puthead( varstr(XL, procname = entry->extname) ); +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; + +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: + fatal1("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) + argvec = autovar(lastargslot/SZADDR, TYADDR, NULL); + 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 == SCJ + 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->const.ci : (ftnint) 0); + +if(proctype == TYCHAR) + { + if(type != TYCHAR) + err("noncharacter entry of character function"); + else if( (np->vleng ? np->vleng->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->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; + 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, iarrlen(); +struct extsym *mkext(); +char *memname(); + +pruse(asmfile, USEBSS); + +for(p = hashtab ; pvarp) + { + if( (q->vclass==CLUNKNOWN && q->vstg!=STGARG) || + (q->vclass==CLVAR && q->vstg==STGUNKNOWN) ) + warn1("local variable %s never used", varstr(VL,q->varname) ); + else if(q->vclass==CLVAR && q->vstg==STGBSS) + { + align = (q->vtype==TYCHAR ? ALILONG : typealign[q->vtype]); + if(bssleng % align != 0) + { + bssleng = roundup(bssleng, align); + preven(align); + } + prlocvar( memname(STGBSS, q->vardesc.varno), iarrl = iarrlen(q) ); + bssleng += iarrl; + } + else if(q->vclass==CLPROC && q->vprocclass==PEXTERNAL && q->vstg!=STGARG) + mkext(varunder(VL, q->varname)) ->extstg = STGEXT; + + if(q->vclass==CLVAR && q->vstg!=STGARG) + { + if(q->vdim && !ISICON(q->vdim->nelt) ) + dclerr("adjustable dimension on non-argument", q); + if(q->vtype==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->const.ci; + else return(-1); +if(q->vleng) + if( ISICON(q->vleng) ) + leng *= q->vleng->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) + { + 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->const.ci; + else size = typesize[type]; + if(t = v->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) + size *= neltp->const.ci; + else + dclerr("adjustable array in common", v); + p->extleng += size; + } + + frchain( &(p->extp) ); + } +} + + + + + +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->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) + fatal1("mktmpn: invalid type %d", type); + +if(type==TYCHAR) + if( ISICON(lengp) ) + leng = lengp->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->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 *mkext(), *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) + { + err1("%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->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 == 4) + goto ret; + break; + + case TYLONG: + if(length == 0) + return(tyint); + if(length == 2) + return(TYSHORT); + if(length == 4) + goto ret; + break; + default: + fatal1("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..bb9226965c --- /dev/null +++ b/usr/src/cmd/f77/put.c @@ -0,0 +1,296 @@ +/* + * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH + * JOHNSON AND RITCHIE FAMILIES OF SECOND PASSES +*/ + +#include "defs" + +#if FAMILY == SCJ +# include "scjdefs" +#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]; +} + + +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( ! ISCONST(p) ) + fatal1("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->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->const.ci != litp->litval.litcval.litclen) + break; + if(! eqn( (int) p->vleng->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->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->const.ci); + break; + + case TYADDR: + prcona(asmfile, p->const.ci); + break; + + default: + fatal1("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/scjdefs b/usr/src/cmd/f77/scjdefs new file mode 100644 index 0000000000..a5c903f586 --- /dev/null +++ b/usr/src/cmd/f77/scjdefs @@ -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/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..8d410e9c31 --- /dev/null +++ b/usr/src/cmd/f77/vax.c @@ -0,0 +1,355 @@ +#include "defs" +#if OUTPUT==BINARY +# include "scjdefs" +#endif + +/* + PDP11-780/VAX - SPECIFIC PRINTING ROUTINES +*/ + +static char textline[50]; +int maxregvar = MAXREGVAR; +int regnum[] = { 11, 10, 9, 8, 7, 6 } ; +static int regmask[] = { 0, 0x800, 0xc00, 0xe00, 0xf00, 0xf80, 0xfc0 }; + + + + +prsave() +{ +int proflab; +p2pass( sprintf(textline, "\t.word\t0x%x", regmask[highregvar]) ); /* register variable mask */ +if(profileflag) + { + proflab = newlabel(); + fprintf(asmfile, "L%d:\t.space\t4\n", proflab); + p2pass( sprintf(textline, "\tmovab\tL%d,r0", proflab) ); + p2pass( sprintf(textline, "\tjsb\tmcount") ); + } +p2pass( sprintf(textline, "\tsubl2\t$.F%d,sp", procno) ); +} + + + +goret(type) +int type; +{ +p2pass( sprintf(textline, "\tret") ); +} + + + + +/* + * move argument slot arg1 (relative to ap) + * to slot arg2 (relative to ARGREG) + */ + +mvarg(type, arg1, arg2) +int type, arg1, arg2; +{ +p2pass( sprintf(textline, "\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); +p2pass( sprintf(textline, "\tcasel\tr0,$1,$%d", nlab-1) ); +p2pass( sprintf(textline, "L%d:", arrlab = newlabel() ) ); +for(i = 0; i< nlab ; ++i) + p2pass( sprintf(textline, "\t.word\tL%d-L%d", labs[i]->labelno, arrlab) ); +} + + +prarif(p, neg, zer, pos) +ptr p; +int neg, zer, pos; +{ +putforce(p->vtype, p); +if( ISINT(p->vtype) ) + p2pass( sprintf(textline, "\ttstl\tr0") ); +else + p2pass( sprintf(textline, "\ttstd\tr0") ); +p2pass( sprintf(textline, "\tjlss\tL%d", neg) ); +p2pass( sprintf(textline, "\tjeql\tL%d", zer) ); +p2pass( sprintf(textline, "\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); + break; + + default: + fatal1("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) + p2pass( sprintf(textline, "_%s:", varstr(XL, ep->entryname->extname)) ); +if(procclass == CLBLOCK) + return; +prsave(); +if(argvec) + { + argloc = argvec->memoffset->const.ci; + 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->tag!=TCONST) + mvarg(TYLENG, argslot, q->vleng->vardesc.varno); + argslot += SZLENG; + } + } + p2pass( sprintf(textline, "\taddl3\t$%d,fp,ap", argloc-ARGOFFSET) ); + } + +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 ]; + /* 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) + { + putforce(TYINT, + fixtype( mkexpr(OPSTAR, ICON(size), + cpexpr(dp->baseoffset)) )); + p2pass( sprintf(textline, "\tsubl2\tr0,%d(ap)", + p->datap->vardesc.varno + ARGOFFSET) ); + } + } + else if(!checksubs && dp->baseoffset->const.ci!=0) + p2pass( sprintf(textline, "\tsubl2\t$%ld,%d(ap)", + dp->baseoffset->const.ci * size, + p->datap->vardesc.varno + ARGOFFSET) ); + } + } + +if(typeaddr) + puteq( cpexpr(typeaddr), mkaddcon(ep->typelabel) ); +putgoto(ep->entrylabel); +} + + + + +prhead(fp) +FILEP fp; +{ +#if FAMILY==SCJ +# if OUTPUT == BINARY + p2triple(P2LBRACKET, ARGREG-highregvar, procno); + p2word( (long) (BITSPERCHAR*autoleng) ); + p2flush(); +# else + fprintf(fp, "[%02d\t%06ld\t%02d\t\n", procno, + BITSPERCHAR*autoleng, ARGREG-highregvar); +# endif +#endif +} + + + +prdbginfo() +{ +} diff --git a/usr/src/cmd/f77/vaxdefs b/usr/src/cmd/f77/vaxdefs new file mode 100644 index 0000000000..8d2a74691d --- /dev/null +++ b/usr/src/cmd/f77/vaxdefs @@ -0,0 +1,54 @@ +#ifndef TARGET +TARGET NOT DEFINED !!! +#endif +#if TARGET!=VAX +Target= TARGET OUT OF RANGE!! +#endif + +#ifndef FAMILY +FAMILY NOT DEFINED!!! +#endif +#if FAMILY!=SCJ && FAMILY!=DMR +Family = FAMILY OUT OF RANGE +#endif + +#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..ff35c43125 --- /dev/null +++ b/usr/src/cmd/f77/vaxx.c @@ -0,0 +1,42 @@ +#include +#include "defines" +#include "locdefs" + + + +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