Commit | Line | Data |
---|---|---|
ec40e2f4 BJ |
1 | #include "defs" |
2 | #include "machdefs" | |
3 | ||
4 | #ifdef SDB | |
5 | # include <a.out.h> | |
6 | char *stabline(); | |
7 | # ifndef N_SO | |
8 | # include <stab.h> | |
9 | # endif | |
10 | #endif | |
11 | ||
12 | /* start a new procedure */ | |
13 | ||
14 | newproc() | |
15 | { | |
16 | if(parstate != OUTSIDE) | |
17 | { | |
18 | execerr("missing end statement", CNULL); | |
19 | endproc(); | |
20 | } | |
21 | ||
22 | parstate = INSIDE; | |
23 | procclass = CLMAIN; /* default */ | |
24 | } | |
25 | ||
26 | ||
27 | ||
28 | /* end of procedure. generate variables, epilogs, and prologs */ | |
29 | ||
30 | endproc() | |
31 | { | |
32 | struct Labelblock *lp; | |
33 | ||
34 | if(parstate < INDATA) | |
35 | enddcl(); | |
36 | if(ctlstack >= ctls) | |
37 | err("DO loop or BLOCK IF not closed"); | |
38 | for(lp = labeltab ; lp < labtabend ; ++lp) | |
39 | if(lp->stateno!=0 && lp->labdefined==NO) | |
40 | errstr("missing statement number %s", convic(lp->stateno) ); | |
41 | ||
42 | epicode(); | |
43 | procode(); | |
44 | donmlist(); | |
45 | dobss(); | |
46 | prdbginfo(); | |
47 | ||
48 | #if FAMILY == PCC | |
49 | putbracket(); | |
50 | #endif | |
51 | ||
52 | procinit(); /* clean up for next procedure */ | |
53 | } | |
54 | ||
55 | ||
56 | ||
57 | /* End of declaration section of procedure. Allocate storage. */ | |
58 | ||
59 | enddcl() | |
60 | { | |
61 | register struct Entrypoint *ep; | |
62 | ||
63 | parstate = INEXEC; | |
64 | docommon(); | |
65 | doequiv(); | |
66 | docomleng(); | |
67 | for(ep = entries ; ep ; ep = ep->entnextp) | |
68 | doentry(ep); | |
69 | } | |
70 | \f | |
71 | /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ | |
72 | ||
73 | /* Main program or Block data */ | |
74 | ||
75 | startproc(progname, class) | |
76 | struct Extsym * progname; | |
77 | int class; | |
78 | { | |
79 | register struct Entrypoint *p; | |
80 | ||
81 | p = ALLOC(Entrypoint); | |
82 | if(class == CLMAIN) | |
83 | puthead("MAIN__", CLMAIN); | |
84 | else | |
85 | puthead(CNULL, CLBLOCK); | |
86 | if(class == CLMAIN) | |
87 | newentry( mkname(5, "MAIN_") ); | |
88 | p->entryname = progname; | |
89 | p->entrylabel = newlabel(); | |
90 | entries = p; | |
91 | ||
92 | procclass = class; | |
93 | retlabel = newlabel(); | |
94 | fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); | |
95 | if(progname) | |
96 | fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) ); | |
97 | fprintf(diagfile, ":\n"); | |
98 | #ifdef SDB | |
99 | if(sdbflag && class==CLMAIN) | |
100 | { | |
101 | char buff[10]; | |
102 | sprintf(buff, "L%d", p->entrylabel); | |
103 | prstab("MAIN_", N_FUN, lineno, buff); | |
104 | p2pass( stabline("MAIN_", N_FNAME, 0, 0) ); | |
105 | if(progname) | |
106 | { | |
107 | prstab(nounder(XL,progname->extname), N_ENTRY, lineno,buff); | |
108 | /* p2pass(stabline(nounder(XL,progname->extname),N_FNAME,0,0)); */ | |
109 | } | |
110 | } | |
111 | #endif | |
112 | } | |
113 | ||
114 | /* subroutine or function statement */ | |
115 | ||
116 | struct Extsym *newentry(v) | |
117 | register Namep v; | |
118 | { | |
119 | register struct Extsym *p; | |
120 | ||
121 | p = mkext( varunder(VL, v->varname) ); | |
122 | ||
123 | if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) | |
124 | { | |
125 | if(p == 0) | |
126 | dclerr("invalid entry name", v); | |
127 | else dclerr("external name already used", v); | |
128 | return(0); | |
129 | } | |
130 | v->vstg = STGAUTO; | |
131 | v->vprocclass = PTHISPROC; | |
132 | v->vclass = CLPROC; | |
133 | p->extstg = STGEXT; | |
134 | p->extinit = YES; | |
135 | return(p); | |
136 | } | |
137 | ||
138 | ||
139 | entrypt(class, type, length, entry, args) | |
140 | int class, type; | |
141 | ftnint length; | |
142 | struct Extsym *entry; | |
143 | chainp args; | |
144 | { | |
145 | register Namep q; | |
146 | register struct Entrypoint *p, *ep; | |
147 | ||
148 | if(class != CLENTRY) | |
149 | puthead( varstr(XL, procname = entry->extname), class); | |
150 | if(class == CLENTRY) | |
151 | fprintf(diagfile, " entry "); | |
152 | fprintf(diagfile, " %s:\n", nounder(XL, entry->extname)); | |
153 | q = mkname(VL, nounder(XL,entry->extname) ); | |
154 | ||
155 | if( (type = lengtype(type, (int) length)) != TYCHAR) | |
156 | length = 0; | |
157 | if(class == CLPROC) | |
158 | { | |
159 | procclass = CLPROC; | |
160 | proctype = type; | |
161 | procleng = length; | |
162 | ||
163 | retlabel = newlabel(); | |
164 | if(type == TYSUBR) | |
165 | ret0label = newlabel(); | |
166 | } | |
167 | ||
168 | p = ALLOC(Entrypoint); | |
169 | ||
170 | if(entries) /* put new block at end of entries list */ | |
171 | { | |
172 | for(ep = entries; ep->entnextp; ep = ep->entnextp) | |
173 | ; | |
174 | ep->entnextp = p; | |
175 | } | |
176 | else | |
177 | entries = p; | |
178 | ||
179 | p->entryname = entry; | |
180 | p->arglist = args; | |
181 | p->entrylabel = newlabel(); | |
182 | p->enamep = q; | |
183 | ||
184 | #ifdef SDB | |
185 | if(sdbflag) | |
186 | { | |
187 | char buff[10]; | |
188 | sprintf(buff, "L%d", p->entrylabel); | |
189 | prstab(nounder(XL, entry->extname), | |
190 | (class==CLENTRY ? N_ENTRY : N_FUN), | |
191 | lineno, buff); | |
192 | if(class != CLENTRY) | |
193 | p2pass( stabline( nounder(XL,entry->extname), N_FNAME, 0, 0) ); | |
194 | } | |
195 | #endif | |
196 | ||
197 | if(class == CLENTRY) | |
198 | { | |
199 | class = CLPROC; | |
200 | if(proctype == TYSUBR) | |
201 | type = TYSUBR; | |
202 | } | |
203 | ||
204 | q->vclass = class; | |
205 | q->vprocclass = PTHISPROC; | |
206 | settype(q, type, (int) length); | |
207 | /* hold all initial entry points till end of declarations */ | |
208 | if(parstate >= INDATA) | |
209 | doentry(p); | |
210 | } | |
211 | \f | |
212 | /* generate epilogs */ | |
213 | ||
214 | LOCAL epicode() | |
215 | { | |
216 | register int i; | |
217 | ||
218 | if(procclass==CLPROC) | |
219 | { | |
220 | if(proctype==TYSUBR) | |
221 | { | |
222 | putlabel(ret0label); | |
223 | if(substars) | |
224 | putforce(TYINT, ICON(0) ); | |
225 | putlabel(retlabel); | |
226 | goret(TYSUBR); | |
227 | } | |
228 | else { | |
229 | putlabel(retlabel); | |
230 | if(multitype) | |
231 | { | |
232 | typeaddr = autovar(1, TYADDR, PNULL); | |
233 | putbranch( cpexpr(typeaddr) ); | |
234 | for(i = 0; i < NTYPES ; ++i) | |
235 | if(rtvlabel[i] != 0) | |
236 | { | |
237 | putlabel(rtvlabel[i]); | |
238 | retval(i); | |
239 | } | |
240 | } | |
241 | else | |
242 | retval(proctype); | |
243 | } | |
244 | } | |
245 | ||
246 | else if(procclass != CLBLOCK) | |
247 | { | |
248 | putlabel(retlabel); | |
249 | goret(TYSUBR); | |
250 | } | |
251 | } | |
252 | ||
253 | ||
254 | /* generate code to return value of type t */ | |
255 | ||
256 | LOCAL retval(t) | |
257 | register int t; | |
258 | { | |
259 | register Addrp p; | |
260 | ||
261 | switch(t) | |
262 | { | |
263 | case TYCHAR: | |
264 | case TYCOMPLEX: | |
265 | case TYDCOMPLEX: | |
266 | break; | |
267 | ||
268 | case TYLOGICAL: | |
269 | t = tylogical; | |
270 | case TYADDR: | |
271 | case TYSHORT: | |
272 | case TYLONG: | |
273 | p = (Addrp) cpexpr(retslot); | |
274 | p->vtype = t; | |
275 | putforce(t, p); | |
276 | break; | |
277 | ||
278 | case TYREAL: | |
279 | case TYDREAL: | |
280 | p = (Addrp) cpexpr(retslot); | |
281 | p->vtype = t; | |
282 | putforce(t, p); | |
283 | break; | |
284 | ||
285 | default: | |
286 | badtype("retval", t); | |
287 | } | |
288 | goret(t); | |
289 | } | |
290 | ||
291 | ||
292 | /* Allocate extra argument array if needed. Generate prologs. */ | |
293 | ||
294 | LOCAL procode() | |
295 | { | |
296 | register struct Entrypoint *p; | |
297 | Addrp argvec; | |
298 | ||
299 | #if TARGET==GCOS | |
300 | argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); | |
301 | #else | |
302 | if(lastargslot>0 && nentry>1) | |
303 | #if TARGET == VAX | |
304 | argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL); | |
305 | #else | |
306 | argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); | |
307 | #endif | |
308 | else | |
309 | argvec = NULL; | |
310 | #endif | |
311 | ||
312 | ||
313 | #if TARGET == PDP11 | |
314 | /* for the optimizer */ | |
315 | if(fudgelabel) | |
316 | putlabel(fudgelabel); | |
317 | #endif | |
318 | ||
319 | for(p = entries ; p ; p = p->entnextp) | |
320 | prolog(p, argvec); | |
321 | ||
322 | #if FAMILY == PCC | |
323 | putrbrack(procno); | |
324 | #endif | |
325 | ||
326 | prendproc(); | |
327 | } | |
328 | \f | |
329 | /* | |
330 | manipulate argument lists (allocate argument slot positions) | |
331 | * keep track of return types and labels | |
332 | */ | |
333 | ||
334 | LOCAL doentry(ep) | |
335 | struct Entrypoint *ep; | |
336 | { | |
337 | register int type; | |
338 | register Namep np; | |
339 | chainp p; | |
340 | register Namep q; | |
341 | Addrp mkarg(); | |
342 | ||
343 | ++nentry; | |
344 | if(procclass == CLMAIN) | |
345 | { | |
346 | putlabel(ep->entrylabel); | |
347 | return; | |
348 | } | |
349 | else if(procclass == CLBLOCK) | |
350 | return; | |
351 | ||
352 | impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) ); | |
353 | type = np->vtype; | |
354 | if(proctype == TYUNKNOWN) | |
355 | if( (proctype = type) == TYCHAR) | |
356 | procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)); | |
357 | ||
358 | if(proctype == TYCHAR) | |
359 | { | |
360 | if(type != TYCHAR) | |
361 | err("noncharacter entry of character function"); | |
362 | else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng) | |
363 | err("mismatched character entry lengths"); | |
364 | } | |
365 | else if(type == TYCHAR) | |
366 | err("character entry of noncharacter function"); | |
367 | else if(type != proctype) | |
368 | multitype = YES; | |
369 | if(rtvlabel[type] == 0) | |
370 | rtvlabel[type] = newlabel(); | |
371 | ep->typelabel = rtvlabel[type]; | |
372 | ||
373 | if(type == TYCHAR) | |
374 | { | |
375 | if(chslot < 0) | |
376 | { | |
377 | chslot = nextarg(TYADDR); | |
378 | chlgslot = nextarg(TYLENG); | |
379 | } | |
380 | np->vstg = STGARG; | |
381 | np->vardesc.varno = chslot; | |
382 | if(procleng < 0) | |
383 | np->vleng = (expptr) mkarg(TYLENG, chlgslot); | |
384 | } | |
385 | else if( ISCOMPLEX(type) ) | |
386 | { | |
387 | np->vstg = STGARG; | |
388 | if(cxslot < 0) | |
389 | cxslot = nextarg(TYADDR); | |
390 | np->vardesc.varno = cxslot; | |
391 | } | |
392 | else if(type != TYSUBR) | |
393 | { | |
394 | if(nentry == 1) | |
395 | retslot = autovar(1, TYDREAL, PNULL); | |
396 | np->vstg = STGAUTO; | |
397 | np->voffset = retslot->memoffset->constblock.const.ci; | |
398 | } | |
399 | ||
400 | for(p = ep->arglist ; p ; p = p->nextp) | |
401 | if(! (( q = (Namep) (p->datap) )->vdcldone) ) | |
402 | q->vardesc.varno = nextarg(TYADDR); | |
403 | ||
404 | for(p = ep->arglist ; p ; p = p->nextp) | |
405 | if(! (( q = (Namep) (p->datap) )->vdcldone) ) | |
406 | { | |
407 | impldcl(q); | |
408 | q->vdcldone = YES; | |
409 | #ifdef SDB | |
410 | if(sdbflag) | |
411 | prstab(varstr(VL,q->varname), N_PSYM, | |
412 | stabtype(q), | |
413 | convic(q->vardesc.varno + ARGOFFSET) ); | |
414 | #endif | |
415 | if(q->vtype == TYCHAR) | |
416 | { | |
417 | if(q->vleng == NULL) /* character*(*) */ | |
418 | q->vleng = (expptr) | |
419 | mkarg(TYLENG, nextarg(TYLENG) ); | |
420 | else if(nentry == 1) | |
421 | nextarg(TYLENG); | |
422 | } | |
423 | else if(q->vclass==CLPROC && nentry==1) | |
424 | nextarg(TYLENG) ; | |
425 | } | |
426 | ||
427 | putlabel(ep->entrylabel); | |
428 | } | |
429 | ||
430 | ||
431 | ||
432 | LOCAL nextarg(type) | |
433 | int type; | |
434 | { | |
435 | int k; | |
436 | k = lastargslot; | |
437 | lastargslot += typesize[type]; | |
438 | return(k); | |
439 | } | |
440 | \f | |
441 | /* generate variable references */ | |
442 | ||
443 | LOCAL dobss() | |
444 | { | |
445 | register struct Hashentry *p; | |
446 | register Namep q; | |
447 | register int i; | |
448 | int align; | |
449 | ftnint leng, iarrl; | |
450 | char *memname(); | |
451 | int qstg, qclass, qtype; | |
452 | ||
453 | pruse(asmfile, USEBSS); | |
454 | ||
455 | for(p = hashtab ; p<lasthash ; ++p) | |
456 | if(q = p->varp) | |
457 | { | |
458 | qstg = q->vstg; | |
459 | qtype = q->vtype; | |
460 | qclass = q->vclass; | |
461 | ||
462 | #ifdef SDB | |
463 | if(sdbflag && qclass==CLVAR) switch(qstg) | |
464 | { | |
465 | case STGAUTO: | |
466 | prstab(varstr(VL,q->varname), N_LSYM, | |
467 | stabtype(q), | |
468 | convic( - q->voffset)) ; | |
469 | prstleng(q, iarrlen(q)); | |
470 | break; | |
471 | ||
472 | case STGBSS: | |
473 | prstab(varstr(VL,q->varname), N_LCSYM, | |
474 | stabtype(q), | |
475 | memname(qstg,q->vardesc.varno) ); | |
476 | prstleng(q, iarrlen(q)); | |
477 | break; | |
478 | ||
479 | case STGINIT: | |
480 | prstab(varstr(VL,q->varname), N_STSYM, | |
481 | stabtype(q), | |
482 | memname(qstg,q->vardesc.varno) ); | |
483 | prstleng(q, iarrlen(q)); | |
484 | break; | |
485 | } | |
486 | #endif | |
487 | ||
488 | if( (qclass==CLUNKNOWN && qstg!=STGARG) || | |
489 | (qclass==CLVAR && qstg==STGUNKNOWN) ) | |
490 | warn1("local variable %s never used", varstr(VL,q->varname) ); | |
491 | else if(qclass==CLVAR && qstg==STGBSS) | |
492 | { | |
493 | align = (qtype==TYCHAR ? ALILONG : typealign[qtype]); | |
494 | if(bssleng % align != 0) | |
495 | { | |
496 | bssleng = roundup(bssleng, align); | |
497 | preven(align); | |
498 | } | |
499 | prlocvar(memname(STGBSS,q->vardesc.varno), iarrl = iarrlen(q) ); | |
500 | bssleng += iarrl; | |
501 | } | |
502 | else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG) | |
503 | mkext(varunder(VL, q->varname)) ->extstg = STGEXT; | |
504 | ||
505 | if(qclass==CLVAR && qstg!=STGARG) | |
506 | { | |
507 | if(q->vdim && !ISICON(q->vdim->nelt) ) | |
508 | dclerr("adjustable dimension on non-argument", q); | |
509 | if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng))) | |
510 | dclerr("adjustable leng on nonargument", q); | |
511 | } | |
512 | } | |
513 | ||
514 | for(i = 0 ; i < nequiv ; ++i) | |
515 | if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 ) | |
516 | { | |
517 | bssleng = roundup(bssleng, ALIDOUBLE); | |
518 | preven(ALIDOUBLE); | |
519 | prlocvar( memname(STGEQUIV, i), leng); | |
520 | bssleng += leng; | |
521 | } | |
522 | } | |
523 | ||
524 | ||
525 | ||
526 | donmlist() | |
527 | { | |
528 | register struct Hashentry *p; | |
529 | register Namep q; | |
530 | ||
531 | pruse(asmfile, USEINIT); | |
532 | ||
533 | for(p=hashtab; p<lasthash; ++p) | |
534 | if( (q = p->varp) && q->vclass==CLNAMELIST) | |
535 | namelist(q); | |
536 | } | |
537 | ||
538 | ||
539 | doext() | |
540 | { | |
541 | struct Extsym *p; | |
542 | ||
543 | for(p = extsymtab ; p<nextext ; ++p) | |
544 | prext( varstr(XL, p->extname), p->maxleng, p->extinit); | |
545 | } | |
546 | ||
547 | ||
548 | ||
549 | ||
550 | ftnint iarrlen(q) | |
551 | register Namep q; | |
552 | { | |
553 | ftnint leng; | |
554 | ||
555 | leng = typesize[q->vtype]; | |
556 | if(leng <= 0) | |
557 | return(-1); | |
558 | if(q->vdim) | |
559 | if( ISICON(q->vdim->nelt) ) | |
560 | leng *= q->vdim->nelt->constblock.const.ci; | |
561 | else return(-1); | |
562 | if(q->vleng) | |
563 | if( ISICON(q->vleng) ) | |
564 | leng *= q->vleng->constblock.const.ci; | |
565 | else return(-1); | |
566 | return(leng); | |
567 | } | |
568 | \f | |
569 | /* This routine creates a static block representing the namelist. | |
570 | An equivalent declaration of the structure produced is: | |
571 | struct namelist | |
572 | { | |
573 | char namelistname[16]; | |
574 | struct namelistentry | |
575 | { | |
576 | char varname[16]; | |
577 | char *varaddr; | |
578 | int type; # negative means -type= number of chars | |
579 | struct dimensions *dimp; # null means scalar | |
580 | } names[]; | |
581 | }; | |
582 | ||
583 | struct dimensions | |
584 | { | |
585 | int numberofdimensions; | |
586 | int numberofelements | |
587 | int baseoffset; | |
588 | int span[numberofdimensions]; | |
589 | }; | |
590 | where the namelistentry list terminates with a null varname | |
591 | If dimp is not null, then the corner element of the array is at | |
592 | varaddr. However, the element with subscripts (i1,...,in) is at | |
593 | varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...) | |
594 | */ | |
595 | ||
596 | namelist(np) | |
597 | Namep np; | |
598 | { | |
599 | register chainp q; | |
600 | register Namep v; | |
601 | register struct Dimblock *dp; | |
602 | char *memname(); | |
603 | int type, dimno, dimoffset; | |
604 | flag bad; | |
605 | ||
606 | ||
607 | preven(ALILONG); | |
608 | fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno)); | |
609 | putstr(asmfile, varstr(VL, np->varname), 16); | |
610 | dimno = ++lastvarno; | |
611 | dimoffset = 0; | |
612 | bad = NO; | |
613 | ||
614 | for(q = np->varxptr.namelist ; q ; q = q->nextp) | |
615 | { | |
616 | vardcl( v = (Namep) (q->datap) ); | |
617 | type = v->vtype; | |
618 | if( ONEOF(v->vstg, MSKSTATIC) ) | |
619 | { | |
620 | preven(ALILONG); | |
621 | putstr(asmfile, varstr(VL,v->varname), 16); | |
622 | praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset); | |
623 | prconi(asmfile, TYINT, | |
624 | type==TYCHAR ? | |
625 | -(v->vleng->constblock.const.ci) : (ftnint) type); | |
626 | if(v->vdim) | |
627 | { | |
628 | praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset); | |
629 | dimoffset += 3 + v->vdim->ndim; | |
630 | } | |
631 | else | |
632 | praddr(asmfile, STGNULL,0,(ftnint) 0); | |
633 | } | |
634 | else | |
635 | { | |
636 | dclerr("may not appear in namelist", v); | |
637 | bad = YES; | |
638 | } | |
639 | } | |
640 | ||
641 | if(bad) | |
642 | return; | |
643 | ||
644 | putstr(asmfile, "", 16); | |
645 | ||
646 | if(dimoffset > 0) | |
647 | { | |
648 | fprintf(asmfile, LABELFMT, memname(STGINIT,dimno)); | |
649 | for(q = np->varxptr.namelist ; q ; q = q->nextp) | |
650 | if(dp = q->datap->nameblock.vdim) | |
651 | { | |
652 | int i; | |
653 | prconi(asmfile, TYINT, (ftnint) (dp->ndim) ); | |
654 | prconi(asmfile, TYINT, | |
655 | (ftnint) (dp->nelt->constblock.const.ci) ); | |
656 | prconi(asmfile, TYINT, | |
657 | (ftnint) (dp->baseoffset->constblock.const.ci)); | |
658 | for(i=0; i<dp->ndim ; ++i) | |
659 | prconi(asmfile, TYINT, | |
660 | dp->dims[i].dimsize->constblock.const.ci); | |
661 | } | |
662 | } | |
663 | ||
664 | } | |
665 | \f | |
666 | LOCAL docommon() | |
667 | { | |
668 | register struct Extsym *p; | |
669 | register chainp q; | |
670 | struct Dimblock *t; | |
671 | expptr neltp; | |
672 | register Namep v; | |
673 | ftnint size; | |
674 | int type; | |
675 | ||
676 | for(p = extsymtab ; p<nextext ; ++p) | |
677 | if(p->extstg==STGCOMMON) | |
678 | { | |
679 | #ifdef SDB | |
680 | if(sdbflag) | |
681 | prstab(CNULL, N_BCOMM, 0, 0); | |
682 | #endif | |
683 | for(q = p->extp ; q ; q = q->nextp) | |
684 | { | |
685 | v = (Namep) (q->datap); | |
686 | if(v->vdcldone == NO) | |
687 | vardcl(v); | |
688 | type = v->vtype; | |
689 | if(p->extleng % typealign[type] != 0) | |
690 | { | |
691 | dclerr("common alignment", v); | |
692 | p->extleng = roundup(p->extleng, typealign[type]); | |
693 | } | |
694 | v->voffset = p->extleng; | |
695 | v->vardesc.varno = p - extsymtab; | |
696 | if(type == TYCHAR) | |
697 | size = v->vleng->constblock.const.ci; | |
698 | else size = typesize[type]; | |
699 | if(t = v->vdim) | |
700 | if( (neltp = t->nelt) && ISCONST(neltp) ) | |
701 | size *= neltp->constblock.const.ci; | |
702 | else | |
703 | dclerr("adjustable array in common", v); | |
704 | p->extleng += size; | |
705 | #ifdef SDB | |
706 | if(sdbflag) | |
707 | { | |
708 | prstssym(v); | |
709 | prstleng(v, size); | |
710 | } | |
711 | #endif | |
712 | } | |
713 | ||
714 | frchain( &(p->extp) ); | |
715 | #ifdef SDB | |
716 | if(sdbflag) | |
717 | prstab(varstr(XL,p->extname), N_ECOMM, 0, 0); | |
718 | #endif | |
719 | } | |
720 | } | |
721 | ||
722 | ||
723 | ||
724 | ||
725 | ||
726 | LOCAL docomleng() | |
727 | { | |
728 | register struct Extsym *p; | |
729 | ||
730 | for(p = extsymtab ; p < nextext ; ++p) | |
731 | if(p->extstg == STGCOMMON) | |
732 | { | |
733 | if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng | |
734 | && !eqn(XL,"_BLNK__ ",p->extname) ) | |
735 | warn1("incompatible lengths for common block %s", | |
736 | nounder(XL, p->extname) ); | |
737 | if(p->maxleng < p->extleng) | |
738 | p->maxleng = p->extleng; | |
739 | p->extleng = 0; | |
740 | } | |
741 | } | |
742 | ||
743 | ||
744 | ||
745 | \f | |
746 | /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ | |
747 | ||
748 | frtemp(p) | |
749 | Addrp p; | |
750 | { | |
751 | /* restore clobbered character string lengths */ | |
752 | if(p->vtype==TYCHAR && p->varleng!=0) | |
753 | { | |
754 | frexpr(p->vleng); | |
755 | p->vleng = ICON(p->varleng); | |
756 | } | |
757 | ||
758 | /* put block on chain of temps to be reclaimed */ | |
759 | holdtemps = mkchain(p, holdtemps); | |
760 | } | |
761 | ||
762 | ||
763 | ||
764 | ||
765 | /* allocate an automatic variable slot */ | |
766 | ||
767 | Addrp autovar(nelt, t, lengp) | |
768 | register int nelt, t; | |
769 | expptr lengp; | |
770 | { | |
771 | ftnint leng; | |
772 | register Addrp q; | |
773 | ||
774 | if(t == TYCHAR) | |
775 | if( ISICON(lengp) ) | |
776 | leng = lengp->constblock.const.ci; | |
777 | else { | |
778 | fatal("automatic variable of nonconstant length"); | |
779 | } | |
780 | else | |
781 | leng = typesize[t]; | |
782 | autoleng = roundup( autoleng, typealign[t]); | |
783 | ||
784 | q = ALLOC(Addrblock); | |
785 | q->tag = TADDR; | |
786 | q->vtype = t; | |
787 | if(t == TYCHAR) | |
788 | { | |
789 | q->vleng = ICON(leng); | |
790 | q->varleng = leng; | |
791 | } | |
792 | q->vstg = STGAUTO; | |
793 | q->ntempelt = nelt; | |
794 | #if TARGET==PDP11 || TARGET==VAX | |
795 | /* stack grows downward */ | |
796 | autoleng += nelt*leng; | |
797 | q->memoffset = ICON( - autoleng ); | |
798 | #else | |
799 | q->memoffset = ICON( autoleng ); | |
800 | autoleng += nelt*leng; | |
801 | #endif | |
802 | ||
803 | return(q); | |
804 | } | |
805 | ||
806 | ||
807 | Addrp mktmpn(nelt, type, lengp) | |
808 | int nelt; | |
809 | register int type; | |
810 | expptr lengp; | |
811 | { | |
812 | ftnint leng; | |
813 | chainp p, oldp; | |
814 | register Addrp q; | |
815 | ||
816 | if(type==TYUNKNOWN || type==TYERROR) | |
817 | badtype("mktmpn", type); | |
818 | ||
819 | if(type==TYCHAR) | |
820 | if( ISICON(lengp) ) | |
821 | leng = lengp->constblock.const.ci; | |
822 | else { | |
823 | err("adjustable length"); | |
824 | return( errnode() ); | |
825 | } | |
826 | /* | |
827 | * if an temporary of appropriate shape is on the templist, | |
828 | * remove it from the list and return it | |
829 | */ | |
830 | ||
831 | for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp) | |
832 | { | |
833 | q = (Addrp) (p->datap); | |
834 | if(q->vtype==type && q->ntempelt==nelt && | |
835 | (type!=TYCHAR || q->vleng->constblock.const.ci==leng) ) | |
836 | { | |
837 | if(oldp) | |
838 | oldp->nextp = p->nextp; | |
839 | else | |
840 | templist = p->nextp; | |
841 | free( (charptr) p); | |
842 | return(q); | |
843 | } | |
844 | } | |
845 | q = autovar(nelt, type, lengp); | |
846 | q->istemp = YES; | |
847 | return(q); | |
848 | } | |
849 | ||
850 | ||
851 | ||
852 | ||
853 | Addrp mktemp(type, lengp) | |
854 | int type; | |
855 | expptr lengp; | |
856 | { | |
857 | return( mktmpn(1,type,lengp) ); | |
858 | } | |
859 | \f | |
860 | /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ | |
861 | ||
862 | struct Extsym *comblock(len, s) | |
863 | register int len; | |
864 | register char *s; | |
865 | { | |
866 | struct Extsym *p; | |
867 | ||
868 | if(len == 0) | |
869 | { | |
870 | s = BLANKCOMMON; | |
871 | len = strlen(s); | |
872 | } | |
873 | p = mkext( varunder(len, s) ); | |
874 | if(p->extstg == STGUNKNOWN) | |
875 | p->extstg = STGCOMMON; | |
876 | else if(p->extstg != STGCOMMON) | |
877 | { | |
878 | errstr("%s cannot be a common block name", s); | |
879 | return(0); | |
880 | } | |
881 | ||
882 | return( p ); | |
883 | } | |
884 | ||
885 | ||
886 | incomm(c, v) | |
887 | struct Extsym *c; | |
888 | Namep v; | |
889 | { | |
890 | if(v->vstg != STGUNKNOWN) | |
891 | dclerr("incompatible common declaration", v); | |
892 | else | |
893 | { | |
894 | v->vstg = STGCOMMON; | |
895 | c->extp = hookup(c->extp, mkchain(v,CHNULL) ); | |
896 | } | |
897 | } | |
898 | ||
899 | ||
900 | ||
901 | ||
902 | settype(v, type, length) | |
903 | register Namep v; | |
904 | register int type; | |
905 | register int length; | |
906 | { | |
907 | if(type == TYUNKNOWN) | |
908 | return; | |
909 | ||
910 | if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) | |
911 | { | |
912 | v->vtype = TYSUBR; | |
913 | frexpr(v->vleng); | |
914 | } | |
915 | else if(type < 0) /* storage class set */ | |
916 | { | |
917 | if(v->vstg == STGUNKNOWN) | |
918 | v->vstg = - type; | |
919 | else if(v->vstg != -type) | |
920 | dclerr("incompatible storage declarations", v); | |
921 | } | |
922 | else if(v->vtype == TYUNKNOWN) | |
923 | { | |
924 | if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0) | |
925 | v->vleng = ICON(length); | |
926 | } | |
927 | else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) ) | |
928 | dclerr("incompatible type declarations", v); | |
929 | } | |
930 | ||
931 | ||
932 | ||
933 | ||
934 | ||
935 | lengtype(type, length) | |
936 | register int type; | |
937 | register int length; | |
938 | { | |
939 | switch(type) | |
940 | { | |
941 | case TYREAL: | |
942 | if(length == 8) | |
943 | return(TYDREAL); | |
944 | if(length == 4) | |
945 | goto ret; | |
946 | break; | |
947 | ||
948 | case TYCOMPLEX: | |
949 | if(length == 16) | |
950 | return(TYDCOMPLEX); | |
951 | if(length == 8) | |
952 | goto ret; | |
953 | break; | |
954 | ||
955 | case TYSHORT: | |
956 | case TYDREAL: | |
957 | case TYDCOMPLEX: | |
958 | case TYCHAR: | |
959 | case TYUNKNOWN: | |
960 | case TYSUBR: | |
961 | case TYERROR: | |
962 | goto ret; | |
963 | ||
964 | case TYLOGICAL: | |
965 | if(length == typesize[TYLOGICAL]) | |
966 | goto ret; | |
967 | break; | |
968 | ||
969 | case TYLONG: | |
970 | if(length == 0) | |
971 | return(tyint); | |
972 | if(length == 2) | |
973 | return(TYSHORT); | |
974 | if(length == 4) | |
975 | goto ret; | |
976 | break; | |
977 | default: | |
978 | badtype("lengtype", type); | |
979 | } | |
980 | ||
981 | if(length != 0) | |
982 | err("incompatible type-length combination"); | |
983 | ||
984 | ret: | |
985 | return(type); | |
986 | } | |
987 | ||
988 | ||
989 | ||
990 | ||
991 | ||
992 | setintr(v) | |
993 | register Namep v; | |
994 | { | |
995 | register int k; | |
996 | ||
997 | if(v->vstg == STGUNKNOWN) | |
998 | v->vstg = STGINTR; | |
999 | else if(v->vstg!=STGINTR) | |
1000 | dclerr("incompatible use of intrinsic function", v); | |
1001 | if(v->vclass==CLUNKNOWN) | |
1002 | v->vclass = CLPROC; | |
1003 | if(v->vprocclass == PUNKNOWN) | |
1004 | v->vprocclass = PINTRINSIC; | |
1005 | else if(v->vprocclass != PINTRINSIC) | |
1006 | dclerr("invalid intrinsic declaration", v); | |
1007 | if(k = intrfunct(v->varname)) | |
1008 | v->vardesc.varno = k; | |
1009 | else | |
1010 | dclerr("unknown intrinsic function", v); | |
1011 | } | |
1012 | ||
1013 | ||
1014 | ||
1015 | setext(v) | |
1016 | register Namep v; | |
1017 | { | |
1018 | if(v->vclass == CLUNKNOWN) | |
1019 | v->vclass = CLPROC; | |
1020 | else if(v->vclass != CLPROC) | |
1021 | dclerr("invalid external declaration", v); | |
1022 | ||
1023 | if(v->vprocclass == PUNKNOWN) | |
1024 | v->vprocclass = PEXTERNAL; | |
1025 | else if(v->vprocclass != PEXTERNAL) | |
1026 | dclerr("invalid external declaration", v); | |
1027 | } | |
1028 | ||
1029 | ||
1030 | ||
1031 | ||
1032 | /* create dimensions block for array variable */ | |
1033 | ||
1034 | setbound(v, nd, dims) | |
1035 | register Namep v; | |
1036 | int nd; | |
1037 | struct { expptr lb, ub; } dims[ ]; | |
1038 | { | |
1039 | register expptr q, t; | |
1040 | register struct Dimblock *p; | |
1041 | int i; | |
1042 | ||
1043 | if(v->vclass == CLUNKNOWN) | |
1044 | v->vclass = CLVAR; | |
1045 | else if(v->vclass != CLVAR) | |
1046 | { | |
1047 | dclerr("only variables may be arrays", v); | |
1048 | return; | |
1049 | } | |
1050 | ||
1051 | v->vdim = p = (struct Dimblock *) | |
1052 | ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); | |
1053 | p->ndim = nd; | |
1054 | p->nelt = ICON(1); | |
1055 | ||
1056 | for(i=0 ; i<nd ; ++i) | |
1057 | { | |
1058 | if( (q = dims[i].ub) == NULL) | |
1059 | { | |
1060 | if(i == nd-1) | |
1061 | { | |
1062 | frexpr(p->nelt); | |
1063 | p->nelt = NULL; | |
1064 | } | |
1065 | else | |
1066 | err("only last bound may be asterisk"); | |
1067 | p->dims[i].dimsize = ICON(1);; | |
1068 | p->dims[i].dimexpr = NULL; | |
1069 | } | |
1070 | else | |
1071 | { | |
1072 | if(dims[i].lb) | |
1073 | { | |
1074 | q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); | |
1075 | q = mkexpr(OPPLUS, q, ICON(1) ); | |
1076 | } | |
1077 | if( ISCONST(q) ) | |
1078 | { | |
1079 | p->dims[i].dimsize = q; | |
1080 | p->dims[i].dimexpr = (expptr) PNULL; | |
1081 | } | |
1082 | else { | |
1083 | p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL); | |
1084 | p->dims[i].dimexpr = q; | |
1085 | } | |
1086 | if(p->nelt) | |
1087 | p->nelt = mkexpr(OPSTAR, p->nelt, | |
1088 | cpexpr(p->dims[i].dimsize) ); | |
1089 | } | |
1090 | } | |
1091 | ||
1092 | q = dims[nd-1].lb; | |
1093 | if(q == NULL) | |
1094 | q = ICON(1); | |
1095 | ||
1096 | for(i = nd-2 ; i>=0 ; --i) | |
1097 | { | |
1098 | t = dims[i].lb; | |
1099 | if(t == NULL) | |
1100 | t = ICON(1); | |
1101 | if(p->dims[i].dimsize) | |
1102 | q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); | |
1103 | } | |
1104 | ||
1105 | if( ISCONST(q) ) | |
1106 | { | |
1107 | p->baseoffset = q; | |
1108 | p->basexpr = NULL; | |
1109 | } | |
1110 | else | |
1111 | { | |
1112 | p->baseoffset = (expptr) autovar(1, tyint, PNULL); | |
1113 | p->basexpr = q; | |
1114 | } | |
1115 | } |