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