Commit | Line | Data |
---|---|---|
9366cd74 C |
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 = p->nextp) | |
34 | attvr1(a, p->datap); | |
35 | ||
36 | if(a->attype == TYFIELD) | |
37 | cfree(a->attypep); | |
38 | else if(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", v->sthead->namep); | |
59 | return; | |
60 | } | |
61 | v->vdclstart = 1; | |
62 | if(v->vclass == CLMOS) | |
63 | dclerr("attempt to redefine structure member", 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", 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 = 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 | v->sthead->namep); | |
95 | else { | |
96 | if(blklevel != a->atcommon->blklevel) | |
97 | dclerr("inconsistent common block usage", ""); | |
98 | for(p = &(a->atcommon->comchain) ; p->nextp!=0 ; p = p->nextp) ; | |
99 | p->nextp = 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",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 */ | |
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 | \f | |
205 | doinits(p) | |
206 | register ptr p; | |
207 | { | |
208 | register ptr q; | |
209 | ||
210 | for( ; p ; p = p->nextp) | |
211 | if( (q = p->datap)->vinit) | |
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", 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", 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", 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 = e->leftp; p; p = 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) v->vsubs->leftp->datap = | |
389 | mknode(TAROP,OPPLUS, 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 = v->vdim->datap ; b; b = 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 | v->sthead->namep); | |
434 | } | |
435 | return( 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 = v->vdim->datap; | |
453 | s = 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 = b->nextp; | |
467 | s = s->nextp; | |
468 | } | |
469 | ||
470 | if(b || s) | |
471 | fatal("nextelt: bad subscript count"); | |
472 | return(NULL); | |
473 | } |