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