Commit | Line | Data |
---|---|---|
f1525c23 WH |
1 | /**************************************************************** |
2 | Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. | |
3 | ||
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. | |
13 | ||
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 | |
21 | this software. | |
22 | ****************************************************************/ | |
23 | ||
24 | #include "defs.h" | |
25 | ||
26 | /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */ | |
27 | ||
28 | static char datafmt[] = "%s\t%09ld\t%d"; | |
29 | static char *cur_varname; | |
30 | ||
31 | /* another initializer, called from parser */ | |
32 | dataval(repp, valp) | |
33 | register expptr repp, valp; | |
34 | { | |
35 | int i, nrep; | |
36 | ftnint elen; | |
37 | register Addrp p; | |
38 | Addrp nextdata(); | |
39 | ||
40 | if (parstate < INDATA) { | |
41 | frexpr(repp); | |
42 | goto ret; | |
43 | } | |
44 | if(repp == NULL) | |
45 | nrep = 1; | |
46 | else if (ISICON(repp) && repp->constblock.Const.ci >= 0) | |
47 | nrep = repp->constblock.Const.ci; | |
48 | else | |
49 | { | |
50 | err("invalid repetition count in DATA statement"); | |
51 | frexpr(repp); | |
52 | goto ret; | |
53 | } | |
54 | frexpr(repp); | |
55 | ||
56 | if( ! ISCONST(valp) ) | |
57 | { | |
58 | err("non-constant initializer"); | |
59 | goto ret; | |
60 | } | |
61 | ||
62 | if(toomanyinit) goto ret; | |
63 | for(i = 0 ; i < nrep ; ++i) | |
64 | { | |
65 | p = nextdata(&elen); | |
66 | if(p == NULL) | |
67 | { | |
68 | err("too many initializers"); | |
69 | toomanyinit = YES; | |
70 | goto ret; | |
71 | } | |
72 | setdata((Addrp)p, (Constp)valp, elen); | |
73 | frexpr((expptr)p); | |
74 | } | |
75 | ||
76 | ret: | |
77 | frexpr(valp); | |
78 | } | |
79 | ||
80 | ||
81 | Addrp nextdata(elenp) | |
82 | ftnint *elenp; | |
83 | { | |
84 | register struct Impldoblock *ip; | |
85 | struct Primblock *pp; | |
86 | register Namep np; | |
87 | register struct Rplblock *rp; | |
88 | tagptr p; | |
89 | expptr neltp; | |
90 | register expptr q; | |
91 | int skip; | |
92 | ftnint off, vlen; | |
93 | ||
94 | while(curdtp) | |
95 | { | |
96 | p = (tagptr)curdtp->datap; | |
97 | if(p->tag == TIMPLDO) | |
98 | { | |
99 | ip = &(p->impldoblock); | |
100 | if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) | |
101 | fatali("bad impldoblock 0%o", (int) ip); | |
102 | if(ip->isactive) | |
103 | ip->varvp->Const.ci += ip->impdiff; | |
104 | else | |
105 | { | |
106 | q = fixtype(cpexpr(ip->implb)); | |
107 | if( ! ISICON(q) ) | |
108 | goto doerr; | |
109 | ip->varvp = (Constp) q; | |
110 | ||
111 | if(ip->impstep) | |
112 | { | |
113 | q = fixtype(cpexpr(ip->impstep)); | |
114 | if( ! ISICON(q) ) | |
115 | goto doerr; | |
116 | ip->impdiff = q->constblock.Const.ci; | |
117 | frexpr(q); | |
118 | } | |
119 | else | |
120 | ip->impdiff = 1; | |
121 | ||
122 | q = fixtype(cpexpr(ip->impub)); | |
123 | if(! ISICON(q)) | |
124 | goto doerr; | |
125 | ip->implim = q->constblock.Const.ci; | |
126 | frexpr(q); | |
127 | ||
128 | ip->isactive = YES; | |
129 | rp = ALLOC(Rplblock); | |
130 | rp->rplnextp = rpllist; | |
131 | rpllist = rp; | |
132 | rp->rplnp = ip->varnp; | |
133 | rp->rplvp = (expptr) (ip->varvp); | |
134 | rp->rpltag = TCONST; | |
135 | } | |
136 | ||
137 | if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) | |
138 | || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) | |
139 | { /* start new loop */ | |
140 | curdtp = ip->datalist; | |
141 | goto next; | |
142 | } | |
143 | ||
144 | /* clean up loop */ | |
145 | ||
146 | if(rpllist) | |
147 | { | |
148 | rp = rpllist; | |
149 | rpllist = rpllist->rplnextp; | |
150 | free( (charptr) rp); | |
151 | } | |
152 | else | |
153 | Fatal("rpllist empty"); | |
154 | ||
155 | frexpr((expptr)ip->varvp); | |
156 | ip->isactive = NO; | |
157 | curdtp = curdtp->nextp; | |
158 | goto next; | |
159 | } | |
160 | ||
161 | pp = (struct Primblock *) p; | |
162 | np = pp->namep; | |
163 | cur_varname = np->fvarname; | |
164 | skip = YES; | |
165 | ||
166 | if(p->primblock.argsp==NULL && np->vdim!=NULL) | |
167 | { /* array initialization */ | |
168 | q = (expptr) mkaddr(np); | |
169 | off = typesize[np->vtype] * curdtelt; | |
170 | if(np->vtype == TYCHAR) | |
171 | off *= np->vleng->constblock.Const.ci; | |
172 | q->addrblock.memoffset = | |
173 | mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); | |
174 | if( (neltp = np->vdim->nelt) && ISCONST(neltp)) | |
175 | { | |
176 | if(++curdtelt < neltp->constblock.Const.ci) | |
177 | skip = NO; | |
178 | } | |
179 | else | |
180 | err("attempt to initialize adjustable array"); | |
181 | } | |
182 | else | |
183 | q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); | |
184 | if(skip) | |
185 | { | |
186 | curdtp = curdtp->nextp; | |
187 | curdtelt = 0; | |
188 | } | |
189 | if(q->headblock.vtype == TYCHAR) | |
190 | if(ISICON(q->headblock.vleng)) | |
191 | *elenp = q->headblock.vleng->constblock.Const.ci; | |
192 | else { | |
193 | err("initialization of string of nonconstant length"); | |
194 | continue; | |
195 | } | |
196 | else *elenp = typesize[q->headblock.vtype]; | |
197 | ||
198 | if (np->vstg == STGBSS) { | |
199 | vlen = np->vtype==TYCHAR | |
200 | ? np->vleng->constblock.Const.ci | |
201 | : typesize[np->vtype]; | |
202 | if(vlen > 0) | |
203 | np->vstg = STGINIT; | |
204 | } | |
205 | return( (Addrp) q ); | |
206 | ||
207 | doerr: | |
208 | err("nonconstant implied DO parameter"); | |
209 | frexpr(q); | |
210 | curdtp = curdtp->nextp; | |
211 | ||
212 | next: | |
213 | curdtelt = 0; | |
214 | } | |
215 | ||
216 | return(NULL); | |
217 | } | |
218 | ||
219 | ||
220 | ||
221 | LOCAL FILEP dfile; | |
222 | ||
223 | ||
224 | setdata(varp, valp, elen) | |
225 | register Addrp varp; | |
226 | ftnint elen; | |
227 | register Constp valp; | |
228 | { | |
229 | struct Constblock con; | |
230 | register int type; | |
231 | int i, k, valtype; | |
232 | ftnint offset; | |
233 | char *dataname(), *varname; | |
234 | static Addrp badvar; | |
235 | register unsigned char *s; | |
236 | static int last_lineno; | |
237 | static char *last_varname; | |
238 | ||
239 | if (varp->vstg == STGCOMMON) { | |
240 | if (!(dfile = blkdfile)) | |
241 | dfile = blkdfile = opf(blkdfname, textwrite); | |
242 | } | |
243 | else { | |
244 | if (procclass == CLBLOCK) { | |
245 | if (varp != badvar) { | |
246 | badvar = varp; | |
247 | warn1("%s is not in a COMMON block", | |
248 | varp->uname_tag == UNAM_NAME | |
249 | ? varp->user.name->fvarname | |
250 | : "???"); | |
251 | } | |
252 | return; | |
253 | } | |
254 | if (!(dfile = initfile)) | |
255 | dfile = initfile = opf(initfname, textwrite); | |
256 | } | |
257 | varname = dataname(varp->vstg, varp->memno); | |
258 | offset = varp->memoffset->constblock.Const.ci; | |
259 | type = varp->vtype; | |
260 | valtype = valp->vtype; | |
261 | if(type!=TYCHAR && valtype==TYCHAR) | |
262 | { | |
263 | if(! ftn66flag | |
264 | && (last_varname != cur_varname || last_lineno != lineno)) { | |
265 | /* prevent multiple warnings */ | |
266 | last_lineno = lineno; | |
267 | warn1( | |
268 | "non-character datum %.42s initialized with character string", | |
269 | last_varname = cur_varname); | |
270 | } | |
271 | varp->vleng = ICON(typesize[type]); | |
272 | varp->vtype = type = TYCHAR; | |
273 | } | |
274 | else if( (type==TYCHAR && valtype!=TYCHAR) || | |
275 | (cktype(OPASSIGN,type,valtype) == TYERROR) ) | |
276 | { | |
277 | err("incompatible types in initialization"); | |
278 | return; | |
279 | } | |
280 | if(type == TYADDR) | |
281 | con.Const.ci = valp->Const.ci; | |
282 | else if(type != TYCHAR) | |
283 | { | |
284 | if(valtype == TYUNKNOWN) | |
285 | con.Const.ci = valp->Const.ci; | |
286 | else consconv(type, &con, valp); | |
287 | } | |
288 | ||
289 | k = 1; | |
290 | ||
291 | switch(type) | |
292 | { | |
293 | case TYLOGICAL: | |
294 | if (tylogical != TYLONG) | |
295 | type = tylogical; | |
296 | case TYINT1: | |
297 | case TYLOGICAL1: | |
298 | case TYLOGICAL2: | |
299 | case TYSHORT: | |
300 | case TYLONG: | |
301 | #ifdef TYQUAD | |
302 | case TYQUAD: | |
303 | #endif | |
304 | dataline(varname, offset, type); | |
305 | prconi(dfile, con.Const.ci); | |
306 | break; | |
307 | ||
308 | case TYADDR: | |
309 | dataline(varname, offset, type); | |
310 | prcona(dfile, con.Const.ci); | |
311 | break; | |
312 | ||
313 | case TYCOMPLEX: | |
314 | case TYDCOMPLEX: | |
315 | k = 2; | |
316 | case TYREAL: | |
317 | case TYDREAL: | |
318 | dataline(varname, offset, type); | |
319 | prconr(dfile, &con, k); | |
320 | break; | |
321 | ||
322 | case TYCHAR: | |
323 | k = valp -> vleng -> constblock.Const.ci; | |
324 | if (elen < k) | |
325 | k = elen; | |
326 | s = (unsigned char *)valp->Const.ccp; | |
327 | for(i = 0 ; i < k ; ++i) { | |
328 | dataline(varname, offset++, TYCHAR); | |
329 | fprintf(dfile, "\t%d\n", *s++); | |
330 | } | |
331 | k = elen - valp->vleng->constblock.Const.ci; | |
332 | if(k > 0) { | |
333 | dataline(varname, offset, TYBLANK); | |
334 | fprintf(dfile, "\t%d\n", k); | |
335 | } | |
336 | break; | |
337 | ||
338 | default: | |
339 | badtype("setdata", type); | |
340 | } | |
341 | ||
342 | } | |
343 | ||
344 | ||
345 | ||
346 | /* | |
347 | output form of name is padded with blanks and preceded | |
348 | with a storage class digit | |
349 | */ | |
350 | char *dataname(stg,memno) | |
351 | int stg; | |
352 | long memno; | |
353 | { | |
354 | static char varname[64]; | |
355 | register char *s, *t; | |
356 | char buf[16], *memname(); | |
357 | ||
358 | if (stg == STGCOMMON) { | |
359 | varname[0] = '2'; | |
360 | sprintf(s = buf, "Q.%ld", memno); | |
361 | } | |
362 | else { | |
363 | varname[0] = stg==STGEQUIV ? '1' : '0'; | |
364 | s = memname(stg, memno); | |
365 | } | |
366 | t = varname + 1; | |
367 | while(*t++ = *s++); | |
368 | *t = 0; | |
369 | return(varname); | |
370 | } | |
371 | ||
372 | ||
373 | ||
374 | ||
375 | ||
376 | frdata(p0) | |
377 | chainp p0; | |
378 | { | |
379 | register struct Chain *p; | |
380 | register tagptr q; | |
381 | ||
382 | for(p = p0 ; p ; p = p->nextp) | |
383 | { | |
384 | q = (tagptr)p->datap; | |
385 | if(q->tag == TIMPLDO) | |
386 | { | |
387 | if(q->impldoblock.isbusy) | |
388 | return; /* circular chain completed */ | |
389 | q->impldoblock.isbusy = YES; | |
390 | frdata(q->impldoblock.datalist); | |
391 | free( (charptr) q); | |
392 | } | |
393 | else | |
394 | frexpr(q); | |
395 | } | |
396 | ||
397 | frchain( &p0); | |
398 | } | |
399 | ||
400 | ||
401 | ||
402 | dataline(varname, offset, type) | |
403 | char *varname; | |
404 | ftnint offset; | |
405 | int type; | |
406 | { | |
407 | fprintf(dfile, datafmt, varname, offset, type); | |
408 | } | |
409 | ||
410 | void | |
411 | make_param(p, e) | |
412 | register struct Paramblock *p; | |
413 | expptr e; | |
414 | { | |
415 | register expptr q; | |
416 | ||
417 | p->vclass = CLPARAM; | |
418 | impldcl((Namep)p); | |
419 | p->paramval = q = mkconv(p->vtype, e); | |
420 | if (p->vtype == TYCHAR) { | |
421 | if (q->tag == TEXPR) | |
422 | p->paramval = q = fixexpr(q); | |
423 | if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { | |
424 | errstr("invalid value for character parameter %s", | |
425 | p->fvarname); | |
426 | return; | |
427 | } | |
428 | if (!(e = p->vleng)) | |
429 | p->vleng = ICON(q->constblock.vleng->constblock.Const.ci | |
430 | + q->constblock.Const.ccp1.blanks); | |
431 | else if (q->constblock.vleng->constblock.Const.ci | |
432 | > e->constblock.Const.ci) { | |
433 | q->constblock.vleng->constblock.Const.ci | |
434 | = e->constblock.Const.ci; | |
435 | q->constblock.Const.ccp1.blanks = 0; | |
436 | } | |
437 | else | |
438 | q->constblock.Const.ccp1.blanks | |
439 | = e->constblock.Const.ci | |
440 | - q->constblock.vleng->constblock.Const.ci; | |
441 | } | |
442 | } |