1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
26 /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
28 static char datafmt[] = "%s\t%09ld\t%d" ;
30 /* another initializer, called from parser */
32 register expptr repp, valp;
39 if (parstate < INDATA) {
45 else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
46 nrep = repp->constblock.Const.ci;
49 err("invalid repetition count in DATA statement");
57 err("non-constant initializer");
61 if(toomanyinit) goto ret;
62 for(i = 0 ; i < nrep ; ++i)
67 err("too many initializers");
71 setdata((Addrp)p, (Constp)valp, elen);
83 register struct Impldoblock *ip;
86 register struct Rplblock *rp;
95 p = (tagptr)curdtp->datap;
98 ip = &(p->impldoblock);
99 if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
100 fatali("bad impldoblock 0%o", (int) ip);
102 ip->varvp->Const.ci += ip->impdiff;
105 q = fixtype(cpexpr(ip->implb));
108 ip->varvp = (Constp) q;
112 q = fixtype(cpexpr(ip->impstep));
115 ip->impdiff = q->constblock.Const.ci;
121 q = fixtype(cpexpr(ip->impub));
124 ip->implim = q->constblock.Const.ci;
128 rp = ALLOC(Rplblock);
129 rp->rplnextp = rpllist;
131 rp->rplnp = ip->varnp;
132 rp->rplvp = (expptr) (ip->varvp);
136 if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
137 || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
138 { /* start new loop */
139 curdtp = ip->datalist;
148 rpllist = rpllist->rplnextp;
152 Fatal("rpllist empty");
154 frexpr((expptr)ip->varvp);
156 curdtp = curdtp->nextp;
160 pp = (struct Primblock *) p;
164 if(p->primblock.argsp==NULL && np->vdim!=NULL)
165 { /* array initialization */
166 q = (expptr) mkaddr(np);
167 off = typesize[np->vtype] * curdtelt;
168 if(np->vtype == TYCHAR)
169 off *= np->vleng->constblock.Const.ci;
170 q->addrblock.memoffset =
171 mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
172 if( (neltp = np->vdim->nelt) && ISCONST(neltp))
174 if(++curdtelt < neltp->constblock.Const.ci)
178 err("attempt to initialize adjustable array");
181 q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
184 curdtp = curdtp->nextp;
187 if(q->headblock.vtype == TYCHAR)
188 if(ISICON(q->headblock.vleng))
189 *elenp = q->headblock.vleng->constblock.Const.ci;
191 err("initialization of string of nonconstant length");
194 else *elenp = typesize[q->headblock.vtype];
196 if (np->vstg == STGBSS) {
197 vlen = np->vtype==TYCHAR
198 ? np->vleng->constblock.Const.ci
199 : typesize[np->vtype];
206 err("nonconstant implied DO parameter");
208 curdtp = curdtp->nextp;
222 setdata(varp, valp, elen)
225 register Constp valp;
227 struct Constblock con;
231 char *dataname(), *varname;
234 if (varp->vstg == STGCOMMON) {
235 if (!(dfile = blkdfile))
236 dfile = blkdfile = opf(blkdfname, textwrite);
239 if (procclass == CLBLOCK) {
240 if (varp != badvar) {
242 warn1("%s is not in a COMMON block",
243 varp->uname_tag == UNAM_NAME
244 ? varp->user.name->fvarname
249 if (!(dfile = initfile))
250 dfile = initfile = opf(initfname, textwrite);
252 varname = dataname(varp->vstg, varp->memno);
253 offset = varp->memoffset->constblock.Const.ci;
255 valtype = valp->vtype;
256 if(type!=TYCHAR && valtype==TYCHAR)
259 warn("non-character datum initialized with character string");
260 varp->vleng = ICON(typesize[type]);
261 varp->vtype = type = TYCHAR;
263 else if( (type==TYCHAR && valtype!=TYCHAR) ||
264 (cktype(OPASSIGN,type,valtype) == TYERROR) )
266 err("incompatible types in initialization");
270 con.Const.ci = valp->Const.ci;
271 else if(type != TYCHAR)
273 if(valtype == TYUNKNOWN)
274 con.Const.ci = valp->Const.ci;
275 else consconv(type, &con, valp);
283 if (tylogical != TYLONG)
287 dataline(varname, offset, type);
288 prconi(dfile, con.Const.ci);
292 dataline(varname, offset, type);
293 prcona(dfile, con.Const.ci);
301 dataline(varname, offset, type);
302 prconr(dfile, &con, k);
306 k = valp -> vleng -> constblock.Const.ci;
309 for(i = 0 ; i < k ; ++i) {
310 dataline(varname, offset++, TYCHAR);
311 fprintf(dfile, "\t%d\n",
314 k = elen - valp->vleng->constblock.Const.ci;
316 dataline(varname, offset, TYBLANK);
317 fprintf(dfile, "\t%d\n", k);
322 badtype("setdata", type);
330 output form of name is padded with blanks and preceded
331 with a storage class digit
333 char *dataname(stg,memno)
337 static char varname[64];
338 register char *s, *t;
339 char buf[16], *memname();
341 if (stg == STGCOMMON) {
343 sprintf(s = buf, "Q.%ld", memno);
346 varname[0] = stg==STGEQUIV ? '1' : '0';
347 s = memname(stg, memno);
362 register struct Chain *p;
365 for(p = p0 ; p ; p = p->nextp)
367 q = (tagptr)p->datap;
368 if(q->tag == TIMPLDO)
370 if(q->impldoblock.isbusy)
371 return; /* circular chain completed */
372 q->impldoblock.isbusy = YES;
373 frdata(q->impldoblock.datalist);
385 dataline(varname, offset, type)
390 fprintf(dfile, datafmt, varname, offset, type);
395 register struct Paramblock *p;
400 p->paramval = mkconv(p->vtype, e);