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