![[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] / 40BSD / cmd / f77|
Return to data.c CVS log | Up to [CSRG BSD Unix] / 40BSD / 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 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.