Commit | Line | Data |
---|---|---|
853979d9 BJ |
1 | #include "defs" |
2 | ||
3 | /* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */ | |
4 | ||
5 | static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ; | |
6 | ||
7 | /* another initializer, called from parser */ | |
8 | dataval(repp, valp) | |
9 | register expptr repp, valp; | |
10 | { | |
11 | int i, nrep; | |
12 | ftnint elen, vlen; | |
13 | register Addrp p; | |
14 | Addrp nextdata(); | |
15 | ||
16 | if(repp == NULL) | |
17 | nrep = 1; | |
18 | else if (ISICON(repp) && repp->constblock.const.ci >= 0) | |
19 | nrep = repp->constblock.const.ci; | |
20 | else | |
21 | { | |
22 | err("invalid repetition count in DATA statement"); | |
23 | frexpr(repp); | |
24 | goto ret; | |
25 | } | |
26 | frexpr(repp); | |
27 | ||
28 | if( ! ISCONST(valp) ) | |
29 | { | |
30 | err("non-constant initializer"); | |
31 | goto ret; | |
32 | } | |
33 | ||
34 | if(toomanyinit) goto ret; | |
35 | for(i = 0 ; i < nrep ; ++i) | |
36 | { | |
37 | p = nextdata(&elen, &vlen); | |
38 | if(p == NULL) | |
39 | { | |
40 | err("too many initializers"); | |
41 | toomanyinit = YES; | |
42 | goto ret; | |
43 | } | |
44 | setdata(p, valp, elen, vlen); | |
45 | frexpr(p); | |
46 | } | |
47 | ||
48 | ret: | |
49 | frexpr(valp); | |
50 | } | |
51 | ||
52 | ||
53 | Addrp nextdata(elenp, vlenp) | |
54 | ftnint *elenp, *vlenp; | |
55 | { | |
56 | register struct Impldoblock *ip; | |
57 | struct Primblock *pp; | |
58 | register Namep np; | |
59 | register struct Rplblock *rp; | |
60 | tagptr p; | |
61 | expptr neltp; | |
62 | register expptr q; | |
63 | int skip; | |
64 | ftnint off; | |
65 | ||
66 | while(curdtp) | |
67 | { | |
68 | p = curdtp->datap; | |
69 | if(p->tag == TIMPLDO) | |
70 | { | |
71 | ip = &(p->impldoblock); | |
72 | if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) | |
73 | fatali("bad impldoblock 0%o", (int) ip); | |
74 | if(ip->isactive) | |
75 | ip->varvp->const.ci += ip->impdiff; | |
76 | else | |
77 | { | |
78 | q = fixtype(cpexpr(ip->implb)); | |
79 | if( ! ISICON(q) ) | |
80 | goto doerr; | |
81 | ip->varvp = (Constp) q; | |
82 | ||
83 | if(ip->impstep) | |
84 | { | |
85 | q = fixtype(cpexpr(ip->impstep)); | |
86 | if( ! ISICON(q) ) | |
87 | goto doerr; | |
88 | ip->impdiff = q->constblock.const.ci; | |
89 | frexpr(q); | |
90 | } | |
91 | else | |
92 | ip->impdiff = 1; | |
93 | ||
94 | q = fixtype(cpexpr(ip->impub)); | |
95 | if(! ISICON(q)) | |
96 | goto doerr; | |
97 | ip->implim = q->constblock.const.ci; | |
98 | frexpr(q); | |
99 | ||
100 | ip->isactive = YES; | |
101 | rp = ALLOC(Rplblock); | |
102 | rp->rplnextp = rpllist; | |
103 | rpllist = rp; | |
104 | rp->rplnp = ip->varnp; | |
105 | rp->rplvp = (expptr) (ip->varvp); | |
106 | rp->rpltag = TCONST; | |
107 | } | |
108 | ||
109 | if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim)) | |
110 | || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) ) | |
111 | { /* start new loop */ | |
112 | curdtp = ip->datalist; | |
113 | goto next; | |
114 | } | |
115 | ||
116 | /* clean up loop */ | |
117 | ||
118 | if(rpllist) | |
119 | { | |
120 | rp = rpllist; | |
121 | rpllist = rpllist->rplnextp; | |
122 | free( (charptr) rp); | |
123 | } | |
124 | else | |
125 | fatal("rpllist empty"); | |
126 | ||
127 | frexpr(ip->varvp); | |
128 | ip->isactive = NO; | |
129 | curdtp = curdtp->nextp; | |
130 | goto next; | |
131 | } | |
132 | ||
133 | pp = (struct Primblock *) p; | |
134 | np = pp->namep; | |
135 | skip = YES; | |
136 | ||
137 | if(p->primblock.argsp==NULL && np->vdim!=NULL) | |
138 | { /* array initialization */ | |
139 | q = (expptr) mkaddr(np); | |
140 | off = typesize[np->vtype] * curdtelt; | |
141 | if(np->vtype == TYCHAR) | |
142 | off *= np->vleng->constblock.const.ci; | |
143 | q->addrblock.memoffset = | |
144 | mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); | |
145 | if( (neltp = np->vdim->nelt) && ISCONST(neltp)) | |
146 | { | |
147 | if(++curdtelt < neltp->constblock.const.ci) | |
148 | skip = NO; | |
149 | } | |
150 | else | |
151 | err("attempt to initialize adjustable array"); | |
152 | } | |
153 | else | |
154 | q = mklhs( cpexpr(pp) ); | |
155 | if(skip) | |
156 | { | |
157 | curdtp = curdtp->nextp; | |
158 | curdtelt = 0; | |
159 | } | |
160 | if(q->headblock.vtype == TYCHAR) | |
161 | if(ISICON(q->headblock.vleng)) | |
162 | *elenp = q->headblock.vleng->constblock.const.ci; | |
163 | else { | |
164 | err("initialization of string of nonconstant length"); | |
165 | continue; | |
166 | } | |
167 | else *elenp = typesize[q->headblock.vtype]; | |
168 | ||
169 | if(np->vstg == STGCOMMON) | |
170 | *vlenp = extsymtab[np->vardesc.varno].maxleng; | |
171 | else if(np->vstg == STGEQUIV) | |
172 | *vlenp = eqvclass[np->vardesc.varno].eqvleng; | |
173 | else { | |
174 | *vlenp = (np->vtype==TYCHAR ? | |
175 | np->vleng->constblock.const.ci : | |
176 | typesize[np->vtype]); | |
177 | if(np->vstg==STGBSS && *vlenp>0) | |
178 | np->vstg = STGINIT; | |
179 | if(np->vdim) | |
180 | *vlenp *= np->vdim->nelt->constblock.const.ci; | |
181 | } | |
182 | return( (Addrp) q ); | |
183 | ||
184 | doerr: | |
185 | err("nonconstant implied DO parameter"); | |
186 | frexpr(q); | |
187 | curdtp = curdtp->nextp; | |
188 | ||
189 | next: curdtelt = 0; | |
190 | } | |
191 | ||
192 | return(NULL); | |
193 | } | |
194 | ||
195 | ||
196 | ||
197 | ||
198 | ||
199 | ||
200 | setdata(varp, valp, elen, vlen) | |
201 | register Addrp varp; | |
202 | ftnint elen, vlen; | |
203 | register Constp valp; | |
204 | { | |
205 | union Constant con; | |
206 | register int type; | |
207 | int i, k, valtype; | |
208 | ftnint offset; | |
209 | char *dataname(), *varname; | |
210 | ||
211 | varname = dataname(varp->vstg, varp->memno); | |
212 | offset = varp->memoffset->constblock.const.ci; | |
213 | type = varp->vtype; | |
214 | valtype = valp->vtype; | |
215 | if(type!=TYCHAR && valtype==TYCHAR) | |
216 | { | |
217 | if(! ftn66flag) | |
218 | warn("non-character datum initialized with character string"); | |
219 | varp->vleng = ICON(typesize[type]); | |
220 | varp->vtype = type = TYCHAR; | |
221 | } | |
222 | else if( (type==TYCHAR && valtype!=TYCHAR) || | |
223 | (cktype(OPASSIGN,type,valtype) == TYERROR) ) | |
224 | { | |
225 | err("incompatible types in initialization"); | |
226 | return; | |
227 | } | |
228 | if(type == TYADDR) | |
229 | con.ci = valp->const.ci; | |
230 | else if(type != TYCHAR) | |
231 | { | |
232 | if(valtype == TYUNKNOWN) | |
233 | con.ci = valp->const.ci; | |
234 | else consconv(type, &con, valtype, &valp->const); | |
235 | } | |
236 | ||
237 | k = 1; | |
238 | switch(type) | |
239 | { | |
240 | case TYLOGICAL: | |
241 | type = tylogical; | |
242 | case TYSHORT: | |
243 | case TYLONG: | |
244 | dataline(varname, offset, vlen, type); | |
245 | prconi(initfile, type, con.ci); | |
246 | break; | |
247 | ||
248 | case TYADDR: | |
249 | dataline(varname, offset, vlen, type); | |
250 | prcona(initfile, con.ci); | |
251 | break; | |
252 | ||
253 | case TYCOMPLEX: | |
254 | k = 2; | |
255 | type = TYREAL; | |
256 | case TYREAL: | |
257 | goto flpt; | |
258 | ||
259 | case TYDCOMPLEX: | |
260 | k = 2; | |
261 | type = TYDREAL; | |
262 | case TYDREAL: | |
263 | flpt: | |
264 | ||
265 | for(i = 0 ; i < k ; ++i) | |
266 | { | |
267 | dataline(varname, offset, vlen, type); | |
268 | prconr(initfile, type, con.cd[i]); | |
269 | offset += typesize[type]; | |
270 | } | |
271 | break; | |
272 | ||
273 | case TYCHAR: | |
274 | k = valp->vleng->constblock.const.ci; | |
275 | if(elen < k) | |
276 | k = elen; | |
277 | ||
278 | for(i = 0 ; i < k ; ++i) | |
279 | { | |
280 | dataline(varname, offset++, vlen, TYCHAR); | |
281 | fprintf(initfile, "\t%d\n", | |
282 | valp->const.ccp[i]); | |
283 | } | |
284 | k = elen - valp->vleng->constblock.const.ci; | |
285 | if(k > 0) | |
286 | { | |
287 | dataline(varname, offset, vlen, TYBLANK); | |
288 | fprintf(initfile, "\t%d\n", k); | |
289 | offset += k; | |
290 | } | |
291 | break; | |
292 | ||
293 | default: | |
294 | badtype("setdata", type); | |
295 | } | |
296 | ||
297 | } | |
298 | ||
299 | ||
300 | ||
301 | /* | |
302 | output form of name is padded with blanks and preceded | |
303 | with a storage class digit | |
304 | */ | |
305 | char *dataname(stg,memno) | |
306 | int stg, memno; | |
307 | { | |
308 | static char varname[XL+2]; | |
309 | register char *s, *t; | |
310 | char *memname(); | |
311 | ||
312 | varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') ); | |
313 | s = memname(stg, memno); | |
314 | for(t = varname+1 ; *s ; ) | |
315 | *t++ = *s++; | |
316 | while(t < varname+XL+1) | |
317 | *t++ = ' '; | |
318 | varname[XL+1] = '\0'; | |
319 | return(varname); | |
320 | } | |
321 | ||
322 | ||
323 | ||
324 | ||
325 | ||
326 | frdata(p0) | |
327 | chainp p0; | |
328 | { | |
329 | register struct Chain *p; | |
330 | register tagptr q; | |
331 | ||
332 | for(p = p0 ; p ; p = p->nextp) | |
333 | { | |
334 | q = p->datap; | |
335 | if(q->tag == TIMPLDO) | |
336 | { | |
337 | if(q->impldoblock.isbusy) | |
338 | return; /* circular chain completed */ | |
339 | q->impldoblock.isbusy = YES; | |
340 | frdata(q->impldoblock.datalist); | |
341 | free( (charptr) q); | |
342 | } | |
343 | else | |
344 | frexpr(q); | |
345 | } | |
346 | ||
347 | frchain( &p0); | |
348 | } | |
349 | ||
350 | ||
351 | ||
352 | dataline(varname, offset, vlen, type) | |
353 | char *varname; | |
354 | ftnint offset, vlen; | |
355 | int type; | |
356 | { | |
357 | fprintf(initfile, datafmt, varname, offset, vlen, type); | |
358 | } |