![[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 / f2c|
Return to data.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25:
26: /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
27:
28: static char datafmt[] = "%s\t%09ld\t%d";
29: static char *cur_varname;
30:
31: /* another initializer, called from parser */
32: dataval(repp, valp)
33: register expptr repp, valp;
34: {
35: int i, nrep;
36: ftnint elen;
37: register Addrp p;
38: Addrp nextdata();
39:
40: if (parstate < INDATA) {
41: frexpr(repp);
42: goto ret;
43: }
44: if(repp == NULL)
45: nrep = 1;
46: else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
47: nrep = repp->constblock.Const.ci;
48: else
49: {
50: err("invalid repetition count in DATA statement");
51: frexpr(repp);
52: goto ret;
53: }
54: frexpr(repp);
55:
56: if( ! ISCONST(valp) )
57: {
58: err("non-constant initializer");
59: goto ret;
60: }
61:
62: if(toomanyinit) goto ret;
63: for(i = 0 ; i < nrep ; ++i)
64: {
65: p = nextdata(&elen);
66: if(p == NULL)
67: {
68: err("too many initializers");
69: toomanyinit = YES;
70: goto ret;
71: }
72: setdata((Addrp)p, (Constp)valp, elen);
73: frexpr((expptr)p);
74: }
75:
76: ret:
77: frexpr(valp);
78: }
79:
80:
81: Addrp nextdata(elenp)
82: ftnint *elenp;
83: {
84: register struct Impldoblock *ip;
85: struct Primblock *pp;
86: register Namep np;
87: register struct Rplblock *rp;
88: tagptr p;
89: expptr neltp;
90: register expptr q;
91: int skip;
92: ftnint off, vlen;
93:
94: while(curdtp)
95: {
96: p = (tagptr)curdtp->datap;
97: if(p->tag == TIMPLDO)
98: {
99: ip = &(p->impldoblock);
100: if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
101: fatali("bad impldoblock 0%o", (int) ip);
102: if(ip->isactive)
103: ip->varvp->Const.ci += ip->impdiff;
104: else
105: {
106: q = fixtype(cpexpr(ip->implb));
107: if( ! ISICON(q) )
108: goto doerr;
109: ip->varvp = (Constp) q;
110:
111: if(ip->impstep)
112: {
113: q = fixtype(cpexpr(ip->impstep));
114: if( ! ISICON(q) )
115: goto doerr;
116: ip->impdiff = q->constblock.Const.ci;
117: frexpr(q);
118: }
119: else
120: ip->impdiff = 1;
121:
122: q = fixtype(cpexpr(ip->impub));
123: if(! ISICON(q))
124: goto doerr;
125: ip->implim = q->constblock.Const.ci;
126: frexpr(q);
127:
128: ip->isactive = YES;
129: rp = ALLOC(Rplblock);
130: rp->rplnextp = rpllist;
131: rpllist = rp;
132: rp->rplnp = ip->varnp;
133: rp->rplvp = (expptr) (ip->varvp);
134: rp->rpltag = TCONST;
135: }
136:
137: if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
138: || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
139: { /* start new loop */
140: curdtp = ip->datalist;
141: goto next;
142: }
143:
144: /* clean up loop */
145:
146: if(rpllist)
147: {
148: rp = rpllist;
149: rpllist = rpllist->rplnextp;
150: free( (charptr) rp);
151: }
152: else
153: Fatal("rpllist empty");
154:
155: frexpr((expptr)ip->varvp);
156: ip->isactive = NO;
157: curdtp = curdtp->nextp;
158: goto next;
159: }
160:
161: pp = (struct Primblock *) p;
162: np = pp->namep;
163: cur_varname = np->fvarname;
164: skip = YES;
165:
166: if(p->primblock.argsp==NULL && np->vdim!=NULL)
167: { /* array initialization */
168: q = (expptr) mkaddr(np);
169: off = typesize[np->vtype] * curdtelt;
170: if(np->vtype == TYCHAR)
171: off *= np->vleng->constblock.Const.ci;
172: q->addrblock.memoffset =
173: mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
174: if( (neltp = np->vdim->nelt) && ISCONST(neltp))
175: {
176: if(++curdtelt < neltp->constblock.Const.ci)
177: skip = NO;
178: }
179: else
180: err("attempt to initialize adjustable array");
181: }
182: else
183: q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
184: if(skip)
185: {
186: curdtp = curdtp->nextp;
187: curdtelt = 0;
188: }
189: if(q->headblock.vtype == TYCHAR)
190: if(ISICON(q->headblock.vleng))
191: *elenp = q->headblock.vleng->constblock.Const.ci;
192: else {
193: err("initialization of string of nonconstant length");
194: continue;
195: }
196: else *elenp = typesize[q->headblock.vtype];
197:
198: if (np->vstg == STGBSS) {
199: vlen = np->vtype==TYCHAR
200: ? np->vleng->constblock.Const.ci
201: : typesize[np->vtype];
202: if(vlen > 0)
203: np->vstg = STGINIT;
204: }
205: return( (Addrp) q );
206:
207: doerr:
208: err("nonconstant implied DO parameter");
209: frexpr(q);
210: curdtp = curdtp->nextp;
211:
212: next:
213: curdtelt = 0;
214: }
215:
216: return(NULL);
217: }
218:
219:
220:
221: LOCAL FILEP dfile;
222:
223:
224: setdata(varp, valp, elen)
225: register Addrp varp;
226: ftnint elen;
227: register Constp valp;
228: {
229: struct Constblock con;
230: register int type;
231: int i, k, valtype;
232: ftnint offset;
233: char *dataname(), *varname;
234: static Addrp badvar;
235: register unsigned char *s;
236: static int last_lineno;
237: static char *last_varname;
238:
239: if (varp->vstg == STGCOMMON) {
240: if (!(dfile = blkdfile))
241: dfile = blkdfile = opf(blkdfname, textwrite);
242: }
243: else {
244: if (procclass == CLBLOCK) {
245: if (varp != badvar) {
246: badvar = varp;
247: warn1("%s is not in a COMMON block",
248: varp->uname_tag == UNAM_NAME
249: ? varp->user.name->fvarname
250: : "???");
251: }
252: return;
253: }
254: if (!(dfile = initfile))
255: dfile = initfile = opf(initfname, textwrite);
256: }
257: varname = dataname(varp->vstg, varp->memno);
258: offset = varp->memoffset->constblock.Const.ci;
259: type = varp->vtype;
260: valtype = valp->vtype;
261: if(type!=TYCHAR && valtype==TYCHAR)
262: {
263: if(! ftn66flag
264: && (last_varname != cur_varname || last_lineno != lineno)) {
265: /* prevent multiple warnings */
266: last_lineno = lineno;
267: warn1(
268: "non-character datum %.42s initialized with character string",
269: last_varname = cur_varname);
270: }
271: varp->vleng = ICON(typesize[type]);
272: varp->vtype = type = TYCHAR;
273: }
274: else if( (type==TYCHAR && valtype!=TYCHAR) ||
275: (cktype(OPASSIGN,type,valtype) == TYERROR) )
276: {
277: err("incompatible types in initialization");
278: return;
279: }
280: if(type == TYADDR)
281: con.Const.ci = valp->Const.ci;
282: else if(type != TYCHAR)
283: {
284: if(valtype == TYUNKNOWN)
285: con.Const.ci = valp->Const.ci;
286: else consconv(type, &con, valp);
287: }
288:
289: k = 1;
290:
291: switch(type)
292: {
293: case TYLOGICAL:
294: if (tylogical != TYLONG)
295: type = tylogical;
296: case TYINT1:
297: case TYLOGICAL1:
298: case TYLOGICAL2:
299: case TYSHORT:
300: case TYLONG:
301: #ifdef TYQUAD
302: case TYQUAD:
303: #endif
304: dataline(varname, offset, type);
305: prconi(dfile, con.Const.ci);
306: break;
307:
308: case TYADDR:
309: dataline(varname, offset, type);
310: prcona(dfile, con.Const.ci);
311: break;
312:
313: case TYCOMPLEX:
314: case TYDCOMPLEX:
315: k = 2;
316: case TYREAL:
317: case TYDREAL:
318: dataline(varname, offset, type);
319: prconr(dfile, &con, k);
320: break;
321:
322: case TYCHAR:
323: k = valp -> vleng -> constblock.Const.ci;
324: if (elen < k)
325: k = elen;
326: s = (unsigned char *)valp->Const.ccp;
327: for(i = 0 ; i < k ; ++i) {
328: dataline(varname, offset++, TYCHAR);
329: fprintf(dfile, "\t%d\n", *s++);
330: }
331: k = elen - valp->vleng->constblock.Const.ci;
332: if(k > 0) {
333: dataline(varname, offset, TYBLANK);
334: fprintf(dfile, "\t%d\n", k);
335: }
336: break;
337:
338: default:
339: badtype("setdata", type);
340: }
341:
342: }
343:
344:
345:
346: /*
347: output form of name is padded with blanks and preceded
348: with a storage class digit
349: */
350: char *dataname(stg,memno)
351: int stg;
352: long memno;
353: {
354: static char varname[64];
355: register char *s, *t;
356: char buf[16], *memname();
357:
358: if (stg == STGCOMMON) {
359: varname[0] = '2';
360: sprintf(s = buf, "Q.%ld", memno);
361: }
362: else {
363: varname[0] = stg==STGEQUIV ? '1' : '0';
364: s = memname(stg, memno);
365: }
366: t = varname + 1;
367: while(*t++ = *s++);
368: *t = 0;
369: return(varname);
370: }
371:
372:
373:
374:
375:
376: frdata(p0)
377: chainp p0;
378: {
379: register struct Chain *p;
380: register tagptr q;
381:
382: for(p = p0 ; p ; p = p->nextp)
383: {
384: q = (tagptr)p->datap;
385: if(q->tag == TIMPLDO)
386: {
387: if(q->impldoblock.isbusy)
388: return; /* circular chain completed */
389: q->impldoblock.isbusy = YES;
390: frdata(q->impldoblock.datalist);
391: free( (charptr) q);
392: }
393: else
394: frexpr(q);
395: }
396:
397: frchain( &p0);
398: }
399:
400:
401:
402: dataline(varname, offset, type)
403: char *varname;
404: ftnint offset;
405: int type;
406: {
407: fprintf(dfile, datafmt, varname, offset, type);
408: }
409:
410: void
411: make_param(p, e)
412: register struct Paramblock *p;
413: expptr e;
414: {
415: register expptr q;
416:
417: p->vclass = CLPARAM;
418: impldcl((Namep)p);
419: p->paramval = q = mkconv(p->vtype, e);
420: if (p->vtype == TYCHAR) {
421: if (q->tag == TEXPR)
422: p->paramval = q = fixexpr(q);
423: if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
424: errstr("invalid value for character parameter %s",
425: p->fvarname);
426: return;
427: }
428: if (!(e = p->vleng))
429: p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
430: + q->constblock.Const.ccp1.blanks);
431: else if (q->constblock.vleng->constblock.Const.ci
432: > e->constblock.Const.ci) {
433: q->constblock.vleng->constblock.Const.ci
434: = e->constblock.Const.ci;
435: q->constblock.Const.ccp1.blanks = 0;
436: }
437: else
438: q->constblock.Const.ccp1.blanks
439: = e->constblock.Const.ci
440: - q->constblock.vleng->constblock.Const.ci;
441: }
442: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.