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