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 <jfr@research.uucp>
Synthesized-from: 32v

diff --git a/usr/src/cmd/f77/data.c b/usr/src/cmd/f77/data.c
new file mode 100644 (file)
index 0000000..3ac8b33
--- /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 (file)
index 0000000..cb44024
--- /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<<x)
+#define ALLOC(x) (struct x *) ckalloc(sizeof(struct x))
+typedef int *ptr;
+typedef FILE *FILEP;
+typedef short flag;
+typedef long int ftnint;
+#define LOCAL static
+
+#define NO 0
+#define YES 1
+
+
+
+/* block tag values */
+
+#define TNAME 1
+#define TCONST 2
+#define TEXPR 3
+#define TADDR 4
+#define TPRIM 5
+#define TLIST 6
+#define TIMPLDO 7
+#define TERROR 8
+
+
+/* parser states */
+
+#define OUTSIDE 0
+#define INSIDE 1
+#define INDCL 2
+#define INDATA 3
+#define INEXEC 4
+
+/* procedure classes */
+
+#define PROCMAIN 1
+#define PROCBLOCK 2
+#define PROCSUBR 3
+#define PROCFUNCT 4
+
+
+/* storage classes */
+
+#define STGUNKNOWN 0
+#define STGARG 1
+#define STGAUTO 2
+#define STGBSS 3
+#define STGINIT 4
+#define STGCONST 5
+#define STGEXT 6
+#define STGINTR 7
+#define STGSTFUNCT 8
+#define STGCOMMON 9
+#define STGEQUIV 10
+#define STGREG 11
+#define STGLENG 12
+
+/* name classes */
+
+#define CLUNKNOWN 0
+#define CLPARAM 1
+#define CLVAR 2
+#define CLENTRY 3
+#define CLMAIN 4
+#define CLBLOCK 5
+#define CLPROC 6
+
+
+/* vproclass values */
+
+#define PUNKNOWN 0
+#define PEXTERNAL 1
+#define PINTRINSIC 2
+#define PSTFUNCT 3
+#define PTHISPROC 4
+
+/* control stack codes */
+
+#define CTLDO 1
+#define CTLIF 2
+#define CTLELSE 3
+
+
+/* operators */
+
+#define OPPLUS 1
+#define OPMINUS 2
+#define OPSTAR 3
+#define OPSLASH 4
+#define OPPOWER 5
+#define OPNEG 6
+#define OPOR 7
+#define OPAND 8
+#define OPEQV 9
+#define OPNEQV 10
+#define OPNOT 11
+#define OPCONCAT 12
+#define OPLT 13
+#define OPEQ 14
+#define OPGT 15
+#define OPLE 16
+#define OPNE 17
+#define OPGE 18
+#define OPCALL 19
+#define OPCCALL 20
+#define OPASSIGN 21
+#define OPPLUSEQ 22
+#define OPSTAREQ 23
+#define OPCONV 24
+#define OPLSHIFT 25
+#define OPMOD 26
+#define OPCOMMA 27
+#define OPQUEST 28
+#define OPCOLON 29
+#define OPABS 30
+#define OPMIN 31
+#define OPMAX 32
+#define OPADDR 33
+#define OPINDIRECT 34
+#define OPBITOR 35
+#define OPBITAND 36
+#define OPBITXOR 37
+#define OPBITNOT 38
+#define OPRSHIFT 39
+
+
+/* memory regions */
+
+#define REGARG 1
+#define REGAUTO 2
+#define REGBSS 3
+#define REGINIT 4
+#define REGCONST 5
+#define REGEXT 6
+#define REGPROG 7
+
+/* label type codes */
+
+#define LABUNKNOWN 0
+#define LABEXEC 1
+#define LABFORMAT 2
+#define LABOTHER 3
+
+
+/* INTRINSIC function codes*/
+
+#define INTREND 0
+#define INTRCONV 1
+#define INTRMIN 2
+#define INTRMAX 3
+#define INTRGEN 4
+#define INTRSPEC 5
+#define INTRBOOL 6
+#define INTRCNST 7
+
+
+/* I/O statement codes */
+
+#define IOSTDIN ICON(5)
+#define IOSTDOUT ICON(6)
+
+#define IOSBAD (-1)
+#define IOSPOSITIONAL 0
+#define IOSUNIT 1
+#define IOSFMT 2
+
+#define IOINQUIRE 1
+#define IOOPEN 2
+#define IOCLOSE 3
+#define IOREWIND 4
+#define IOBACKSPACE 5
+#define IOENDFILE 6
+#define IOREAD 7
+#define IOWRITE 8
+
+
+/* type masks */
+
+#define MSKLOGICAL     M(TYLOGICAL)
+#define MSKADDR        M(TYADDR)
+#define MSKCHAR        M(TYCHAR)
+#define MSKINT M(TYSHORT)|M(TYLONG)
+#define MSKREAL        M(TYREAL)|M(TYDREAL)
+#define MSKCOMPLEX     M(TYCOMPLEX)|M(TYDCOMPLEX)
+
+/* miscellaneous macros */
+
+#define ONEOF(x,y) (M(x) & (y))
+#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
+#define ISREAL(z) ONEOF(z, MSKREAL)
+#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
+#define ISICON(z) (z->tag==TCONST && ISINT(z->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 (file)
index 0000000..a4e1f8f
--- /dev/null
+++ b/usr/src/cmd/f77/defs
@@ -0,0 +1,440 @@
+#include <stdio.h>
+
+#ifdef unix
+#      include <ctype.h>
+#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;
+\f
+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 (file)
index 0000000..a330f9d
--- /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 (file)
index 0000000..bfcc268
--- /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 <stdio.h>
+#include <ctype.h>
+#include "defines"
+#include "locdefs"
+#include "drivedefs"
+#include "ftypes"
+#include <signal.h>
+
+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;
+
+\f
+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<argc ; ++i)
+       switch(c =  dotchar(infname = argv[i]) )
+               {
+               case 'r':       /* Ratfor file */
+               case 'e':       /* EFL file */
+                       if( unreadable(argv[i]) )
+                               break;
+                       s = fortfile;
+                       t = lastfield(argv[i]);
+                       while( *s++ = *t++)
+                               ;
+                       s[-2] = 'f';
+
+                       if(macroflag)
+                               {
+                               if(sys(sprintf(buff, "%s %s >%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);
+}
+\f
+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<v ; ++p)
+               fprintf(diagfile, "%s ", *p);
+       fprintf(diagfile, "\n");
+       }
+
+#if HERE==PDP11 || HERE==INTERDATA || HERE==VAX
+       if( (waitpid = fork()) == 0)
+               {
+               enbint(SIG_DFL);
+               execv(ldname, v0);
+               fatal1("couldn't load %s", ldname);
+               }
+       await(waitpid);
+#endif
+
+#if HERE==INTERDATA
+       if(optimflag)
+               {
+               char buff[100];
+               if( sys(sprintf(buff, "nopt %s -o junk.%d", aoutname, pid))
+                || sys(sprintf(buff, "mv junk.%d %s", pid, aoutname)) )
+                       err("bad optimization");
+               }
+#endif
+
+if(verbose)
+       fprintf(diagfile, "\n");
+}
+\f
+/* Process control and Shell-simulating routines */
+
+sys(str)
+char *str;
+{
+register char *s, *t;
+char *argv[100], path[100];
+char *inname, *outname;
+int append;
+int waitpid;
+int argc;
+
+
+if(debugflag)
+       fprintf(diagfile, "%s\n", str);
+inname  = NULL;
+outname = NULL;
+argv[0] = shellname;
+argc = 1;
+
+t = str;
+while( isspace(*t) )
+       ++t;
+while(*t)
+       {
+       if(*t == '<')
+               inname = t+1;
+       else if(*t == '>')
+               {
+               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 <errno.h>
+
+/* modified version from the Shell */
+texec(f, av)
+char *f;
+char **av;
+{
+extern int errno;
+
+execv(f, av+1);
+
+if (errno==ENOEXEC)
+       {
+       av[1] = f;
+       execv(shellname, av);
+       fatal("No shell!");
+       }
+if (errno==ENOMEM)
+       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);
+}
+\f
+/* 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 <sys/types.h>
+#include <sys/stat.h>
+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);
+}
+\f
+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 ; i<XL ; ++i)
+       {
+       if( (c = getc(sortfile)) == EOF)
+               return(NO);
+       if(c != ' ')
+               *name++ = c;
+       }
+*name = '\0';
+return(YES);
+}
+
+
+
+rdlong(n)
+register ftnint *n;
+{
+register int c;
+
+for(c = getc(sortfile) ; c!=EOF && isspace(c) ; c = getc(sortfile) );
+       ;
+if(c == EOF)
+       return(NO);
+
+for(*n = 0 ; isdigit(c) ; c = getc(sortfile) )
+       *n = 10* (*n) + c - '0';
+return(YES);
+}
+
+
+
+
+prch(c)
+register int c;
+{
+static int buff[SZSHORT];
+
+buff[nch++] = c;
+if(nch == SZSHORT)
+       {
+       prchars(asmfile, buff);
+       nch = 0;
+       }
+}

diff --git a/usr/src/cmd/f77/equiv.c b/usr/src/cmd/f77/equiv.c
new file mode 100644 (file)
index 0000000..7b6db7f
--- /dev/null
+++ b/usr/src/cmd/f77/equiv.c
@@ -0,0 +1,264 @@
+#include "defs"
+
+/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
+
+/* called at end of declarations section to process chains
+   created by EQUIVALENCE statements
+ */
+doequiv()
+{
+register int i;
+int inequiv, comno, ovarno;
+ftnint comoffset, offset, leng, iarrlen(), lmin(), lmax();
+register struct equivblock *p;
+register struct eqvchain *q;
+struct primblock *itemp;
+register struct nameblock *np;
+expptr offp, suboffset();
+int ns, nsubs();
+chainp cp;
+
+for(i = 0 ; i < nequiv ; ++i)
+       {
+       p = &eqvclass[i];
+       p->eqvbottom = p->eqvtop = 0;
+       comno = -1;
+
+       for(q = p->equivs ; q ; q = q->nextp)
+               {
+               itemp = q->eqvitem;
+               vardcl(np = itemp->namep);
+               if(itemp->argsp || itemp->fcharp)
+                       {
+                       if(np->vdim!=NULL && np->vdim->ndim>1 &&
+                          nsubs(itemp->argsp)==1 )
+                               {
+                               if(! ftn66flag)
+                                       warn("1-dim subscript in EQUIVALENCE");
+                               cp = NULL;
+                               ns = np->vdim->ndim;
+                               while(--ns > 0)
+                                       cp = mkchain( ICON(1), cp);
+                               itemp->argsp->listp->nextp = cp;
+                               }
+                       offp = suboffset(itemp);
+                       }
+               else    offp = ICON(0);
+               if(ISICON(offp))
+                       offset = q->eqvoffset = offp->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 (file)
index 0000000..7cfa33b
--- /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 (file)
index 0000000..992c87a
--- /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);
+}
+\f
+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);
+}
+\f
+/* 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);
+}
+\f
+#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
+\f
+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');
+}
+\f
+#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() );
+}
+\f
+#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);
+}
+\f
+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 */
+}
+\f
+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);
+}
+\f
+
+
+/* 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 (file)
index 0000000..1ebe1f4
--- /dev/null
+++ b/usr/src/cmd/f77/fio.h
@@ -0,0 +1,101 @@
+#include <stdio.h>
+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 (file)
index 0000000..8cb28b3
--- /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 (file)
index 0000000..7fd6b19
--- /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 (file)
index 0000000..b2d33ef
--- /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 (file)
index 0000000..4491d0b
--- /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 (file)
index 0000000..2455cbf
--- /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->blklevel<blklevel
+                                   && thislabel->labtype!=LABFORMAT)
+                                       warn1("there is a branch to label %s from outside block",
+                                             convic( (ftnint) (thislabel->stateno) ) );
+                               thislabel->blklevel = blklevel;
+                               thislabel->labdefined = YES;
+                               if(thislabel->labtype != LABFORMAT)
+                                       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 (file)
index 0000000..469214c
--- /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 (file)
index 0000000..9a148f3
--- /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<NTYPES ; ++i)
+       rtvlabel[i] = 0;
+fudgelabel = 0;
+
+if(undeftype)
+       setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
+else
+       {
+       setimpl(TYREAL, (ftnint) 0, 'a', 'z');
+       setimpl(tyint,  (ftnint) 0, 'i', 'n');
+       }
+setimpl(-STGBSS, (ftnint) 0, 'a', 'z');        /* set class */
+setlog();
+}
+
+
+
+
+setimpl(type, length, c1, c2)
+int type;
+ftnint length;
+int c1, c2;
+{
+int i;
+char buff[100];
+
+if(c1==0 || c2==0)
+       return;
+
+if(c1 > c2)
+       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 (file)
index 0000000..2922d48
--- /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},
+
+"" };
+\f
+
+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"
+       };
+\f
+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; i<packed.bits.f2 ; ++i)
+                       if(sp->atype == 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 ; i<VL ; ++s)
+       nm[i++] = (*s==' ' ? '\0' : *s);
+
+for(p = intrtab; p->intrval.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 (file)
index 0000000..f7b8157
--- /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
+\f
+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);
+}
+\f
+
+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 (file)
index 0000000..d475cad
--- /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 (file)
index 0000000..648fd33
--- /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<n && *s!=' ' && *s!='\0' ; ++i)
+       name[i] = *s++;
+
+name[i] = '\0';
+
+return( name );
+}
+
+
+
+
+char * varunder(n, s)
+register int n;
+register char *s;
+{
+register int i;
+static char name[XL+1];
+
+for(i=0;  i<n && *s!=' ' && *s!='\0' ; ++i)
+       name[i] = *s++;
+
+#if TARGET != GCOS
+name[i++] = '_';
+#endif
+
+name[i] = '\0';
+
+return( name );
+}
+
+
+
+
+
+char * nounder(n, s)
+register int n;
+register char *s;
+{
+register int i;
+static char name[XL+1];
+
+for(i=0;  i<n && *s!=' ' && *s!='\0' ; ++s)
+       if(*s != '_')
+               name[i++] = *s;
+
+name[i] = '\0';
+
+return( name );
+}
+
+
+
+char *copyn(n, s)
+register int n;
+register char *s;
+{
+register char *p, *q;
+
+p = q = ckalloc(n);
+while(--n >= 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 ; i<l && *s!='\0' ; ++i)
+       {
+       hash += *s;
+       n[i] = *s++;
+       }
+hash %= MAXHASH;
+while( i < VL )
+       n[i++] = ' ';
+
+hp = hashtab + hash;
+while(q = hp->varp)
+       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(i<XL && *s)
+       *t++ = *s++;
+while(t < n+XL)
+       *t++ = ' ';
+
+for(p = extsymtab ; p<nextext ; ++p)
+       if(eqn(XL, n, p->extname))
+               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 (file)
index 0000000..007aaa2
--- /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);
+}
+\f
+/* 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);
+}
+\f
+/* 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();
+}
+\f
+/*
+   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);
+}
+\f
+/* 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 ; p<lasthash ; ++p)
+    if(q = p->varp)
+       {
+       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 ; p<nextext ; ++p)
+       prext( varstr(XL, p->extname), 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);
+}
+\f
+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 ; p<nextext ; ++p)
+       if(p->extstg==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;
+       }
+}
+
+
+
+\f
+/* 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) );
+}
+\f
+/* 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 ; i<nd ; ++i)
+       {
+       if( (q = dims[i].ub) == NULL)
+               {
+               if(i == nd-1)
+                       {
+                       frexpr(p->nelt);
+                       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 (file)
index 0000000..bb92269
--- /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);
+}
+\f
+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 ; litp<lastlit ; ++litp)
+                       if(type == litp->littype) 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 );
+}
+\f
+/*
+ * 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 (file)
index 0000000..a5c903f
--- /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 (file)
index 0000000..3868cea
--- /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 (file)
index 0000000..8d410e9
--- /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 (file)
index 0000000..8d2a746
--- /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 (file)
index 0000000..ff35c43
--- /dev/null
+++ b/usr/src/cmd/f77/vaxx.c
@@ -0,0 +1,42 @@
+#include <stdio.h>
+#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);
+}