4.4BSD/usr/src/usr.bin/f77/pass1.tahoe/data.c
/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* This module is believed to contain source code proprietary to AT&T.
* Use and redistribution is subject to the Berkeley Software License
* Agreement and your Software Agreement with AT&T (Western Electric).
*/
#ifndef lint
static char sccsid[] = "@(#)data.c 5.3 (Berkeley) 4/12/91";
#endif /* not lint */
/*
* data.c
*
* Routines for handling DATA statements, f77 compiler, 4.2 BSD.
*
* University of Utah CS Dept modification history:
*
* 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;
{
static char *iscomm =" improper initialization for variable in COMMON";
register aelt *p;
p = ALLOC(Aelt);
p->tag = SIMPLE;
p->var = mkname(name->dname.len, name->dname.repr);
if ((procclass != CLBLOCK) && (p->var->vstg == STGCOMMON))
warn(iscomm);
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.constant.ci == MININT)
p->status = MINLESS1;
else
{
p->status = NORMAL;
p->value = tp->paramval->constblock.constant.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;
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.constant.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;
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.constant.ci;
index = sub[i] + index * size;
}
index -= dp->baseoffset->constblock.constant.ci;
if (index < 0 || index >= dp->nelt->constblock.constant.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.constant.ci;
else
nelt = 1;
type = np->vtype;
if (type == TYCHAR)
typelen = np->vleng->constblock.constant.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, constant)
long offset;
ftnint repl;
ftnint len;
char *constant;
{
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 (constant[--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, constant, 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 constant;
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.constant.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);
}
constant = getdatum();
if (constant == NULL || !ISCONST(constant))
return;
constant = (Constp) convconst(type, typelen, constant);
if (constant == NULL || !ISCONST(constant))
{
frexpr((tagptr) constant);
return;
}
if (type == TYCHAR)
wrtdata(base + soffset, 1, typelen, constant->constant.ccp);
else
wrtdata(base + soffset, 1, typelen, packbytes(constant));
frexpr((tagptr) constant);
}
else
{
soffset = 0;
k = np->vdim->nelt->constblock.constant.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
{
constant = grvals->value;
if (constant == NULL || !ISCONST(constant))
{
dataerror = YES;
}
else
{
constant = (Constp) convconst(type, typelen, constant);
if (constant == NULL || !ISCONST(constant))
{
dataerror = YES;
frexpr((tagptr) constant);
}
else
{
if (k > grvals->repl)
repl = grvals->repl;
else
repl = k;
grvals->repl -= repl;
k -= repl;
if (type == TYCHAR)
wrtdata(base+soffset, repl, typelen,
constant->constant.ccp);
else
wrtdata(base+soffset, repl, typelen,
packbytes(constant));
soffset = soffset + repl * typelen;
frexpr((tagptr) constant);
}
}
}
}
}
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;
}