From ec40e2f47462a300792a3722b25e7b091bfc0262 Mon Sep 17 00:00:00 2001 From: Bill Joy Date: Tue, 16 Sep 1980 00:09:53 -0800 Subject: [PATCH] BSD 4 development Work on file usr/src/cmd/f77/proc.c Synthesized-from: CSRG//cd1/4.0 --- usr/src/cmd/f77/proc.c | 1115 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1115 insertions(+) create mode 100644 usr/src/cmd/f77/proc.c diff --git a/usr/src/cmd/f77/proc.c b/usr/src/cmd/f77/proc.c new file mode 100644 index 0000000000..5cc34ab8b2 --- /dev/null +++ b/usr/src/cmd/f77/proc.c @@ -0,0 +1,1115 @@ +#include "defs" +#include "machdefs" + +#ifdef SDB +# include +char *stabline(); +# ifndef N_SO +# include +# 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); +} + +/* 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); +} + +/* 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(); +} + +/* + 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); +} + +/* 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 ; pvarp) + { + 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; pvarp) && q->vclass==CLNAMELIST) + namelist(q); +} + + +doext() +{ +struct Extsym *p; + +for(p = extsymtab ; pextname), 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); +} + +/* 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; indim ; ++i) + prconi(asmfile, TYINT, + dp->dims[i].dimsize->constblock.const.ci); + } + } + +} + +LOCAL docommon() +{ +register struct Extsym *p; +register chainp q; +struct Dimblock *t; +expptr neltp; +register Namep v; +ftnint size; +int type; + +for(p = extsymtab ; pextstg==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; + } +} + + + + +/* 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) ); +} + +/* 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 ; inelt); + p->nelt = NULL; + } + else + err("only last bound may be asterisk"); + p->dims[i].dimsize = ICON(1);; + p->dims[i].dimexpr = NULL; + } + else + { + if(dims[i].lb) + { + q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); + q = mkexpr(OPPLUS, q, ICON(1) ); + } + if( ISCONST(q) ) + { + p->dims[i].dimsize = q; + p->dims[i].dimexpr = (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; + } +} -- 2.20.1