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