+#include "defs"
+#include "machdefs"
+
+#ifdef SDB
+# include <a.out.h>
+char *stabline();
+# ifndef N_SO
+# include <stab.h>
+# endif
+#endif
+
+/* start a new procedure */
+
+newproc()
+{
+if(parstate != OUTSIDE)
+ {
+ execerr("missing end statement", CNULL);
+ endproc();
+ }
+
+parstate = INSIDE;
+procclass = CLMAIN; /* default */
+}
+
+
+
+/* end of procedure. generate variables, epilogs, and prologs */
+
+endproc()
+{
+struct Labelblock *lp;
+
+if(parstate < INDATA)
+ enddcl();
+if(ctlstack >= ctls)
+ err("DO loop or BLOCK IF not closed");
+for(lp = labeltab ; lp < labtabend ; ++lp)
+ if(lp->stateno!=0 && lp->labdefined==NO)
+ errstr("missing statement number %s", convic(lp->stateno) );
+
+epicode();
+procode();
+donmlist();
+dobss();
+prdbginfo();
+
+#if FAMILY == PCC
+ putbracket();
+#endif
+
+procinit(); /* clean up for next procedure */
+}
+
+
+
+/* End of declaration section of procedure. Allocate storage. */
+
+enddcl()
+{
+register struct Entrypoint *ep;
+
+parstate = INEXEC;
+docommon();
+doequiv();
+docomleng();
+for(ep = entries ; ep ; ep = ep->entnextp)
+ doentry(ep);
+}
+\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__", CLMAIN);
+else
+ puthead(CNULL, CLBLOCK);
+if(class == CLMAIN)
+ newentry( mkname(5, "MAIN_") );
+p->entryname = progname;
+p->entrylabel = newlabel();
+entries = p;
+
+procclass = class;
+retlabel = newlabel();
+fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
+if(progname)
+ fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) );
+fprintf(diagfile, ":\n");
+#ifdef SDB
+if(sdbflag && class==CLMAIN)
+ {
+ char buff[10];
+ sprintf(buff, "L%d", p->entrylabel);
+ prstab("MAIN_", N_FUN, lineno, buff);
+ p2pass( stabline("MAIN_", N_FNAME, 0, 0) );
+ if(progname)
+ {
+ prstab(nounder(XL,progname->extname), N_ENTRY, lineno,buff);
+/* p2pass(stabline(nounder(XL,progname->extname),N_FNAME,0,0)); */
+ }
+ }
+#endif
+}
+
+/* subroutine or function statement */
+
+struct Extsym *newentry(v)
+register Namep v;
+{
+register struct Extsym *p;
+
+p = mkext( varunder(VL, v->varname) );
+
+if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
+ {
+ if(p == 0)
+ dclerr("invalid entry name", v);
+ else dclerr("external name already used", v);
+ return(0);
+ }
+v->vstg = STGAUTO;
+v->vprocclass = PTHISPROC;
+v->vclass = CLPROC;
+p->extstg = STGEXT;
+p->extinit = YES;
+return(p);
+}
+
+
+entrypt(class, type, length, entry, args)
+int class, type;
+ftnint length;
+struct Extsym *entry;
+chainp args;
+{
+register Namep q;
+register struct Entrypoint *p, *ep;
+
+if(class != CLENTRY)
+ puthead( varstr(XL, procname = entry->extname), class);
+if(class == CLENTRY)
+ fprintf(diagfile, " entry ");
+fprintf(diagfile, " %s:\n", nounder(XL, entry->extname));
+q = mkname(VL, nounder(XL,entry->extname) );
+
+if( (type = lengtype(type, (int) length)) != TYCHAR)
+ length = 0;
+if(class == CLPROC)
+ {
+ procclass = CLPROC;
+ proctype = type;
+ procleng = length;
+
+ retlabel = newlabel();
+ if(type == TYSUBR)
+ ret0label = newlabel();
+ }
+
+p = ALLOC(Entrypoint);
+
+if(entries) /* put new block at end of entries list */
+ {
+ for(ep = entries; ep->entnextp; ep = ep->entnextp)
+ ;
+ ep->entnextp = p;
+ }
+else
+ entries = p;
+
+p->entryname = entry;
+p->arglist = args;
+p->entrylabel = newlabel();
+p->enamep = q;
+
+#ifdef SDB
+if(sdbflag)
+ {
+ char buff[10];
+ sprintf(buff, "L%d", p->entrylabel);
+ prstab(nounder(XL, entry->extname),
+ (class==CLENTRY ? N_ENTRY : N_FUN),
+ lineno, buff);
+ if(class != CLENTRY)
+ p2pass( stabline( nounder(XL,entry->extname), N_FNAME, 0, 0) );
+ }
+#endif
+
+if(class == CLENTRY)
+ {
+ class = CLPROC;
+ if(proctype == TYSUBR)
+ type = TYSUBR;
+ }
+
+q->vclass = class;
+q->vprocclass = PTHISPROC;
+settype(q, type, (int) length);
+/* hold all initial entry points till end of declarations */
+if(parstate >= INDATA)
+ doentry(p);
+}
+\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(multitype)
+ {
+ typeaddr = autovar(1, TYADDR, PNULL);
+ 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 Addrp p;
+
+switch(t)
+ {
+ case TYCHAR:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ break;
+
+ case TYLOGICAL:
+ t = tylogical;
+ case TYADDR:
+ case TYSHORT:
+ case TYLONG:
+ p = (Addrp) cpexpr(retslot);
+ p->vtype = t;
+ putforce(t, p);
+ break;
+
+ case TYREAL:
+ case TYDREAL:
+ p = (Addrp) cpexpr(retslot);
+ p->vtype = t;
+ putforce(t, p);
+ break;
+
+ default:
+ badtype("retval", t);
+ }
+goret(t);
+}
+
+
+/* Allocate extra argument array if needed. Generate prologs. */
+
+LOCAL procode()
+{
+register struct Entrypoint *p;
+Addrp argvec;
+
+#if TARGET==GCOS
+ argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
+#else
+ if(lastargslot>0 && nentry>1)
+#if TARGET == VAX
+ argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
+#else
+ argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
+#endif
+ else
+ argvec = NULL;
+#endif
+
+
+#if TARGET == PDP11
+ /* for the optimizer */
+ if(fudgelabel)
+ putlabel(fudgelabel);
+#endif
+
+for(p = entries ; p ; p = p->entnextp)
+ prolog(p, argvec);
+
+#if FAMILY == PCC
+ 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 Namep np;
+chainp p;
+register Namep q;
+Addrp mkarg();
+
+++nentry;
+if(procclass == CLMAIN)
+ {
+ putlabel(ep->entrylabel);
+ return;
+ }
+else if(procclass == CLBLOCK)
+ return;
+
+impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
+type = np->vtype;
+if(proctype == TYUNKNOWN)
+ if( (proctype = type) == TYCHAR)
+ procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
+
+if(proctype == TYCHAR)
+ {
+ if(type != TYCHAR)
+ err("noncharacter entry of character function");
+ else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != 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 = (expptr) 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, PNULL);
+ np->vstg = STGAUTO;
+ np->voffset = retslot->memoffset->constblock.const.ci;
+ }
+
+for(p = ep->arglist ; p ; p = p->nextp)
+ if(! (( q = (Namep) (p->datap) )->vdcldone) )
+ q->vardesc.varno = nextarg(TYADDR);
+
+for(p = ep->arglist ; p ; p = p->nextp)
+ if(! (( q = (Namep) (p->datap) )->vdcldone) )
+ {
+ impldcl(q);
+ q->vdcldone = YES;
+#ifdef SDB
+ if(sdbflag)
+ prstab(varstr(VL,q->varname), N_PSYM,
+ stabtype(q),
+ convic(q->vardesc.varno + ARGOFFSET) );
+#endif
+ if(q->vtype == TYCHAR)
+ {
+ if(q->vleng == NULL) /* character*(*) */
+ q->vleng = (expptr)
+ 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 Namep q;
+register int i;
+int align;
+ftnint leng, iarrl;
+char *memname();
+int qstg, qclass, qtype;
+
+pruse(asmfile, USEBSS);
+
+for(p = hashtab ; p<lasthash ; ++p)
+ if(q = p->varp)
+ {
+ qstg = q->vstg;
+ qtype = q->vtype;
+ qclass = q->vclass;
+
+#ifdef SDB
+ if(sdbflag && qclass==CLVAR) switch(qstg)
+ {
+ case STGAUTO:
+ prstab(varstr(VL,q->varname), N_LSYM,
+ stabtype(q),
+ convic( - q->voffset)) ;
+ prstleng(q, iarrlen(q));
+ break;
+
+ case STGBSS:
+ prstab(varstr(VL,q->varname), N_LCSYM,
+ stabtype(q),
+ memname(qstg,q->vardesc.varno) );
+ prstleng(q, iarrlen(q));
+ break;
+
+ case STGINIT:
+ prstab(varstr(VL,q->varname), N_STSYM,
+ stabtype(q),
+ memname(qstg,q->vardesc.varno) );
+ prstleng(q, iarrlen(q));
+ break;
+ }
+#endif
+
+ if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
+ (qclass==CLVAR && qstg==STGUNKNOWN) )
+ warn1("local variable %s never used", varstr(VL,q->varname) );
+ else if(qclass==CLVAR && qstg==STGBSS)
+ {
+ align = (qtype==TYCHAR ? ALILONG : typealign[qtype]);
+ if(bssleng % align != 0)
+ {
+ bssleng = roundup(bssleng, align);
+ preven(align);
+ }
+ prlocvar(memname(STGBSS,q->vardesc.varno), iarrl = iarrlen(q) );
+ bssleng += iarrl;
+ }
+ else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
+ mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
+
+ if(qclass==CLVAR && qstg!=STGARG)
+ {
+ if(q->vdim && !ISICON(q->vdim->nelt) )
+ dclerr("adjustable dimension on non-argument", q);
+ if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
+ dclerr("adjustable leng on nonargument", q);
+ }
+ }
+
+for(i = 0 ; i < nequiv ; ++i)
+ if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 )
+ {
+ bssleng = roundup(bssleng, ALIDOUBLE);
+ preven(ALIDOUBLE);
+ prlocvar( memname(STGEQUIV, i), leng);
+ bssleng += leng;
+ }
+}
+
+
+
+donmlist()
+{
+register struct Hashentry *p;
+register Namep q;
+
+pruse(asmfile, USEINIT);
+
+for(p=hashtab; p<lasthash; ++p)
+ if( (q = p->varp) && q->vclass==CLNAMELIST)
+ namelist(q);
+}
+
+
+doext()
+{
+struct Extsym *p;
+
+for(p = extsymtab ; p<nextext ; ++p)
+ prext( varstr(XL, p->extname), p->maxleng, p->extinit);
+}
+
+
+
+
+ftnint iarrlen(q)
+register Namep q;
+{
+ftnint leng;
+
+leng = typesize[q->vtype];
+if(leng <= 0)
+ return(-1);
+if(q->vdim)
+ if( ISICON(q->vdim->nelt) )
+ leng *= q->vdim->nelt->constblock.const.ci;
+ else return(-1);
+if(q->vleng)
+ if( ISICON(q->vleng) )
+ leng *= q->vleng->constblock.const.ci;
+ else return(-1);
+return(leng);
+}
+\f
+/* This routine creates a static block representing the namelist.
+ An equivalent declaration of the structure produced is:
+ struct namelist
+ {
+ char namelistname[16];
+ struct namelistentry
+ {
+ char varname[16];
+ char *varaddr;
+ int type; # negative means -type= number of chars
+ struct dimensions *dimp; # null means scalar
+ } names[];
+ };
+
+ struct dimensions
+ {
+ int numberofdimensions;
+ int numberofelements
+ int baseoffset;
+ int span[numberofdimensions];
+ };
+ where the namelistentry list terminates with a null varname
+ If dimp is not null, then the corner element of the array is at
+ varaddr. However, the element with subscripts (i1,...,in) is at
+ varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
+*/
+
+namelist(np)
+Namep np;
+{
+register chainp q;
+register Namep v;
+register struct Dimblock *dp;
+char *memname();
+int type, dimno, dimoffset;
+flag bad;
+
+
+preven(ALILONG);
+fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
+putstr(asmfile, varstr(VL, np->varname), 16);
+dimno = ++lastvarno;
+dimoffset = 0;
+bad = NO;
+
+for(q = np->varxptr.namelist ; q ; q = q->nextp)
+ {
+ vardcl( v = (Namep) (q->datap) );
+ type = v->vtype;
+ if( ONEOF(v->vstg, MSKSTATIC) )
+ {
+ preven(ALILONG);
+ putstr(asmfile, varstr(VL,v->varname), 16);
+ praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
+ prconi(asmfile, TYINT,
+ type==TYCHAR ?
+ -(v->vleng->constblock.const.ci) : (ftnint) type);
+ if(v->vdim)
+ {
+ praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
+ dimoffset += 3 + v->vdim->ndim;
+ }
+ else
+ praddr(asmfile, STGNULL,0,(ftnint) 0);
+ }
+ else
+ {
+ dclerr("may not appear in namelist", v);
+ bad = YES;
+ }
+ }
+
+if(bad)
+ return;
+
+putstr(asmfile, "", 16);
+
+if(dimoffset > 0)
+ {
+ fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
+ for(q = np->varxptr.namelist ; q ; q = q->nextp)
+ if(dp = q->datap->nameblock.vdim)
+ {
+ int i;
+ prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
+ prconi(asmfile, TYINT,
+ (ftnint) (dp->nelt->constblock.const.ci) );
+ prconi(asmfile, TYINT,
+ (ftnint) (dp->baseoffset->constblock.const.ci));
+ for(i=0; i<dp->ndim ; ++i)
+ prconi(asmfile, TYINT,
+ dp->dims[i].dimsize->constblock.const.ci);
+ }
+ }
+
+}
+\f
+LOCAL docommon()
+{
+register struct Extsym *p;
+register chainp q;
+struct Dimblock *t;
+expptr neltp;
+register Namep v;
+ftnint size;
+int type;
+
+for(p = extsymtab ; p<nextext ; ++p)
+ if(p->extstg==STGCOMMON)
+ {
+#ifdef SDB
+ if(sdbflag)
+ prstab(CNULL, N_BCOMM, 0, 0);
+#endif
+ for(q = p->extp ; q ; q = q->nextp)
+ {
+ v = (Namep) (q->datap);
+ if(v->vdcldone == NO)
+ vardcl(v);
+ type = v->vtype;
+ if(p->extleng % typealign[type] != 0)
+ {
+ dclerr("common alignment", v);
+ p->extleng = roundup(p->extleng, typealign[type]);
+ }
+ v->voffset = p->extleng;
+ v->vardesc.varno = p - extsymtab;
+ if(type == TYCHAR)
+ size = v->vleng->constblock.const.ci;
+ else size = typesize[type];
+ if(t = v->vdim)
+ if( (neltp = t->nelt) && ISCONST(neltp) )
+ size *= neltp->constblock.const.ci;
+ else
+ dclerr("adjustable array in common", v);
+ p->extleng += size;
+#ifdef SDB
+ if(sdbflag)
+ {
+ prstssym(v);
+ prstleng(v, size);
+ }
+#endif
+ }
+
+ frchain( &(p->extp) );
+#ifdef SDB
+ if(sdbflag)
+ prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
+#endif
+ }
+}
+
+
+
+
+
+LOCAL docomleng()
+{
+register struct Extsym *p;
+
+for(p = extsymtab ; p < nextext ; ++p)
+ if(p->extstg == STGCOMMON)
+ {
+ if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
+ && !eqn(XL,"_BLNK__ ",p->extname) )
+ warn1("incompatible lengths for common block %s",
+ nounder(XL, p->extname) );
+ if(p->maxleng < p->extleng)
+ p->maxleng = p->extleng;
+ p->extleng = 0;
+ }
+}
+
+
+
+\f
+/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
+
+frtemp(p)
+Addrp p;
+{
+/* restore clobbered character string lengths */
+if(p->vtype==TYCHAR && p->varleng!=0)
+ {
+ frexpr(p->vleng);
+ p->vleng = ICON(p->varleng);
+ }
+
+/* put block on chain of temps to be reclaimed */
+holdtemps = mkchain(p, holdtemps);
+}
+
+
+
+
+/* allocate an automatic variable slot */
+
+Addrp autovar(nelt, t, lengp)
+register int nelt, t;
+expptr lengp;
+{
+ftnint leng;
+register Addrp q;
+
+if(t == TYCHAR)
+ if( ISICON(lengp) )
+ leng = lengp->constblock.const.ci;
+ else {
+ fatal("automatic variable of nonconstant length");
+ }
+else
+ leng = typesize[t];
+autoleng = roundup( autoleng, typealign[t]);
+
+q = ALLOC(Addrblock);
+q->tag = TADDR;
+q->vtype = t;
+if(t == TYCHAR)
+ {
+ q->vleng = ICON(leng);
+ q->varleng = 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);
+}
+
+
+Addrp mktmpn(nelt, type, lengp)
+int nelt;
+register int type;
+expptr lengp;
+{
+ftnint leng;
+chainp p, oldp;
+register Addrp q;
+
+if(type==TYUNKNOWN || type==TYERROR)
+ badtype("mktmpn", type);
+
+if(type==TYCHAR)
+ if( ISICON(lengp) )
+ leng = lengp->constblock.const.ci;
+ else {
+ err("adjustable length");
+ return( errnode() );
+ }
+/*
+ * if an temporary of appropriate shape is on the templist,
+ * remove it from the list and return it
+ */
+
+for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp)
+ {
+ q = (Addrp) (p->datap);
+ if(q->vtype==type && q->ntempelt==nelt &&
+ (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
+ {
+ if(oldp)
+ oldp->nextp = p->nextp;
+ else
+ templist = p->nextp;
+ free( (charptr) p);
+ return(q);
+ }
+ }
+q = autovar(nelt, type, lengp);
+q->istemp = YES;
+return(q);
+}
+
+
+
+
+Addrp 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 *p;
+
+if(len == 0)
+ {
+ s = BLANKCOMMON;
+ len = strlen(s);
+ }
+p = mkext( varunder(len, s) );
+if(p->extstg == STGUNKNOWN)
+ p->extstg = STGCOMMON;
+else if(p->extstg != STGCOMMON)
+ {
+ errstr("%s cannot be a common block name", s);
+ return(0);
+ }
+
+return( p );
+}
+
+
+incomm(c, v)
+struct Extsym *c;
+Namep v;
+{
+if(v->vstg != STGUNKNOWN)
+ dclerr("incompatible common declaration", v);
+else
+ {
+ v->vstg = STGCOMMON;
+ c->extp = hookup(c->extp, mkchain(v,CHNULL) );
+ }
+}
+
+
+
+
+settype(v, type, length)
+register Namep v;
+register int type;
+register int length;
+{
+if(type == TYUNKNOWN)
+ return;
+
+if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
+ {
+ v->vtype = TYSUBR;
+ frexpr(v->vleng);
+ }
+else if(type < 0) /* storage class set */
+ {
+ if(v->vstg == STGUNKNOWN)
+ v->vstg = - type;
+ else if(v->vstg != -type)
+ dclerr("incompatible storage declarations", v);
+ }
+else if(v->vtype == TYUNKNOWN)
+ {
+ if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
+ v->vleng = ICON(length);
+ }
+else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
+ dclerr("incompatible type declarations", v);
+}
+
+
+
+
+
+lengtype(type, length)
+register int type;
+register int length;
+{
+switch(type)
+ {
+ case TYREAL:
+ if(length == 8)
+ return(TYDREAL);
+ if(length == 4)
+ goto ret;
+ break;
+
+ case TYCOMPLEX:
+ if(length == 16)
+ return(TYDCOMPLEX);
+ if(length == 8)
+ goto ret;
+ break;
+
+ case TYSHORT:
+ case TYDREAL:
+ case TYDCOMPLEX:
+ case TYCHAR:
+ case TYUNKNOWN:
+ case TYSUBR:
+ case TYERROR:
+ goto ret;
+
+ case TYLOGICAL:
+ if(length == typesize[TYLOGICAL])
+ goto ret;
+ break;
+
+ case TYLONG:
+ if(length == 0)
+ return(tyint);
+ if(length == 2)
+ return(TYSHORT);
+ if(length == 4)
+ goto ret;
+ break;
+ default:
+ badtype("lengtype", type);
+ }
+
+if(length != 0)
+ err("incompatible type-length combination");
+
+ret:
+ return(type);
+}
+
+
+
+
+
+setintr(v)
+register Namep 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 Namep 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 Namep 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 = (expptr) PNULL;
+ }
+ else {
+ p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
+ 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 = (expptr) autovar(1, tyint, PNULL);
+ p->basexpr = q;
+ }
+}
projects / unix-history / commitdiff