data.c

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

#ifndef lint
static	char	*sccsid = "@(#)data.c	4.1	(ULTRIX)	7/17/90";
#endif lint

/************************************************************************
 *									*
 *			Copyright (c) 1984 by				*
 *		Digital Equipment Corporation, Maynard, MA		*
 *			All rights reserved.				*
 *									*
 *   This software is furnished under a license and may be used and	*
 *   copied  only  in accordance with the terms of such license and	*
 *   with the  inclusion  of  the  above  copyright  notice.   This	*
 *   software  or  any  other copies thereof may not be provided or	*
 *   otherwise made available to any other person.  No title to and	*
 *   ownership of the software is hereby transferred.			*
 *									*
 *   This software is  derived  from  software  received  from  the	*
 *   University    of   California,   Berkeley,   and   from   Bell	*
 *   Laboratories.  Use, duplication, or disclosure is  subject  to	*
 *   restrictions  under  license  agreements  with  University  of	*
 *   California and with AT&T.						*
 *									*
 *   The information in this software is subject to change  without	*
 *   notice  and should not be construed as a commitment by Digital	*
 *   Equipment Corporation.						*
 *									*
 *   Digital assumes no responsibility for the use  or  reliability	*
 *   of its software on equipment which is not supplied by Digital.	*
 *									*
 ************************************************************************/

/*
 * data.c
 *
 * Routines for handling DATA statements, f77 compiler, 4.2 BSD.
 *
 * University of Utah CS Dept modification history:
 *
 * $Log:	data.c,v $
 * Revision 3.1  84/10/13  01:09:50  donn
 * Installed Jerry Berkman's version; added UofU comment header.
 * 
 */

#include "defs.h"
#include "data.h"


/*  global variables  */

flag overlapflag;



/*  local variables  */

LOCAL char rstatus;
LOCAL ftnint rvalue;
LOCAL dovars *dvlist;
LOCAL int dataerror;
LOCAL vallist *grvals;
LOCAL int datafile;
LOCAL int chkfile;
LOCAL long base;



/*  Copied from expr.c  */

LOCAL letter(c)
register int c;
{
if( isupper(c) )
	c = tolower(c);
return(c - 'a');
}



vexpr *
cpdvalue(dp)
vexpr *dp;
{
  register dvalue *p;

  if (dp->tag != DVALUE)
    badtag("cpdvalue", dp->tag);

  p = ALLOC(Dvalue);
  p->tag = DVALUE;
  p->status = dp->dvalue.status;
  p->value = dp->dvalue.value;

  return ((vexpr *) p);
}



frvexpr(vp)
register vexpr *vp;
{
  if (vp != NULL)
    {
      if (vp->tag == DNAME)
	free(vp->dname.repr);
      else if (vp->tag == DEXPR)
	{
	  frvexpr(vp->dexpr.left);
	  frvexpr(vp->dexpr.right);
	}

      free((char *) vp);
    }

  return;
}



frvlist(vp)
register vlist *vp;
{
  register vlist *t;

  while (vp)
    {
      t = vp->next;
      frvexpr(vp->val);
      free((char *) vp);
      vp = t;
    }

  return;
}



frelist(ep)
elist *ep;
{
  register elist *p;
  register elist *t;
  register aelt *ap;
  register dolist *dp;

  p = ep;

  while (p != NULL)
    {
      if (p->elt->tag == SIMPLE)
	{
	  ap = (aelt *) p->elt;
	  frvlist(ap->subs);
	  if (ap->range != NULL)
	    {
	      frvexpr(ap->range->low);
	      frvexpr(ap->range->high);
	      free((char *) ap->range);
	    }
	  free((char *) ap);
	}
      else
	{
	  dp = (dolist *) p->elt;
	  frvexpr(dp->dovar);
	  frvexpr(dp->init);
	  frvexpr(dp->limit);
	  frvexpr(dp->step);
	  frelist(dp->elts);
	  free((char *) dp);
	}

      t = p;
      p = p->next;
      free((char *) t);
    }

  return;
}



frvallist(vp)
vallist *vp;
{
  register vallist *p;
  register vallist *t;

  p = vp;
  while (p != NULL)
    {
      frexpr((tagptr) p->value);
      t = p;
      p = p->next;
      free((char *) t);
    }

  return;
}



elist *revelist(ep)
register elist *ep;
{
  register elist *next;
  register elist *t;

  if (ep != NULL)
    {
      next = ep->next;
      ep->next = NULL;

      while (next)
	{
	  t = next->next;
	  next->next = ep;
	  ep = next;
	  next = t;
	}
    }

  return (ep);
}



vlist *revvlist(vp)
vlist *vp;
{
  register vlist *p;
  register vlist *next;
  register vlist *t;

  if (vp == NULL)
    p = NULL;
  else
    {
      p = vp;
      next = p->next;
      p->next = NULL;

      while (next)
	{
	  t = next->next;
	  next->next = p;
	  p = next;
	  next = t;
	}
    }

  return (p);
}



vallist *
revrvals(vp)
vallist *vp;
{
  register vallist *p;
  register vallist *next;
  register vallist *t;

  if (vp == NULL)
    p = NULL;
  else
    {
      p = vp;
      next = p->next;
      p->next = NULL;
      while (next)
	{
	  t = next->next;
	  next->next = p;
	  p = next;
	  next = t;
	}
    }

  return (p);
}



vlist *prepvexpr(tail, head)
vlist *tail;
vexpr *head;
{
  register vlist *p;

  p = ALLOC(Vlist);
  p->next = tail;
  p->val = head;

  return (p);
}



elist *preplval(tail, head)
elist *tail;
delt* head;
{
  register elist *p;
  p = ALLOC(Elist);
  p->next = tail;
  p->elt = head;

  return (p);
}



delt *mkdlval(name, subs, range)
vexpr *name;
vlist *subs;
rpair *range;
{
  register aelt *p;

  p = ALLOC(Aelt);
  p->tag = SIMPLE;
  p->var = mkname(name->dname.len, name->dname.repr);
  p->subs = subs;
  p->range = range;

  return ((delt *) p);
}



delt *mkdatado(lvals, dovar, params)
elist *lvals;
vexpr *dovar;
vlist *params;
{
  static char *toofew = "missing loop parameters";
  static char *toomany = "too many loop parameters";

  register dolist *p;
  register vlist *vp;
  register int pcnt;
  register dvalue *one;

  p = ALLOC(DoList);
  p->tag = NESTED;
  p->elts = revelist(lvals);
  p->dovar = dovar;

  vp = params;
  pcnt = 0;
  while (vp)
    {
      pcnt++;
      vp = vp->next;
    }

  if (pcnt != 2 && pcnt != 3)
    {
      if (pcnt < 2)
	err(toofew);
      else
	err(toomany);

      p->init = (vexpr *) ALLOC(Derror);
      p->init->tag = DERROR;

      p->limit = (vexpr *) ALLOC(Derror);
      p->limit->tag = DERROR;

      p->step = (vexpr *) ALLOC(Derror);
      p->step->tag = DERROR;
    }
  else
    {
      vp = params;

      if (pcnt == 2)
	{
	  one = ALLOC(Dvalue);
	  one->tag = DVALUE;
	  one->status = NORMAL;
	  one->value = 1;
	  p->step = (vexpr *) one;
	}
      else
	{
	  p->step = vp->val;
	  vp->val = NULL;
	  vp = vp->next;
	}

      p->limit = vp->val;
      vp->val = NULL;
      vp = vp->next;

      p->init = vp->val;
      vp->val = NULL;
    }

  frvlist(params);
  return ((delt *) p);
}



rpair *mkdrange(lb, ub)
vexpr *lb, *ub;
{
  register rpair *p;

  p = ALLOC(Rpair);
  p->low = lb;
  p->high = ub;

  return (p);
}



vallist *mkdrval(repl, val)
vexpr *repl;
expptr val;
{
  static char *badtag = "bad tag in mkdrval";
  static char *negrepl = "negative replicator";
  static char *zerorepl = "zero replicator";
  static char *toobig = "replicator too large";
  static char *nonconst = "%s is not a constant";

  register vexpr *vp;
  register vallist *p;
  register int status;
  register ftnint value;
  register int copied;

  copied = 0;

  if (repl->tag == DNAME)
    {
      vp = evaldname(repl);
      copied = 1;
    }
  else
    vp = repl;

  p = ALLOC(ValList);
  p->next = NULL;
  p->value = (Constp) val;

  if (vp->tag == DVALUE)
    {
      status = vp->dvalue.status;
      value = vp->dvalue.value;

      if ((status == NORMAL && value < 0) || status == MINLESS1)
	{
	  err(negrepl);
	  p->status = ERRVAL;
	}
      else if (status == NORMAL)
	{
	  if (value == 0)
	    warn(zerorepl);
	  p->status = NORMAL;
	  p->repl = value;
	}
      else if (status == MAXPLUS1)
	{
	  err(toobig);
	  p->status = ERRVAL;
	}
      else
	p->status = ERRVAL;
    }
  else if (vp->tag == DNAME)
    {
      errnm(nonconst, vp->dname.len, vp->dname.repr);
      p->status = ERRVAL;
    }
  else if (vp->tag == DERROR)
    p->status = ERRVAL;
  else
    fatal(badtag);

  if (copied) frvexpr(vp);
  return (p);
}



/*  Evicon returns the value of the integer constant  */
/*  pointed to by token.                              */

vexpr *evicon(len, token)
register int len;
register char *token;
{
  static char *badconst = "bad integer constant";
  static char *overflow = "integer constant too large";

  register int i;
  register ftnint val;
  register int digit;
  register dvalue *p;

  if (len <= 0)
    fatal(badconst);

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

  i = 0;
  val = 0;
  while (i < len)
    {
      if (val > MAXINT/10)
	{
	  err(overflow);
	  p->status = ERRVAL;
	  goto ret;
	}
      val = 10*val;
      digit = token[i++];
      if (!isdigit(digit))
	fatal(badconst);
      digit = digit - '0';
      if (MAXINT - val >= digit)
	val = val + digit;
      else
	if (i == len && MAXINT - val + 1 == digit)
	  {
	    p->status = MAXPLUS1;
	    goto ret;
	  }
	else
	  {
	    err(overflow);
	    p->status = ERRVAL;
	    goto ret;
	  }
    }

  p->status = NORMAL;
  p->value = val;

ret:
  return ((vexpr *) p);
}



/*  Ivaltoicon converts a dvalue into a constant block.  */

expptr ivaltoicon(vp)
register vexpr *vp;
{
  static char *badtag = "bad tag in ivaltoicon";
  static char *overflow = "integer constant too large";

  register int vs;
  register expptr p;

  if (vp->tag == DERROR)
    return(errnode());
  else if (vp->tag != DVALUE)
    fatal(badtag);

  vs = vp->dvalue.status;
  if (vs == NORMAL)
    p = mkintcon(vp->dvalue.value);
  else if ((MAXINT + MININT == -1) && vs == MINLESS1)
    p = mkintcon(MININT);
  else if (vs == MAXPLUS1 || vs == MINLESS1)
    {
      err(overflow);
      p = errnode();
    }
  else
    p = errnode();

  return (p);
}



/*  Mkdname stores an identifier as a dname  */

vexpr *mkdname(len, str)
int len;
register char *str;
{
  register dname *p;
  register int i;
  register char *s;

  s = (char *) ckalloc(len + 1);
  i = len;
  s[i] = '\0';

  while (--i >= 0)
    s[i] = str[i];

  p = ALLOC(Dname);
  p->tag = DNAME;
  p->len = len;
  p->repr = s;

  return ((vexpr *) p);
}



/*  Getname gets the symbol table information associated with  */
/*  a name.  Getname differs from mkname in that it will not   */
/*  add the name to the symbol table if it is not already      */
/*  present.                                                   */

Namep getname(l, s)
int l;
register char *s;
{
  struct Hashentry *hp;
  int hash;
  register Namep q;
  register int i;
  char n[VL];

  hash = 0;
  for (i = 0; i < l && *s != '\0'; ++i)
    {
      hash += *s;
      n[i] = *s++;
    }

  while (i < VL)
    n[i++] = ' ';

  hash %= maxhash;
  hp = hashtab + hash;

  while (q = hp->varp)
    if (hash == hp->hashval
	&& eqn(VL, n, q->varname))
      goto ret;
    else if (++hp >= lasthash)
      hp = hashtab;

ret:
  return (q);
}



/*  Evparam returns the value of the constant named by name.  */

expptr evparam(np)
register vexpr *np;
{
  static char *badtag = "bad tag in evparam";
  static char *undefined = "%s is undefined";
  static char *nonconst = "%s is not constant";

  register struct Paramblock *tp;
  register expptr p;
  register int len;
  register char *repr;

  if (np->tag != DNAME)
    fatal(badtag);

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

  tp = (struct Paramblock *) getname(len, repr);

  if (tp == NULL)
    {
      errnm(undefined, len, repr);
      p = errnode();
    }
  else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
    {
      if (tp->paramval->tag != TERROR)
        errnm(nonconst, len, repr);
      p = errnode();
    }
  else
    p = (expptr) cpexpr(tp->paramval);

  return (p);
}



vexpr *evaldname(dp)
vexpr *dp;
{
  static char *undefined = "%s is undefined";
  static char *nonconst = "%s is not a constant";
  static char *nonint = "%s is not an integer";

  register dvalue *p;
  register struct Paramblock *tp;
  register int len;
  register char *repr;

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

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

  tp = (struct Paramblock *) getname(len, repr);

  if (tp == NULL)
    {
      errnm(undefined, len, repr);
      p->status = ERRVAL;
    }
  else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
    {
      if (tp->paramval->tag != TERROR)
        errnm(nonconst, len, repr);
      p->status = ERRVAL;
    }
  else if (!ISINT(tp->paramval->constblock.vtype))
    {
      errnm(nonint, len, repr);
      p->status = ERRVAL;
    }
  else
    {
      if ((MAXINT + MININT == -1)
	  && tp->paramval->constblock.const.ci == MININT)
	p->status = MINLESS1;
      else
	{
	  p->status = NORMAL;
          p->value = tp->paramval->constblock.const.ci;
	}
    }

  return ((vexpr *) p);
}



vexpr *mkdexpr(op, l, r)
register int op;
register vexpr *l;
register vexpr *r;
{
  static char *badop = "bad operator in mkdexpr";

  register vexpr *p;

  switch (op)
    {
    default:
      fatal(badop);

    case OPNEG:
    case OPPLUS:
    case OPMINUS:
    case OPSTAR:
    case OPSLASH:
    case OPPOWER:
      break;
    }

  if ((l != NULL && l->tag == DERROR) || r->tag == DERROR)
    {
      frvexpr(l);
      frvexpr(r);
      p = (vexpr *) ALLOC(Derror);
      p->tag = DERROR;
    }
  else if (op == OPNEG && r->tag == DVALUE)
    {
      p = negival(r);
      frvexpr(r);
    }
  else if (op != OPNEG && l->tag == DVALUE && r->tag == DVALUE)
    {
      switch (op)
	{
	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);
    }
  else
    {
      p = (vexpr *) ALLOC(Dexpr);
      p->tag = DEXPR;
      p->dexpr.opcode = op;
      p->dexpr.left = l;
      p->dexpr.right = r;
    }

  return (p);
}



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

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

  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)
    {
      addints(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 = ls;
      else if (ls == MAXPLUS1)
	{
	  if (rs == NORMAL && rv < 0)
	    {
	      p->status = NORMAL;