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