![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dcl.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / efl|
Return to dcl.c CVS log | Up to [Research Unix] / researchv10no / cmd / efl |
1.1 root 1: #include "defs"
2:
3:
4: static char mess[ ] = "inconsistent attributes";
5:
6: attatt(a1 , a2)
7: register struct atblock *a1, *a2;
8: {
9: #define MERGE1(x) {if(a1->x==0) a1->x = a2->x; else if(a2->x!=0 && a1->x!=a2->x) dclerr(mess,"x"+2); }
10:
11: MERGE1(attype);
12: MERGE1(attypep);
13: MERGE1(atprec);
14: MERGE1(atclass);
15: MERGE1(atext);
16: MERGE1(atcommon);
17: MERGE1(atdim);
18:
19: if(a1->atprec!=0 && (a1->attype==TYREAL || a1->attype==TYCOMPLEX) )
20: a1->attype += (TYLREAL-TYREAL);
21:
22: cfree(a2);
23: }
24:
25:
26:
27: attvars(a , v)
28: register struct atblock * a;
29: register chainp v;
30: {
31: register chainp p;
32:
33: for(p=v; p!=0 ; p = (chainp)p->nextp)
34: attvr1(a, p->datap);
35:
36: if(a->attype == TYFIELD)
37: cfree(a->attypep);
38: else if((int)a->attype == TYCHAR)
39: frexpr(a->attypep);
40:
41: cfree(a);
42: }
43:
44: #define MERGE(x,y) {if(v->y==0) v->y = a->x; else if(a->x!=0 && a->x!=v->y) dclerr(mess,"x"+2); }
45:
46:
47:
48:
49:
50: attvr1(a, v)
51: register struct atblock * a;
52: register struct varblock * v;
53: {
54: register chainp p;
55:
56: if(v->vdcldone)
57: {
58: dclerr("attempt to declare variable after use", ((struct stentry *)(v->sthead))->namep);
59: return;
60: }
61: v->vdclstart = 1;
62: if(v->vclass == CLMOS)
63: dclerr("attempt to redefine structure member", ((struct stentry *)(v->sthead))->namep);
64: if (v->vdim == 0)
65: v->vdim = a->atdim;
66: else if(!eqdim(a->atdim, v->vdim))
67: dclerr("inconsistent dimensions", ((struct stentry *)(v->sthead))->namep);
68: if(v->vprec == 0)
69: v->vprec = a->atprec;
70:
71: MERGE(attype,vtype);
72:
73: if(v->vtypep == 0)
74: {
75: if(a->attypep != 0)
76: if(a->attype == TYFIELD)
77: {
78: v->vtypep = (int *)ALLOC(fieldspec);
79: cpblock(a->attypep, v->vtypep, sizeof(struct fieldspec));
80: }
81: else if(a->attype == TYCHAR)
82: v->vtypep = cpexpr(a->attypep);
83: else v->vtypep = a->attypep;
84: else if(a->attypep!=0 && a->attypep!=v->vtypep)
85: dclerr("inconsistent attributes", "typep");
86: }
87:
88: if(v->vprec!=0 && (v->vtype==TYREAL || v->vtype==TYCOMPLEX) )
89: v->vtype += (TYLREAL-TYREAL);
90:
91: if(a->atcommon)
92: if(v->vclass != 0)
93: dclerr("common variable already in common, argument list, or external",
94: ((struct stentry *)(v->sthead))->namep);
95: else {
96: if(blklevel != ((struct headbits *)a->atcommon)->blklevel)
97: dclerr("inconsistent common block usage", "");
98: for(p = (chainp)&(((struct comentry *)a->atcommon)->comchain) ; p->nextp!=0 ; p = (chainp)p->nextp) ;
99: p->nextp = (int *)mkchain(v, PNULL);
100: }
101:
102: if(a->atext!=0 && v->vext==0)
103: {
104: v->vext = 1;
105: extname(v);
106: }
107: else if(a->atclass == CLVALUE)
108: if(v->vclass==CLARG || v->vclass==CLVALUE)
109: v->vclass = CLVALUE;
110: else dclerr("cannot value a non-argument variable",((struct stentry *)(v->sthead))->namep);
111: else MERGE(atclass,vclass);
112: if(v->vclass==CLCOMMON || v->vclass==CLVALUE || v->vclass==CLAUTO)
113: setvproc(v, PROCNO);
114: }
115:
116:
117:
118:
119:
120: eqdim(a,b)
121: register ptr a, b;
122: {
123: if(a==0 || b==0 || a==b) return(1);
124:
125: a = a->datap;
126: b = b->datap;
127:
128: while(a!=0 && b!=0)
129: {
130: if(!eqexpr(a->lowerb,b->lowerb) || !eqexpr(a->upperb,b->upperb))
131: return(0);
132:
133: a = a->nextp;
134: b = b->nextp;
135: }
136:
137: return( a == b );
138: }
139:
140:
141: eqexpr(a,b)
142: register ptr a, b;
143: {
144: if(a==b) return(1);
145: if(a==0 || b==0) return(0);
146: if(a->tag!=b->tag || a->subtype!=b->subtype)
147: return(0);
148:
149: switch(a->tag)
150: {
151: case TCONST:
152: return( equals(a->leftp, b->leftp) );
153:
154: case TNAME:
155: return( a->sthead == b->sthead );
156:
157: case TLIST:
158: a = a->leftp;
159: b = b->leftp;
160:
161: while(a!=0 && b!=0)
162: {
163: if(!eqexpr(a->datap,b->datap))
164: return(0);
165: a = a->nextp;
166: b = b->nextp;
167: }
168: return( a == b );
169:
170: case TAROP:
171: case TASGNOP:
172: case TLOGOP:
173: case TRELOP:
174: case TCALL:
175: case TREPOP:
176: return(eqexpr(a->leftp,b->leftp) && eqexpr(a->rightp,b->rightp));
177:
178: case TNOTOP:
179: case TNEGOP:
180: return(eqexpr(a->leftp,b->leftp));
181:
182: default:
183: badtag("eqexpr", a->tag);
184: }
185: /* NOTREACHED */ return 0;
186: }
187:
188:
189:
190: setimpl(type, c1, c2)
191: int type;
192: register int c1, c2;
193: {
194: register int i;
195:
196: if(c1<'a' || c2<c1 || c2>'z')
197: dclerr("bad implicit range", CNULL);
198: else if(type==TYUNDEFINED || type>TYLCOMPLEX)
199: dclerr("bad type in implicit statement", CNULL);
200: else
201: for(i = c1 ; i<=c2 ; ++i)
202: impltype[i-'a'] = type;
203: }
204:
205: doinits(p)
206: register ptr p;
207: {
208: register ptr q;
209:
210: for( ; p ; p = p->nextp)
211: if( ((struct varblock *)(q = p->datap))->vinit && q->tag!=TLABEL)
212: {
213: mkinit(q, q->vinit);
214: q->vinit = 0;
215: }
216: }
217:
218:
219:
220:
221: mkinit(v, e)
222: register ptr v;
223: register ptr e;
224: {
225: if(v->vdcldone == 0)
226: dclit(v);
227:
228: swii(idfile);
229:
230: if(v->vtype!=TYCHAR && v->vtypep)
231: dclerr("structure initialization", ((struct stentry *)(v->sthead))->namep);
232: else if(v->vdim==NULL || v->vsubs!=NULL)
233: {
234: if(e->tag==TLIST && (v->vtype==TYCOMPLEX || v->vtype==TYLCOMPLEX) )
235: e = compconst(e);
236: valinit(v, e);
237: }
238: else
239: arrinit(v,e);
240:
241: swii(icfile);
242:
243: frexpr(e);
244: }
245:
246:
247:
248:
249:
250: valinit(v, e)
251: register ptr v;
252: register ptr e;
253: {
254: static char buf[4] = "1hX";
255: int vt;
256:
257: vt = v->vtype;
258: /*check for special case of one-character initialization of
259: non-character datum
260: */
261: if(vt==TYCHAR || e->vtype!=TYCHAR || !isconst(e) || strlen(e->leftp)!=1)
262: {
263: e = simple(RVAL, coerce(vt,e) );
264: if(e->tag == TERROR)
265: return;
266: if( ! isconst(e) )
267: {
268: dclerr("nonconstant initializer", ((struct stentry *)(v->sthead))->namep);
269: return;
270: }
271: }
272: if(vt == TYCHAR)
273: {
274: charinit(v, e->leftp);
275: return;
276: }
277: prexpr( simple(LVAL,v) );
278: putic(ICOP,OPSLASH);
279: if(e->vtype != TYCHAR)
280: prexpr(e);
281: else if(strlen(e->leftp) == 1)
282: {
283: buf[2] = e->leftp[0];
284: putsii(ICCONST, buf);
285: }
286: else dclerr("character initialization of nonchar", ((struct stentry *)(v->sthead))->namep);
287: putic(ICOP,OPSLASH);
288: putic(ICMARK,0);
289: }
290:
291:
292:
293: arrinit(v, e)
294: register ptr v;
295: register ptr e;
296: {
297: struct exprblock *listinit(), *firstelt(), *nextelt();
298: ptr arrsize();
299:
300: if(e->tag!=TLIST && e->tag!=TREPOP)
301: e = mknode(TREPOP, 0, arrsize(v), e);
302: if( listinit(v, firstelt(v), e) )
303: warn("too few initializers");
304: if(v->vsubs)
305: {
306: frexpr(v->vsubs);
307: v->vsubs = NULL;
308: }
309: }
310:
311:
312:
313: struct exprblock *listinit(v, subs, e)
314: register struct varblock *v;
315: struct exprblock *subs;
316: register ptr e;
317: {
318: struct varblock *vt;
319: register chainp p;
320: int n;
321: struct varblock *subscript();
322: struct exprblock *nextelt();
323:
324: switch(e->tag)
325: {
326: case TLIST:
327: for(p = (chainp)e->leftp; p; p = (chainp)p->nextp)
328: {
329: if(subs == NULL)
330: goto toomany;
331: subs = listinit(v, subs, p->datap);
332: }
333: return(subs);
334:
335: case TREPOP:
336: if( ! isicon(e->leftp, &n) )
337: {
338: dclerr("nonconstant repetition factor");
339: return(subs);
340: }
341: while(--n >= 0)
342: {
343: if(subs == NULL)
344: goto toomany;
345: subs = listinit(v, subs, e->rightp);
346: }
347: return(subs);
348:
349: default:
350: if(subs == NULL)
351: goto toomany;
352: vt = subscript(cpexpr(v), cpexpr(subs));
353: valinit(vt, e);
354: frexpr(vt);
355: return( nextelt(v,subs) );
356:
357: }
358:
359: toomany:
360: dclerr("too many initializers", NULL);
361: return(NULL);
362: }
363:
364:
365:
366:
367: charinit(v,e)
368: ptr v;
369: char *e;
370: {
371: register char *bp;
372: char buf[50];
373: register int i, j;
374: int nwd, nch;
375:
376: v = cpexpr(v);
377: if(v->vsubs == 0)
378: v->vsubs = mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL);
379:
380: nwd = ceil( nch = conval(v->vtypep) , tailor.ftnchwd);
381: sprintf(buf,"%dh", tailor.ftnchwd);
382: for(bp = buf ; *bp ; ++bp )
383: ;
384:
385:
386: for(i = 0; i<nwd ; ++i)
387: {
388: if(i > 0) ((chainp)((struct exprblock *)v->vsubs)->leftp)->datap =
389: mknode(TAROP,OPPLUS, ((chainp)((struct exprblock *)v->vsubs)->leftp)->datap, mkint(1));
390: prexpr( v = simple(LVAL,v) );
391:
392: for(j = 0 ; j<tailor.ftnchwd && *e!='\0' && nch-->0 ; )
393: bp[j++] = *e++;
394: while(j < tailor.ftnchwd)
395: {
396: bp[j++] = ' ';
397: nch--;
398: }
399: bp[j] = '\0';
400:
401: putic(ICOP,OPSLASH);
402: putsii(ICCONST, buf);
403: putic(ICOP,OPSLASH);
404: putic(ICMARK,0);
405: }
406:
407: frexpr(v);
408: }
409:
410:
411:
412:
413:
414:
415:
416: struct exprblock *firstelt(v)
417: register struct varblock *v;
418: {
419: register struct dimblock *b;
420: register chainp s;
421: ptr t;
422: int junk;
423:
424: if(v->vdim==NULL || v->vsubs!=NULL)
425: fatal("firstelt: bad argument");
426: s = NULL;
427: for(b = (struct dimblock *)((chainp)v->vdim)->datap ; b; b = (struct dimblock *)b->nextp)
428: {
429: t = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
430: s = hookup(s, mkchain(t,CHNULL) );
431: if(!isicon(b->upperb,&junk) || (b->lowerb && !isicon(b->lowerb,&junk)) )
432: dclerr("attempt to initialize adjustable array",
433: ((struct stentry *)(v->sthead))->namep);
434: }
435: return( (struct exprblock *)mknode(TLIST, 0, s, PNULL) );
436: }
437:
438:
439:
440:
441: struct exprblock *nextelt(v,subs)
442: struct varblock *v;
443: struct exprblock *subs;
444: {
445: register struct dimblock *b;
446: register chainp *s;
447: int sv;
448:
449: if(v == NULL)
450: return(NULL);
451:
452: b = (struct dimblock *)((chainp)v->vdim)->datap;
453: s = (chainp *)subs->leftp;
454:
455: while(b && s)
456: {
457: sv = conval(s->datap);
458: frexpr(s->datap);
459: if( sv < conval(b->upperb) )
460: {
461: s->datap =mkint(sv+1);
462: return(subs);
463: }
464: s->datap = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
465:
466: b = (struct dimblock *)b->nextp;
467: s = (chainp *)s->nextp;
468: }
469:
470: if(b || s)
471: fatal("nextelt: bad subscript count");
472: return(NULL);
473: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.