data.c

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

	      k = MAXINT + rv;
	      p->value = k + 1;
	    }
	  else if (rs == MINLESS1)
	    {
	      p->status = NORMAL;
	      p->value = 0;
	    }
	  else
	    {
	      err(overflow);
	      p->status = ERRVAL;
	    }
	}
      else
	{
	  if (rs == NORMAL && rv > 0)
	    {
	      p->status = NORMAL;
	      k = ( -MAXINT ) + rv;
	      p->value = k - 1;
	    }
	  else if (rs == MAXPLUS1)
	    {
	      p->status = NORMAL;
	      p->value = 0;
	    }
	  else
	    {
	      err(overflow);
	      p->status = ERRVAL;
	    }
	}
    }

  return ((vexpr *) p);
}



vexpr *negival(vp)
vexpr *vp;
{
  static char *badtag = "bad tag in negival";

  register int vs;
  register dvalue *p;

  if (vp->tag != DVALUE)
    fatal(badtag);

  vs = vp->dvalue.status;

  p = ALLOC(Dvalue);
  p->tag = DVALUE;

  if (vs == ERRVAL)
    p->status = ERRVAL;
  else if (vs == NORMAL)
    {
      p->status = NORMAL;
      p->value = -(vp->dvalue.value);
    }
  else if (vs == MAXPLUS1)
    p->status = MINLESS1;
  else
    p->status = MAXPLUS1;

  return ((vexpr *) p);
}



vexpr *subivals(l, r)
vexpr *l;
vexpr *r;
{
  static char *badtag = "bad tag in subivals";

  register vexpr *p;
  register vexpr *t;

  if (l->tag != DVALUE || r->tag != DVALUE)
    fatal(badtag);

  t = negival(r);
  p = addivals(l, t);
  frvexpr(t);

  return (p);
}



vexpr *mulivals(l, r)
vexpr *l;
vexpr *r;
{
  static char *badtag = "bad tag in mulivals";
  static char *overflow = "integer value too large";

  register int ls, rs;
  register ftnint lv, rv;
  register dvalue *p;

  if (l->tag != DVALUE || r->tag != DVALUE)
    fatal(badtag);

  ls = l->dvalue.status;
  lv = l->dvalue.value;
  rs = r->dvalue.status;
  rv = r->dvalue.value;

  p = ALLOC(Dvalue);
  p->tag = DVALUE;

  if (ls == ERRVAL || rs == ERRVAL)
    p->status = ERRVAL;

  else if (ls == NORMAL && rs == NORMAL)
    {
      mulints(lv, rv);
      if (rstatus == ERRVAL)
	err(overflow);
      p->status = rstatus;
      p->value = rvalue;
    }
  else
    {
      if (rs == MAXPLUS1 || rs == MINLESS1)
	{
	  rs = ls;
	  rv = lv;
	  ls = r->dvalue.status;
	}

      if (rs == NORMAL && rv == 0)
	{
	  p->status = NORMAL;
	  p->value = 0;
	}
      else if (rs == NORMAL && rv == 1)
	p->status = ls;
      else if (rs == NORMAL && rv == -1)
	if (ls == MAXPLUS1)
	  p->status = MINLESS1;
	else
	  p->status = MAXPLUS1;
      else
	{
	  err(overflow);
	  p->status = ERRVAL;
	}
    }

  return ((vexpr *) p);
}



vexpr *divivals(l, r)
vexpr *l;
vexpr *r;
{
  static char *badtag = "bad tag in divivals";
  static char *zerodivide = "division by zero";

  register int ls, rs;
  register ftnint lv, rv;
  register dvalue *p;
  register ftnint k;
  register int sign;

  if (l->tag != DVALUE && r->tag != DVALUE)
    fatal(badtag);

  ls = l->dvalue.status;
  lv = l->dvalue.value;
  rs = r->dvalue.status;
  rv = r->dvalue.value;

  p = ALLOC(Dvalue);
  p->tag = DVALUE;

  if (ls == ERRVAL || rs == ERRVAL)
    p->status = ERRVAL;
  else if (rs == NORMAL)
    {
      if (rv == 0)
	{
	  err(zerodivide);
	  p->status = ERRVAL;
	}
      else if (ls == NORMAL)
	{
	  p->status = NORMAL;
	  p->value = lv / rv;
	}
      else if (rv == 1)
	p->status = ls;
      else if (rv == -1)
	if (ls == MAXPLUS1)
	  p->status = MINLESS1;
	else
	  p->status = MAXPLUS1;
      else
	{
	  p->status = NORMAL;

	  if (ls == MAXPLUS1)
	    sign = 1;
	  else
	    sign = -1;

	  if (rv < 0)
	    {
	      rv = -rv;
	      sign = -sign;
	    }
	
	  k = MAXINT - rv;
	  p->value = sign * ((k + 1)/rv + 1);
	}
    }
  else
    {
      p->status = NORMAL;
      if (ls == NORMAL)
	p->value = 0;
      else if ((ls == MAXPLUS1 && rs == MAXPLUS1)
		|| (ls == MINLESS1 && rs == MINLESS1))
	p->value = 1;
      else
	p->value = -1;
    }

  return ((vexpr *) p);
}



vexpr *powivals(l, r)
vexpr *l;
vexpr *r;
{
  static char *badtag = "bad tag in powivals";
  static char *zerozero = "zero raised to the zero-th power";
  static char *zeroneg = "zero raised to a negative power";
  static char *overflow = "integer value too large";

  register int ls, rs;
  register ftnint lv, rv;
  register dvalue *p;

  if (l->tag != DVALUE || r->tag != DVALUE)
    fatal(badtag);

  ls = l->dvalue.status;
  lv = l->dvalue.value;
  rs = r->dvalue.status;
  rv = r->dvalue.value;

  p = ALLOC(Dvalue);
  p->tag = DVALUE;

  if (ls == ERRVAL || rs == ERRVAL)
    p->status = ERRVAL;

  else if (ls == NORMAL)
    {
      if (lv == 1)
	{
	  p->status = NORMAL;
	  p->value = 1;
	}
      else if (lv == 0)
	{
	  if (rs == MAXPLUS1 || (rs == NORMAL && rv > 0))
	    {
	      p->status = NORMAL;
	      p->value = 0;
	    }
	  else if (rs == NORMAL && rv == 0)
	    {
	      warn(zerozero);
	      p->status = NORMAL;
	      p->value = 1;
	    }
	  else
	    {
	      err(zeroneg);
	      p->status = ERRVAL;
	    }
	}
      else if (lv == -1)
	{
	  p->status = NORMAL;
	  if (rs == NORMAL)
	    {
	      if (rv < 0) rv = -rv;
	      if (rv % 2 == 0)
		p->value = 1;
	      else
		p->value = -1;
	    }
	  else
#	    if (MAXINT % 2 == 1)
	      p->value = 1;
#	    else
	      p->value = -1;
#	    endif
	}
      else
	{
	  if (rs == NORMAL && rv > 0)
	    {
	      rstatus = NORMAL;
	      rvalue = lv;
	      while (--rv && rstatus == NORMAL)
		mulints(rvalue, lv);
	      if (rv == 0 && rstatus != ERRVAL)
		{
		  p->status = rstatus;
		  p->value = rvalue;
		}
	      else
		{
		  err(overflow);
		  p->status = ERRVAL;
		}
	    }
	  else if (rs == MAXPLUS1)
	    {
	      err(overflow);
	      p->status = ERRVAL;
	    }
	  else if (rs == NORMAL && rv == 0)
	    {
	      p->status = NORMAL;
	      p->value = 1;
	    }
	  else
	    {
	      p->status = NORMAL;
	      p->value = 0;
	    }
	}
    }

  else
    {
      if (rs == MAXPLUS1 || (rs == NORMAL && rv > 1))
	{
	  err(overflow);
	  p->status = ERRVAL;
	}
      else if (rs == NORMAL && rv == 1)
	p->status = ls;
      else if (rs == NORMAL && rv == 0)
	{
	  p->status = NORMAL;
	  p->value = 1;
	}
      else
	{
	  p->status = NORMAL;
	  p->value = 0;
	}
    }

  return ((vexpr *) p);
}



/*  Addints adds two integer values.  */

addints(i, j)
register ftnint i, j;
{
  register ftnint margin;

  if (i == 0)
    {
      rstatus = NORMAL;
      rvalue = j;
    }
  else if (i > 0)
    {
      margin = MAXINT - i;
      if (j <= margin)
	{
	  rstatus = NORMAL;
	  rvalue = i + j;
	}
      else if (j == margin + 1)
	rstatus = MAXPLUS1;
      else
	rstatus = ERRVAL;
    }
  else
    {
      margin = ( -MAXINT ) - i;
      if (j >= margin)
	{
	  rstatus = NORMAL;
	  rvalue = i + j;
	}
      else if (j == margin - 1)
	rstatus = MINLESS1;
      else
	rstatus = ERRVAL;
    }

   return;
}



/*  Mulints multiplies two integer values  */

mulints(i, j)
register ftnint i, j;
{
  register ftnint sign;
  register ftnint margin;

  if (i == 0 || j == 0)
    {
      rstatus = NORMAL;
      rvalue = 0;
    }
  else
    {
      if ((i > 0 && j > 0) || (i < 0 && j < 0))
	sign = 1;
      else
	sign = -1;

      if (i < 0) i = -i;
      if (j < 0) j = -j;

      margin = MAXINT - i;
      margin = (margin + 1) / i;

      if (j <= margin)
	{
	  rstatus = NORMAL;
	  rvalue = i * j * sign;
	}
      else if (j - 1 == margin)
	{
	  margin = i*margin - 1;
	  if (margin == MAXINT - i)
	    if (sign > 0)
	      rstatus = MAXPLUS1;
	    else
	      rstatus = MINLESS1;
	  else
	    {
	      rstatus = NORMAL;
	      rvalue = i * j * sign;
	    }
	}
      else
	rstatus = ERRVAL;
    }

  return;
}



vexpr *
evalvexpr(ep)
vexpr *ep;
{
  register vexpr *p;
  register vexpr *l, *r;

  switch (ep->tag)
    {
    case DVALUE:
      p = cpdvalue(ep);
      break;

    case DVAR:
      p = cpdvalue((vexpr *) ep->dvar.valp);
      break;

    case DNAME:
      p = evaldname(ep);
      break;

    case DEXPR:
      if (ep->dexpr.left == NULL)
	l = NULL;
      else
	l = evalvexpr(ep->dexpr.left);

      if (ep->dexpr.right == NULL)
	r = NULL;
      else
	r = evalvexpr(ep->dexpr.right);

      switch (ep->dexpr.opcode)
	{
	case OPNEG:
	  p = negival(r);
	  break;

	case OPPLUS:
	  p = addivals(l, r);
	  break;

	case OPMINUS:
	  p = subivals(l, r);
	  break;

	case OPSTAR:
	  p = mulivals(l, r);
	  break;

	case OPSLASH:
	  p = divivals(l, r);
	  break;

	case OPPOWER:
	  p = powivals(l, r);
	  break;
	}

      frvexpr(l);
      frvexpr(r);
      break;

    case DERROR:
      p = (vexpr *) ALLOC(Dvalue);
      p->tag = DVALUE;
      p->dvalue.status = ERRVAL;
      break;
    }

  return (p);
}



vexpr *
refrigdname(vp)
vexpr *vp;
{
  register vexpr *p;
  register int len;
  register char *repr;
  register int found;
  register dovars *dvp;

  len = vp->dname.len;
  repr = vp->dname.repr;

  found = NO;
  dvp = dvlist;
  while (found == NO && dvp != NULL)
    {
      if (len == dvp->len && eqn(len, repr, dvp->repr))
	found = YES;
      else
	dvp = dvp->next;
    }

  if (found == YES)
    {
      p = (vexpr *) ALLOC(Dvar);
      p->tag = DVAR;
      p->dvar.valp = dvp->valp;
    }
  else
    {
      p = evaldname(vp);
      if (p->dvalue.status == ERRVAL)
	dataerror = YES;
    }

  return (p);
}



refrigvexpr(vpp)
vexpr **vpp;
{
  register vexpr *vp;

  vp = *vpp;

  switch (vp->tag)
    {
    case DVALUE:
    case DVAR:
    case DERROR:
      break;

    case DEXPR:
      refrigvexpr( &(vp->dexpr.left) );
      refrigvexpr( &(vp->dexpr.right) );
      break;

    case DNAME:
      *(vpp) = refrigdname(vp);
      frvexpr(vp);
      break;
    }

  return;
}



int
chkvar(np, sname)
Namep np;
char *sname;
{
  static char *nonvar = "%s is not a variable";
  static char *arginit = "attempt to initialize a dummy argument: %s";
  static char *autoinit = "attempt to initialize an automatic variable: %s";
  static char *badclass = "bad class in chkvar";

  register int status;
  register struct Dimblock *dp;
  register int i;

  status = YES;

  if (np->vclass == CLUNKNOWN
      || (np->vclass == CLVAR && !np->vdcldone))
    vardcl(np);

  if (np->vstg == STGARG)
    {
      errstr(arginit, sname);
      dataerror = YES;
      status = NO;
    }
  else if (np->vclass != CLVAR)
    {
      errstr(nonvar, sname);
      dataerror = YES;
      status = NO;
    }
  else if (np->vstg == STGAUTO)
    {
      errstr(autoinit, sname);
      dataerror = YES;
      status = NO;
    }
  else if (np->vstg != STGBSS && np->vstg != STGINIT
	    && np->vstg != STGCOMMON && np->vstg != STGEQUIV)
    {
      fatal(badclass);
    }
  else
    {
      switch (np->vtype)
	{
	case TYERROR:
	  status = NO;
	  dataerror = YES;
	  break;

	case TYSHORT:
	case TYLONG:
	case TYREAL:
	case TYDREAL:
	case TYCOMPLEX:
	case TYDCOMPLEX:
	case TYLOGICAL:
	case TYCHAR:
	  dp = np->vdim;
	  if (dp != NULL)
	    {
	      if (dp->nelt == NULL || !ISICON(dp->nelt))
	        {
	          status = NO;
	          dataerror = YES;
	        }
	    }
	  break;

	default:
	  badtype("chkvar", np->vtype);
	}
    }

  return (status);
}



refrigsubs(ap, sname)
aelt *ap;
char *sname;
{
  static char *nonarray = "subscripts on a simple variable:  %s";
  static char *toofew = "not enough subscripts on %s";
  static char *toomany = "too many subscripts on %s";

  register vlist *subp;
  register int nsubs;
  register Namep np;
  register struct Dimblock *dp;
  register int i;

  np = ap->var;
  dp = np->vdim;

  if (ap->subs != NULL)
    {
      if (np->vdim == NULL)
	{
	  errstr(nonarray, sname);
	  dataerror = YES;
	}
      else
	{
	  nsubs = 0;
	  subp = ap->subs;
	  while (subp != NULL)
	    {
	      nsubs++;
	      refrigvexpr( &(subp->val) );
	      subp = subp->next;
	    }

	  if (dp->ndim != nsubs)
	    {
	      if (np->vdim->ndim > nsubs)
		errstr(toofew, sname);
	      else
		errstr(toomany, sname);
	      dataerror = YES;
	    }
	  else if (dp->baseoffset == NULL || !ISICON(dp->baseoffset))
	    dataerror = YES;
	  else
	    {
	      i = dp->ndim;
	      while (i-- > 0)
		{
		  if (dp->dims[i].dimsize == NULL
		      || !ISICON(dp->dims[i].dimsize))
		    dataerror = YES;
		}
	    }
	}
    }

  return;
}



refrigrange(ap, sname)
aelt *ap;
char *sname;
{
  static char *nonstr = "substring of a noncharacter variable:  %s";
  static char *array = "substring applied to an array:  %s";

  register Namep np;
  register dvalue *t;
  register rpair *rp;

  if (ap->range != NULL)
    {
      np = ap->var;
      if (np->vtype != TYCHAR)
	{
	  errstr(nonstr, sname);
	  dataerror = YES;
	}
      else if (ap->subs == NULL && np->vdim != NULL)
	{
	  errstr(array, sname);
	  dataerror = YES;
	}
      else
	{
	  rp = ap->range;

	  if (rp->low != NULL)
	    refrigvexpr( &(rp->low) );
	  else
	    {
	      t = ALLOC(Dvalue);
	      t->tag = DVALUE;
	      t->status = NORMAL;
	      t->value = 1;
	      rp->low = (vexpr *) t;
	    }

	  if (rp->high != NULL)
	    refrigvexpr( &(rp->high) );
	  else
	    {
	      if (!ISICON(np->vleng))
		{
		  rp->high = (vexpr *) ALLOC(Derror);
		  rp->high->tag = DERROR;
		}
	      else
		{
		  t = ALLOC(Dvalue);
		  t->tag = DVALUE;
		  t->status = NORMAL;
		  t->value = np->vleng->constblock.const.ci;
		  rp->high = (vexpr *) t;
		}
	    }
	}
    }

  return;
}



refrigaelt(ap)
aelt *ap;
{
  register Namep np;
  register char *bp, *sp;
  register int len;
  char buff[VL+1];

  np = ap->var;

  len = 0;
  bp = buff;
  sp = np->varname;
  while (len < VL && *sp != ' ' && *sp != '\0')
    {
      *bp++ = *sp++;
      len++;
    }
  *bp = '\0';

  if (chkvar(np, buff))
    {
      refrigsubs(ap, buff);
      refrigrange(ap, buff);
    }

  return;
}



refrigdo(dp)
dolist *dp;
{
  static char *duplicates = "implied DO variable %s redefined";
  static char *nonvar = "%s is not a variable";
  static char *nonint = "%s is not integer";

  register int len;
  register char *repr;
  register int found;
  register dovars *dvp;
  register Namep np;
  register dovars *t;

  refrigvexpr( &(dp->init) );
  refrigvexpr( &(dp->limit) );
  refrigvexpr( &(dp->step) );

  len = dp->dovar->dname.len;