![[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 [Research Unix] / researchv10no / cmd / f77|
Return to data.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 root 1: #include "defs"
2:
3: /* ROUTINES CALLED DURING DATA AND PARAMETER 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:
190: curdtelt = 0;
191: }
192:
193: return(NULL);
194: }
195:
196:
197:
198:
199:
200:
201: setdata(varp, valp, elen, vlen)
202: register Addrp varp;
203: ftnint elen, vlen;
204: register Constp valp;
205: {
206: union Constant con;
207: register int type;
208: int i, k, valtype;
209: ftnint offset;
210: char *dataname(), *varname;
211:
212: varname = dataname(varp->vstg, varp->memno);
213: offset = varp->memoffset->constblock.Const.ci;
214: type = varp->vtype;
215: valtype = valp->vtype;
216: if(type!=TYCHAR && valtype==TYCHAR)
217: {
218: if(! ftn66flag)
219: warn("non-character datum initialized with character string");
220: varp->vleng = ICON(typesize[type]);
221: varp->vtype = type = TYCHAR;
222: }
223: else if( (type==TYCHAR && valtype!=TYCHAR) ||
224: (cktype(OPASSIGN,type,valtype) == TYERROR) )
225: {
226: err("incompatible types in initialization");
227: return;
228: }
229: if(type == TYADDR)
230: con.ci = valp->Const.ci;
231: else if(type != TYCHAR)
232: {
233: if(valtype == TYUNKNOWN)
234: con.ci = valp->Const.ci;
235: else consconv(type, &con, valtype, &valp->Const);
236: }
237:
238: k = 1;
239: switch(type)
240: {
241: case TYLOGICAL:
242: type = tylogical;
243: case TYSHORT:
244: case TYLONG:
245: dataline(varname, offset, vlen, type);
246: prconi(initfile, type, con.ci);
247: break;
248:
249: case TYADDR:
250: dataline(varname, offset, vlen, type);
251: prcona(initfile, con.ci);
252: break;
253:
254: case TYCOMPLEX:
255: k = 2;
256: type = TYREAL;
257: case TYREAL:
258: goto flpt;
259:
260: case TYDCOMPLEX:
261: k = 2;
262: type = TYDREAL;
263: case TYDREAL:
264: flpt:
265:
266: for(i = 0 ; i < k ; ++i)
267: {
268: dataline(varname, offset, vlen, type);
269: prconr(initfile, type, con.cd[i]);
270: offset += typesize[type];
271: }
272: break;
273:
274: case TYCHAR:
275: k = valp->vleng->constblock.Const.ci;
276: if(elen < k)
277: k = elen;
278:
279: for(i = 0 ; i < k ; ++i)
280: {
281: dataline(varname, offset++, vlen, TYCHAR);
282: fprintf(initfile, "\t%d\n",
283: valp->Const.ccp[i]);
284: }
285: k = elen - valp->vleng->constblock.Const.ci;
286: if(k > 0)
287: {
288: dataline(varname, offset, vlen, TYBLANK);
289: fprintf(initfile, "\t%d\n", k);
290: offset += k;
291: }
292: break;
293:
294: default:
295: badtype("setdata", type);
296: }
297:
298: }
299:
300:
301:
302: /*
303: output form of name is padded with blanks and preceded
304: with a storage class digit
305: */
306: char *dataname(stg,memno)
307: int stg, memno;
308: {
309: static char varname[XL+2];
310: register char *s, *t;
311: char *memname();
312:
313: varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
314: s = memname(stg, memno);
315: for(t = varname+1 ; *s ; )
316: *t++ = *s++;
317: while(t < varname+XL+1)
318: *t++ = ' ';
319: varname[XL+1] = '\0';
320: return(varname);
321: }
322:
323:
324:
325:
326:
327: frdata(p0)
328: chainp p0;
329: {
330: register struct Chain *p;
331: register tagptr q;
332:
333: for(p = p0 ; p ; p = p->nextp)
334: {
335: q = p->datap;
336: if(q->tag == TIMPLDO)
337: {
338: if(q->impldoblock.isbusy)
339: return; /* circular chain completed */
340: q->impldoblock.isbusy = YES;
341: frdata(q->impldoblock.datalist);
342: free( (charptr) q);
343: }
344: else
345: frexpr(q);
346: }
347:
348: frchain( &p0);
349: }
350:
351:
352:
353: dataline(varname, offset, vlen, type)
354: char *varname;
355: ftnint offset, vlen;
356: int type;
357: {
358: fprintf(initfile, datafmt, varname, offset, vlen, type);
359: }
360:
361:
362: void
363: make_param(p, e)
364: register struct Paramblock *p;
365: expptr e;
366: {
367: p->vclass = CLPARAM;
368: impldcl(p);
369: if (p->vtype != ((Constp)e)->vtype && bugwarn & 1)
370: warnb1("old f77 typed parameter %s incorrectly",
371: varstr(VL, p->varname));
372: p->paramval = (bugwarn & 2) ? e : mkconv(p->vtype, e);
373: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.