![[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] / 43BSD / usr.bin / f77 / src / f77pass1|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 43BSD / usr.bin / f77 / src / f77pass1 |
1.1 root 1: /*
2: * Copyright (c) 1980 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)proc.c 5.7 (Berkeley) 1/30/86";
9: #endif not lint
10:
11: /*
12: * proc.c
13: *
14: * Routines for handling procedures, f77 compiler, pass 1.
15: *
16: * University of Utah CS Dept modification history:
17: *
18: * $Log: proc.c,v $
19: * Revision 5.9 86/01/28 22:30:28 donn
20: * Let functions of type character have adjustable length.
21: *
22: * Revision 5.8 86/01/10 19:02:19 donn
23: * More dbx hacking -- filter out incomplete declarations (with bogus types).
24: *
25: * Revision 5.7 86/01/10 13:53:02 donn
26: * Since we now postpone determination of the type of an argument, we must
27: * make sure to emit stab information at the end of the routine when we
28: * definitely have the type. Notice some care was taken to make sure that
29: * arguments appear in order in the output file since that's how dbx wants
30: * them. Also a minor change for dummy procedures.
31: *
32: * Revision 5.6 86/01/06 16:28:06 donn
33: * Sigh. We can't commit to defining a symbol as a variable instead of a
34: * function based only on what we have seen through the declaration section;
35: * this was properly handled for normal variables but not for arguments.
36: *
37: * Revision 5.5 86/01/01 21:59:17 donn
38: * Pick up CHARACTER*(*) declarations for variables which aren't dummy
39: * arguments, and complain about them.
40: *
41: * Revision 5.4 85/12/20 19:18:35 donn
42: * Don't assume that dummy procedures of unknown type are functions of type
43: * undefined until the user (mis-)uses them that way -- they may also be
44: * subroutines.
45: *
46: * Revision 5.3 85/09/30 23:21:07 donn
47: * Print space with prspace() in outlocvars() so that alignment is preserved.
48: *
49: * Revision 5.2 85/08/10 05:03:34 donn
50: * Support for NAMELIST i/o from Jerry Berkman.
51: *
52: * Revision 5.1 85/08/10 03:49:14 donn
53: * 4.3 alpha
54: *
55: * Revision 3.11 85/06/04 03:45:29 donn
56: * Changed retval() to recognize that a function declaration might have
57: * bombed out earlier, leaving an error node behind...
58: *
59: * Revision 3.10 85/03/08 23:13:06 donn
60: * Finally figured out why function calls and array elements are not legal
61: * dummy array dimension declarator elements. Hacked safedim() to stop 'em.
62: *
63: * Revision 3.9 85/02/02 00:26:10 donn
64: * Removed the call to entrystab() in enddcl() -- this was redundant (it was
65: * also done in startproc()) and confusing to dbx to boot.
66: *
67: * Revision 3.8 85/01/14 04:21:53 donn
68: * Added changes to implement Jerry's '-q' option.
69: *
70: * Revision 3.7 85/01/11 21:10:35 donn
71: * In conjunction with other changes to implement SAVE statements, function
72: * nameblocks were changed to make it appear that they are 'saved' too --
73: * this arranges things so that function return values are forced out of
74: * register before a return.
75: *
76: * Revision 3.6 84/12/10 19:27:20 donn
77: * comblock() signals an illegal common block name by returning a null pointer,
78: * but incomm() wasn't able to handle it, leading to core dumps. I put the
79: * fix in incomm() to pick up null common blocks.
80: *
81: * Revision 3.5 84/11/21 20:33:31 donn
82: * It seems that I/O elements are treated as character strings so that their
83: * length can be passed to the I/O routines... Unfortunately the compiler
84: * assumes that no temporaries can be of type CHARACTER and casually tosses
85: * length and type info away when removing TEMP blocks. This has been fixed...
86: *
87: * Revision 3.4 84/11/05 22:19:30 donn
88: * Fixed a silly bug in the last fix.
89: *
90: * Revision 3.3 84/10/29 08:15:23 donn
91: * Added code to check the type and shape of subscript declarations,
92: * per Jerry Berkman's suggestion.
93: *
94: * Revision 3.2 84/10/29 05:52:07 donn
95: * Added change suggested by Jerry Berkman to report an error when an array
96: * is redimensioned.
97: *
98: * Revision 3.1 84/10/13 02:12:31 donn
99: * Merged Jerry Berkman's version into mine.
100: *
101: * Revision 2.1 84/07/19 12:04:09 donn
102: * Changed comment headers for UofU.
103: *
104: * Revision 1.6 84/07/19 11:32:15 donn
105: * Incorporated fix to setbound() to detect backward array subscript limits.
106: * The fix is by Bob Corbett, donated by Jerry Berkman.
107: *
108: * Revision 1.5 84/07/18 18:25:50 donn
109: * Fixed problem with doentry() where a placeholder for a return value
110: * was not allocated if the first entry didn't require one but a later
111: * entry did.
112: *
113: * Revision 1.4 84/05/24 20:52:09 donn
114: * Installed firewall #ifdef around the code that recycles stack temporaries,
115: * since it seems to be broken and lacks a good fix for the time being.
116: *
117: * Revision 1.3 84/04/16 09:50:46 donn
118: * Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
119: * the original for its own use. This fixes a set of bugs that are caused by
120: * elements in the argtemplist getting stomped on.
121: *
122: * Revision 1.2 84/02/28 21:12:58 donn
123: * Added Berkeley changes for subroutine call argument temporaries fix.
124: *
125: */
126:
127: #include "defs.h"
128:
129: #ifdef SDB
130: # include <a.out.h>
131: # ifndef N_SO
132: # include <stab.h>
133: # endif
134: #endif
135:
136: extern flag namesflag;
137:
138: typedef
139: struct SizeList
140: {
141: struct SizeList *next;
142: ftnint size;
143: struct VarList *vars;
144: }
145: sizelist;
146:
147:
148: typedef
149: struct VarList
150: {
151: struct VarList *next;
152: Namep np;
153: struct Equivblock *ep;
154: }
155: varlist;
156:
157:
158: LOCAL sizelist *varsizes;
159:
160:
161: /* start a new procedure */
162:
163: newproc()
164: {
165: if(parstate != OUTSIDE)
166: {
167: execerr("missing end statement", CNULL);
168: endproc();
169: }
170:
171: parstate = INSIDE;
172: procclass = CLMAIN; /* default */
173: }
174:
175:
176:
177: /* end of procedure. generate variables, epilogs, and prologs */
178:
179: endproc()
180: {
181: struct Labelblock *lp;
182:
183: if(parstate < INDATA)
184: enddcl();
185: if(ctlstack >= ctls)
186: err("DO loop or BLOCK IF not closed");
187: for(lp = labeltab ; lp < labtabend ; ++lp)
188: if(lp->stateno!=0 && lp->labdefined==NO)
189: errstr("missing statement number %s", convic(lp->stateno) );
190:
191: if (optimflag)
192: optimize();
193:
194: outiodata();
195: epicode();
196: procode();
197: donmlist();
198: dobss();
199:
200: #if FAMILY == PCC
201: putbracket();
202: #endif
203: fixlwm();
204: procinit(); /* clean up for next procedure */
205: }
206:
207:
208:
209: /* End of declaration section of procedure. Allocate storage. */
210:
211: enddcl()
212: {
213: register struct Entrypoint *ep;
214:
215: parstate = INEXEC;
216: docommon();
217: doequiv();
218: docomleng();
219: for(ep = entries ; ep ; ep = ep->entnextp) {
220: doentry(ep);
221: }
222: }
223:
224: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
225:
226: /* Main program or Block data */
227:
228: startproc(prgname, class)
229: Namep prgname;
230: int class;
231: {
232: struct Extsym *progname;
233: register struct Entrypoint *p;
234:
235: if(prgname)
236: procname = prgname->varname;
237: if(namesflag == YES) {
238: fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
239: if(prgname)
240: fprintf(diagfile, " %s", varstr(XL, procname) );
241: fprintf(diagfile, ":\n");
242: }
243:
244: if( prgname )
245: progname = newentry( prgname );
246: else
247: progname = NULL;
248:
249: p = ALLOC(Entrypoint);
250: if(class == CLMAIN)
251: puthead("MAIN_", CLMAIN);
252: else
253: puthead(CNULL, CLBLOCK);
254: if(class == CLMAIN)
255: newentry( mkname(5, "MAIN") );
256: p->entryname = progname;
257: p->entrylabel = newlabel();
258: entries = p;
259:
260: procclass = class;
261: retlabel = newlabel();
262: #ifdef SDB
263: if(sdbflag) {
264: entrystab(p,class);
265: }
266: #endif
267: }
268:
269: /* subroutine or function statement */
270:
271: struct Extsym *newentry(v)
272: register Namep v;
273: {
274: register struct Extsym *p;
275:
276: p = mkext( varunder(VL, v->varname) );
277:
278: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
279: {
280: if(p == 0)
281: dclerr("invalid entry name", v);
282: else dclerr("external name already used", v);
283: return(0);
284: }
285: v->vstg = STGAUTO;
286: v->vprocclass = PTHISPROC;
287: v->vclass = CLPROC;
288: p->extstg = STGEXT;
289: p->extinit = YES;
290: return(p);
291: }
292:
293:
294: entrypt(class, type, length, entname, args)
295: int class, type;
296: ftnint length;
297: Namep entname;
298: chainp args;
299: {
300: struct Extsym *entry;
301: register Namep q;
302: register struct Entrypoint *p, *ep;
303:
304: if(namesflag == YES) {
305: if(class == CLENTRY)
306: fprintf(diagfile, " entry ");
307: if(entname)
308: fprintf(diagfile, " %s", varstr(XL, entname->varname) );
309: fprintf(diagfile, ":\n");
310: }
311:
312: if( entname->vclass == CLPARAM ) {
313: errstr("entry name %s used in 'parameter' statement",
314: varstr(XL, entname->varname) );
315: return;
316: }
317: if( ((type == TYSUBR) || (class == CLENTRY && proctype == TYSUBR))
318: && (entname->vtype != TYUNKNOWN && entname->vtype != TYSUBR) ) {
319: errstr("subroutine entry %s previously declared",
320: varstr(XL, entname->varname) );
321: return;
322: }
323: if( (entname->vstg != STGEXT && entname->vstg != STGUNKNOWN)
324: || (entname->vdim != NULL) ) {
325: errstr("subroutine or function entry %s previously declared",
326: varstr(XL, entname->varname) );
327: return;
328: }
329:
330: if( (class == CLPROC || class == CLENTRY) && type != TYSUBR )
331: /* arrange to save function return values */
332: entname->vsave = YES;
333:
334: entry = newentry( entname );
335:
336: if(class != CLENTRY)
337: puthead( varstr(XL, procname = entry->extname), class);
338: q = mkname(VL, nounder(XL,entry->extname) );
339:
340: if( (type = lengtype(type, (int) length)) != TYCHAR)
341: length = 0;
342: if(class == CLPROC)
343: {
344: procclass = CLPROC;
345: proctype = type;
346: procleng = length;
347:
348: retlabel = newlabel();
349: if(type == TYSUBR)
350: ret0label = newlabel();
351: }
352:
353: p = ALLOC(Entrypoint);
354: if(entries) /* put new block at end of entries list */
355: {
356: for(ep = entries; ep->entnextp; ep = ep->entnextp)
357: ;
358: ep->entnextp = p;
359: }
360: else
361: entries = p;
362:
363: p->entryname = entry;
364: p->arglist = args;
365: p->entrylabel = newlabel();
366: p->enamep = q;
367:
368: if(class == CLENTRY)
369: {
370: class = CLPROC;
371: if(proctype == TYSUBR)
372: type = TYSUBR;
373: }
374:
375: q->vclass = class;
376: q->vprocclass = PTHISPROC;
377: settype(q, type, (int) length);
378: /* hold all initial entry points till end of declarations */
379: if(parstate >= INDATA) {
380: doentry(p);
381: }
382: #ifdef SDB
383: if(sdbflag)
384: { /* may need to preserve CLENTRY here */
385: entrystab(p,class);
386: }
387: #endif
388: }
389:
390: /* generate epilogs */
391:
392: LOCAL epicode()
393: {
394: register int i;
395:
396: if(procclass==CLPROC)
397: {
398: if(proctype==TYSUBR)
399: {
400: putlabel(ret0label);
401: if(substars)
402: putforce(TYINT, ICON(0) );
403: putlabel(retlabel);
404: goret(TYSUBR);
405: }
406: else {
407: putlabel(retlabel);
408: if(multitype)
409: {
410: typeaddr = autovar(1, TYADDR, PNULL);
411: putbranch( cpexpr(typeaddr) );
412: for(i = 0; i < NTYPES ; ++i)
413: if(rtvlabel[i] != 0)
414: {
415: putlabel(rtvlabel[i]);
416: retval(i);
417: }
418: }
419: else
420: retval(proctype);
421: }
422: }
423:
424: else if(procclass != CLBLOCK)
425: {
426: putlabel(retlabel);
427: goret(TYSUBR);
428: }
429: }
430:
431:
432: /* generate code to return value of type t */
433:
434: LOCAL retval(t)
435: register int t;
436: {
437: register Addrp p;
438:
439: switch(t)
440: {
441: case TYCHAR:
442: case TYCOMPLEX:
443: case TYDCOMPLEX:
444: break;
445:
446: case TYLOGICAL:
447: t = tylogical;
448: case TYADDR:
449: case TYSHORT:
450: case TYLONG:
451: p = (Addrp) cpexpr(retslot);
452: p->vtype = t;
453: putforce(t, p);
454: break;
455:
456: case TYREAL:
457: case TYDREAL:
458: p = (Addrp) cpexpr(retslot);
459: p->vtype = t;
460: putforce(t, p);
461: break;
462:
463: case TYERROR:
464: return; /* someone else already complained */
465:
466: default:
467: badtype("retval", t);
468: }
469: goret(t);
470: }
471:
472:
473: /* Allocate extra argument array if needed. Generate prologs. */
474:
475: LOCAL procode()
476: {
477: register struct Entrypoint *p;
478: Addrp argvec;
479:
480: #if TARGET==GCOS
481: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
482: #else
483: if(lastargslot>0 && nentry>1)
484: #if TARGET == VAX
485: argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
486: #else
487: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
488: #endif
489: else
490: argvec = NULL;
491: #endif
492:
493:
494: #if TARGET == PDP11
495: /* for the optimizer */
496: if(fudgelabel)
497: putlabel(fudgelabel);
498: #endif
499:
500: for(p = entries ; p ; p = p->entnextp)
501: prolog(p, argvec);
502:
503: #if FAMILY == PCC
504: putrbrack(procno);
505: #endif
506:
507: prendproc();
508: }
509:
510:
511: /*
512: * manipulate argument lists (allocate argument slot positions)
513: * keep track of return types and labels
514: */
515:
516: LOCAL doentry(ep)
517: struct Entrypoint *ep;
518: {
519: register int type;
520: register Namep np;
521: chainp p;
522: register Namep q;
523: Addrp mkarg();
524:
525: ++nentry;
526: if(procclass == CLMAIN)
527: {
528: if (optimflag)
529: optbuff (SKLABEL, 0, ep->entrylabel, 0);
530: else
531: putlabel(ep->entrylabel);
532: return;
533: }
534: else if(procclass == CLBLOCK)
535: return;
536:
537: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
538: type = np->vtype;
539: if(proctype == TYUNKNOWN)
540: if( (proctype = type) == TYCHAR)
541: procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
542:
543: if(proctype == TYCHAR)
544: {
545: if(type != TYCHAR)
546: err("noncharacter entry of character function");
547: else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
548: err("mismatched character entry lengths");
549: }
550: else if(type == TYCHAR)
551: err("character entry of noncharacter function");
552: else if(type != proctype)
553: multitype = YES;
554: if(rtvlabel[type] == 0)
555: rtvlabel[type] = newlabel();
556: ep->typelabel = rtvlabel[type];
557:
558: if(type == TYCHAR)
559: {
560: if(chslot < 0)
561: {
562: chslot = nextarg(TYADDR);
563: chlgslot = nextarg(TYLENG);
564: }
565: np->vstg = STGARG;
566: np->vardesc.varno = chslot;
567: if(procleng < 0)
568: np->vleng = (expptr) mkarg(TYLENG, chlgslot);
569: }
570: else if( ISCOMPLEX(type) )
571: {
572: np->vstg = STGARG;
573: if(cxslot < 0)
574: cxslot = nextarg(TYADDR);
575: np->vardesc.varno = cxslot;
576: }
577: else if(type != TYSUBR)
578: {
579: if(retslot == NULL)
580: retslot = autovar(1, TYDREAL, PNULL);
581: np->vstg = STGAUTO;
582: np->voffset = retslot->memoffset->constblock.const.ci;
583: }
584:
585: for(p = ep->arglist ; p ; p = p->nextp)
586: if(! (( q = (Namep) (p->datap) )->vdcldone) )
587: q->vardesc.varno = nextarg(TYADDR);
588:
589: for(p = ep->arglist ; p ; p = p->nextp)
590: if(! (( q = (Namep) (p->datap) )->vdcldone) )
591: {
592: if(q->vclass == CLPROC && q->vtype == TYUNKNOWN)
593: continue;
594: impldcl(q);
595: if(q->vtype == TYCHAR)
596: {
597: if(q->vleng == NULL) /* character*(*) */
598: q->vleng = (expptr)
599: mkarg(TYLENG, nextarg(TYLENG) );
600: else if(nentry == 1)
601: nextarg(TYLENG);
602: }
603: else if(q->vclass==CLPROC && nentry==1)
604: nextarg(TYLENG) ;
605: }
606:
607: if (optimflag)
608: optbuff (SKLABEL, 0, ep->entrylabel, 0);
609: else
610: putlabel(ep->entrylabel);
611: }
612:
613:
614:
615: LOCAL nextarg(type)
616: int type;
617: {
618: int k;
619: k = lastargslot;
620: lastargslot += typesize[type];
621: return(k);
622: }
623:
624: /* generate variable references */
625:
626: LOCAL dobss()
627: {
628: register struct Hashentry *p;
629: register Namep q;
630: register int i;
631: int align;
632: ftnint leng, iarrl;
633: char *memname();
634: int qstg, qclass, qtype;
635:
636: pruse(asmfile, USEBSS);
637: varsizes = NULL;
638:
639: for(p = hashtab ; p<lasthash ; ++p)
640: if(q = p->varp)
641: {
642: qstg = q->vstg;
643: qtype = q->vtype;
644: qclass = q->vclass;
645:
646: if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
647: (qclass==CLVAR && qstg==STGUNKNOWN) )
648: warn1("local variable %s never used", varstr(VL,q->varname) );
649: else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
650: mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
651:
652: if (qclass == CLVAR && qstg == STGBSS)
653: {
654: if (SMALLVAR(q->varsize))
655: {
656: enlist(q->varsize, q, NULL);
657: q->inlcomm = NO;
658: }
659: else
660: {
661: if (q->init == NO)
662: {
663: preven(ALIDOUBLE);
664: prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
665: q->inlcomm = YES;
666: }
667: else
668: prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
669: q->vtype, q->initoffset, &(q->inlcomm));
670: }
671: }
672: else if(qclass==CLVAR && qstg!=STGARG)
673: {
674: if(q->vdim && !ISICON(q->vdim->nelt) )
675: dclerr("adjustable dimension on non-argument", q);
676: if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
677: dclerr("adjustable leng on nonargument", q);
678: }
679:
680: chkdim(q);
681: }
682:
683: for (i = 0 ; i < nequiv ; ++i)
684: if ( (leng = eqvclass[i].eqvleng) != 0 )
685: {
686: if (SMALLVAR(leng))
687: enlist(leng, NULL, eqvclass + i);
688: else if (eqvclass[i].init == NO)
689: {
690: preven(ALIDOUBLE);
691: prlocvar(memname(STGEQUIV, i), leng);
692: eqvclass[i].inlcomm = YES;
693: }
694: else
695: prlocdata(memname(STGEQUIV, i), leng, TYDREAL,
696: eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
697: }
698:
699: outlocvars();
700: #ifdef SDB
701: if(sdbflag) {
702: register struct Entrypoint *ep;
703: register chainp cp;
704:
705: for (ep = entries; ep; ep = ep->entnextp)
706: for (cp = ep->arglist ; cp ; cp = cp->nextp)
707: if ((q = (Namep) cp->datap) && q->vstg == STGARG) {
708: q->vdcldone = YES;
709: namestab(q);
710: }
711: for (p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
712: if (q->vtype == TYUNKNOWN || q->vtype == TYERROR)
713: continue;
714: qstg = q->vstg;
715: qclass = q->vclass;
716: q->vdcldone = YES;
717: if ( ONEOF(qclass, M(CLVAR)|M(CLPARAM)|M(CLPROC)) ) {
718: if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) )
719: namestab(q);
720: }
721: }
722: }
723: #endif
724:
725: close(vdatafile);
726: close(vchkfile);
727: unlink(vdatafname);
728: unlink(vchkfname);
729: vdatahwm = 0;
730: }
731:
732:
733:
734: donmlist()
735: {
736: register struct Hashentry *p;
737: register Namep q;
738:
739: pruse(asmfile, USEINIT);
740:
741: for(p=hashtab; p<lasthash; ++p)
742: if( (q = p->varp) && q->vclass==CLNAMELIST)
743: namelist(q);
744: }
745:
746:
747: doext()
748: {
749: struct Extsym *p;
750:
751: for(p = extsymtab ; p<nextext ; ++p)
752: prext(p);
753: }
754:
755:
756:
757:
758: ftnint iarrlen(q)
759: register Namep q;
760: {
761: ftnint leng;
762:
763: leng = typesize[q->vtype];
764: if(leng <= 0)
765: return(-1);
766: if(q->vdim)
767: if( ISICON(q->vdim->nelt) )
768: leng *= q->vdim->nelt->constblock.const.ci;
769: else return(-1);
770: if(q->vleng)
771: if( ISICON(q->vleng) )
772: leng *= q->vleng->constblock.const.ci;
773: else return(-1);
774: return(leng);
775: }
776:
777: /* This routine creates a static block representing the namelist.
778: An equivalent declaration of the structure produced is:
779: struct namelist
780: {
781: char namelistname[16];
782: struct namelistentry
783: {
784: char varname[16]; # 16 plus null padding -> 20
785: char *varaddr;
786: short int type;
787: short int len; # length of type
788: struct dimensions *dimp; # null means scalar
789: } names[];
790: };
791:
792: struct dimensions
793: {
794: int numberofdimensions;
795: int numberofelements
796: int baseoffset;
797: int span[numberofdimensions];
798: };
799: where the namelistentry list terminates with a null varname
800: If dimp is not null, then the corner element of the array is at
801: varaddr. However, the element with subscripts (i1,...,in) is at
802: varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
803: */
804:
805: namelist(np)
806: Namep np;
807: {
808: register chainp q;
809: register Namep v;
810: register struct Dimblock *dp;
811: char *memname();
812: int type, dimno, dimoffset;
813: flag bad;
814:
815:
816: preven(ALILONG);
817: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
818: putstr(asmfile, varstr(VL, np->varname), 16);
819: dimno = ++lastvarno;
820: dimoffset = 0;
821: bad = NO;
822:
823: for(q = np->varxptr.namelist ; q ; q = q->nextp)
824: {
825: vardcl( v = (Namep) (q->datap) );
826: type = v->vtype;
827: if( ONEOF(v->vstg, MSKSTATIC) )
828: {
829: preven(ALILONG);
830: putstr(asmfile, varstr(VL,v->varname), 16);
831: praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
832: prconi(asmfile, TYSHORT, type );
833: prconi(asmfile, TYSHORT,
834: type==TYCHAR ?
835: (v->vleng->constblock.const.ci) :
836: (ftnint) typesize[type]);
837: if(v->vdim)
838: {
839: praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
840: dimoffset += (3 + v->vdim->ndim) * SZINT;
841: }
842: else
843: praddr(asmfile, STGNULL,0,(ftnint) 0);
844: }
845: else
846: {
847: dclerr("may not appear in namelist", v);
848: bad = YES;
849: }
850: }
851:
852: if(bad)
853: return;
854:
855: putstr(asmfile, "", 16);
856:
857: if(dimoffset > 0)
858: {
859: fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
860: for(q = np->varxptr.namelist ; q ; q = q->nextp)
861: if(dp = q->datap->nameblock.vdim)
862: {
863: int i;
864: prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
865: prconi(asmfile, TYINT,
866: (ftnint) (dp->nelt->constblock.const.ci) );
867: prconi(asmfile, TYINT,
868: (ftnint) (dp->baseoffset->constblock.const.ci));
869: for(i=0; i<dp->ndim ; ++i)
870: prconi(asmfile, TYINT,
871: dp->dims[i].dimsize->constblock.const.ci);
872: }
873: }
874:
875: }
876:
877: LOCAL docommon()
878: {
879: register struct Extsym *p;
880: register chainp q;
881: struct Dimblock *t;
882: expptr neltp;
883: register Namep v;
884: ftnint size;
885: int type;
886:
887: for(p = extsymtab ; p<nextext ; ++p)
888: if(p->extstg==STGCOMMON)
889: {
890: #ifdef SDB
891: if(sdbflag)
892: prstab(varstr(XL,p->extname), N_BCOMM, 0, 0);
893: #endif
894: for(q = p->extp ; q ; q = q->nextp)
895: {
896: v = (Namep) (q->datap);
897: if(v->vdcldone == NO)
898: vardcl(v);
899: type = v->vtype;
900: if(p->extleng % typealign[type] != 0)
901: {
902: dclerr("common alignment", v);
903: p->extleng = roundup(p->extleng, typealign[type]);
904: }
905: v->voffset = p->extleng;
906: v->vardesc.varno = p - extsymtab;
907: if(type == TYCHAR)
908: size = v->vleng->constblock.const.ci;
909: else size = typesize[type];
910: if(t = v->vdim)
911: if( (neltp = t->nelt) && ISCONST(neltp) )
912: size *= neltp->constblock.const.ci;
913: else
914: dclerr("adjustable array in common", v);
915: p->extleng += size;
916: #ifdef SDB
917: if(sdbflag)
918: {
919: namestab(v);
920: }
921: #endif
922: }
923:
924: frchain( &(p->extp) );
925: #ifdef SDB
926: if(sdbflag)
927: prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
928: #endif
929: }
930: }
931:
932:
933:
934:
935:
936: LOCAL docomleng()
937: {
938: register struct Extsym *p;
939:
940: for(p = extsymtab ; p < nextext ; ++p)
941: if(p->extstg == STGCOMMON)
942: {
943: if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
944: && !eqn(XL,"_BLNK__ ",p->extname) )
945: warn1("incompatible lengths for common block %s",
946: nounder(XL, p->extname) );
947: if(p->maxleng < p->extleng)
948: p->maxleng = p->extleng;
949: p->extleng = 0;
950: }
951: }
952:
953:
954:
955:
956: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
957:
958: /* frees a temporary block */
959:
960: frtemp(p)
961: Tempp p;
962: {
963: Addrp t;
964:
965: if (optimflag)
966: {
967: if (p->tag != TTEMP)
968: badtag ("frtemp",p->tag);
969: t = p->memalloc;
970: }
971: else
972: t = (Addrp) p;
973:
974: /* restore clobbered character string lengths */
975: if(t->vtype==TYCHAR && t->varleng!=0)
976: {
977: frexpr(t->vleng);
978: t->vleng = ICON(t->varleng);
979: }
980:
981: /* put block on chain of temps to be reclaimed */
982: holdtemps = mkchain(t, holdtemps);
983: }
984:
985:
986:
987: /* allocate an automatic variable slot */
988:
989: Addrp autovar(nelt, t, lengp)
990: register int nelt, t;
991: expptr lengp;
992: {
993: ftnint leng;
994: register Addrp q;
995:
996: if(lengp)
997: if( ISICON(lengp) )
998: leng = lengp->constblock.const.ci;
999: else {
1000: fatal("automatic variable of nonconstant length");
1001: }
1002: else
1003: leng = typesize[t];
1004: autoleng = roundup( autoleng, typealign[t]);
1005:
1006: q = ALLOC(Addrblock);
1007: q->tag = TADDR;
1008: q->vtype = t;
1009: if(lengp)
1010: {
1011: q->vleng = ICON(leng);
1012: q->varleng = leng;
1013: }
1014: q->vstg = STGAUTO;
1015: q->memno = newlabel();
1016: q->ntempelt = nelt;
1017: #if TARGET==PDP11 || TARGET==VAX
1018: /* stack grows downward */
1019: autoleng += nelt*leng;
1020: q->memoffset = ICON( - autoleng );
1021: #else
1022: q->memoffset = ICON( autoleng );
1023: autoleng += nelt*leng;
1024: #endif
1025:
1026: return(q);
1027: }
1028:
1029:
1030:
1031: /*
1032: * create a temporary block (TTEMP) when optimizing,
1033: * an ordinary TADDR block when not optimizing
1034: */
1035:
1036: Tempp mktmpn(nelt, type, lengp)
1037: int nelt;
1038: register int type;
1039: expptr lengp;
1040: {
1041: ftnint leng;
1042: chainp p, oldp;
1043: register Tempp q;
1044: Addrp altemp;
1045:
1046: if (! optimflag)
1047: return ( (Tempp) mkaltmpn(nelt,type,lengp) );
1048: if(type==TYUNKNOWN || type==TYERROR)
1049: badtype("mktmpn", type);
1050:
1051: if(type==TYCHAR)
1052: if( ISICON(lengp) )
1053: leng = lengp->constblock.const.ci;
1054: else {
1055: err("adjustable length");
1056: return( (Tempp) errnode() );
1057: }
1058: else
1059: leng = typesize[type];
1060:
1061: q = ALLOC(Tempblock);
1062: q->tag = TTEMP;
1063: q->vtype = type;
1064: if(type == TYCHAR)
1065: {
1066: q->vleng = ICON(leng);
1067: q->varleng = leng;
1068: }
1069:
1070: altemp = ALLOC(Addrblock);
1071: altemp->tag = TADDR;
1072: altemp->vstg = STGUNKNOWN;
1073: q->memalloc = altemp;
1074:
1075: q->ntempelt = nelt;
1076: q->istemp = YES;
1077: return(q);
1078: }
1079:
1080:
1081:
1082: Addrp mktemp(type, lengp)
1083: int type;
1084: expptr lengp;
1085: {
1086: return( (Addrp) mktmpn(1,type,lengp) );
1087: }
1088:
1089:
1090:
1091: /* allocate a temporary location for the given temporary block;
1092: if already allocated, return its location */
1093:
1094: Addrp altmpn(tp)
1095: Tempp tp;
1096:
1097: {
1098: Addrp t, q;
1099:
1100: if (tp->tag != TTEMP)
1101: badtag ("altmpn",tp->tag);
1102:
1103: t = tp->memalloc;
1104: if (t->vstg != STGUNKNOWN)
1105: {
1106: if (tp->vtype == TYCHAR)
1107: {
1108: /*
1109: * Unformatted I/O parameters are treated like character
1110: * strings (sigh) -- propagate type and length.
1111: */
1112: t = (Addrp) cpexpr(t);
1113: t->vtype = tp->vtype;
1114: t->vleng = tp->vleng;
1115: t->varleng = tp->varleng;
1116: }
1117: return (t);
1118: }
1119:
1120: q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
1121: cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
1122: free ( (charptr) q);
1123: return(t);
1124: }
1125:
1126:
1127:
1128: /* create and allocate space immediately for a temporary */
1129:
1130: Addrp mkaltemp(type,lengp)
1131: int type;
1132: expptr lengp;
1133: {
1134: return (mkaltmpn(1,type,lengp));
1135: }
1136:
1137:
1138:
1139: Addrp mkaltmpn(nelt,type,lengp)
1140: int nelt;
1141: register int type;
1142: expptr lengp;
1143: {
1144: ftnint leng;
1145: chainp p, oldp;
1146: register Addrp q;
1147:
1148: if(type==TYUNKNOWN || type==TYERROR)
1149: badtype("mkaltmpn", type);
1150:
1151: if(type==TYCHAR)
1152: if( ISICON(lengp) )
1153: leng = lengp->constblock.const.ci;
1154: else {
1155: err("adjustable length");
1156: return( (Addrp) errnode() );
1157: }
1158:
1159: /*
1160: * if a temporary of appropriate shape is on the templist,
1161: * remove it from the list and return it
1162: */
1163:
1164: #ifdef notdef
1165: /*
1166: * This code is broken until SKFRTEMP slots can be processed in putopt()
1167: * instead of in optimize() -- all kinds of things in putpcc.c can
1168: * bomb because of this. Sigh.
1169: */
1170: for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp)
1171: {
1172: q = (Addrp) (p->datap);
1173: if(q->vtype==type && q->ntempelt==nelt &&
1174: (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
1175: {
1176: if(oldp)
1177: oldp->nextp = p->nextp;
1178: else
1179: templist = p->nextp;
1180: free( (charptr) p);
1181:
1182: if (debugflag[14])
1183: fprintf(diagfile,"mkaltmpn reusing offset %d\n",
1184: q->memoffset->constblock.const.ci);
1185: return(q);
1186: }
1187: }
1188: #endif notdef
1189: q = autovar(nelt, type, lengp);
1190: q->istemp = YES;
1191:
1192: if (debugflag[14])
1193: fprintf(diagfile,"mkaltmpn new offset %d\n",
1194: q->memoffset->constblock.const.ci);
1195: return(q);
1196: }
1197:
1198:
1199:
1200: /* The following routine is a patch which is only needed because the */
1201: /* code for processing actual arguments for calls does not allocate */
1202: /* the temps it needs before optimization takes place. A better */
1203: /* solution is possible, but I do not have the time to implement it */
1204: /* now. */
1205: /* */
1206: /* Robert P. Corbett */
1207:
1208: Addrp
1209: mkargtemp(type, lengp)
1210: int type;
1211: expptr lengp;
1212: {
1213: ftnint leng;
1214: chainp oldp, p;
1215: Addrp q;
1216:
1217: if (type == TYUNKNOWN || type == TYERROR)
1218: badtype("mkargtemp", type);
1219:
1220: if (type == TYCHAR)
1221: {
1222: if (ISICON(lengp))
1223: leng = lengp->constblock.const.ci;
1224: else
1225: {
1226: err("adjustable length");
1227: return ((Addrp) errnode());
1228: }
1229: }
1230:
1231: oldp = CHNULL;
1232: p = argtemplist;
1233:
1234: while (p)
1235: {
1236: q = (Addrp) (p->datap);
1237: if (q->vtype == type
1238: && (type != TYCHAR || q->vleng->constblock.const.ci == leng))
1239: {
1240: if (oldp)
1241: oldp->nextp = p->nextp;
1242: else
1243: argtemplist = p->nextp;
1244:
1245: p->nextp = activearglist;
1246: activearglist = p;
1247:
1248: return ((Addrp) cpexpr(q));
1249: }
1250:
1251: oldp = p;
1252: p = p->nextp;
1253: }
1254:
1255: q = autovar(1, type, lengp);
1256: activearglist = mkchain(q, activearglist);
1257: return ((Addrp) cpexpr(q));
1258: }
1259:
1260: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1261:
1262: struct Extsym *comblock(len, s)
1263: register int len;
1264: register char *s;
1265: {
1266: struct Extsym *p;
1267:
1268: if(len == 0)
1269: {
1270: s = BLANKCOMMON;
1271: len = strlen(s);
1272: }
1273: p = mkext( varunder(len, s) );
1274: if(p->extstg == STGUNKNOWN)
1275: p->extstg = STGCOMMON;
1276: else if(p->extstg != STGCOMMON)
1277: {
1278: errstr("%s cannot be a common block name", s);
1279: return(0);
1280: }
1281:
1282: return( p );
1283: }
1284:
1285:
1286: incomm(c, v)
1287: struct Extsym *c;
1288: Namep v;
1289: {
1290: if(v->vstg != STGUNKNOWN)
1291: dclerr("incompatible common declaration", v);
1292: else
1293: {
1294: if(c == (struct Extsym *) 0)
1295: return; /* Illegal common block name upstream */
1296: v->vstg = STGCOMMON;
1297: c->extp = hookup(c->extp, mkchain(v,CHNULL) );
1298: }
1299: }
1300:
1301:
1302:
1303:
1304: settype(v, type, length)
1305: register Namep v;
1306: register int type;
1307: register int length;
1308: {
1309: if(type == TYUNKNOWN)
1310: return;
1311:
1312: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1313: {
1314: v->vtype = TYSUBR;
1315: frexpr(v->vleng);
1316: }
1317: else if(type < 0) /* storage class set */
1318: {
1319: if(v->vstg == STGUNKNOWN)
1320: v->vstg = - type;
1321: else if(v->vstg != -type)
1322: dclerr("incompatible storage declarations", v);
1323: }
1324: else if(v->vtype == TYUNKNOWN)
1325: {
1326: if( (v->vtype = lengtype(type, length))==TYCHAR )
1327: {
1328: if(length >= 0)
1329: v->vleng = ICON(length);
1330: else if(!(v->vstg == STGARG || v->vclass == CLENTRY ||
1331: (v->vclass == CLPROC && v->vprocclass == PTHISPROC)))
1332: {
1333: dclerr("illegal adjustable length character variable", v);
1334: v->vleng = ICON(0);
1335: }
1336: }
1337: }
1338: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
1339: dclerr("incompatible type declarations", v);
1340: }
1341:
1342:
1343:
1344:
1345:
1346: lengtype(type, length)
1347: register int type;
1348: register int length;
1349: {
1350: switch(type)
1351: {
1352: case TYREAL:
1353: if(length == 8)
1354: return(TYDREAL);
1355: if(length == 4)
1356: goto ret;
1357: break;
1358:
1359: case TYCOMPLEX:
1360: if(length == 16)
1361: return(TYDCOMPLEX);
1362: if(length == 8)
1363: goto ret;
1364: break;
1365:
1366: case TYSHORT:
1367: case TYDREAL:
1368: case TYDCOMPLEX:
1369: case TYCHAR:
1370: case TYUNKNOWN:
1371: case TYSUBR:
1372: case TYERROR:
1373: goto ret;
1374:
1375: case TYLOGICAL:
1376: if(length == typesize[TYLOGICAL])
1377: goto ret;
1378: break;
1379:
1380: case TYLONG:
1381: if(length == 0)
1382: return(tyint);
1383: if(length == 2)
1384: return(TYSHORT);
1385: if(length == 4)
1386: goto ret;
1387: break;
1388: default:
1389: badtype("lengtype", type);
1390: }
1391:
1392: if(length != 0)
1393: err("incompatible type-length combination");
1394:
1395: ret:
1396: return(type);
1397: }
1398:
1399:
1400:
1401:
1402:
1403: setintr(v)
1404: register Namep v;
1405: {
1406: register int k;
1407:
1408: if(v->vstg == STGUNKNOWN)
1409: v->vstg = STGINTR;
1410: else if(v->vstg!=STGINTR)
1411: dclerr("incompatible use of intrinsic function", v);
1412: if(v->vclass==CLUNKNOWN)
1413: v->vclass = CLPROC;
1414: if(v->vprocclass == PUNKNOWN)
1415: v->vprocclass = PINTRINSIC;
1416: else if(v->vprocclass != PINTRINSIC)
1417: dclerr("invalid intrinsic declaration", v);
1418: if(k = intrfunct(v->varname))
1419: v->vardesc.varno = k;
1420: else
1421: dclerr("unknown intrinsic function", v);
1422: }
1423:
1424:
1425:
1426: setext(v)
1427: register Namep v;
1428: {
1429: if(v->vclass == CLUNKNOWN)
1430: v->vclass = CLPROC;
1431: else if(v->vclass != CLPROC)
1432: dclerr("conflicting declarations", v);
1433:
1434: if(v->vprocclass == PUNKNOWN)
1435: v->vprocclass = PEXTERNAL;
1436: else if(v->vprocclass != PEXTERNAL)
1437: dclerr("conflicting declarations", v);
1438: }
1439:
1440:
1441:
1442:
1443: /* create dimensions block for array variable */
1444:
1445: setbound(v, nd, dims)
1446: register Namep v;
1447: int nd;
1448: struct { expptr lb, ub; } dims[ ];
1449: {
1450: register expptr q, t;
1451: register struct Dimblock *p;
1452: int i;
1453:
1454: if(v->vclass == CLUNKNOWN)
1455: v->vclass = CLVAR;
1456: else if(v->vclass != CLVAR)
1457: {
1458: dclerr("only variables may be arrays", v);
1459: return;
1460: }
1461: if(v->vdim)
1462: {
1463: dclerr("redimensioned array", v);
1464: return;
1465: }
1466:
1467: v->vdim = p = (struct Dimblock *)
1468: ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
1469: p->ndim = nd;
1470: p->nelt = ICON(1);
1471:
1472: for(i=0 ; i<nd ; ++i)
1473: {
1474: #ifdef SDB
1475: if(sdbflag) {
1476: /* Save the bounds trees built up by the grammar routines for use in stabs */
1477:
1478: if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
1479: else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
1480: if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
1481: else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);
1482:
1483: if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
1484: else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
1485: if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
1486: else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
1487: }
1488: #endif
1489: if( (q = dims[i].ub) == NULL)
1490: {
1491: if(i == nd-1)
1492: {
1493: frexpr(p->nelt);
1494: p->nelt = NULL;
1495: }
1496: else
1497: err("only last bound may be asterisk");
1498: p->dims[i].dimsize = ICON(1);;
1499: p->dims[i].dimexpr = NULL;
1500: }
1501: else
1502: {
1503: if(dims[i].lb)
1504: {
1505: q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1506: q = mkexpr(OPPLUS, q, ICON(1) );
1507: }
1508: if( ISCONST(q) )
1509: {
1510: if (!ISINT(q->headblock.vtype)) {
1511: dclerr("dimension bounds must be integer expression", v);
1512: frexpr(q);
1513: q = ICON(0);
1514: }
1515: if ( q->constblock.const.ci <= 0)
1516: {
1517: dclerr("array bounds out of sequence", v);
1518: frexpr(q);
1519: q = ICON(0);
1520: }
1521: p->dims[i].dimsize = q;
1522: p->dims[i].dimexpr = (expptr) PNULL;
1523: }
1524: else {
1525: p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
1526: p->dims[i].dimexpr = q;
1527: }
1528: if(p->nelt)
1529: p->nelt = mkexpr(OPSTAR, p->nelt,
1530: cpexpr(p->dims[i].dimsize) );
1531: }
1532: }
1533:
1534: q = dims[nd-1].lb;
1535: if(q == NULL)
1536: q = ICON(1);
1537:
1538: for(i = nd-2 ; i>=0 ; --i)
1539: {
1540: t = dims[i].lb;
1541: if(t == NULL)
1542: t = ICON(1);
1543: if(p->dims[i].dimsize)
1544: q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
1545: }
1546:
1547: if( ISCONST(q) )
1548: {
1549: p->baseoffset = q;
1550: p->basexpr = NULL;
1551: }
1552: else
1553: {
1554: p->baseoffset = (expptr) autovar(1, tyint, PNULL);
1555: p->basexpr = q;
1556: }
1557: }
1558:
1559:
1560:
1561: /*
1562: * Check the dimensions of q to ensure that they are appropriately defined.
1563: */
1564: LOCAL chkdim(q)
1565: register Namep q;
1566: {
1567: register struct Dimblock *p;
1568: register int i;
1569: expptr e;
1570:
1571: if (q == NULL)
1572: return;
1573: if (q->vclass != CLVAR)
1574: return;
1575: if (q->vdim == NULL)
1576: return;
1577: p = q->vdim;
1578: for (i = 0; i < p->ndim; ++i)
1579: {
1580: #ifdef SDB
1581: if (sdbflag)
1582: {
1583: if (e = p->dims[i].lb)
1584: chkdime(e, q);
1585: if (e = p->dims[i].ub)
1586: chkdime(e, q);
1587: }
1588: else
1589: #endif SDB
1590: if (e = p->dims[i].dimexpr)
1591: chkdime(e, q);
1592: }
1593: }
1594:
1595:
1596:
1597: /*
1598: * The actual checking for chkdim() -- examines each expression.
1599: */
1600: LOCAL chkdime(expr, q)
1601: expptr expr;
1602: Namep q;
1603: {
1604: register expptr e;
1605:
1606: e = fixtype(cpexpr(expr));
1607: if (!ISINT(e->exprblock.vtype))
1608: dclerr("non-integer dimension", q);
1609: else if (!safedim(e))
1610: dclerr("undefined dimension", q);
1611: frexpr(e);
1612: return;
1613: }
1614:
1615:
1616:
1617: /*
1618: * A recursive routine to find undefined variables in dimension expressions.
1619: */
1620: LOCAL safedim(e)
1621: expptr e;
1622: {
1623: chainp cp;
1624:
1625: if (e == NULL)
1626: return 1;
1627: switch (e->tag)
1628: {
1629: case TEXPR:
1630: if (e->exprblock.opcode == OPCALL || e->exprblock.opcode == OPCCALL)
1631: return 0;
1632: return safedim(e->exprblock.leftp) && safedim(e->exprblock.rightp);
1633: case TADDR:
1634: switch (e->addrblock.vstg)
1635: {
1636: case STGCOMMON:
1637: case STGARG:
1638: case STGCONST:
1639: case STGEQUIV:
1640: if (e->addrblock.isarray)
1641: return 0;
1642: return safedim(e->addrblock.memoffset);
1643: default:
1644: return 0;
1645: }
1646: case TCONST:
1647: case TTEMP:
1648: return 1;
1649: }
1650: return 0;
1651: }
1652:
1653:
1654:
1655: LOCAL enlist(size, np, ep)
1656: ftnint size;
1657: Namep np;
1658: struct Equivblock *ep;
1659: {
1660: register sizelist *sp;
1661: register sizelist *t;
1662: register varlist *p;
1663:
1664: sp = varsizes;
1665:
1666: if (sp == NULL)
1667: {
1668: sp = ALLOC(SizeList);
1669: sp->size = size;
1670: varsizes = sp;
1671: }
1672: else
1673: {
1674: while (sp->size != size)
1675: {
1676: if (sp->next != NULL && sp->next->size <= size)
1677: sp = sp->next;
1678: else
1679: {
1680: t = sp;
1681: sp = ALLOC(SizeList);
1682: sp->size = size;
1683: sp->next = t->next;
1684: t->next = sp;
1685: }
1686: }
1687: }
1688:
1689: p = ALLOC(VarList);
1690: p->next = sp->vars;
1691: p->np = np;
1692: p->ep = ep;
1693:
1694: sp->vars = p;
1695:
1696: return;
1697: }
1698:
1699:
1700:
1701: outlocvars()
1702: {
1703:
1704: register varlist *first, *last;
1705: register varlist *vp, *t;
1706: register sizelist *sp, *sp1;
1707: register Namep np;
1708: register struct Equivblock *ep;
1709: register int i;
1710: register int alt;
1711: register int type;
1712: char sname[100];
1713: char setbuff[100];
1714:
1715: sp = varsizes;
1716: if (sp == NULL)
1717: return;
1718:
1719: vp = sp->vars;
1720: if (vp->np != NULL)
1721: {
1722: np = vp->np;
1723: sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
1724: np->vardesc.varno);
1725: }
1726: else
1727: {
1728: i = vp->ep - eqvclass;
1729: sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
1730: }
1731:
1732: first = last = NULL;
1733: alt = NO;
1734:
1735: while (sp != NULL)
1736: {
1737: vp = sp->vars;
1738: while (vp != NULL)
1739: {
1740: t = vp->next;
1741: if (alt == YES)
1742: {
1743: alt = NO;
1744: vp->next = first;
1745: first = vp;
1746: }
1747: else
1748: {
1749: alt = YES;
1750: if (last != NULL)
1751: last->next = vp;
1752: else
1753: first = vp;
1754: vp->next = NULL;
1755: last = vp;
1756: }
1757: vp = t;
1758: }
1759: sp1 = sp;
1760: sp = sp->next;
1761: free((char *) sp1);
1762: }
1763:
1764: vp = first;
1765: while(vp != NULL)
1766: {
1767: if (vp->np != NULL)
1768: {
1769: np = vp->np;
1770: sprintf(sname, "v.%d", np->vardesc.varno);
1771: if (np->init)
1772: prlocdata(sname, np->varsize, np->vtype, np->initoffset,
1773: &(np->inlcomm));
1774: else
1775: {
1776: pralign(typealign[np->vtype]);
1777: fprintf(initfile, "%s:\n", sname);
1778: prspace(np->varsize);
1779: }
1780: np->inlcomm = NO;
1781: }
1782: else
1783: {
1784: ep = vp->ep;
1785: i = ep - eqvclass;
1786: if (ep->eqvleng >= 8)
1787: type = TYDREAL;
1788: else if (ep->eqvleng >= 4)
1789: type = TYLONG;
1790: else if (ep->eqvleng >= 2)
1791: type = TYSHORT;
1792: else
1793: type = TYCHAR;
1794: sprintf(sname, "q.%d", i + eqvstart);
1795: if (ep->init)
1796: prlocdata(sname, ep->eqvleng, type, ep->initoffset,
1797: &(ep->inlcomm));
1798: else
1799: {
1800: pralign(typealign[type]);
1801: fprintf(initfile, "%s:\n", sname);
1802: prspace(ep->eqvleng);
1803: }
1804: ep->inlcomm = NO;
1805: }
1806: t = vp;
1807: vp = vp->next;
1808: free((char *) t);
1809: }
1810: fprintf(initfile, "%s\n", setbuff);
1811: return;
1812: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.