1 /* Id: data.c,v 1.15 2008/05/11 15:28:03 ragge Exp */
2 /* $NetBSD: data.c,v 1.1.1.2 2010/06/03 18:57:46 plunky Exp $ */
3 /*
4 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * Redistributions of source code and documentation must retain the above
11 * copyright notice, this list of conditions and the following disclaimer.
12 * Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditionsand the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 * All advertising materials mentioning features or use of this software
16 * must display the following acknowledgement:
17 * This product includes software developed or owned by Caldera
18 * International, Inc.
19 * Neither the name of Caldera International, Inc. nor the names of other
20 * contributors may be used to endorse or promote products derived from
21 * this software without specific prior written permission.
22 *
23 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
24 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
28 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
32 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
33 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 * POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "defines.h"
38 #include "defs.h"
39
40 #if 1 /* RAGGE */
41 extern FILE *initfile;
42 #endif
43
44 /* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */
45 LOCAL void setdata(struct bigblock *, struct bigblock *, ftnint, ftnint);
46
47 static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ;
48
49 /* another initializer, called from parser */
50 void
dataval(repp,valp)51 dataval(repp, valp)
52 register struct bigblock *repp, *valp;
53 {
54 int i, nrep;
55 ftnint elen, vlen;
56 register struct bigblock *p;
57
58 if(repp == NULL)
59 nrep = 1;
60 else if (ISICON(repp) && repp->b_const.fconst.ci >= 0)
61 nrep = repp->b_const.fconst.ci;
62 else
63 {
64 err("invalid repetition count in DATA statement");
65 frexpr(repp);
66 goto ret;
67 }
68 frexpr(repp);
69
70 if( ! ISCONST(valp) )
71 {
72 err("non-constant initializer");
73 goto ret;
74 }
75
76 if(toomanyinit) goto ret;
77 for(i = 0 ; i < nrep ; ++i)
78 {
79 p = nextdata(&elen, &vlen);
80 if(p == NULL)
81 {
82 err("too many initializers");
83 toomanyinit = YES;
84 goto ret;
85 }
86 setdata(p, valp, elen, vlen);
87 frexpr(p);
88 }
89
90 ret:
91 frexpr(valp);
92 }
93
94
nextdata(elenp,vlenp)95 struct bigblock *nextdata(elenp, vlenp)
96 ftnint *elenp, *vlenp;
97 {
98 register struct bigblock *ip;
99 struct bigblock *pp;
100 register struct bigblock *np;
101 register chainp rp;
102 bigptr p;
103 bigptr neltp;
104 register bigptr q;
105 int skip;
106 ftnint off;
107
108 while(curdtp)
109 {
110 p = curdtp->chain.datap;
111 if(p->tag == TIMPLDO)
112 {
113 ip = p;
114 if(ip->b_impldo.implb==NULL || ip->b_impldo.impub==NULL || ip->b_impldo.varnp==NULL)
115 fatal1("bad impldoblock 0%o", ip);
116 if(ip->isactive)
117 ip->b_impldo.varvp->b_const.fconst.ci += ip->b_impldo.impdiff;
118 else
119 {
120 q = fixtype(cpexpr(ip->b_impldo.implb));
121 if( ! ISICON(q) )
122 goto doerr;
123 ip->b_impldo.varvp = q;
124
125 if(ip->b_impldo.impstep)
126 {
127 q = fixtype(cpexpr(ip->b_impldo.impstep));
128 if( ! ISICON(q) )
129 goto doerr;
130 ip->b_impldo.impdiff = q->b_const.fconst.ci;
131 frexpr(q);
132 }
133 else
134 ip->b_impldo.impdiff = 1;
135
136 q = fixtype(cpexpr(ip->b_impldo.impub));
137 if(! ISICON(q))
138 goto doerr;
139 ip->b_impldo.implim = q->b_const.fconst.ci;
140 frexpr(q);
141
142 ip->isactive = YES;
143 rp = ALLOC(rplblock);
144 rp->rplblock.nextp = rpllist;
145 rpllist = rp;
146 rp->rplblock.rplnp = ip->b_impldo.varnp;
147 rp->rplblock.rplvp = ip->b_impldo.varvp;
148 rp->rplblock.rpltag = TCONST;
149 }
150
151 if( (ip->b_impldo.impdiff>0 &&
152 (ip->b_impldo.varvp->b_const.fconst.ci <= ip->b_impldo.implim))
153 || (ip->b_impldo.impdiff<0 &&
154 (ip->b_impldo.varvp->b_const.fconst.ci >= ip->b_impldo.implim)))
155 { /* start new loop */
156 curdtp = ip->b_impldo.datalist;
157 goto next;
158 }
159
160 /* clean up loop */
161
162 popstack(&rpllist);
163
164 frexpr(ip->b_impldo.varvp);
165 ip->isactive = NO;
166 curdtp = curdtp->chain.nextp;
167 goto next;
168 }
169
170 pp = p;
171 np = pp->b_prim.namep;
172 skip = YES;
173
174 if(p->b_prim.argsp==NULL && np->b_name.vdim!=NULL)
175 { /* array initialization */
176 q = mkaddr(np);
177 off = typesize[np->vtype] * curdtelt;
178 if(np->vtype == TYCHAR)
179 off *= np->vleng->b_const.fconst.ci;
180 q->b_addr.memoffset = mkexpr(OPPLUS, q->b_addr.memoffset, mkintcon(off) );
181 if( (neltp = np->b_name.vdim->nelt) && ISCONST(neltp))
182 {
183 if(++curdtelt < neltp->b_const.fconst.ci)
184 skip = NO;
185 }
186 else
187 err("attempt to initialize adjustable array");
188 }
189 else
190 q = mklhs( cpexpr(pp) );
191 if(skip)
192 {
193 curdtp = curdtp->chain.nextp;
194 curdtelt = 0;
195 }
196 if(q->vtype == TYCHAR)
197 if(ISICON(q->vleng))
198 *elenp = q->vleng->b_const.fconst.ci;
199 else {
200 err("initialization of string of nonconstant length");
201 continue;
202 }
203 else *elenp = typesize[q->vtype];
204
205 if(np->vstg == STGCOMMON)
206 *vlenp = extsymtab[np->b_name.vardesc.varno].maxleng;
207 else if(np->vstg == STGEQUIV)
208 *vlenp = eqvclass[np->b_name.vardesc.varno].eqvleng;
209 else {
210 *vlenp = (np->vtype==TYCHAR ?
211 np->vleng->b_const.fconst.ci : typesize[np->vtype]);
212 if(np->b_name.vdim)
213 *vlenp *= np->b_name.vdim->nelt->b_const.fconst.ci;
214 }
215 return(q);
216
217 doerr:
218 err("nonconstant implied DO parameter");
219 frexpr(q);
220 curdtp = curdtp->chain.nextp;
221
222 next: curdtelt = 0;
223 }
224
225 return(NULL);
226 }
227
228
229
230
231
232
setdata(varp,valp,elen,vlen)233 LOCAL void setdata(varp, valp, elen, vlen)
234 struct bigblock *varp;
235 ftnint elen, vlen;
236 struct bigblock *valp;
237 {
238 union constant con;
239 int i, k;
240 int stg, type, valtype;
241 ftnint offset;
242 register char *s, *t;
243 static char varname[XL+2];
244
245 /* output form of name is padded with blanks and preceded
246 with a storage class digit
247 */
248
249 stg = varp->vstg;
250 varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
251 s = memname(stg, varp->b_addr.memno);
252 for(t = varname+1 ; *s ; )
253 *t++ = *s++;
254 while(t < varname+XL+1)
255 *t++ = ' ';
256 varname[XL+1] = '\0';
257
258 offset = varp->b_addr.memoffset->b_const.fconst.ci;
259 type = varp->vtype;
260 valtype = valp->vtype;
261 if(type!=TYCHAR && valtype==TYCHAR)
262 {
263 if(! ftn66flag)
264 warn("non-character datum initialized with character string");
265 varp->vleng = MKICON(typesize[type]);
266 varp->vtype = type = TYCHAR;
267 }
268 else if( (type==TYCHAR && valtype!=TYCHAR) ||
269 (cktype(OPASSIGN,type,valtype) == TYERROR) )
270 {
271 err("incompatible types in initialization");
272 return;
273 }
274 if(type != TYCHAR) {
275 if(valtype == TYUNKNOWN)
276 con.ci = valp->b_const.fconst.ci;
277 else consconv(type, &con, valtype, &valp->b_const.fconst);
278 }
279
280 k = 1;
281 switch(type)
282 {
283 case TYLOGICAL:
284 type = tylogical;
285 case TYSHORT:
286 case TYLONG:
287 fprintf(initfile, datafmt, varname, offset, vlen, type);
288 prconi(initfile, type, con.ci);
289 break;
290
291 case TYCOMPLEX:
292 k = 2;
293 type = TYREAL;
294 case TYREAL:
295 goto flpt;
296
297 case TYDCOMPLEX:
298 k = 2;
299 type = TYDREAL;
300 case TYDREAL:
301 flpt:
302
303 for(i = 0 ; i < k ; ++i)
304 {
305 fprintf(initfile, datafmt, varname, offset, vlen, type);
306 prconr(initfile, type, con.cd[i]);
307 offset += typesize[type];
308 }
309 break;
310
311 case TYCHAR:
312 k = valp->vleng->b_const.fconst.ci;
313 if(elen < k)
314 k = elen;
315
316 for(i = 0 ; i < k ; ++i)
317 {
318 fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
319 fprintf(initfile, "\t%d\n", valp->b_const.fconst.ccp[i]);
320 }
321 k = elen - valp->vleng->b_const.fconst.ci;
322 while( k-- > 0)
323 {
324 fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
325 fprintf(initfile, "\t%d\n", ' ');
326 }
327 break;
328
329 default:
330 fatal1("setdata: impossible type %d", type);
331 }
332
333 }
334
335
336 void
frdata(p0)337 frdata(p0)
338 chainp p0;
339 {
340 register chainp p;
341 register bigptr q;
342
343 for(p = p0 ; p ; p = p->chain.nextp)
344 {
345 q = p->chain.datap;
346 if(q->tag == TIMPLDO)
347 {
348 if(q->isbusy)
349 return; /* circular chain completed */
350 q->isbusy = YES;
351 frdata(q->b_impldo.datalist);
352 ckfree(q);
353 }
354 else
355 frexpr(q);
356 }
357
358 frchain( &p0);
359 }
360