![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to data.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / f77|
Return to data.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / f77 |
1.1 root 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 struct Addrblock *p;
14: struct Addrblock *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: 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:
66: while(curdtp)
67: {
68: p = (tagptr) (curdtp->datap);
69: if(p->headblock.tag == TIMPLDO)
70: {
71: ip = &(p->impldoblock);
72: if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
73: fatali("bad impldoblock 0%o", 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 = 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->nextp = rpllist;
103: rpllist = rp;
104: rp->rplnp = ip->varnp;
105: rp->rplvp = 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: popstack(&rpllist);
119:
120: frexpr(ip->varvp);
121: ip->isactive = NO;
122: curdtp = curdtp->nextp;
123: goto next;
124: }
125:
126: pp = p;
127: np = pp->namep;
128: skip = YES;
129:
130: if(p->primblock.argsp==NULL && np->vdim!=NULL)
131: { /* array initialization */
132: q = mkaddr(np);
133: off = typesize[np->vtype] * curdtelt;
134: if(np->vtype == TYCHAR)
135: off *= np->vleng->constblock.const.ci;
136: q->addrblock.memoffset =
137: mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
138: if( (neltp = np->vdim->nelt) && ISCONST(neltp))
139: {
140: if(++curdtelt < neltp->constblock.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->headblock.vtype == TYCHAR)
154: if(ISICON(q->headblock.vleng))
155: *elenp = q->headblock.vleng->constblock.const.ci;
156: else {
157: err("initialization of string of nonconstant length");
158: continue;
159: }
160: else *elenp = typesize[q->headblock.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->constblock.const.ci : typesize[np->vtype]);
169: if(np->vdim)
170: *vlenp *= np->vdim->nelt->constblock.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->constblock.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->constblock.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",
277: valp->const.ccp[i]);
278: }
279: k = elen - valp->vleng->constblock.const.ci;
280: if(k > 0)
281: {
282: fprintf(initfile, datafmt, varname, offset, vlen, TYBLANK);
283: fprintf(initfile, "\t%d\n", k);
284: offset += k;
285: }
286: break;
287:
288: default:
289: fatali("setdata: impossible type %d", type);
290: }
291:
292: }
293:
294:
295:
296: frdata(p0)
297: chainp p0;
298: {
299: register struct Chain *p;
300: register tagptr q;
301:
302: for(p = p0 ; p ; p = p->nextp)
303: {
304: q = p->datap;
305: if(q->headblock.tag == TIMPLDO)
306: {
307: if(q->impldoblock.isbusy)
308: return; /* circular chain completed */
309: q->impldoblock.isbusy = YES;
310: frdata(q->impldoblock.datalist);
311: free(q);
312: }
313: else
314: frexpr(q);
315: }
316:
317: frchain( &p0);
318: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.