![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to proc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1 |
1.1 root 1: /* @(#)proc.c 1.4 (Berkeley) 6/1/81 */
2: #include "defs.h"
3: #include "machdefs.h"
4:
5: #ifdef SDB
6: # include <a.out.h>
7: # ifndef N_SO
8: # include <stab.h>
9: # endif
10: #endif
11:
12:
13: typedef
14: struct SizeList
15: {
16: struct SizeList *next;
17: ftnint size;
18: struct VarList *vars;
19: }
20: sizelist;
21:
22:
23: typedef
24: struct VarList
25: {
26: struct VarList *next;
27: Namep np;
28: struct Equivblock *ep;
29: }
30: varlist;
31:
32:
33: LOCAL sizelist *varsizes;
34:
35:
36: /* start a new procedure */
37:
38: newproc()
39: {
40: if(parstate != OUTSIDE)
41: {
42: execerr("missing end statement", CNULL);
43: endproc();
44: }
45:
46: parstate = INSIDE;
47: procclass = CLMAIN; /* default */
48: }
49:
50:
51:
52: /* end of procedure. generate variables, epilogs, and prologs */
53:
54: endproc()
55: {
56: struct Labelblock *lp;
57:
58: if(parstate < INDATA)
59: enddcl();
60: if(ctlstack >= ctls)
61: err("DO loop or BLOCK IF not closed");
62: for(lp = labeltab ; lp < labtabend ; ++lp)
63: if(lp->stateno!=0 && lp->labdefined==NO)
64: errstr("missing statement number %s", convic(lp->stateno) );
65:
66: if (optimflag)
67: optimize();
68:
69: outiodata();
70: epicode();
71: procode();
72: donmlist();
73: dobss();
74:
75: #if FAMILY == PCC
76: putbracket();
77: #endif
78: fixlwm();
79: procinit(); /* clean up for next procedure */
80: }
81:
82:
83:
84: /* End of declaration section of procedure. Allocate storage. */
85:
86: enddcl()
87: {
88: register struct Entrypoint *ep;
89:
90: parstate = INEXEC;
91: docommon();
92: doequiv();
93: docomleng();
94: for(ep = entries ; ep ; ep = ep->entnextp) {
95: doentry(ep);
96: #ifdef SDB
97: if(sdbflag)
98: {
99: entrystab(ep,procclass);
100: }
101: #endif
102: }
103: }
104:
105: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
106:
107: /* Main program or Block data */
108:
109: startproc(progname, class)
110: struct Extsym * progname;
111: int class;
112: {
113: register struct Entrypoint *p;
114:
115: p = ALLOC(Entrypoint);
116: if(class == CLMAIN)
117: puthead("MAIN_", CLMAIN);
118: else
119: puthead(CNULL, CLBLOCK);
120: if(class == CLMAIN)
121: newentry( mkname(5, "MAIN") );
122: p->entryname = progname;
123: p->entrylabel = newlabel();
124: entries = p;
125:
126: procclass = class;
127: retlabel = newlabel();
128: fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
129: if(progname)
130: fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) );
131: fprintf(diagfile, ":\n");
132: #ifdef SDB
133: if(sdbflag) {
134: entrystab(p,class);
135: }
136: #endif
137: }
138:
139: /* subroutine or function statement */
140:
141: struct Extsym *newentry(v)
142: register Namep v;
143: {
144: register struct Extsym *p;
145:
146: p = mkext( varunder(VL, v->varname) );
147:
148: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
149: {
150: if(p == 0)
151: dclerr("invalid entry name", v);
152: else dclerr("external name already used", v);
153: return(0);
154: }
155: v->vstg = STGAUTO;
156: v->vprocclass = PTHISPROC;
157: v->vclass = CLPROC;
158: p->extstg = STGEXT;
159: p->extinit = YES;
160: return(p);
161: }
162:
163:
164: entrypt(class, type, length, entry, args)
165: int class, type;
166: ftnint length;
167: struct Extsym *entry;
168: chainp args;
169: {
170: register Namep q;
171: register struct Entrypoint *p, *ep;
172:
173: if(class != CLENTRY)
174: puthead( varstr(XL, procname = entry->extname), class);
175: if(class == CLENTRY)
176: fprintf(diagfile, " entry ");
177: fprintf(diagfile, " %s:\n", nounder(XL, entry->extname));
178: q = mkname(VL, nounder(XL,entry->extname) );
179:
180: if( (type = lengtype(type, (int) length)) != TYCHAR)
181: length = 0;
182: if(class == CLPROC)
183: {
184: procclass = CLPROC;
185: proctype = type;
186: procleng = length;
187:
188: retlabel = newlabel();
189: if(type == TYSUBR)
190: ret0label = newlabel();
191: }
192:
193: p = ALLOC(Entrypoint);
194:
195: if(entries) /* put new block at end of entries list */
196: {
197: for(ep = entries; ep->entnextp; ep = ep->entnextp)
198: ;
199: ep->entnextp = p;
200: }
201: else
202: entries = p;
203:
204: p->entryname = entry;
205: p->arglist = args;
206: p->entrylabel = newlabel();
207: p->enamep = q;
208:
209: if(class == CLENTRY)
210: {
211: class = CLPROC;
212: if(proctype == TYSUBR)
213: type = TYSUBR;
214: }
215:
216: q->vclass = class;
217: q->vprocclass = PTHISPROC;
218: settype(q, type, (int) length);
219: /* hold all initial entry points till end of declarations */
220: if(parstate >= INDATA) {
221: doentry(p);
222: }
223: #ifdef SDB
224: if(sdbflag)
225: { /* may need to preserve CLENTRY here */
226: entrystab(p,class);
227: }
228: #endif
229: }
230:
231: /* generate epilogs */
232:
233: LOCAL epicode()
234: {
235: register int i;
236:
237: if(procclass==CLPROC)
238: {
239: if(proctype==TYSUBR)
240: {
241: putlabel(ret0label);
242: if(substars)
243: putforce(TYINT, ICON(0) );
244: putlabel(retlabel);
245: goret(TYSUBR);
246: }
247: else {
248: putlabel(retlabel);
249: if(multitype)
250: {
251: typeaddr = autovar(1, TYADDR, PNULL);
252: putbranch( cpexpr(typeaddr) );
253: for(i = 0; i < NTYPES ; ++i)
254: if(rtvlabel[i] != 0)
255: {
256: putlabel(rtvlabel[i]);
257: retval(i);
258: }
259: }
260: else
261: retval(proctype);
262: }
263: }
264:
265: else if(procclass != CLBLOCK)
266: {
267: putlabel(retlabel);
268: goret(TYSUBR);
269: }
270: }
271:
272:
273: /* generate code to return value of type t */
274:
275: LOCAL retval(t)
276: register int t;
277: {
278: register Addrp p;
279:
280: switch(t)
281: {
282: case TYCHAR:
283: case TYCOMPLEX:
284: case TYDCOMPLEX:
285: break;
286:
287: case TYLOGICAL:
288: t = tylogical;
289: case TYADDR:
290: case TYSHORT:
291: case TYLONG:
292: p = (Addrp) cpexpr(retslot);
293: p->vtype = t;
294: putforce(t, p);
295: break;
296:
297: case TYREAL:
298: case TYDREAL:
299: p = (Addrp) cpexpr(retslot);
300: p->vtype = t;
301: putforce(t, p);
302: break;
303:
304: default:
305: badtype("retval", t);
306: }
307: goret(t);
308: }
309:
310:
311: /* Allocate extra argument array if needed. Generate prologs. */
312:
313: LOCAL procode()
314: {
315: register struct Entrypoint *p;
316: Addrp argvec;
317:
318: #if TARGET==GCOS
319: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
320: #else
321: if(lastargslot>0 && nentry>1)
322: #if TARGET == VAX
323: argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
324: #else
325: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
326: #endif
327: else
328: argvec = NULL;
329: #endif
330:
331:
332: #if TARGET == PDP11
333: /* for the optimizer */
334: if(fudgelabel)
335: putlabel(fudgelabel);
336: #endif
337:
338: for(p = entries ; p ; p = p->entnextp)
339: prolog(p, argvec);
340:
341: #if FAMILY == PCC
342: putrbrack(procno);
343: #endif
344:
345: prendproc();
346: }
347:
348: /*
349: manipulate argument lists (allocate argument slot positions)
350: * keep track of return types and labels
351: */
352:
353: LOCAL doentry(ep)
354: struct Entrypoint *ep;
355: {
356: register int type;
357: register Namep np;
358: chainp p;
359: register Namep q;
360: Addrp mkarg();
361:
362: ++nentry;
363: if(procclass == CLMAIN)
364: {
365: if (optimflag)
366: optbuff (SKLABEL, 0, ep->entrylabel, 0);
367: else
368: putlabel(ep->entrylabel);
369: return;
370: }
371: else if(procclass == CLBLOCK)
372: return;
373:
374: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
375: type = np->vtype;
376: if(proctype == TYUNKNOWN)
377: if( (proctype = type) == TYCHAR)
378: procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
379:
380: if(proctype == TYCHAR)
381: {
382: if(type != TYCHAR)
383: err("noncharacter entry of character function");
384: else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
385: err("mismatched character entry lengths");
386: }
387: else if(type == TYCHAR)
388: err("character entry of noncharacter function");
389: else if(type != proctype)
390: multitype = YES;
391: if(rtvlabel[type] == 0)
392: rtvlabel[type] = newlabel();
393: ep->typelabel = rtvlabel[type];
394:
395: if(type == TYCHAR)
396: {
397: if(chslot < 0)
398: {
399: chslot = nextarg(TYADDR);
400: chlgslot = nextarg(TYLENG);
401: }
402: np->vstg = STGARG;
403: np->vardesc.varno = chslot;
404: if(procleng < 0)
405: np->vleng = (expptr) mkarg(TYLENG, chlgslot);
406: }
407: else if( ISCOMPLEX(type) )
408: {
409: np->vstg = STGARG;
410: if(cxslot < 0)
411: cxslot = nextarg(TYADDR);
412: np->vardesc.varno = cxslot;
413: }
414: else if(type != TYSUBR)
415: {
416: if(nentry == 1)
417: retslot = autovar(1, TYDREAL, PNULL);
418: np->vstg = STGAUTO;
419: np->voffset = retslot->memoffset->constblock.const.ci;
420: }
421:
422: for(p = ep->arglist ; p ; p = p->nextp)
423: if(! (( q = (Namep) (p->datap) )->vdcldone) )
424: q->vardesc.varno = nextarg(TYADDR);
425:
426: for(p = ep->arglist ; p ; p = p->nextp)
427: if(! (( q = (Namep) (p->datap) )->vdcldone) )
428: {
429: impldcl(q);
430: q->vdcldone = YES;
431: if(q->vtype == TYCHAR)
432: {
433: if(q->vleng == NULL) /* character*(*) */
434: q->vleng = (expptr)
435: mkarg(TYLENG, nextarg(TYLENG) );
436: else if(nentry == 1)
437: nextarg(TYLENG);
438: }
439: else if(q->vclass==CLPROC && nentry==1)
440: nextarg(TYLENG) ;
441: #ifdef SDB
442: if(sdbflag) {
443: namestab(q);
444: }
445: #endif
446: }
447:
448: if (optimflag)
449: optbuff (SKLABEL, 0, ep->entrylabel, 0);
450: else
451: putlabel(ep->entrylabel);
452: }
453:
454:
455:
456: LOCAL nextarg(type)
457: int type;
458: {
459: int k;
460: k = lastargslot;
461: lastargslot += typesize[type];
462: return(k);
463: }
464:
465: /* generate variable references */
466:
467: LOCAL dobss()
468: {
469: register struct Hashentry *p;
470: register Namep q;
471: register int i;
472: int align;
473: ftnint leng, iarrl;
474: char *memname();
475: int qstg, qclass, qtype;
476:
477: pruse(asmfile, USEBSS);
478: varsizes = NULL;
479:
480: for(p = hashtab ; p<lasthash ; ++p)
481: if(q = p->varp)
482: {
483: qstg = q->vstg;
484: qtype = q->vtype;
485: qclass = q->vclass;
486:
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==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
492: mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
493:
494: if (qclass == CLVAR && qstg == STGBSS)
495: {
496: if (SMALLVAR(q->varsize))
497: {
498: enlist(q->varsize, q, NULL);
499: q->inlcomm = NO;
500: }
501: else
502: {
503: if (q->init == NO)
504: {
505: preven(ALIDOUBLE);
506: prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
507: q->inlcomm = YES;
508: }
509: else
510: prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
511: q->vtype, q->initoffset, &(q->inlcomm));
512: }
513: }
514: else if(qclass==CLVAR && qstg!=STGARG)
515: {
516: if(q->vdim && !ISICON(q->vdim->nelt) )
517: dclerr("adjustable dimension on non-argument", q);
518: if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
519: dclerr("adjustable leng on nonargument", q);
520: }
521: }
522:
523: for (i = 0 ; i < nequiv ; ++i)
524: if ( (leng = eqvclass[i].eqvleng) != 0 )
525: {
526: if (SMALLVAR(leng))
527: enlist(leng, NULL, eqvclass + i);
528: else if (eqvclass[i].init == NO)
529: {
530: preven(ALIDOUBLE);
531: prlocvar(memname(STGEQUIV, i), leng);
532: eqvclass[i].inlcomm = YES;
533: }
534: else
535: prlocdata(memname(STGEQUIV, i), leng, TYDREAL,
536: eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
537: }
538:
539: outlocvars();
540: #ifdef SDB
541: if(sdbflag) {
542: for(p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
543: qstg = q->vstg;
544: qclass = q->vclass;
545: if( ONEOF(qclass, M(CLVAR))) {
546: if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) ) namestab(q);
547: }
548: }
549: }
550: #endif
551:
552: close(vdatafile);
553: close(vchkfile);
554: unlink(vdatafname);
555: unlink(vchkfname);
556: vdatahwm = 0;
557: }
558:
559:
560:
561: donmlist()
562: {
563: register struct Hashentry *p;
564: register Namep q;
565:
566: pruse(asmfile, USEINIT);
567:
568: for(p=hashtab; p<lasthash; ++p)
569: if( (q = p->varp) && q->vclass==CLNAMELIST)
570: namelist(q);
571: }
572:
573:
574: doext()
575: {
576: struct Extsym *p;
577:
578: for(p = extsymtab ; p<nextext ; ++p)
579: prext(p);
580: }
581:
582:
583:
584:
585: ftnint iarrlen(q)
586: register Namep q;
587: {
588: ftnint leng;
589:
590: leng = typesize[q->vtype];
591: if(leng <= 0)
592: return(-1);
593: if(q->vdim)
594: if( ISICON(q->vdim->nelt) )
595: leng *= q->vdim->nelt->constblock.const.ci;
596: else return(-1);
597: if(q->vleng)
598: if( ISICON(q->vleng) )
599: leng *= q->vleng->constblock.const.ci;
600: else return(-1);
601: return(leng);
602: }
603:
604: /* This routine creates a static block representing the namelist.
605: An equivalent declaration of the structure produced is:
606: struct namelist
607: {
608: char namelistname[16];
609: struct namelistentry
610: {
611: char varname[16];
612: char *varaddr;
613: int type; # negative means -type= number of chars
614: struct dimensions *dimp; # null means scalar
615: } names[];
616: };
617:
618: struct dimensions
619: {
620: int numberofdimensions;
621: int numberofelements
622: int baseoffset;
623: int span[numberofdimensions];
624: };
625: where the namelistentry list terminates with a null varname
626: If dimp is not null, then the corner element of the array is at
627: varaddr. However, the element with subscripts (i1,...,in) is at
628: varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
629: */
630:
631: namelist(np)
632: Namep np;
633: {
634: register chainp q;
635: register Namep v;
636: register struct Dimblock *dp;
637: char *memname();
638: int type, dimno, dimoffset;
639: flag bad;
640:
641:
642: preven(ALILONG);
643: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
644: putstr(asmfile, varstr(VL, np->varname), 16);
645: dimno = ++lastvarno;
646: dimoffset = 0;
647: bad = NO;
648:
649: for(q = np->varxptr.namelist ; q ; q = q->nextp)
650: {
651: vardcl( v = (Namep) (q->datap) );
652: type = v->vtype;
653: if( ONEOF(v->vstg, MSKSTATIC) )
654: {
655: preven(ALILONG);
656: putstr(asmfile, varstr(VL,v->varname), 16);
657: praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
658: prconi(asmfile, TYINT,
659: type==TYCHAR ?
660: -(v->vleng->constblock.const.ci) : (ftnint) type);
661: if(v->vdim)
662: {
663: praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
664: dimoffset += 3 + v->vdim->ndim;
665: }
666: else
667: praddr(asmfile, STGNULL,0,(ftnint) 0);
668: }
669: else
670: {
671: dclerr("may not appear in namelist", v);
672: bad = YES;
673: }
674: }
675:
676: if(bad)
677: return;
678:
679: putstr(asmfile, "", 16);
680:
681: if(dimoffset > 0)
682: {
683: fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
684: for(q = np->varxptr.namelist ; q ; q = q->nextp)
685: if(dp = q->datap->nameblock.vdim)
686: {
687: int i;
688: prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
689: prconi(asmfile, TYINT,
690: (ftnint) (dp->nelt->constblock.const.ci) );
691: prconi(asmfile, TYINT,
692: (ftnint) (dp->baseoffset->constblock.const.ci));
693: for(i=0; i<dp->ndim ; ++i)
694: prconi(asmfile, TYINT,
695: dp->dims[i].dimsize->constblock.const.ci);
696: }
697: }
698:
699: }
700:
701: LOCAL docommon()
702: {
703: register struct Extsym *p;
704: register chainp q;
705: struct Dimblock *t;
706: expptr neltp;
707: register Namep v;
708: ftnint size;
709: int type;
710:
711: for(p = extsymtab ; p<nextext ; ++p)
712: if(p->extstg==STGCOMMON)
713: {
714: #ifdef SDB
715: if(sdbflag)
716: prstab(varstr(XL,p->extname), N_BCOMM, 0, 0);
717: #endif
718: for(q = p->extp ; q ; q = q->nextp)
719: {
720: v = (Namep) (q->datap);
721: if(v->vdcldone == NO)
722: vardcl(v);
723: type = v->vtype;
724: if(p->extleng % typealign[type] != 0)
725: {
726: dclerr("common alignment", v);
727: p->extleng = roundup(p->extleng, typealign[type]);
728: }
729: v->voffset = p->extleng;
730: v->vardesc.varno = p - extsymtab;
731: if(type == TYCHAR)
732: size = v->vleng->constblock.const.ci;
733: else size = typesize[type];
734: if(t = v->vdim)
735: if( (neltp = t->nelt) && ISCONST(neltp) )
736: size *= neltp->constblock.const.ci;
737: else
738: dclerr("adjustable array in common", v);
739: p->extleng += size;
740: #ifdef SDB
741: if(sdbflag)
742: {
743: namestab(v);
744: }
745: #endif
746: }
747:
748: frchain( &(p->extp) );
749: #ifdef SDB
750: if(sdbflag)
751: prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
752: #endif
753: }
754: }
755:
756:
757:
758:
759:
760: LOCAL docomleng()
761: {
762: register struct Extsym *p;
763:
764: for(p = extsymtab ; p < nextext ; ++p)
765: if(p->extstg == STGCOMMON)
766: {
767: if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
768: && !eqn(XL,"_BLNK__ ",p->extname) )
769: warn1("incompatible lengths for common block %s",
770: nounder(XL, p->extname) );
771: if(p->maxleng < p->extleng)
772: p->maxleng = p->extleng;
773: p->extleng = 0;
774: }
775: }
776:
777:
778:
779:
780: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
781:
782: /* frees a temporary block */
783:
784: frtemp(p)
785: Tempp p;
786: {
787: Addrp t;
788:
789: if (optimflag)
790: {
791: if (p->tag != TTEMP)
792: badtag ("frtemp",p->tag);
793: t = p->memalloc;
794: }
795: else
796: t = (Addrp) p;
797:
798: /* restore clobbered character string lengths */
799: if(t->vtype==TYCHAR && t->varleng!=0)
800: {
801: frexpr(t->vleng);
802: t->vleng = ICON(t->varleng);
803: }
804:
805: /* put block on chain of temps to be reclaimed */
806: holdtemps = mkchain(t, holdtemps);
807: }
808:
809:
810:
811: /* allocate an automatic variable slot */
812:
813: Addrp autovar(nelt, t, lengp)
814: register int nelt, t;
815: expptr lengp;
816: {
817: ftnint leng;
818: register Addrp q;
819:
820: if(t == TYCHAR)
821: if( ISICON(lengp) )
822: leng = lengp->constblock.const.ci;
823: else {
824: fatal("automatic variable of nonconstant length");
825: }
826: else
827: leng = typesize[t];
828: autoleng = roundup( autoleng, typealign[t]);
829:
830: q = ALLOC(Addrblock);
831: q->tag = TADDR;
832: q->vtype = t;
833: if(t == TYCHAR)
834: {
835: q->vleng = ICON(leng);
836: q->varleng = leng;
837: }
838: q->vstg = STGAUTO;
839: q->memno = newlabel();
840: q->ntempelt = nelt;
841: #if TARGET==PDP11 || TARGET==VAX
842: /* stack grows downward */
843: autoleng += nelt*leng;
844: q->memoffset = ICON( - autoleng );
845: #else
846: q->memoffset = ICON( autoleng );
847: autoleng += nelt*leng;
848: #endif
849:
850: return(q);
851: }
852:
853:
854:
855: /*
856: * create a temporary block (TTEMP) when optimizing,
857: * an ordinary TADDR block when not optimizing
858: */
859:
860: Tempp mktmpn(nelt, type, lengp)
861: int nelt;
862: register int type;
863: expptr lengp;
864: {
865: ftnint leng;
866: chainp p, oldp;
867: register Tempp q;
868: Addrp altemp;
869:
870: if (! optimflag)
871: return ( (Tempp) mkaltmpn(nelt,type,lengp) );
872: if(type==TYUNKNOWN || type==TYERROR)
873: badtype("mktmpn", type);
874:
875: if(type==TYCHAR)
876: if( ISICON(lengp) )
877: leng = lengp->constblock.const.ci;
878: else {
879: err("adjustable length");
880: return( (Tempp) errnode() );
881: }
882:
883: if(type == TYCHAR)
884: if( ISICON(lengp) )
885: leng = lengp->constblock.const.ci;
886: else
887: fatal("temporary variable of nonconstant length");
888: else
889: leng = typesize[type];
890:
891: q = ALLOC(Tempblock);
892: q->tag = TTEMP;
893: q->vtype = type;
894: if(type == TYCHAR)
895: {
896: q->vleng = ICON(leng);
897: q->varleng = leng;
898: }
899:
900: altemp = ALLOC(Addrblock);
901: altemp->tag = TADDR;
902: altemp->vstg = STGUNKNOWN;
903: q->memalloc = altemp;
904:
905: q->ntempelt = nelt;
906: q->istemp = YES;
907: return(q);
908: }
909:
910:
911:
912: Addrp mktemp(type, lengp)
913: int type;
914: expptr lengp;
915: {
916: return( (Addrp) mktmpn(1,type,lengp) );
917: }
918:
919:
920:
921: /* allocate a temporary location for the given temporary block;
922: if already allocated, return its location */
923:
924: Addrp altmpn(tp)
925: Tempp tp;
926:
927: {
928: Addrp t, q;
929:
930: if (tp->tag != TTEMP)
931: badtag ("altmpn",tp->tag);
932:
933: t = tp->memalloc;
934: if (t->vstg != STGUNKNOWN)
935: return (t);
936:
937: q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
938: cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
939: free ( (charptr) q);
940: return(t);
941: }
942:
943:
944:
945: /* create and allocate space immediately for a temporary */
946:
947: Addrp mkaltemp(type,lengp)
948: int type;
949: expptr lengp;
950: {
951: return (mkaltmpn(1,type,lengp));
952: }
953:
954:
955:
956: Addrp mkaltmpn(nelt,type,lengp)
957: int nelt;
958: register int type;
959: expptr lengp;
960: {
961: ftnint leng;
962: chainp p, oldp;
963: register Addrp q;
964:
965: if(type==TYUNKNOWN || type==TYERROR)
966: badtype("mkaltmpn", type);
967:
968: if(type==TYCHAR)
969: if( ISICON(lengp) )
970: leng = lengp->constblock.const.ci;
971: else {
972: err("adjustable length");
973: return( (Addrp) errnode() );
974: }
975:
976: /*
977: * if a temporary of appropriate shape is on the templist,
978: * remove it from the list and return it
979: */
980:
981: for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp)
982: {
983: q = (Addrp) (p->datap);
984: if(q->vtype==type && q->ntempelt==nelt &&
985: (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
986: {
987: if(oldp)
988: oldp->nextp = p->nextp;
989: else
990: templist = p->nextp;
991: free( (charptr) p);
992:
993: if (debugflag[14])
994: fprintf(diagfile,"mkaltmpn reusing offset %d\n",
995: q->memoffset->constblock.const.ci);
996: return(q);
997: }
998: }
999: q = autovar(nelt, type, lengp);
1000: q->istemp = YES;
1001:
1002: if (debugflag[14])
1003: fprintf(diagfile,"mkaltmpn new offset %d\n",
1004: q->memoffset->constblock.const.ci);
1005: return(q);
1006: }
1007:
1008: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1009:
1010: struct Extsym *comblock(len, s)
1011: register int len;
1012: register char *s;
1013: {
1014: struct Extsym *p;
1015:
1016: if(len == 0)
1017: {
1018: s = BLANKCOMMON;
1019: len = strlen(s);
1020: }
1021: p = mkext( varunder(len, s) );
1022: if(p->extstg == STGUNKNOWN)
1023: p->extstg = STGCOMMON;
1024: else if(p->extstg != STGCOMMON)
1025: {
1026: errstr("%s cannot be a common block name", s);
1027: return(0);
1028: }
1029:
1030: return( p );
1031: }
1032:
1033:
1034: incomm(c, v)
1035: struct Extsym *c;
1036: Namep v;
1037: {
1038: if(v->vstg != STGUNKNOWN)
1039: dclerr("incompatible common declaration", v);
1040: else
1041: {
1042: v->vstg = STGCOMMON;
1043: c->extp = hookup(c->extp, mkchain(v,CHNULL) );
1044: }
1045: }
1046:
1047:
1048:
1049:
1050: settype(v, type, length)
1051: register Namep v;
1052: register int type;
1053: register int length;
1054: {
1055: if(type == TYUNKNOWN)
1056: return;
1057:
1058: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1059: {
1060: v->vtype = TYSUBR;
1061: frexpr(v->vleng);
1062: }
1063: else if(type < 0) /* storage class set */
1064: {
1065: if(v->vstg == STGUNKNOWN)
1066: v->vstg = - type;
1067: else if(v->vstg != -type)
1068: dclerr("incompatible storage declarations", v);
1069: }
1070: else if(v->vtype == TYUNKNOWN)
1071: {
1072: if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
1073: v->vleng = ICON(length);
1074: }
1075: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
1076: dclerr("incompatible type declarations", v);
1077: }
1078:
1079:
1080:
1081:
1082:
1083: lengtype(type, length)
1084: register int type;
1085: register int length;
1086: {
1087: switch(type)
1088: {
1089: case TYREAL:
1090: if(length == 8)
1091: return(TYDREAL);
1092: if(length == 4)
1093: goto ret;
1094: break;
1095:
1096: case TYCOMPLEX:
1097: if(length == 16)
1098: return(TYDCOMPLEX);
1099: if(length == 8)
1100: goto ret;
1101: break;
1102:
1103: case TYSHORT:
1104: case TYDREAL:
1105: case TYDCOMPLEX:
1106: case TYCHAR:
1107: case TYUNKNOWN:
1108: case TYSUBR:
1109: case TYERROR:
1110: goto ret;
1111:
1112: case TYLOGICAL:
1113: if(length == typesize[TYLOGICAL])
1114: goto ret;
1115: break;
1116:
1117: case TYLONG:
1118: if(length == 0)
1119: return(tyint);
1120: if(length == 2)
1121: return(TYSHORT);
1122: if(length == 4)
1123: goto ret;
1124: break;
1125: default:
1126: badtype("lengtype", type);
1127: }
1128:
1129: if(length != 0)
1130: err("incompatible type-length combination");
1131:
1132: ret:
1133: return(type);
1134: }
1135:
1136:
1137:
1138:
1139:
1140: setintr(v)
1141: register Namep v;
1142: {
1143: register int k;
1144:
1145: if(v->vstg == STGUNKNOWN)
1146: v->vstg = STGINTR;
1147: else if(v->vstg!=STGINTR)
1148: dclerr("incompatible use of intrinsic function", v);
1149: if(v->vclass==CLUNKNOWN)
1150: v->vclass = CLPROC;
1151: if(v->vprocclass == PUNKNOWN)
1152: v->vprocclass = PINTRINSIC;
1153: else if(v->vprocclass != PINTRINSIC)
1154: dclerr("invalid intrinsic declaration", v);
1155: if(k = intrfunct(v->varname))
1156: v->vardesc.varno = k;
1157: else
1158: dclerr("unknown intrinsic function", v);
1159: }
1160:
1161:
1162:
1163: setext(v)
1164: register Namep v;
1165: {
1166: if(v->vclass == CLUNKNOWN)
1167: v->vclass = CLPROC;
1168: else if(v->vclass != CLPROC)
1169: dclerr("invalid external declaration", v);
1170:
1171: if(v->vprocclass == PUNKNOWN)
1172: v->vprocclass = PEXTERNAL;
1173: else if(v->vprocclass != PEXTERNAL)
1174: dclerr("invalid external declaration", v);
1175: }
1176:
1177:
1178:
1179:
1180: /* create dimensions block for array variable */
1181:
1182: setbound(v, nd, dims)
1183: register Namep v;
1184: int nd;
1185: struct { expptr lb, ub; } dims[ ];
1186: {
1187: register expptr q, t;
1188: register struct Dimblock *p;
1189: int i;
1190:
1191: if(v->vclass == CLUNKNOWN)
1192: v->vclass = CLVAR;
1193: else if(v->vclass != CLVAR)
1194: {
1195: dclerr("only variables may be arrays", v);
1196: return;
1197: }
1198:
1199: v->vdim = p = (struct Dimblock *)
1200: ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
1201: p->ndim = nd;
1202: p->nelt = ICON(1);
1203:
1204: for(i=0 ; i<nd ; ++i)
1205: {
1206: #ifdef SDB
1207: if(sdbflag) {
1208: /* Save the bounds trees built up by the grammar routines for use in stabs */
1209:
1210: if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
1211: else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
1212: if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
1213: else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);
1214:
1215: if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
1216: else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
1217: if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
1218: else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
1219: }
1220: #endif
1221: if( (q = dims[i].ub) == NULL)
1222: {
1223: if(i == nd-1)
1224: {
1225: frexpr(p->nelt);
1226: p->nelt = NULL;
1227: }
1228: else
1229: err("only last bound may be asterisk");
1230: p->dims[i].dimsize = ICON(1);;
1231: p->dims[i].dimexpr = NULL;
1232: }
1233: else
1234: {
1235: if(dims[i].lb)
1236: {
1237: q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1238: q = mkexpr(OPPLUS, q, ICON(1) );
1239: }
1240: if( ISCONST(q) )
1241: {
1242: p->dims[i].dimsize = q;
1243: p->dims[i].dimexpr = (expptr) PNULL;
1244: }
1245: else {
1246: p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
1247: p->dims[i].dimexpr = q;
1248: }
1249: if(p->nelt)
1250: p->nelt = mkexpr(OPSTAR, p->nelt,
1251: cpexpr(p->dims[i].dimsize) );
1252: }
1253: }
1254:
1255: q = dims[nd-1].lb;
1256: if(q == NULL)
1257: q = ICON(1);
1258:
1259: for(i = nd-2 ; i>=0 ; --i)
1260: {
1261: t = dims[i].lb;
1262: if(t == NULL)
1263: t = ICON(1);
1264: if(p->dims[i].dimsize)
1265: q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
1266: }
1267:
1268: if( ISCONST(q) )
1269: {
1270: p->baseoffset = q;
1271: p->basexpr = NULL;
1272: }
1273: else
1274: {
1275: p->baseoffset = (expptr) autovar(1, tyint, PNULL);
1276: p->basexpr = q;
1277: }
1278: }
1279:
1280:
1281:
1282: LOCAL enlist(size, np, ep)
1283: ftnint size;
1284: Namep np;
1285: struct Equivblock *ep;
1286: {
1287: register sizelist *sp;
1288: register sizelist *t;
1289: register varlist *p;
1290:
1291: sp = varsizes;
1292:
1293: if (sp == NULL)
1294: {
1295: sp = ALLOC(SizeList);
1296: sp->size = size;
1297: varsizes = sp;
1298: }
1299: else
1300: {
1301: while (sp->size != size)
1302: {
1303: if (sp->next != NULL && sp->next->size <= size)
1304: sp = sp->next;
1305: else
1306: {
1307: t = sp;
1308: sp = ALLOC(SizeList);
1309: sp->size = size;
1310: sp->next = t->next;
1311: t->next = sp;
1312: }
1313: }
1314: }
1315:
1316: p = ALLOC(VarList);
1317: p->next = sp->vars;
1318: p->np = np;
1319: p->ep = ep;
1320:
1321: sp->vars = p;
1322:
1323: return;
1324: }
1325:
1326:
1327:
1328: outlocvars()
1329: {
1330:
1331: register varlist *first, *last;
1332: register varlist *vp, *t;
1333: register sizelist *sp, *sp1;
1334: register Namep np;
1335: register struct Equivblock *ep;
1336: register int i;
1337: register int alt;
1338: register int type;
1339: char sname[100];
1340: char setbuff[100];
1341:
1342: sp = varsizes;
1343: if (sp == NULL)
1344: return;
1345:
1346: vp = sp->vars;
1347: if (vp->np != NULL)
1348: {
1349: np = vp->np;
1350: sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
1351: np->vardesc.varno);
1352: }
1353: else
1354: {
1355: i = vp->ep - eqvclass;
1356: sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
1357: }
1358:
1359: first = last = NULL;
1360: alt = NO;
1361:
1362: while (sp != NULL)
1363: {
1364: vp = sp->vars;
1365: while (vp != NULL)
1366: {
1367: t = vp->next;
1368: if (alt == YES)
1369: {
1370: alt = NO;
1371: vp->next = first;
1372: first = vp;
1373: }
1374: else
1375: {
1376: alt = YES;
1377: if (last != NULL)
1378: last->next = vp;
1379: else
1380: first = vp;
1381: vp->next = NULL;
1382: last = vp;
1383: }
1384: vp = t;
1385: }
1386: sp1 = sp;
1387: sp = sp->next;
1388: free((char *) sp1);
1389: }
1390:
1391: vp = first;
1392: while(vp != NULL)
1393: {
1394: if (vp->np != NULL)
1395: {
1396: np = vp->np;
1397: sprintf(sname, "v.%d", np->vardesc.varno);
1398: if (np->init)
1399: prlocdata(sname, np->varsize, np->vtype, np->initoffset,
1400: &(np->inlcomm));
1401: else
1402: {
1403: pralign(typealign[np->vtype]);
1404: fprintf(initfile, "%s:\n\t.space\t%d\n", sname,
1405: np->varsize);
1406: }
1407: np->inlcomm = NO;
1408: }
1409: else
1410: {
1411: ep = vp->ep;
1412: i = ep - eqvclass;
1413: if (ep->eqvleng >= 8)
1414: type = TYDREAL;
1415: else if (ep->eqvleng >= 4)
1416: type = TYLONG;
1417: else if (ep->eqvleng >= 2)
1418: type = TYSHORT;
1419: else
1420: type = TYCHAR;
1421: sprintf(sname, "q.%d", i + eqvstart);
1422: if (ep->init)
1423: prlocdata(sname, ep->eqvleng, type, ep->initoffset,
1424: &(ep->inlcomm));
1425: else
1426: {
1427: pralign(typealign[type]);
1428: fprintf(initfile, "%s:\n\t.space\t%d\n", sname, ep->eqvleng);
1429: }
1430: ep->inlcomm = NO;
1431: }
1432: t = vp;
1433: vp = vp->next;
1434: free((char *) t);
1435: }
1436: fprintf(initfile, "%s\n", setbuff);
1437: return;
1438: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.