proc.c

来自「<B>Digital的Unix操作系统VAX 4.2源码</B>」· C语言 代码 · 共 1,806 行 · 第 1/3 页

		q->vdcldone = YES;
		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) ;
#ifdef SDB
		if(sdbflag) {
			namestab(q);
		}
#endif
		}

if (optimflag)
	optbuff (SKLABEL, 0, ep->entrylabel, 0);
else
	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);
varsizes = NULL;

for(p = hashtab ; p<lasthash ; ++p)
    if(q = p->varp)
	{
	qstg = q->vstg;
	qtype = q->vtype;
	qclass = q->vclass;

	if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
	    (qclass==CLVAR && qstg==STGUNKNOWN) )
		warn1("local variable %s never used", varstr(VL,q->varname) );
	else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
		mkext(varunder(VL, q->varname)) ->extstg = STGEXT;

	if (qclass == CLVAR && qstg == STGBSS)
	  {
	    if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
		    dclerr("adjustable leng on nonargument", q);
	    if (SMALLVAR(q->varsize))
	      {
		enlist(q->varsize, q, NULL);
		q->inlcomm = NO;
	      }
	    else
	      {
		if (q->init == NO)
		  {
		    preven(ALIDOUBLE);
		    prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
		    q->inlcomm = YES;
		  }
		else
		  prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
			    q->vtype, q->initoffset, &(q->inlcomm));
	      }
	  }
	else 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);
		}

	chkdim(q);
	}

for (i = 0 ; i < nequiv ; ++i)
  if ( (leng = eqvclass[i].eqvleng) != 0 )
    {
      if (SMALLVAR(leng))
	enlist(leng, NULL, eqvclass + i);
      else if (eqvclass[i].init == NO)
	{
	  preven(ALIDOUBLE);
	  prlocvar(memname(STGEQUIV, i), leng);
	  eqvclass[i].inlcomm = YES;
	}
      else
	prlocdata(memname(STGEQUIV, i), leng, TYDREAL, 
		  eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
    }

  outlocvars();
#ifdef SDB
    if(sdbflag) {
      for(p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
	  qstg = q->vstg;
	  qclass = q->vclass;
          if( ONEOF(qclass, M(CLVAR))) {
	     if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) ) namestab(q);
	  } 
      }
    }
#endif

  close(vdatafile);
  close(vchkfile);
  unlink(vdatafname);
  unlink(vchkfname);
  vdatahwm = 0;
}



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(p);
}




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]; #  16 plus null padding -> 20
			char *varaddr;
			short int type;
			short int len;	# length of type
			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, TYSHORT, type );
		prconi(asmfile, TYSHORT,
			type==TYCHAR ?
			    (v->vleng->constblock.const.ci) :
					(ftnint) typesize[type]);
		if(v->vdim)
			{
			praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
			dimoffset += (3 + v->vdim->ndim) * SZINT;
			}
		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);
			}
	}

}

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(varstr(XL,p->extname), 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)
				{
				namestab(v);
				}
#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 */

/*  frees a temporary block  */

frtemp(p)
Tempp p;
{
Addrp t;

if (optimflag)
	{
	if (p->tag != TTEMP)
		badtag ("frtemp",p->tag);
	t = p->memalloc;
	}
else
	t = (Addrp) p;

/* restore clobbered character string lengths */
if(t->vtype==TYCHAR && t->varleng!=0)
	{
	frexpr(t->vleng);
	t->vleng = ICON(t->varleng);
	}

/* put block on chain of temps to be reclaimed */
holdtemps = mkchain(t, holdtemps);
}



/* allocate an automatic variable slot */

Addrp autovar(nelt, t, lengp)
register int nelt, t;
expptr lengp;
{
ftnint leng;
register Addrp q;

if(lengp)
	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(lengp)
	{
	q->vleng = ICON(leng);
	q->varleng = leng;
	}
q->vstg = STGAUTO;
q->memno = newlabel();
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);
}



/*
 *  create a temporary block (TTEMP) when optimizing,
 *  an ordinary TADDR block when not optimizing
 */

Tempp mktmpn(nelt, type, lengp)
int nelt;
register int type;
expptr lengp;
{
ftnint leng;
chainp p, oldp;
register Tempp q;
Addrp altemp;

if (! optimflag)
	return ( (Tempp) mkaltmpn(nelt,type,lengp) );
if(type==TYUNKNOWN || type==TYERROR)
	badtype("mktmpn", type);

if(type==TYCHAR)
	if( ISICON(lengp) )
		leng = lengp->constblock.const.ci;
	else	{
		err("adjustable length");
		return( (Tempp) errnode() );
		}
else
	leng = typesize[type];

q = ALLOC(Tempblock);
q->tag = TTEMP;
q->vtype = type;
if(type == TYCHAR)
	{
	q->vleng = ICON(leng);
	q->varleng = leng;
	}

altemp = ALLOC(Addrblock);
altemp->tag = TADDR;
altemp->vstg = STGUNKNOWN;
q->memalloc = altemp;

q->ntempelt = nelt;
q->istemp = YES;
return(q);
}



Addrp mktemp(type, lengp)
int type;
expptr lengp;
{
return( (Addrp) mktmpn(1,type,lengp) );
}



/*  allocate a temporary location for the given temporary block;
    if already allocated, return its location  */

Addrp altmpn(tp)
Tempp tp;

{
Addrp t, q;

if (tp->tag != TTEMP)
	badtag ("altmpn",tp->tag);

t = tp->memalloc;
if (t->vstg != STGUNKNOWN)
	{
	if (tp->vtype == TYCHAR)
		{
		/*
		 * Unformatted I/O parameters are treated like character
		 *	strings (sigh) -- propagate type and length.
		 */
		t = (Addrp) cpexpr(t);
		t->vtype = tp->vtype;
		t->vleng = tp->vleng;
		t->varleng = tp->varleng;
		}
	return (t);
	}

q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
free ( (charptr) q);
return(t);
}



/*  create and allocate space immediately for a temporary  */

Addrp mkaltemp(type,lengp)
int type;
expptr lengp;
{
return (mkaltmpn(1,type,lengp));
}



Addrp mkaltmpn(nelt,type,lengp)
int nelt;
register int type;
expptr lengp;
{
ftnint leng;
chainp p, oldp;
register Addrp q;

if(type==TYUNKNOWN || type==TYERROR)
	badtype("mkaltmpn", type);

if(type==TYCHAR)
	if( ISICON(lengp) )
		leng = lengp->constblock.const.ci;
	else	{
		err("adjustable length");
		return( (Addrp) errnode() );
		}

/*
 * if a temporary of appropriate shape is on the templist,
 * remove it from the list and return it
 */

#ifdef notdef
/*
 * This code is broken until SKFRTEMP slots can be processed in putopt()
 *	instead of in optimize() -- all kinds of things in putpcc.c can
 *	bomb because of this.  Sigh.
 */
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);

		if (debugflag[14])
			fprintf(diagfile,"mkaltmpn reusing offset %d\n",
				q->memoffset->constblock.const.ci);
		return(q);
		}
	}
#endif notdef
q = autovar(nelt, type, lengp);
q->istemp = YES;

if (debugflag[14])
	fprintf(diagfile,"mkaltmpn new offset %d\n",
		q->memoffset->constblock.const.ci);
return(q);
}



/*  The following routine is a patch which is only needed because the	*/
/*  code for processing actual arguments for calls does not allocate	*/