* Copyright (c) 1980 The Regents of the University of California.
* 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).
static char sccsid
[] = "@(#)data.c 5.3 (Berkeley) 4/12/91";
* 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.
badtag("cpdvalue", dp
->tag
);
p
->status
= dp
->dvalue
.status
;
p
->value
= dp
->dvalue
.value
;
else if (vp
->tag
== DEXPR
)
frvexpr(vp
->dexpr
.right
);
if (p
->elt
->tag
== SIMPLE
)
frvexpr(ap
->range
->high
);
free((char *) ap
->range
);
frexpr((tagptr
) p
->value
);
vlist
*prepvexpr(tail
, head
)
elist
*preplval(tail
, head
)
delt
*mkdlval(name
, subs
, range
)
p
->var
= mkname(name
->dname
.len
, name
->dname
.repr
);
delt
*mkdatado(lvals
, dovar
, params
)
static char *toofew
= "missing loop parameters";
static char *toomany
= "too many loop parameters";
p
->elts
= revelist(lvals
);
if (pcnt
!= 2 && pcnt
!= 3)
p
->init
= (vexpr
*) ALLOC(Derror
);
p
->limit
= (vexpr
*) ALLOC(Derror
);
p
->step
= (vexpr
*) ALLOC(Derror
);
vallist
*mkdrval(repl
, 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";
status
= vp
->dvalue
.status
;
value
= vp
->dvalue
.value
;
if ((status
== NORMAL
&& value
< 0) || status
== MINLESS1
)
else if (status
== NORMAL
)
else if (status
== MAXPLUS1
)
else if (vp
->tag
== DNAME
)
errnm(nonconst
, vp
->dname
.len
, vp
->dname
.repr
);
else if (vp
->tag
== DERROR
)
/* Evicon returns the value of the integer constant */
/* pointed to by token. */
vexpr
*evicon(len
, token
)
static char *badconst
= "bad integer constant";
static char *overflow
= "integer constant too large";
if (MAXINT
- val
>= digit
)
if (i
== len
&& MAXINT
- val
+ 1 == digit
)
/* Ivaltoicon converts a dvalue into a constant block. */
static char *badtag
= "bad tag in ivaltoicon";
static char *overflow
= "integer constant too large";
else if (vp
->tag
!= DVALUE
)
p
= mkintcon(vp
->dvalue
.value
);
else if ((MAXINT
+ MININT
== -1) && vs
== MINLESS1
)
else if (vs
== MAXPLUS1
|| vs
== MINLESS1
)
/* Mkdname stores an identifier as a dname */
s
= (char *) ckalloc(len
+ 1);
/* 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 */
for (i
= 0; i
< l
&& *s
!= '\0'; ++i
)
&& eqn(VL
, n
, q
->varname
))
else if (++hp
>= lasthash
)
/* Evparam returns the value of the constant named by name. */
static char *badtag
= "bad tag in evparam";
static char *undefined
= "%s is undefined";
static char *nonconst
= "%s is not constant";
register struct Paramblock
*tp
;
tp
= (struct Paramblock
*) getname(len
, repr
);
errnm(undefined
, len
, repr
);
else if (tp
->vclass
!= CLPARAM
|| !ISCONST(tp
->paramval
))
if (tp
->paramval
->tag
!= TERROR
)
errnm(nonconst
, len
, repr
);
p
= (expptr
) cpexpr(tp
->paramval
);
static char *undefined
= "%s is undefined";
static char *nonconst
= "%s is not a constant";
static char *nonint
= "%s is not an integer";
register struct Paramblock
*tp
;
tp
= (struct Paramblock
*) getname(len
, repr
);
errnm(undefined
, len
, repr
);
else if (tp
->vclass
!= CLPARAM
|| !ISCONST(tp
->paramval
))
if (tp
->paramval
->tag
!= TERROR
)
errnm(nonconst
, len
, repr
);
else if (!ISINT(tp
->paramval
->constblock
.vtype
))
errnm(nonint
, len
, repr
);
if ((MAXINT
+ MININT
== -1)
&& tp
->paramval
->constblock
.constant
.ci
== MININT
)
p
->value
= tp
->paramval
->constblock
.constant
.ci
;
static char *badop
= "bad operator in mkdexpr";
if ((l
!= NULL
&& l
->tag
== DERROR
) || r
->tag
== DERROR
)
p
= (vexpr
*) ALLOC(Derror
);
else if (op
== OPNEG
&& r
->tag
== DVALUE
)
else if (op
!= OPNEG
&& l
->tag
== DVALUE
&& r
->tag
== DVALUE
)
p
= (vexpr
*) ALLOC(Dexpr
);
static char *badtag
= "bad tag in addivals";
static char *overflow
= "integer value too large";
if (l
->tag
!= DVALUE
|| r
->tag
!= DVALUE
)
if (ls
== ERRVAL
|| rs
== ERRVAL
)
else if (ls
== NORMAL
&& rs
== NORMAL
)
if (rs
== MAXPLUS1
|| rs
== MINLESS1
)
if (rs
== NORMAL
&& rv
== 0)
if (rs
== NORMAL
&& rv
< 0)
if (rs
== NORMAL
&& rv
> 0)
static char *badtag
= "bad tag in negival";
p
->value
= -(vp
->dvalue
.value
);
static char *badtag
= "bad tag in subivals";
if (l
->tag
!= DVALUE
|| r
->tag
!= DVALUE
)
static char *badtag
= "bad tag in mulivals";
static char *overflow
= "integer value too large";
if (l
->tag
!= DVALUE
|| r
->tag
!= DVALUE
)
if (ls
== ERRVAL
|| rs
== ERRVAL
)
else if (ls
== NORMAL
&& rs
== NORMAL
)
if (rs
== MAXPLUS1
|| rs
== MINLESS1
)
if (rs
== NORMAL
&& rv
== 0)
else if (rs
== NORMAL
&& rv
== 1)
else if (rs
== NORMAL
&& rv
== -1)
static char *badtag
= "bad tag in divivals";
static char *zerodivide
= "division by zero";
if (l
->tag
!= DVALUE
&& r
->tag
!= DVALUE
)
if (ls
== ERRVAL
|| rs
== ERRVAL
)
p
->value
= sign
* ((k
+ 1)/rv
+ 1);
else if ((ls
== MAXPLUS1
&& rs
== MAXPLUS1
)
|| (ls
== MINLESS1
&& rs
== MINLESS1
))
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";
if (l
->tag
!= DVALUE
|| r
->tag
!= DVALUE
)
if (ls
== ERRVAL
|| rs
== ERRVAL
)
if (rs
== MAXPLUS1
|| (rs
== NORMAL
&& rv
> 0))
else if (rs
== NORMAL
&& rv
== 0)
if (rs
== NORMAL
&& rv
> 0)
while (--rv
&& rstatus
== NORMAL
)
if (rv
== 0 && rstatus
!= ERRVAL
)
else if (rs
== NORMAL
&& rv
== 0)
if (rs
== MAXPLUS1
|| (rs
== NORMAL
&& rv
> 1))
else if (rs
== NORMAL
&& rv
== 1)
else if (rs
== NORMAL
&& rv
== 0)
/* Addints adds two integer values. */
else if (j
== margin
+ 1)
margin
= ( -MAXINT
) - i
;
else if (j
== margin
- 1)
/* Mulints multiplies two integer values */
if ((i
> 0 && j
> 0) || (i
< 0 && j
< 0))
margin
= (margin
+ 1) / i
;
else if (j
- 1 == margin
)
if (margin
== MAXINT
- i
)
p
= cpdvalue((vexpr
*) ep
->dvar
.valp
);
if (ep
->dexpr
.left
== NULL
)
l
= evalvexpr(ep
->dexpr
.left
);
if (ep
->dexpr
.right
== NULL
)
r
= evalvexpr(ep
->dexpr
.right
);
switch (ep
->dexpr
.opcode
)
p
= (vexpr
*) ALLOC(Dvalue
);
p
->dvalue
.status
= ERRVAL
;
while (found
== NO
&& dvp
!= NULL
)
if (len
== dvp
->len
&& eqn(len
, repr
, dvp
->repr
))
p
= (vexpr
*) ALLOC(Dvar
);
p
->dvar
.valp
= dvp
->valp
;
if (p
->dvalue
.status
== ERRVAL
)
refrigvexpr( &(vp
->dexpr
.left
) );
refrigvexpr( &(vp
->dexpr
.right
) );
*(vpp
) = refrigdname(vp
);
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 struct Dimblock
*dp
;
if (np
->vclass
== CLUNKNOWN
|| (np
->vclass
== CLVAR
&& !np
->vdcldone
))
else if (np
->vclass
!= CLVAR
)
else if (np
->vstg
== STGAUTO
)
else if (np
->vstg
!= STGBSS
&& np
->vstg
!= STGINIT
&& np
->vstg
!= STGCOMMON
&& np
->vstg
!= STGEQUIV
)
if (dp
->nelt
== NULL
|| !ISICON(dp
->nelt
))
badtype("chkvar", np
->vtype
);
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 struct Dimblock
*dp
;
refrigvexpr( &(subp
->val
) );
if (np
->vdim
->ndim
> nsubs
)
else if (dp
->baseoffset
== NULL
|| !ISICON(dp
->baseoffset
))
if (dp
->dims
[i
].dimsize
== NULL
|| !ISICON(dp
->dims
[i
].dimsize
))
static char *nonstr
= "substring of a noncharacter variable: %s";
static char *array
= "substring applied to an array: %s";
else if (ap
->subs
== NULL
&& np
->vdim
!= NULL
)
refrigvexpr( &(rp
->low
) );
refrigvexpr( &(rp
->high
) );
rp
->high
= (vexpr
*) ALLOC(Derror
);
t
->value
= np
->vleng
->constblock
.constant
.ci
;
while (len
< VL
&& *sp
!= ' ' && *sp
!= '\0')
static char *duplicates
= "implied DO variable %s redefined";
static char *nonvar
= "%s is not a variable";
static char *nonint
= "%s is not integer";
refrigvexpr( &(dp
->init
) );
refrigvexpr( &(dp
->limit
) );
refrigvexpr( &(dp
->step
) );
len
= dp
->dovar
->dname
.len
;
repr
= dp
->dovar
->dname
.repr
;
while (found
== NO
&& dvp
!= NULL
)
if (len
== dvp
->len
&& eqn(len
, repr
, dvp
->repr
))
errnm(duplicates
, len
, repr
);
if (!ISINT(impltype
[letter(*repr
)]))
warnnm(nonint
, len
, repr
);
if (np
->vclass
== CLUNKNOWN
)
warnnm(nonvar
, len
, repr
);
else if (!ISINT(np
->vtype
))
warnnm(nonint
, len
, repr
);
dp
->dovar
= (vexpr
*) t
->valp
;
if (top
->elt
->tag
== SIMPLE
)
refrigaelt((aelt
*) top
->elt
);
refrigdo((dolist
*) top
->elt
);
/* Refrig freezes name/value bindings in the DATA name list */
static char *badvar
= "bad variable in indexer";
static char *boundserror
= "subscript out of bounds";
register struct Dimblock
*dp
;
if (sp
== NULL
) return (0);
vp
= (dvalue
*) evalvexpr(sp
->val
);
if (vp
->status
== NORMAL
)
else if ((MININT
+ MAXINT
== -1) && vp
->status
== MINLESS1
)
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
)
static char *toomany
= "more data values than data items";
grvals
= revrvals(rvals
);
while (grvals
!= NULL
&& dataerror
== NO
)
if (grvals
->status
!= NORMAL
)
else if (grvals
->repl
<= 0)
register struct Extsym
*cp
;
register struct Equivblock
*ep
;
if (stg
== STGBSS
|| stg
== STGINIT
)
np
->initoffset
= base
= vdatahwm
;
nelt
= np
->vdim
->nelt
->constblock
.constant
.ci
;
typelen
= np
->vleng
->constblock
.constant
.ci
;
else if (type
== TYLOGICAL
)
typelen
= typesize
[tylogical
];
typelen
= typesize
[type
];
varsize
= nelt
* typelen
;
else if (stg
== STGEQUIV
)
ep
= &eqvclass
[np
->vardesc
.varno
];
ep
->initoffset
= base
= vdatahwm
;
else if (stg
== STGCOMMON
)
cp
= &extsymtab
[np
->vardesc
.varno
];
cp
->initoffset
= base
= cdatahwm
;
wrtdata(offset
, repl
, len
, 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";
lastbyte
= offset
+ k
- 1;
bitpos
= offset
% BYTESIZE
;
chkoff
= offset
/BYTESIZE
;
lastoff
= lastbyte
/BYTESIZE
;
chklen
= lastoff
- chkoff
+ 1;
pos
= lseek(chkfile
, chkoff
, 0);
nbytes
= read(chkfile
, buff
, n
);
while (k
> 0 && bitpos
< BYTESIZE
)
while (i
< nbytes
&& overlap
== NO
)
if (buff
[i
] == 0 && k
>= BYTESIZE
)
pos
= lseek(chkfile
, -nbytes
, 1);
nbytes
= write(chkfile
, buff
, n
);
while (k
> 0 && allzero
!= NO
)
if (constant
[--k
] != 0) allzero
= NO
;
pos
= lseek(datafile
, offset
, 0);
nbytes
= write(datafile
, constant
, len
);
if (overlap
) overlapflag
= YES
;
static char *toofew
= "more data items than data values";
if (grvals
->status
!= NORMAL
)
else if (grvals
->repl
> 0)
frexpr ((tagptr
) grvals
->value
);
while (top
!= NULL
&& dataerror
== NO
)
if (top
->elt
->tag
== SIMPLE
)
outaelt((aelt
*) top
->elt
);
outdolist((dolist
*) top
->elt
);
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 Constp constant
;
extern char *packbytes();
typelen
= np
->vleng
->constblock
.constant
.ci
;
else if (type
== TYLOGICAL
)
typelen
= typesize
[tylogical
];
typelen
= typesize
[type
];
if (ap
->subs
!= NULL
|| np
->vdim
== NULL
)
soffset
= soffset
* typelen
;
lwb
= (dvalue
*) evalvexpr(ap
->range
->low
);
upb
= (dvalue
*) evalvexpr(ap
->range
->high
);
if (lwb
->status
== ERRVAL
|| upb
->status
== ERRVAL
)
if (lwb
->status
!= NORMAL
||
if (lwb
->value
> upb
->value
)
soffset
= soffset
+ lwb
->value
- 1;
typelen
= upb
->value
- lwb
->value
+ 1;
if (constant
== NULL
|| !ISCONST(constant
))
constant
= (Constp
) convconst(type
, typelen
, constant
);
if (constant
== NULL
|| !ISCONST(constant
))
frexpr((tagptr
) constant
);
wrtdata(base
+ soffset
, 1, typelen
, constant
->constant
.ccp
);
wrtdata(base
+ soffset
, 1, typelen
, packbytes(constant
));
frexpr((tagptr
) constant
);
k
= np
->vdim
->nelt
->constblock
.constant
.ci
;
while (k
> 0 && dataerror
== NO
)
else if (grvals
->status
!= NORMAL
)
else if (grvals
-> repl
<= 0)
frexpr((tagptr
) grvals
->value
);
constant
= grvals
->value
;
if (constant
== NULL
|| !ISCONST(constant
))
constant
= (Constp
) convconst(type
, typelen
, constant
);
if (constant
== NULL
|| !ISCONST(constant
))
frexpr((tagptr
) constant
);
wrtdata(base
+soffset
, repl
, typelen
, constant
->constant
.ccp
);
wrtdata(base
+soffset
, repl
, typelen
, packbytes(constant
));
soffset
= soffset
+ repl
* typelen
;
frexpr((tagptr
) constant
);
static char *zerostep
= "zero step in implied-DO";
static char *order
= "zero iteration count in implied-DO";
register dvalue
*e1
, *e2
, *e3
;
e1
= (dvalue
*) evalvexpr(dp
->init
);
e2
= (dvalue
*) evalvexpr(dp
->limit
);
e3
= (dvalue
*) evalvexpr(dp
->step
);
if (e1
->status
== ERRVAL
||
if (e1
->status
== NORMAL
)
if (e2
->status
== NORMAL
)
if (e1
->value
< e2
->value
)
else if (e1
->value
> e2
->value
)
else if (e2
->status
== MAXPLUS1
)
else if (e1
->status
== MAXPLUS1
)
if (e2
->status
== MAXPLUS1
)
if (e2
->status
== MINLESS1
)
if (e3
->status
== NORMAL
&& e3
->value
== 0)
else if (e3
->status
== MAXPLUS1
||
(e3
->status
== NORMAL
&& e3
->value
> 0))
dv
= (dvalue
*) dp
->dovar
;
while (done
== NO
&& dataerror
== NO
)
if (e3
->status
== NORMAL
&& dv
->status
== NORMAL
)
addints(e3
->value
, dv
->value
);
if (e3
->status
!= NORMAL
)
if (e3
->status
== MAXPLUS1
)
if (dv
->status
== MAXPLUS1
)
if (ts
== MAXPLUS1
|| (ts
== NORMAL
&& tv
> 0))
else if (ts
== NORMAL
&& tv
== 0)
if (ts
== MINLESS1
|| (ts
== NORMAL
&& tv
< 0))
else if (ts
== NORMAL
&& tv
== 0)
if (dv
->status
== ERRVAL
)
if (e2
->status
== NORMAL
)
if (dv
->status
== MAXPLUS1
||
(dv
->status
== NORMAL
&& dv
->value
> e2
->value
))
if (e2
->status
== NORMAL
)
if (dv
->status
== MINLESS1
||
(dv
->status
== NORMAL
&& dv
->value
< e2
->value
))