![[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 / old / f77|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 42BSD / old / 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:
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: fixlwm();
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:
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:
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:
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:
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:
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:
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:
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:
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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.