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