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