proc.c

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

/*  the temps it needs before optimization takes place.  A better	*/
/*  solution is possible, but I do not have the time to implement it	*/
/*  now.								*/
/*									*/
/*					Robert P. Corbett		*/

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

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

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

  oldp = CHNULL;
  p = argtemplist;

  while (p)
    {
      q = (Addrp) (p->datap);
      if (q->vtype == type
	  && (type != TYCHAR || q->vleng->constblock.const.ci == leng))
	{
	  if (oldp)
	    oldp->nextp = p->nextp;
	  else
	    argtemplist = p->nextp;

	  p->nextp = activearglist;
	  activearglist = p;

	  return ((Addrp) cpexpr(q));
	}

      oldp = p;
      p = p->nextp;
    }

  q = autovar(1, type, lengp);
  activearglist = mkchain(q, activearglist);
  return ((Addrp) cpexpr(q));
}

/* 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
	{
	if(c == (struct Extsym *) 0)
		return;		/* Illegal common block name upstream */
	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("conflicting declarations", v);

if(v->vprocclass == PUNKNOWN)
	v->vprocclass = PEXTERNAL;
else if(v->vprocclass != PEXTERNAL)
	dclerr("conflicting declarations", 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;
	}
if(v->vdim)
	{
	dclerr("redimensioned array", v);
	return;
	}

v->vdim = p = (struct Dimblock *)
		ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
p->ndim = nd;
p->nelt = ICON(1);

for(i=0 ; i<nd ; ++i)
	{
#ifdef SDB
        if(sdbflag) {
/* Save the bounds trees built up by the grammar routines for use in stabs */

		if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
        	else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
                if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
                else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);

		if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
        	else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
                if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
                else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
	}
#endif
	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) )
			{
			if (!ISINT(q->headblock.vtype)) {
			   dclerr("dimension bounds must be integer expression", v);
			   frexpr(q);
			   q = ICON(0);
			   }
			if ( q->constblock.const.ci <= 0)
			   {
			   dclerr("array bounds out of sequence", v);
			   frexpr(q);
			   q = ICON(0);
			   }
			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;
	}
}



/*
 * Check the dimensions of q to ensure that they are appropriately defined.
 */
LOCAL chkdim(q)
register Namep q;
{
  register struct Dimblock *p;
  register int i;
  expptr e;

  if (q == NULL)
    return;
  if (q->vclass != CLVAR)
    return;
  if (q->vdim == NULL)
    return;
  p = q->vdim;
  for (i = 0; i < p->ndim; ++i)
    {
#ifdef SDB
      if (sdbflag)
	{
	  if (e = p->dims[i].lb)
	    chkdime(e, q);
	  if (e = p->dims[i].ub)
	    chkdime(e, q);
	}
      else
#endif SDB
      if (e = p->dims[i].dimexpr)
	chkdime(e, q);
    }
}



/*
 * The actual checking for chkdim() -- examines each expression.
 */
LOCAL chkdime(expr, q)
expptr expr;
Namep q;
{
  register expptr e;

  e = fixtype(cpexpr(expr));
  if (!ISINT(e->exprblock.vtype))
    dclerr("non-integer dimension", q);
  else if (!safedim(e))
    dclerr("undefined dimension", q);
  frexpr(e);
  return;
}



/*
 * A recursive routine to find undefined variables in dimension expressions.
 */
LOCAL safedim(e)
expptr e;
{
  chainp cp;

  if (e == NULL)
    return 1;
  switch (e->tag)
    {
      case TEXPR:
	if (e->exprblock.opcode == OPCALL || e->exprblock.opcode == OPCCALL)
	  return 0;
	return safedim(e->exprblock.leftp) && safedim(e->exprblock.rightp);
      case TADDR:
	switch (e->addrblock.vstg)
	  {
	    case STGCOMMON:
	    case STGARG:
	    case STGCONST:
	    case STGEQUIV:
	      if (e->addrblock.isarray)
		return 0;
	      return safedim(e->addrblock.memoffset);
	    default:
	      return 0;
	  }
      case TCONST:
      case TTEMP:
	return 1;
    }
  return 0;
}



LOCAL enlist(size, np, ep)
ftnint size;
Namep np;
struct Equivblock *ep;
{
  register sizelist *sp;
  register sizelist *t;
  register varlist *p;

  sp = varsizes;

  if (sp == NULL)
    {
      sp = ALLOC(SizeList);
      sp->size = size;
      varsizes = sp;
    }
  else
    {
      while (sp->size != size)
	{
	  if (sp->next != NULL && sp->next->size <= size)
	    sp = sp->next;
	  else
	    {
	      t = sp;
	      sp = ALLOC(SizeList);
	      sp->size = size;
	      sp->next = t->next;
	      t->next = sp;
	    }
	}
    }

  p = ALLOC(VarList);
  p->next = sp->vars;
  p->np = np;
  p->ep = ep;

  sp->vars = p;

  return;
}



outlocvars()
{

  register varlist *first, *last;
  register varlist *vp, *t;
  register sizelist *sp, *sp1;
  register Namep np;
  register struct Equivblock *ep;
  register int i;
  register int alt;
  register int type;
  char sname[100];
  char setbuff[100];

  sp = varsizes;
  if (sp == NULL)
    return;

  vp = sp->vars;
  if (vp->np != NULL)
    {
      np = vp->np;
      sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
	      np->vardesc.varno);
    }
  else
    {
      i = vp->ep - eqvclass;
      sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
    }

  first = last = NULL;
  alt = NO;

  while (sp != NULL)
    {
      vp = sp->vars;
      while (vp != NULL)
	{
	  t = vp->next;
	  if (alt == YES)
	    {
	      alt = NO;
	      vp->next = first;
	      first = vp;
	    }
	  else
	    {
	      alt = YES;
	      if (last != NULL)
	        last->next = vp;
	      else
		first = vp;
	      vp->next = NULL;
	      last = vp;
	    }
	  vp = t;
	}
      sp1 = sp;
      sp = sp->next;
      free((char *) sp1);
    }

  vp = first;
  while(vp != NULL)
    {
      if (vp->np != NULL)
	{
	  np = vp->np;
	  sprintf(sname, "v.%d", np->vardesc.varno);
	  if (np->init)
	    prlocdata(sname, np->varsize, np->vtype, np->initoffset,
		      &(np->inlcomm));
	  else
	    {
	      pralign(typealign[np->vtype]);
	      fprintf(initfile, "%s:\n\t.space\t%d\n", sname,
		      np->varsize);
	    }
	  np->inlcomm = NO;
	}
      else
	{
	  ep = vp->ep;
	  i = ep - eqvclass;
	  if (ep->eqvleng >= 8)
	    type = TYDREAL;
	  else if (ep->eqvleng >= 4)
	    type = TYLONG;
	  else if (ep->eqvleng >= 2)
	    type = TYSHORT;
	  else
	    type = TYCHAR;
	  sprintf(sname, "q.%d", i + eqvstart);
	  if (ep->init)
	    prlocdata(sname, ep->eqvleng, type, ep->initoffset,
		      &(ep->inlcomm));
	  else
	    {
	      pralign(typealign[type]);
	      fprintf(initfile, "%s:\n\t.space\t%d\n", sname, ep->eqvleng);
	    }
	  ep->inlcomm = NO;
	}
      t = vp;
      vp = vp->next;
      free((char *) t);
    }
  fprintf(initfile, "%s\n", setbuff);
  return;
}