Commit | Line | Data |
---|---|---|
eb5ad1d2 F |
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 struct constblock *repp, *valp; | |
10 | { | |
11 | int i, nrep; | |
12 | ftnint elen, vlen; | |
13 | register struct addrblock *p; | |
14 | struct addrblock *nextdata(); | |
15 | ||
16 | if(repp == NULL) | |
17 | nrep = 1; | |
18 | else if (ISICON(repp) && repp->const.ci >= 0) | |
19 | nrep = repp->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 | struct addrblock *nextdata(elenp, vlenp) | |
54 | ftnint *elenp, *vlenp; | |
55 | { | |
56 | register struct impldoblock *ip; | |
57 | struct primblock *pp; | |
58 | register struct nameblock *np; | |
59 | register struct rplblock *rp; | |
60 | tagptr p; | |
61 | expptr neltp; | |
62 | register expptr q; | |
63 | int skip; | |
64 | ftnint off; | |
65 | struct constblock *mkintcon(); | |
66 | ||
67 | while(curdtp) | |
68 | { | |
69 | p = curdtp->datap; | |
70 | if(p->tag == TIMPLDO) | |
71 | { | |
72 | ip = p; | |
73 | if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) | |
74 | fatal1("bad impldoblock 0%o", ip); | |
75 | if(ip->isactive) | |
76 | ip->varvp->const.ci += ip->impdiff; | |
77 | else | |
78 | { | |
79 | q = fixtype(cpexpr(ip->implb)); | |
80 | if( ! ISICON(q) ) | |
81 | goto doerr; | |
82 | ip->varvp = q; | |
83 | ||
84 | if(ip->impstep) | |
85 | { | |
86 | q = fixtype(cpexpr(ip->impstep)); | |
87 | if( ! ISICON(q) ) | |
88 | goto doerr; | |
89 | ip->impdiff = q->const.ci; | |
90 | frexpr(q); | |
91 | } | |
92 | else | |
93 | ip->impdiff = 1; | |
94 | ||
95 | q = fixtype(cpexpr(ip->impub)); | |
96 | if(! ISICON(q)) | |
97 | goto doerr; | |
98 | ip->implim = q->const.ci; | |
99 | frexpr(q); | |
100 | ||
101 | ip->isactive = YES; | |
102 | rp = ALLOC(rplblock); | |
103 | rp->nextp = rpllist; | |
104 | rpllist = rp; | |
105 | rp->rplnp = ip->varnp; | |
106 | rp->rplvp = ip->varvp; | |
107 | rp->rpltag = TCONST; | |
108 | } | |
109 | ||
110 | if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim)) | |
111 | || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) ) | |
112 | { /* start new loop */ | |
113 | curdtp = ip->datalist; | |
114 | goto next; | |
115 | } | |
116 | ||
117 | /* clean up loop */ | |
118 | ||
119 | popstack(&rpllist); | |
120 | ||
121 | frexpr(ip->varvp); | |
122 | ip->isactive = NO; | |
123 | curdtp = curdtp->nextp; | |
124 | goto next; | |
125 | } | |
126 | ||
127 | pp = p; | |
128 | np = pp->namep; | |
129 | skip = YES; | |
130 | ||
131 | if(p->argsp==NULL && np->vdim!=NULL) | |
132 | { /* array initialization */ | |
133 | q = mkaddr(np); | |
134 | off = typesize[np->vtype] * curdtelt; | |
135 | if(np->vtype == TYCHAR) | |
136 | off *= np->vleng->const.ci; | |
137 | q->memoffset = mkexpr(OPPLUS, q->memoffset, mkintcon(off) ); | |
138 | if( (neltp = np->vdim->nelt) && ISCONST(neltp)) | |
139 | { | |
140 | if(++curdtelt < neltp->const.ci) | |
141 | skip = NO; | |
142 | } | |
143 | else | |
144 | err("attempt to initialize adjustable array"); | |
145 | } | |
146 | else | |
147 | q = mklhs( cpexpr(pp) ); | |
148 | if(skip) | |
149 | { | |
150 | curdtp = curdtp->nextp; | |
151 | curdtelt = 0; | |
152 | } | |
153 | if(q->vtype == TYCHAR) | |
154 | if(ISICON(q->vleng)) | |
155 | *elenp = q->vleng->const.ci; | |
156 | else { | |
157 | err("initialization of string of nonconstant length"); | |
158 | continue; | |
159 | } | |
160 | else *elenp = typesize[q->vtype]; | |
161 | ||
162 | if(np->vstg == STGCOMMON) | |
163 | *vlenp = extsymtab[np->vardesc.varno].maxleng; | |
164 | else if(np->vstg == STGEQUIV) | |
165 | *vlenp = eqvclass[np->vardesc.varno].eqvleng; | |
166 | else { | |
167 | *vlenp = (np->vtype==TYCHAR ? | |
168 | np->vleng->const.ci : typesize[np->vtype]); | |
169 | if(np->vdim) | |
170 | *vlenp *= np->vdim->nelt->const.ci; | |
171 | } | |
172 | return(q); | |
173 | ||
174 | doerr: | |
175 | err("nonconstant implied DO parameter"); | |
176 | frexpr(q); | |
177 | curdtp = curdtp->nextp; | |
178 | ||
179 | next: curdtelt = 0; | |
180 | } | |
181 | ||
182 | return(NULL); | |
183 | } | |
184 | ||
185 | ||
186 | ||
187 | ||
188 | ||
189 | ||
190 | LOCAL setdata(varp, valp, elen, vlen) | |
191 | struct addrblock *varp; | |
192 | ftnint elen, vlen; | |
193 | struct constblock *valp; | |
194 | { | |
195 | union constant con; | |
196 | int i, k; | |
197 | int stg, type, valtype; | |
198 | ftnint offset; | |
199 | register char *s, *t; | |
200 | char *memname(); | |
201 | static char varname[XL+2]; | |
202 | ||
203 | /* output form of name is padded with blanks and preceded | |
204 | with a storage class digit | |
205 | */ | |
206 | ||
207 | stg = varp->vstg; | |
208 | varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') ); | |
209 | s = memname(stg, varp->memno); | |
210 | for(t = varname+1 ; *s ; ) | |
211 | *t++ = *s++; | |
212 | while(t < varname+XL+1) | |
213 | *t++ = ' '; | |
214 | varname[XL+1] = '\0'; | |
215 | ||
216 | offset = varp->memoffset->const.ci; | |
217 | type = varp->vtype; | |
218 | valtype = valp->vtype; | |
219 | if(type!=TYCHAR && valtype==TYCHAR) | |
220 | { | |
221 | if(! ftn66flag) | |
222 | warn("non-character datum initialized with character string"); | |
223 | varp->vleng = ICON(typesize[type]); | |
224 | varp->vtype = type = TYCHAR; | |
225 | } | |
226 | else if( (type==TYCHAR && valtype!=TYCHAR) || | |
227 | (cktype(OPASSIGN,type,valtype) == TYERROR) ) | |
228 | { | |
229 | err("incompatible types in initialization"); | |
230 | return; | |
231 | } | |
232 | if(type != TYCHAR) | |
233 | if(valtype == TYUNKNOWN) | |
234 | con.ci = valp->const.ci; | |
235 | else consconv(type, &con, valtype, &valp->const); | |
236 | ||
237 | k = 1; | |
238 | switch(type) | |
239 | { | |
240 | case TYLOGICAL: | |
241 | type = tylogical; | |
242 | case TYSHORT: | |
243 | case TYLONG: | |
244 | fprintf(initfile, datafmt, varname, offset, vlen, type); | |
245 | prconi(initfile, type, con.ci); | |
246 | break; | |
247 | ||
248 | case TYCOMPLEX: | |
249 | k = 2; | |
250 | type = TYREAL; | |
251 | case TYREAL: | |
252 | goto flpt; | |
253 | ||
254 | case TYDCOMPLEX: | |
255 | k = 2; | |
256 | type = TYDREAL; | |
257 | case TYDREAL: | |
258 | flpt: | |
259 | ||
260 | for(i = 0 ; i < k ; ++i) | |
261 | { | |
262 | fprintf(initfile, datafmt, varname, offset, vlen, type); | |
263 | prconr(initfile, type, con.cd[i]); | |
264 | offset += typesize[type]; | |
265 | } | |
266 | break; | |
267 | ||
268 | case TYCHAR: | |
269 | k = valp->vleng->const.ci; | |
270 | if(elen < k) | |
271 | k = elen; | |
272 | ||
273 | for(i = 0 ; i < k ; ++i) | |
274 | { | |
275 | fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR); | |
276 | fprintf(initfile, "\t%d\n", valp->const.ccp[i]); | |
277 | } | |
278 | k = elen - valp->vleng->const.ci; | |
279 | while( k-- > 0) | |
280 | { | |
281 | fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR); | |
282 | fprintf(initfile, "\t%d\n", ' '); | |
283 | } | |
284 | break; | |
285 | ||
286 | default: | |
287 | fatal1("setdata: impossible type %d", type); | |
288 | } | |
289 | ||
290 | } | |
291 | ||
292 | ||
293 | ||
294 | frdata(p0) | |
295 | chainp p0; | |
296 | { | |
297 | register chainp p; | |
298 | register tagptr q; | |
299 | ||
300 | for(p = p0 ; p ; p = p->nextp) | |
301 | { | |
302 | q = p->datap; | |
303 | if(q->tag == TIMPLDO) | |
304 | { | |
305 | if(q->isbusy) | |
306 | return; /* circular chain completed */ | |
307 | q->isbusy = YES; | |
308 | frdata(q->datalist); | |
309 | free(q); | |
310 | } | |
311 | else | |
312 | frexpr(q); | |
313 | } | |
314 | ||
315 | frchain( &p0); | |
316 | } |