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