data.c

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

  repr = dp->dovar->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)
    {
      errnm(duplicates, len, repr);
      dataerror = YES;
    }
  else
    {
      np = getname(len, repr);
      if (np == NULL)
	{
	  if (!ISINT(impltype[letter(*repr)]))
	    warnnm(nonint, len, repr);
	}
      else
	{
	  if (np->vclass == CLUNKNOWN)
	    vardcl(np);
	  if (np->vclass != CLVAR)
	    warnnm(nonvar, len, repr);
	  else if (!ISINT(np->vtype))
	    warnnm(nonint, len, repr);
	}
    }

  t = ALLOC(DoVars);
  t->next = dvlist;
  t->len = len;
  t->repr = repr;
  t->valp = ALLOC(Dvalue);
  t->valp->tag = DVALUE;
  dp->dovar = (vexpr *) t->valp;

  dvlist = t;

  refriglvals(dp->elts);

  dvlist = t->next;
  free((char *) t);

  return;
}



refriglvals(lvals)
elist *lvals;
{
  register elist *top;

  top = lvals;

  while (top != NULL)
    {
      if (top->elt->tag == SIMPLE)
	refrigaelt((aelt *) top->elt);
      else
	refrigdo((dolist *) top->elt);

      top = top->next;
    }

  return;
}



/*  Refrig freezes name/value bindings in the DATA name list  */


refrig(lvals)
elist *lvals;
{
  dvlist = NULL;
  refriglvals(lvals);
  return;
}



ftnint
indexer(ap)
aelt *ap;
{
  static char *badvar = "bad variable in indexer";
  static char *boundserror = "subscript out of bounds";

  register ftnint index;
  register vlist *sp;
  register Namep np;
  register struct Dimblock *dp;
  register int i;
  register dvalue *vp;
  register ftnint size;
  ftnint sub[MAXDIM];

  sp = ap->subs;
  if (sp == NULL) return (0);

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

  if (dp == NULL)
    fatal(badvar);

  i = 0;
  while (sp != NULL)
    {
      vp = (dvalue *) evalvexpr(sp->val);

      if (vp->status == NORMAL)
	sub[i++] = vp->value;
      else if ((MININT + MAXINT == -1) && vp->status == MINLESS1)
	sub[i++] = MININT;
      else
	{
	  frvexpr((vexpr *) vp);
	  return (-1);
	}

      frvexpr((vexpr *) vp);
      sp = sp->next;
    }

  index = sub[--i];
  while (i-- > 0)
    {
      size = dp->dims[i].dimsize->constblock.const.ci;
      index = sub[i] + index * size;
    }

  index -= dp->baseoffset->constblock.const.ci;

  if (index < 0 || index >= dp->nelt->constblock.const.ci)
    {
      err(boundserror);
      return (-1);
    }

  return (index);
}



savedata(lvals, rvals)
elist *lvals;
vallist *rvals;
{
  static char *toomany = "more data values than data items";

  register elist *top;

  dataerror = NO;
  badvalue = NO;

  lvals = revelist(lvals);
  grvals = revrvals(rvals);

  refrig(lvals);

  if (!dataerror)
    outdata(lvals);

  frelist(lvals);

  while (grvals != NULL && dataerror == NO)
    {
      if (grvals->status != NORMAL)
	dataerror = YES;
      else if (grvals->repl <= 0)
        grvals = grvals->next;
      else
	{
	  err(toomany);
	  dataerror = YES;
	}
    }
    
  frvallist(grvals);

  return;
}



setdfiles(np)
register Namep np;
{
  register struct Extsym *cp;
  register struct Equivblock *ep;
  register int stg;
  register int type;
  register ftnint typelen;
  register ftnint nelt;
  register ftnint varsize;

  stg = np->vstg;

  if (stg == STGBSS || stg == STGINIT)
    {
      datafile = vdatafile;
      chkfile = vchkfile;
      if (np->init == YES)
	base = np->initoffset;
      else
	{
	  np->init = YES;
	  np->initoffset = base = vdatahwm;
	  if (np->vdim != NULL)
	    nelt = np->vdim->nelt->constblock.const.ci;
	  else
	    nelt = 1;
	  type = np->vtype;
	  if (type == TYCHAR)
	    typelen = np->vleng->constblock.const.ci;
	  else if (type == TYLOGICAL)
	    typelen = typesize[tylogical];
	  else
	    typelen = typesize[type];
	  varsize = nelt * typelen;
	  vdatahwm += varsize;
	}
    }
  else if (stg == STGEQUIV)
    {
      datafile = vdatafile;
      chkfile = vchkfile;
      ep = &eqvclass[np->vardesc.varno];
      if (ep->init == YES)
	base = ep->initoffset;
      else
	{
	  ep->init = YES;
	  ep->initoffset = base = vdatahwm;
	  vdatahwm += ep->eqvleng;
	}
      base += np->voffset;
    }
  else if (stg == STGCOMMON)
    {
      datafile = cdatafile;
      chkfile = cchkfile;
      cp = &extsymtab[np->vardesc.varno];
      if (cp->init == YES)
	base = cp->initoffset;
      else
	{
	  cp->init = YES;
	  cp->initoffset = base = cdatahwm;
	  cdatahwm += cp->maxleng;
	}
      base += np->voffset;
    }

  return;
}



wrtdata(offset, repl, len, const)
long offset;
ftnint repl;
ftnint len;
char *const;
{
  static char *badoffset = "bad offset in wrtdata";
  static char *toomuch = "too much data";
  static char *readerror = "read error on tmp file";
  static char *writeerror = "write error on tmp file";
  static char *seekerror = "seek error on tmp file";

  register ftnint k;
  long lastbyte;
  int bitpos;
  long chkoff;
  long lastoff;
  long chklen;
  long pos;
  int n;
  ftnint nbytes;
  int mask;
  register int i;
  char overlap;
  char allzero;
  char buff[BUFSIZ];

  if (offset < 0)
    fatal(badoffset);

  overlap = NO;

  k = repl * len;
  lastbyte = offset + k - 1;
  if (lastbyte < 0)
    {
      err(toomuch);
      dataerror = YES;
      return;
    }

  bitpos = offset % BYTESIZE;
  chkoff = offset/BYTESIZE;
  lastoff = lastbyte/BYTESIZE;
  chklen = lastoff - chkoff + 1;

  pos = lseek(chkfile, chkoff, 0);
  if (pos == -1)
    {
      err(seekerror);
      done(1);
    }

  while (k > 0)
    {
      if (chklen <= BUFSIZ)
	n = chklen;
      else
	{
	  n = BUFSIZ;
	  chklen -= BUFSIZ;
	}

      nbytes = read(chkfile, buff, n);
      if (nbytes < 0)
	{
	  err(readerror);
	  done(1);
	}

      if (nbytes == 0)
	buff[0] = '\0';

      if (nbytes < n)
	buff[ n-1 ] = '\0';

      i = 0;

      if (bitpos > 0)
	{
	  while (k > 0 && bitpos < BYTESIZE)
	    {
	      mask = 1 << bitpos;

	      if (mask & buff[0])
		overlap = YES;
	      else
		buff[0] |= mask;

	      k--;
	      bitpos++;
	    }

	  if (bitpos == BYTESIZE)
	    {
	      bitpos = 0;
	      i++;
	    }
	}

      while (i < nbytes && overlap == NO)
	{
	  if (buff[i] == 0 && k >= BYTESIZE)
	    {
	      buff[i++] = MAXBYTE;
	      k -= BYTESIZE;
	    }
	  else if (k < BYTESIZE)
	    {
	      while (k-- > 0)
		{
		  mask = 1 << k;
		  if (mask & buff[i])
		    overlap = YES;
		  else
		    buff[i] |= mask;
		}
	      i++;
	    }
	  else
	    {
	      overlap = YES;
	      buff[i++] = MAXBYTE;
	      k -= BYTESIZE;
	    }
	}

      while (i < n)
	{
	  if (k >= BYTESIZE)
	    {
	      buff[i++] = MAXBYTE;
	      k -= BYTESIZE;
	    }
	  else
	    {
	      while (k-- > 0)
		{
		  mask = 1 << k;
		  buff[i] |= mask;
		}
	      i++;
	    }
	}

      pos = lseek(chkfile, -nbytes, 1);
      if (pos == -1)
	{
	  err(seekerror);
	  done(1);
	}

      nbytes = write(chkfile, buff, n);
      if (nbytes != n)
	{
	  err(writeerror);
	  done(1);
	}
    }

  if (overlap == NO)
    {
      allzero = YES;
      k = len;

      while (k > 0 && allzero != NO)
	if (const[--k] != 0) allzero = NO;

      if (allzero == YES)
	return;
    }

  pos = lseek(datafile, offset, 0);
  if (pos == -1)
    {
      err(seekerror);
      done(1);
    }

  k = repl;
  while (k-- > 0)
    {
      nbytes = write(datafile, const, len);
      if (nbytes != len)
	{
	  err(writeerror);
	  done(1);
	}
    }

  if (overlap) overlapflag = YES;

  return;
}



Constp
getdatum()
{
  static char *toofew = "more data items than data values";

  register vallist *t;

  while (grvals != NULL)
    {
      if (grvals->status != NORMAL)
	{
	  dataerror = YES;
	  return (NULL);
	}
      else if (grvals->repl > 0)
	{
	  grvals->repl--;
	  return (grvals->value);
	}
      else
	{
	  badvalue = 0;
	  frexpr ((tagptr) grvals->value);
	  t = grvals;
	  grvals = t->next;
	  free((char *) t);
	}
    }

  err(toofew);
  dataerror = YES;
  return (NULL);
}



outdata(lvals)
elist *lvals;
{
  register elist *top;

  top = lvals;

  while (top != NULL && dataerror == NO)
    {
      if (top->elt->tag == SIMPLE)
	outaelt((aelt *) top->elt);
      else
	outdolist((dolist *) top->elt);

      top = top->next;
    }

  return;
}



outaelt(ap)
aelt *ap;
{
  static char *toofew = "more data items than data values";
  static char *boundserror = "substring expression out of bounds";
  static char *order = "substring expressions out of order";

  register Namep np;
  register long soffset;
  register dvalue *lwb;
  register dvalue *upb;
  register Constp const;
  register int k;
  register vallist *t;
  register int type;
  register ftnint typelen;
  register ftnint repl;

  extern char *packbytes();

  np = ap->var;
  setdfiles(np);

  type = np->vtype;

  if (type == TYCHAR)
    typelen = np->vleng->constblock.const.ci;
  else if (type == TYLOGICAL)
    typelen = typesize[tylogical];
  else
    typelen = typesize[type];

  if (ap->subs != NULL || np->vdim == NULL)
    {
      soffset = indexer(ap);
      if (soffset == -1)
	{
	  dataerror = YES;
	  return;
	}

      soffset = soffset * typelen;

      if (ap->range != NULL)
	{
	  lwb = (dvalue *) evalvexpr(ap->range->low);
	  upb = (dvalue *) evalvexpr(ap->range->high);
	  if (lwb->status == ERRVAL || upb->status == ERRVAL)
	    {
	      frvexpr((vexpr *) lwb);
	      frvexpr((vexpr *) upb);
	      dataerror = YES;
	      return;
	    }

	  if (lwb->status != NORMAL ||
	      lwb->value < 1 ||
	      lwb->value > typelen ||
	      upb->status != NORMAL ||
	      upb->value < 1 ||
	      upb->value > typelen)
	    {
	      err(boundserror);
	      frvexpr((vexpr *) lwb);
	      frvexpr((vexpr *) upb);
	      dataerror = YES;
	      return;
	    }

	  if (lwb->value > upb->value)
	    {
	      err(order);
	      frvexpr((vexpr *) lwb);
	      frvexpr((vexpr *) upb);
	      dataerror = YES;
	      return;
	    }

	  soffset = soffset + lwb->value - 1;
	  typelen = upb->value - lwb->value + 1;
	  frvexpr((vexpr *) lwb);
	  frvexpr((vexpr *) upb);
	}

      const = getdatum();
      if (const == NULL || !ISCONST(const))
	return;

      const = (Constp) convconst(type, typelen, const);
      if (const == NULL || !ISCONST(const))
	{
	  frexpr((tagptr) const);
	  return;
	}

      if (type == TYCHAR)
	wrtdata(base + soffset, 1, typelen, const->const.ccp);
      else
	wrtdata(base + soffset, 1, typelen, packbytes(const));

      frexpr((tagptr) const);
    }
  else
    {
      soffset = 0;
      k = np->vdim->nelt->constblock.const.ci;
      while (k > 0 && dataerror == NO)
	{
	  if (grvals == NULL)
	    {
	      err(toofew);
	      dataerror = YES;
	    }
	  else if (grvals->status != NORMAL)
	    dataerror = YES;
	  else if (grvals-> repl <= 0)
	    {
	      badvalue = 0;
	      frexpr((tagptr) grvals->value);
	      t = grvals;
	      grvals = t->next;
	      free((char *) t);
	    }
	  else
	    {
	      const = grvals->value;
	      if (const == NULL || !ISCONST(const))
		{
		  dataerror = YES;
		}
	      else
		{
		  const = (Constp) convconst(type, typelen, const);
		  if (const == NULL || !ISCONST(const))
		    {
		      dataerror = YES;
		      frexpr((tagptr) const);
		    }
		  else
		    {
		      if (k > grvals->repl)
			repl = grvals->repl;
		      else
			repl = k;

		      grvals->repl -= repl;
		      k -= repl;

		      if (type == TYCHAR)
			wrtdata(base+soffset, repl, typelen, const->const.ccp);
		      else
			wrtdata(base+soffset, repl, typelen, packbytes(const));

		      soffset = soffset + repl * typelen;

		      frexpr((tagptr) const);
		    }
		}
	    }
	}
    }

  return;
}



outdolist(dp)
dolist *dp;
{
  static char *zerostep = "zero step in implied-DO";
  static char *order = "zero iteration count in implied-DO";

  register dvalue *e1, *e2, *e3;
  register int direction;
  register dvalue *dv;
  register int done;
  register int addin;
  register int ts;
  register ftnint tv;

  e1 = (dvalue *) evalvexpr(dp->init);
  e2 = (dvalue *) evalvexpr(dp->limit);
  e3 = (dvalue *) evalvexpr(dp->step);

  if (e1->status == ERRVAL ||
      e2->status == ERRVAL ||
      e3->status == ERRVAL)
    {
      dataerror = YES;
      goto ret;
    }

  if (e1->status == NORMAL)
    {
      if (e2->status == NORMAL)
	{
	  if (e1->value < e2->value)
	    direction = 1;
	  else if (e1->value > e2->value)
	    direction = -1;
	  else
	    direction = 0;
	}
      else if (e2->status == MAXPLUS1)
	direction = 1;
      else
	direction = -1;
    }
  else if (e1->status == MAXPLUS1)
    {
      if (e2->status == MAXPLUS1)
	direction = 0;
      else
	direction = -1;
    }
  else
    {
      if (e2->status == MINLESS1)
	direction = 0;
      else
	direction = 1;
    }

  if (e3->status == NORMAL && e3->value == 0)
    {
      err(zerostep);
      dataerror = YES;
      goto ret;
    }
  else if (e3->status == MAXPLUS1 ||
	   (e3->status == NORMAL && e3->value > 0))
    {
      if (direction == -1)
	{
	  warn(order);
	  goto ret;
	}
    }
  else
    {
      if (direction == 1)
	{
	  warn(order);
	  goto ret;
	}
    }

  dv = (dvalue *) dp->dovar;
  dv->status = e1->status;
  dv->value = e1->value;

  done = NO;
  while (done == NO && dataerror == NO)
    {
      outdata(dp->elts);

      if (e3->status == NORMAL && dv->status == NORMAL)
	{
	  addints(e3->value, dv->value);
	  dv->status = rstatus;
	  dv->value = rvalue;
	}
      else
	{
	  if (e3->status != NORMAL)
	    {
	      if (e3->status == MAXPLUS1)
		addin = MAXPLUS1;
	      else
		addin = MINLESS1;
	      ts = dv->status;
	      tv = dv->value;
	    }
	  else
	    {
	      if (dv->status == MAXPLUS1)
		addin = MAXPLUS1;
	      else
		addin = MINLESS1;
	      ts = e3->status;
	      tv = e3->value;
	    }

	  if (addin == MAXPLUS1)
	    {
	      if (ts == MAXPLUS1 || (ts == NORMAL && tv > 0))
		dv->status = ERRVAL;
	      else if (ts == NORMAL && tv == 0)
		dv->status = MAXPLUS1;
	      else if (ts == NORMAL)
		{
		  dv->status = NORMAL;
		  dv->value = tv + MAXINT;
		  dv->value++;
		}
	      else
		{
		  dv->status = NORMAL;
		  dv->value = 0;
		}
	    }
	  else
	    {
	      if (ts == MINLESS1 || (ts == NORMAL && tv < 0))
		dv->status = ERRVAL;
	      else if (ts == NORMAL && tv == 0)
		dv->status = MINLESS1;
	      else if (ts == NORMAL)
		{
		  dv->status = NORMAL;
		  dv->value = tv - MAXINT;
		  dv->value--;
		}
	      else
		{
		  dv->status = NORMAL;
		  dv->value = 0;
		}
	    }
	}

      if (dv->status == ERRVAL)
	done = YES;
      else if (direction > 0)
	{
	  if (e2->status == NORMAL)
	    {
	      if (dv->status == MAXPLUS1 ||
		  (dv->status == NORMAL && dv->value > e2->value))
		done = YES;
	    }
	}
      else if (direction < 0)
	{
	  if (e2->status == NORMAL)
	    {
	      if (dv->status == MINLESS1 ||
		  (dv->status == NORMAL && dv->value < e2->value))
		done = YES;
	    }
	}
      else
	done = YES;
    }

ret:
  frvexpr((vexpr *) e1);
  frvexpr((vexpr *) e2);
  frvexpr((vexpr *) e3);
  return;
}