xref: /csrg-svn/usr.bin/f77/pass1.vax/proc.c (revision 25103)
122861Smckusick /*
222861Smckusick  * Copyright (c) 1980 Regents of the University of California.
322861Smckusick  * All rights reserved.  The Berkeley software License Agreement
422861Smckusick  * specifies the terms and conditions for redistribution.
522861Smckusick  */
622861Smckusick 
722861Smckusick #ifndef lint
8*25103Sdonn static char sccsid[] = "@(#)proc.c	5.4 (Berkeley) 10/06/85";
922861Smckusick #endif not lint
1022861Smckusick 
1122861Smckusick /*
1222861Smckusick  * proc.c
1322861Smckusick  *
1422861Smckusick  * Routines for handling procedures, f77 compiler, pass 1.
1522861Smckusick  *
1622861Smckusick  * University of Utah CS Dept modification history:
1722861Smckusick  *
18*25103Sdonn  * $Header: proc.c,v 5.3 85/09/30 23:21:07 donn Exp $
1922861Smckusick  * $Log:	proc.c,v $
20*25103Sdonn  * Revision 5.3  85/09/30  23:21:07  donn
21*25103Sdonn  * Print space with prspace() in outlocvars() so that alignment is preserved.
22*25103Sdonn  *
2324484Sdonn  * Revision 5.2  85/08/10  05:03:34  donn
2424484Sdonn  * Support for NAMELIST i/o from Jerry Berkman.
2524484Sdonn  *
2624484Sdonn  * Revision 5.1  85/08/10  03:49:14  donn
2724484Sdonn  * 4.3 alpha
2824484Sdonn  *
2923477Smckusick  * Revision 3.11  85/06/04  03:45:29  donn
3023477Smckusick  * Changed retval() to recognize that a function declaration might have
3123477Smckusick  * bombed out earlier, leaving an error node behind...
3223477Smckusick  *
3322861Smckusick  * Revision 3.10  85/03/08  23:13:06  donn
3422861Smckusick  * Finally figured out why function calls and array elements are not legal
3522861Smckusick  * dummy array dimension declarator elements.  Hacked safedim() to stop 'em.
3622861Smckusick  *
3722861Smckusick  * Revision 3.9  85/02/02  00:26:10  donn
3822861Smckusick  * Removed the call to entrystab() in enddcl() -- this was redundant (it was
3922861Smckusick  * also done in startproc()) and confusing to dbx to boot.
4022861Smckusick  *
4122861Smckusick  * Revision 3.8  85/01/14  04:21:53  donn
4222861Smckusick  * Added changes to implement Jerry's '-q' option.
4322861Smckusick  *
4422861Smckusick  * Revision 3.7  85/01/11  21:10:35  donn
4522861Smckusick  * In conjunction with other changes to implement SAVE statements, function
4622861Smckusick  * nameblocks were changed to make it appear that they are 'saved' too --
4722861Smckusick  * this arranges things so that function return values are forced out of
4822861Smckusick  * register before a return.
4922861Smckusick  *
5022861Smckusick  * Revision 3.6  84/12/10  19:27:20  donn
5122861Smckusick  * comblock() signals an illegal common block name by returning a null pointer,
5222861Smckusick  * but incomm() wasn't able to handle it, leading to core dumps.  I put the
5322861Smckusick  * fix in incomm() to pick up null common blocks.
5422861Smckusick  *
5522861Smckusick  * Revision 3.5  84/11/21  20:33:31  donn
5622861Smckusick  * It seems that I/O elements are treated as character strings so that their
5722861Smckusick  * length can be passed to the I/O routines...  Unfortunately the compiler
5822861Smckusick  * assumes that no temporaries can be of type CHARACTER and casually tosses
5922861Smckusick  * length and type info away when removing TEMP blocks.  This has been fixed...
6022861Smckusick  *
6122861Smckusick  * Revision 3.4  84/11/05  22:19:30  donn
6222861Smckusick  * Fixed a silly bug in the last fix.
6322861Smckusick  *
6422861Smckusick  * Revision 3.3  84/10/29  08:15:23  donn
6522861Smckusick  * Added code to check the type and shape of subscript declarations,
6622861Smckusick  * per Jerry Berkman's suggestion.
6722861Smckusick  *
6822861Smckusick  * Revision 3.2  84/10/29  05:52:07  donn
6922861Smckusick  * Added change suggested by Jerry Berkman to report an error when an array
7022861Smckusick  * is redimensioned.
7122861Smckusick  *
7222861Smckusick  * Revision 3.1  84/10/13  02:12:31  donn
7322861Smckusick  * Merged Jerry Berkman's version into mine.
7422861Smckusick  *
7522861Smckusick  * Revision 2.1  84/07/19  12:04:09  donn
7622861Smckusick  * Changed comment headers for UofU.
7722861Smckusick  *
7822861Smckusick  * Revision 1.6  84/07/19  11:32:15  donn
7922861Smckusick  * Incorporated fix to setbound() to detect backward array subscript limits.
8022861Smckusick  * The fix is by Bob Corbett, donated by Jerry Berkman.
8122861Smckusick  *
8222861Smckusick  * Revision 1.5  84/07/18  18:25:50  donn
8322861Smckusick  * Fixed problem with doentry() where a placeholder for a return value
8422861Smckusick  * was not allocated if the first entry didn't require one but a later
8522861Smckusick  * entry did.
8622861Smckusick  *
8722861Smckusick  * Revision 1.4  84/05/24  20:52:09  donn
8822861Smckusick  * Installed firewall #ifdef around the code that recycles stack temporaries,
8922861Smckusick  * since it seems to be broken and lacks a good fix for the time being.
9022861Smckusick  *
9122861Smckusick  * Revision 1.3  84/04/16  09:50:46  donn
9222861Smckusick  * Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
9322861Smckusick  * the original for its own use.  This fixes a set of bugs that are caused by
9422861Smckusick  * elements in the argtemplist getting stomped on.
9522861Smckusick  *
9622861Smckusick  * Revision 1.2  84/02/28  21:12:58  donn
9722861Smckusick  * Added Berkeley changes for subroutine call argument temporaries fix.
9822861Smckusick  *
9922861Smckusick  */
10022861Smckusick 
10122861Smckusick #include "defs.h"
10222861Smckusick 
10322861Smckusick #ifdef SDB
10422861Smckusick #	include <a.out.h>
10522861Smckusick #	ifndef N_SO
10622861Smckusick #		include <stab.h>
10722861Smckusick #	endif
10822861Smckusick #endif
10922861Smckusick 
11022861Smckusick extern flag namesflag;
11122861Smckusick 
11222861Smckusick typedef
11322861Smckusick   struct SizeList
11422861Smckusick     {
11522861Smckusick       struct SizeList *next;
11622861Smckusick       ftnint size;
11722861Smckusick       struct VarList *vars;
11822861Smckusick     }
11922861Smckusick   sizelist;
12022861Smckusick 
12122861Smckusick 
12222861Smckusick typedef
12322861Smckusick   struct VarList
12422861Smckusick     {
12522861Smckusick       struct VarList *next;
12622861Smckusick       Namep np;
12722861Smckusick       struct Equivblock *ep;
12822861Smckusick     }
12922861Smckusick   varlist;
13022861Smckusick 
13122861Smckusick 
13222861Smckusick LOCAL sizelist *varsizes;
13322861Smckusick 
13422861Smckusick 
13522861Smckusick /* start a new procedure */
13622861Smckusick 
13722861Smckusick newproc()
13822861Smckusick {
13922861Smckusick if(parstate != OUTSIDE)
14022861Smckusick 	{
14122861Smckusick 	execerr("missing end statement", CNULL);
14222861Smckusick 	endproc();
14322861Smckusick 	}
14422861Smckusick 
14522861Smckusick parstate = INSIDE;
14622861Smckusick procclass = CLMAIN;	/* default */
14722861Smckusick }
14822861Smckusick 
14922861Smckusick 
15022861Smckusick 
15122861Smckusick /* end of procedure. generate variables, epilogs, and prologs */
15222861Smckusick 
15322861Smckusick endproc()
15422861Smckusick {
15522861Smckusick struct Labelblock *lp;
15622861Smckusick 
15722861Smckusick if(parstate < INDATA)
15822861Smckusick 	enddcl();
15922861Smckusick if(ctlstack >= ctls)
16022861Smckusick 	err("DO loop or BLOCK IF not closed");
16122861Smckusick for(lp = labeltab ; lp < labtabend ; ++lp)
16222861Smckusick 	if(lp->stateno!=0 && lp->labdefined==NO)
16322861Smckusick 		errstr("missing statement number %s", convic(lp->stateno) );
16422861Smckusick 
16522861Smckusick if (optimflag)
16622861Smckusick   optimize();
16722861Smckusick 
16822861Smckusick outiodata();
16922861Smckusick epicode();
17022861Smckusick procode();
17122861Smckusick donmlist();
17222861Smckusick dobss();
17322861Smckusick 
17422861Smckusick #if FAMILY == PCC
17522861Smckusick 	putbracket();
17622861Smckusick #endif
17722861Smckusick fixlwm();
17822861Smckusick procinit();	/* clean up for next procedure */
17922861Smckusick }
18022861Smckusick 
18122861Smckusick 
18222861Smckusick 
18322861Smckusick /* End of declaration section of procedure.  Allocate storage. */
18422861Smckusick 
18522861Smckusick enddcl()
18622861Smckusick {
18722861Smckusick register struct Entrypoint *ep;
18822861Smckusick 
18922861Smckusick parstate = INEXEC;
19022861Smckusick docommon();
19122861Smckusick doequiv();
19222861Smckusick docomleng();
19322861Smckusick for(ep = entries ; ep ; ep = ep->entnextp) {
19422861Smckusick 	doentry(ep);
19522861Smckusick }
19622861Smckusick }
19722861Smckusick 
19822861Smckusick /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
19922861Smckusick 
20022861Smckusick /* Main program or Block data */
20122861Smckusick 
20222861Smckusick startproc(prgname, class)
20322861Smckusick Namep prgname;
20422861Smckusick int class;
20522861Smckusick {
20622861Smckusick struct Extsym *progname;
20722861Smckusick register struct Entrypoint *p;
20822861Smckusick 
20922861Smckusick if(prgname)
21022861Smckusick 	procname = prgname->varname;
21122861Smckusick if(namesflag == YES) {
21222861Smckusick 	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
21322861Smckusick 	if(prgname)
21422861Smckusick 		fprintf(diagfile, " %s", varstr(XL, procname) );
21522861Smckusick 	fprintf(diagfile, ":\n");
21622861Smckusick 	}
21722861Smckusick 
21822861Smckusick if( prgname )
21922861Smckusick 	progname = newentry( prgname );
22022861Smckusick else
22122861Smckusick 	progname = NULL;
22222861Smckusick 
22322861Smckusick p = ALLOC(Entrypoint);
22422861Smckusick if(class == CLMAIN)
22522861Smckusick 	puthead("MAIN_", CLMAIN);
22622861Smckusick else
22722861Smckusick 	puthead(CNULL, CLBLOCK);
22822861Smckusick if(class == CLMAIN)
22922861Smckusick 	newentry( mkname(5, "MAIN") );
23022861Smckusick p->entryname = progname;
23122861Smckusick p->entrylabel = newlabel();
23222861Smckusick entries = p;
23322861Smckusick 
23422861Smckusick procclass = class;
23522861Smckusick retlabel = newlabel();
23622861Smckusick #ifdef SDB
23722861Smckusick if(sdbflag) {
23822861Smckusick          entrystab(p,class);
23922861Smckusick }
24022861Smckusick #endif
24122861Smckusick }
24222861Smckusick 
24322861Smckusick /* subroutine or function statement */
24422861Smckusick 
24522861Smckusick struct Extsym *newentry(v)
24622861Smckusick register Namep v;
24722861Smckusick {
24822861Smckusick register struct Extsym *p;
24922861Smckusick 
25022861Smckusick p = mkext( varunder(VL, v->varname) );
25122861Smckusick 
25222861Smckusick if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
25322861Smckusick 	{
25422861Smckusick 	if(p == 0)
25522861Smckusick 		dclerr("invalid entry name", v);
25622861Smckusick 	else	dclerr("external name already used", v);
25722861Smckusick 	return(0);
25822861Smckusick 	}
25922861Smckusick v->vstg = STGAUTO;
26022861Smckusick v->vprocclass = PTHISPROC;
26122861Smckusick v->vclass = CLPROC;
26222861Smckusick p->extstg = STGEXT;
26322861Smckusick p->extinit = YES;
26422861Smckusick return(p);
26522861Smckusick }
26622861Smckusick 
26722861Smckusick 
26822861Smckusick entrypt(class, type, length, entname, args)
26922861Smckusick int class, type;
27022861Smckusick ftnint length;
27122861Smckusick Namep entname;
27222861Smckusick chainp args;
27322861Smckusick {
27422861Smckusick struct Extsym *entry;
27522861Smckusick register Namep q;
27622861Smckusick register struct Entrypoint *p, *ep;
27722861Smckusick 
27822861Smckusick if(namesflag == YES) {
27922861Smckusick 	if(class == CLENTRY)
28022861Smckusick 		fprintf(diagfile, "       entry ");
28122861Smckusick 	if(entname)
28222861Smckusick 		fprintf(diagfile, "   %s", varstr(XL, entname->varname) );
28322861Smckusick 	fprintf(diagfile, ":\n");
28422861Smckusick 	}
28522861Smckusick 
28622861Smckusick if( entname->vclass == CLPARAM ) {
28722861Smckusick 	errstr("entry name %s used in 'parameter' statement",
28822861Smckusick 		varstr(XL, entname->varname) );
28922861Smckusick 	return;
29022861Smckusick 	}
29122861Smckusick if( ((type == TYSUBR) || (class == CLENTRY && proctype == TYSUBR))
29222861Smckusick 	&& (entname->vtype != TYUNKNOWN && entname->vtype != TYSUBR) ) {
29322861Smckusick 	errstr("subroutine entry %s previously declared",
29422861Smckusick 		varstr(XL, entname->varname) );
29522861Smckusick 	return;
29622861Smckusick 	}
29722861Smckusick if(  (entname->vstg != STGEXT && entname->vstg != STGUNKNOWN)
29822861Smckusick 	||  (entname->vdim != NULL) ) {
29922861Smckusick 	errstr("subroutine or function entry %s previously declared",
30022861Smckusick 		varstr(XL, entname->varname) );
30122861Smckusick 	return;
30222861Smckusick 	}
30322861Smckusick 
30422861Smckusick if( (class == CLPROC || class == CLENTRY) && type != TYSUBR )
30522861Smckusick 	/* arrange to save function return values */
30622861Smckusick 	entname->vsave = YES;
30722861Smckusick 
30822861Smckusick entry = newentry( entname );
30922861Smckusick 
31022861Smckusick if(class != CLENTRY)
31122861Smckusick 	puthead( varstr(XL, procname = entry->extname), class);
31222861Smckusick q = mkname(VL, nounder(XL,entry->extname) );
31322861Smckusick 
31422861Smckusick if( (type = lengtype(type, (int) length)) != TYCHAR)
31522861Smckusick 	length = 0;
31622861Smckusick if(class == CLPROC)
31722861Smckusick 	{
31822861Smckusick 	procclass = CLPROC;
31922861Smckusick 	proctype = type;
32022861Smckusick 	procleng = length;
32122861Smckusick 
32222861Smckusick 	retlabel = newlabel();
32322861Smckusick 	if(type == TYSUBR)
32422861Smckusick 		ret0label = newlabel();
32522861Smckusick 	}
32622861Smckusick 
32722861Smckusick p = ALLOC(Entrypoint);
32822861Smckusick if(entries)	/* put new block at end of entries list */
32922861Smckusick 	{
33022861Smckusick 	for(ep = entries; ep->entnextp; ep = ep->entnextp)
33122861Smckusick 		;
33222861Smckusick 	ep->entnextp = p;
33322861Smckusick 	}
33422861Smckusick else
33522861Smckusick 	entries = p;
33622861Smckusick 
33722861Smckusick p->entryname = entry;
33822861Smckusick p->arglist = args;
33922861Smckusick p->entrylabel = newlabel();
34022861Smckusick p->enamep = q;
34122861Smckusick 
34222861Smckusick if(class == CLENTRY)
34322861Smckusick 	{
34422861Smckusick 	class = CLPROC;
34522861Smckusick 	if(proctype == TYSUBR)
34622861Smckusick 		type = TYSUBR;
34722861Smckusick 	}
34822861Smckusick 
34922861Smckusick q->vclass = class;
35022861Smckusick q->vprocclass = PTHISPROC;
35122861Smckusick settype(q, type, (int) length);
35222861Smckusick /* hold all initial entry points till end of declarations */
35322861Smckusick if(parstate >= INDATA) {
35422861Smckusick 	doentry(p);
35522861Smckusick }
35622861Smckusick #ifdef SDB
35722861Smckusick 	if(sdbflag)
35822861Smckusick 	{ /* may need to preserve CLENTRY here */
35922861Smckusick 	entrystab(p,class);
36022861Smckusick 	}
36122861Smckusick #endif
36222861Smckusick }
36322861Smckusick 
36422861Smckusick /* generate epilogs */
36522861Smckusick 
36622861Smckusick LOCAL epicode()
36722861Smckusick {
36822861Smckusick register int i;
36922861Smckusick 
37022861Smckusick if(procclass==CLPROC)
37122861Smckusick 	{
37222861Smckusick 	if(proctype==TYSUBR)
37322861Smckusick 		{
37422861Smckusick 		putlabel(ret0label);
37522861Smckusick 		if(substars)
37622861Smckusick 			putforce(TYINT, ICON(0) );
37722861Smckusick 		putlabel(retlabel);
37822861Smckusick 		goret(TYSUBR);
37922861Smckusick 		}
38022861Smckusick 	else	{
38122861Smckusick 		putlabel(retlabel);
38222861Smckusick 		if(multitype)
38322861Smckusick 			{
38422861Smckusick 			typeaddr = autovar(1, TYADDR, PNULL);
38522861Smckusick 			putbranch( cpexpr(typeaddr) );
38622861Smckusick 			for(i = 0; i < NTYPES ; ++i)
38722861Smckusick 				if(rtvlabel[i] != 0)
38822861Smckusick 					{
38922861Smckusick 					putlabel(rtvlabel[i]);
39022861Smckusick 					retval(i);
39122861Smckusick 					}
39222861Smckusick 			}
39322861Smckusick 		else
39422861Smckusick 			retval(proctype);
39522861Smckusick 		}
39622861Smckusick 	}
39722861Smckusick 
39822861Smckusick else if(procclass != CLBLOCK)
39922861Smckusick 	{
40022861Smckusick 	putlabel(retlabel);
40122861Smckusick 	goret(TYSUBR);
40222861Smckusick 	}
40322861Smckusick }
40422861Smckusick 
40522861Smckusick 
40622861Smckusick /* generate code to return value of type  t */
40722861Smckusick 
40822861Smckusick LOCAL retval(t)
40922861Smckusick register int t;
41022861Smckusick {
41122861Smckusick register Addrp p;
41222861Smckusick 
41322861Smckusick switch(t)
41422861Smckusick 	{
41522861Smckusick 	case TYCHAR:
41622861Smckusick 	case TYCOMPLEX:
41722861Smckusick 	case TYDCOMPLEX:
41822861Smckusick 		break;
41922861Smckusick 
42022861Smckusick 	case TYLOGICAL:
42122861Smckusick 		t = tylogical;
42222861Smckusick 	case TYADDR:
42322861Smckusick 	case TYSHORT:
42422861Smckusick 	case TYLONG:
42522861Smckusick 		p = (Addrp) cpexpr(retslot);
42622861Smckusick 		p->vtype = t;
42722861Smckusick 		putforce(t, p);
42822861Smckusick 		break;
42922861Smckusick 
43022861Smckusick 	case TYREAL:
43122861Smckusick 	case TYDREAL:
43222861Smckusick 		p = (Addrp) cpexpr(retslot);
43322861Smckusick 		p->vtype = t;
43422861Smckusick 		putforce(t, p);
43522861Smckusick 		break;
43622861Smckusick 
43723477Smckusick 	case TYERROR:
43823477Smckusick 		return;		/* someone else already complained */
43923477Smckusick 
44022861Smckusick 	default:
44122861Smckusick 		badtype("retval", t);
44222861Smckusick 	}
44322861Smckusick goret(t);
44422861Smckusick }
44522861Smckusick 
44622861Smckusick 
44722861Smckusick /* Allocate extra argument array if needed. Generate prologs. */
44822861Smckusick 
44922861Smckusick LOCAL procode()
45022861Smckusick {
45122861Smckusick register struct Entrypoint *p;
45222861Smckusick Addrp argvec;
45322861Smckusick 
45422861Smckusick #if TARGET==GCOS
45522861Smckusick 	argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
45622861Smckusick #else
45722861Smckusick 	if(lastargslot>0 && nentry>1)
45822861Smckusick #if TARGET == VAX
45922861Smckusick 		argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
46022861Smckusick #else
46122861Smckusick 		argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
46222861Smckusick #endif
46322861Smckusick 	else
46422861Smckusick 		argvec = NULL;
46522861Smckusick #endif
46622861Smckusick 
46722861Smckusick 
46822861Smckusick #if TARGET == PDP11
46922861Smckusick 	/* for the optimizer */
47022861Smckusick 	if(fudgelabel)
47122861Smckusick 		putlabel(fudgelabel);
47222861Smckusick #endif
47322861Smckusick 
47422861Smckusick for(p = entries ; p ; p = p->entnextp)
47522861Smckusick 	prolog(p, argvec);
47622861Smckusick 
47722861Smckusick #if FAMILY == PCC
47822861Smckusick 	putrbrack(procno);
47922861Smckusick #endif
48022861Smckusick 
48122861Smckusick prendproc();
48222861Smckusick }
48322861Smckusick 
48422861Smckusick 
48522861Smckusick /*
48622861Smckusick    manipulate argument lists (allocate argument slot positions)
48722861Smckusick  * keep track of return types and labels
48822861Smckusick  */
48922861Smckusick 
49022861Smckusick LOCAL doentry(ep)
49122861Smckusick struct Entrypoint *ep;
49222861Smckusick {
49322861Smckusick register int type;
49422861Smckusick register Namep np;
49522861Smckusick chainp p;
49622861Smckusick register Namep q;
49722861Smckusick Addrp mkarg();
49822861Smckusick 
49922861Smckusick ++nentry;
50022861Smckusick if(procclass == CLMAIN)
50122861Smckusick 	{
50222861Smckusick 	if (optimflag)
50322861Smckusick 		optbuff (SKLABEL, 0, ep->entrylabel, 0);
50422861Smckusick 	else
50522861Smckusick 		putlabel(ep->entrylabel);
50622861Smckusick 	return;
50722861Smckusick 	}
50822861Smckusick else if(procclass == CLBLOCK)
50922861Smckusick 	return;
51022861Smckusick 
51122861Smckusick impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
51222861Smckusick type = np->vtype;
51322861Smckusick if(proctype == TYUNKNOWN)
51422861Smckusick 	if( (proctype = type) == TYCHAR)
51522861Smckusick 		procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
51622861Smckusick 
51722861Smckusick if(proctype == TYCHAR)
51822861Smckusick 	{
51922861Smckusick 	if(type != TYCHAR)
52022861Smckusick 		err("noncharacter entry of character function");
52122861Smckusick 	else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
52222861Smckusick 		err("mismatched character entry lengths");
52322861Smckusick 	}
52422861Smckusick else if(type == TYCHAR)
52522861Smckusick 	err("character entry of noncharacter function");
52622861Smckusick else if(type != proctype)
52722861Smckusick 	multitype = YES;
52822861Smckusick if(rtvlabel[type] == 0)
52922861Smckusick 	rtvlabel[type] = newlabel();
53022861Smckusick ep->typelabel = rtvlabel[type];
53122861Smckusick 
53222861Smckusick if(type == TYCHAR)
53322861Smckusick 	{
53422861Smckusick 	if(chslot < 0)
53522861Smckusick 		{
53622861Smckusick 		chslot = nextarg(TYADDR);
53722861Smckusick 		chlgslot = nextarg(TYLENG);
53822861Smckusick 		}
53922861Smckusick 	np->vstg = STGARG;
54022861Smckusick 	np->vardesc.varno = chslot;
54122861Smckusick 	if(procleng < 0)
54222861Smckusick 		np->vleng = (expptr) mkarg(TYLENG, chlgslot);
54322861Smckusick 	}
54422861Smckusick else if( ISCOMPLEX(type) )
54522861Smckusick 	{
54622861Smckusick 	np->vstg = STGARG;
54722861Smckusick 	if(cxslot < 0)
54822861Smckusick 		cxslot = nextarg(TYADDR);
54922861Smckusick 	np->vardesc.varno = cxslot;
55022861Smckusick 	}
55122861Smckusick else if(type != TYSUBR)
55222861Smckusick 	{
55322861Smckusick 	if(retslot == NULL)
55422861Smckusick 		retslot = autovar(1, TYDREAL, PNULL);
55522861Smckusick 	np->vstg = STGAUTO;
55622861Smckusick 	np->voffset = retslot->memoffset->constblock.const.ci;
55722861Smckusick 	}
55822861Smckusick 
55922861Smckusick for(p = ep->arglist ; p ; p = p->nextp)
56022861Smckusick 	if(! (( q = (Namep) (p->datap) )->vdcldone) )
56122861Smckusick 		q->vardesc.varno = nextarg(TYADDR);
56222861Smckusick 
56322861Smckusick for(p = ep->arglist ; p ; p = p->nextp)
56422861Smckusick 	if(! (( q = (Namep) (p->datap) )->vdcldone) )
56522861Smckusick 		{
56622861Smckusick 		impldcl(q);
56722861Smckusick 		q->vdcldone = YES;
56822861Smckusick 		if(q->vtype == TYCHAR)
56922861Smckusick 			{
57022861Smckusick 			if(q->vleng == NULL)	/* character*(*) */
57122861Smckusick 				q->vleng = (expptr)
57222861Smckusick 						mkarg(TYLENG, nextarg(TYLENG) );
57322861Smckusick 			else if(nentry == 1)
57422861Smckusick 				nextarg(TYLENG);
57522861Smckusick 			}
57622861Smckusick 		else if(q->vclass==CLPROC && nentry==1)
57722861Smckusick 			nextarg(TYLENG) ;
57822861Smckusick #ifdef SDB
57922861Smckusick 		if(sdbflag) {
58022861Smckusick 			namestab(q);
58122861Smckusick 		}
58222861Smckusick #endif
58322861Smckusick 		}
58422861Smckusick 
58522861Smckusick if (optimflag)
58622861Smckusick 	optbuff (SKLABEL, 0, ep->entrylabel, 0);
58722861Smckusick else
58822861Smckusick 	putlabel(ep->entrylabel);
58922861Smckusick }
59022861Smckusick 
59122861Smckusick 
59222861Smckusick 
59322861Smckusick LOCAL nextarg(type)
59422861Smckusick int type;
59522861Smckusick {
59622861Smckusick int k;
59722861Smckusick k = lastargslot;
59822861Smckusick lastargslot += typesize[type];
59922861Smckusick return(k);
60022861Smckusick }
60122861Smckusick 
60222861Smckusick /* generate variable references */
60322861Smckusick 
60422861Smckusick LOCAL dobss()
60522861Smckusick {
60622861Smckusick register struct Hashentry *p;
60722861Smckusick register Namep q;
60822861Smckusick register int i;
60922861Smckusick int align;
61022861Smckusick ftnint leng, iarrl;
61122861Smckusick char *memname();
61222861Smckusick int qstg, qclass, qtype;
61322861Smckusick 
61422861Smckusick pruse(asmfile, USEBSS);
61522861Smckusick varsizes = NULL;
61622861Smckusick 
61722861Smckusick for(p = hashtab ; p<lasthash ; ++p)
61822861Smckusick     if(q = p->varp)
61922861Smckusick 	{
62022861Smckusick 	qstg = q->vstg;
62122861Smckusick 	qtype = q->vtype;
62222861Smckusick 	qclass = q->vclass;
62322861Smckusick 
62422861Smckusick 	if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
62522861Smckusick 	    (qclass==CLVAR && qstg==STGUNKNOWN) )
62622861Smckusick 		warn1("local variable %s never used", varstr(VL,q->varname) );
62722861Smckusick 	else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
62822861Smckusick 		mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
62922861Smckusick 
63022861Smckusick 	if (qclass == CLVAR && qstg == STGBSS)
63122861Smckusick 	  {
63222861Smckusick 	    if (SMALLVAR(q->varsize))
63322861Smckusick 	      {
63422861Smckusick 		enlist(q->varsize, q, NULL);
63522861Smckusick 		q->inlcomm = NO;
63622861Smckusick 	      }
63722861Smckusick 	    else
63822861Smckusick 	      {
63922861Smckusick 		if (q->init == NO)
64022861Smckusick 		  {
64122861Smckusick 		    preven(ALIDOUBLE);
64222861Smckusick 		    prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
64322861Smckusick 		    q->inlcomm = YES;
64422861Smckusick 		  }
64522861Smckusick 		else
64622861Smckusick 		  prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
64722861Smckusick 			    q->vtype, q->initoffset, &(q->inlcomm));
64822861Smckusick 	      }
64922861Smckusick 	  }
65022861Smckusick 	else if(qclass==CLVAR && qstg!=STGARG)
65122861Smckusick 		{
65222861Smckusick 		if(q->vdim && !ISICON(q->vdim->nelt) )
65322861Smckusick 			dclerr("adjustable dimension on non-argument", q);
65422861Smckusick 		if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
65522861Smckusick 			dclerr("adjustable leng on nonargument", q);
65622861Smckusick 		}
65722861Smckusick 
65822861Smckusick 	chkdim(q);
65922861Smckusick 	}
66022861Smckusick 
66122861Smckusick for (i = 0 ; i < nequiv ; ++i)
66222861Smckusick   if ( (leng = eqvclass[i].eqvleng) != 0 )
66322861Smckusick     {
66422861Smckusick       if (SMALLVAR(leng))
66522861Smckusick 	enlist(leng, NULL, eqvclass + i);
66622861Smckusick       else if (eqvclass[i].init == NO)
66722861Smckusick 	{
66822861Smckusick 	  preven(ALIDOUBLE);
66922861Smckusick 	  prlocvar(memname(STGEQUIV, i), leng);
67022861Smckusick 	  eqvclass[i].inlcomm = YES;
67122861Smckusick 	}
67222861Smckusick       else
67322861Smckusick 	prlocdata(memname(STGEQUIV, i), leng, TYDREAL,
67422861Smckusick 		  eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
67522861Smckusick     }
67622861Smckusick 
67722861Smckusick   outlocvars();
67822861Smckusick #ifdef SDB
67922861Smckusick     if(sdbflag) {
68022861Smckusick       for(p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
68122861Smckusick 	  qstg = q->vstg;
68222861Smckusick 	  qclass = q->vclass;
68322861Smckusick           if( ONEOF(qclass, M(CLVAR))) {
68422861Smckusick 	     if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) ) namestab(q);
68522861Smckusick 	  }
68622861Smckusick       }
68722861Smckusick     }
68822861Smckusick #endif
68922861Smckusick 
69022861Smckusick   close(vdatafile);
69122861Smckusick   close(vchkfile);
69222861Smckusick   unlink(vdatafname);
69322861Smckusick   unlink(vchkfname);
69422861Smckusick   vdatahwm = 0;
69522861Smckusick }
69622861Smckusick 
69722861Smckusick 
69822861Smckusick 
69922861Smckusick donmlist()
70022861Smckusick {
70122861Smckusick register struct Hashentry *p;
70222861Smckusick register Namep q;
70322861Smckusick 
70422861Smckusick pruse(asmfile, USEINIT);
70522861Smckusick 
70622861Smckusick for(p=hashtab; p<lasthash; ++p)
70722861Smckusick 	if( (q = p->varp) && q->vclass==CLNAMELIST)
70822861Smckusick 		namelist(q);
70922861Smckusick }
71022861Smckusick 
71122861Smckusick 
71222861Smckusick doext()
71322861Smckusick {
71422861Smckusick struct Extsym *p;
71522861Smckusick 
71622861Smckusick for(p = extsymtab ; p<nextext ; ++p)
71722861Smckusick 	prext(p);
71822861Smckusick }
71922861Smckusick 
72022861Smckusick 
72122861Smckusick 
72222861Smckusick 
72322861Smckusick ftnint iarrlen(q)
72422861Smckusick register Namep q;
72522861Smckusick {
72622861Smckusick ftnint leng;
72722861Smckusick 
72822861Smckusick leng = typesize[q->vtype];
72922861Smckusick if(leng <= 0)
73022861Smckusick 	return(-1);
73122861Smckusick if(q->vdim)
73222861Smckusick 	if( ISICON(q->vdim->nelt) )
73322861Smckusick 		leng *= q->vdim->nelt->constblock.const.ci;
73422861Smckusick 	else	return(-1);
73522861Smckusick if(q->vleng)
73622861Smckusick 	if( ISICON(q->vleng) )
73722861Smckusick 		leng *= q->vleng->constblock.const.ci;
73822861Smckusick 	else 	return(-1);
73922861Smckusick return(leng);
74022861Smckusick }
74122861Smckusick 
74222861Smckusick /* This routine creates a static block representing the namelist.
74322861Smckusick    An equivalent declaration of the structure produced is:
74422861Smckusick 	struct namelist
74522861Smckusick 		{
74622861Smckusick 		char namelistname[16];
74722861Smckusick 		struct namelistentry
74822861Smckusick 			{
74924484Sdonn 			char varname[16]; #  16 plus null padding -> 20
75022861Smckusick 			char *varaddr;
75124484Sdonn 			short int type;
75224484Sdonn 			short int len;	# length of type
75322861Smckusick 			struct dimensions *dimp; # null means scalar
75422861Smckusick 			} names[];
75522861Smckusick 		};
75622861Smckusick 
75722861Smckusick 	struct dimensions
75822861Smckusick 		{
75922861Smckusick 		int numberofdimensions;
76022861Smckusick 		int numberofelements
76122861Smckusick 		int baseoffset;
76222861Smckusick 		int span[numberofdimensions];
76322861Smckusick 		};
76422861Smckusick    where the namelistentry list terminates with a null varname
76522861Smckusick    If dimp is not null, then the corner element of the array is at
76622861Smckusick    varaddr.  However,  the element with subscripts (i1,...,in) is at
76722861Smckusick    varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
76822861Smckusick */
76922861Smckusick 
77022861Smckusick namelist(np)
77122861Smckusick Namep np;
77222861Smckusick {
77322861Smckusick register chainp q;
77422861Smckusick register Namep v;
77522861Smckusick register struct Dimblock *dp;
77622861Smckusick char *memname();
77722861Smckusick int type, dimno, dimoffset;
77822861Smckusick flag bad;
77922861Smckusick 
78022861Smckusick 
78122861Smckusick preven(ALILONG);
78222861Smckusick fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
78322861Smckusick putstr(asmfile, varstr(VL, np->varname), 16);
78422861Smckusick dimno = ++lastvarno;
78522861Smckusick dimoffset = 0;
78622861Smckusick bad = NO;
78722861Smckusick 
78822861Smckusick for(q = np->varxptr.namelist ; q ; q = q->nextp)
78922861Smckusick 	{
79022861Smckusick 	vardcl( v = (Namep) (q->datap) );
79122861Smckusick 	type = v->vtype;
79222861Smckusick 	if( ONEOF(v->vstg, MSKSTATIC) )
79322861Smckusick 		{
79422861Smckusick 		preven(ALILONG);
79522861Smckusick 		putstr(asmfile, varstr(VL,v->varname), 16);
79622861Smckusick 		praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
79724484Sdonn 		prconi(asmfile, TYSHORT, type );
79824484Sdonn 		prconi(asmfile, TYSHORT,
79922861Smckusick 			type==TYCHAR ?
80024484Sdonn 			    (v->vleng->constblock.const.ci) :
80124484Sdonn 					(ftnint) typesize[type]);
80222861Smckusick 		if(v->vdim)
80322861Smckusick 			{
80422861Smckusick 			praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
80524484Sdonn 			dimoffset += (3 + v->vdim->ndim) * SZINT;
80622861Smckusick 			}
80722861Smckusick 		else
80822861Smckusick 			praddr(asmfile, STGNULL,0,(ftnint) 0);
80922861Smckusick 		}
81022861Smckusick 	else
81122861Smckusick 		{
81222861Smckusick 		dclerr("may not appear in namelist", v);
81322861Smckusick 		bad = YES;
81422861Smckusick 		}
81522861Smckusick 	}
81622861Smckusick 
81722861Smckusick if(bad)
81822861Smckusick 	return;
81922861Smckusick 
82022861Smckusick putstr(asmfile, "", 16);
82122861Smckusick 
82222861Smckusick if(dimoffset > 0)
82322861Smckusick 	{
82422861Smckusick 	fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
82522861Smckusick 	for(q = np->varxptr.namelist ; q ; q = q->nextp)
82622861Smckusick 		if(dp = q->datap->nameblock.vdim)
82722861Smckusick 			{
82822861Smckusick 			int i;
82922861Smckusick 			prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
83022861Smckusick 			prconi(asmfile, TYINT,
83122861Smckusick 				(ftnint) (dp->nelt->constblock.const.ci) );
83222861Smckusick 			prconi(asmfile, TYINT,
83322861Smckusick 				(ftnint) (dp->baseoffset->constblock.const.ci));
83422861Smckusick 			for(i=0; i<dp->ndim ; ++i)
83522861Smckusick 				prconi(asmfile, TYINT,
83622861Smckusick 					dp->dims[i].dimsize->constblock.const.ci);
83722861Smckusick 			}
83822861Smckusick 	}
83922861Smckusick 
84022861Smckusick }
84122861Smckusick 
84222861Smckusick LOCAL docommon()
84322861Smckusick {
84422861Smckusick register struct Extsym *p;
84522861Smckusick register chainp q;
84622861Smckusick struct Dimblock *t;
84722861Smckusick expptr neltp;
84822861Smckusick register Namep v;
84922861Smckusick ftnint size;
85022861Smckusick int type;
85122861Smckusick 
85222861Smckusick for(p = extsymtab ; p<nextext ; ++p)
85322861Smckusick 	if(p->extstg==STGCOMMON)
85422861Smckusick 		{
85522861Smckusick #ifdef SDB
85622861Smckusick 		if(sdbflag)
85722861Smckusick 			prstab(varstr(XL,p->extname), N_BCOMM, 0, 0);
85822861Smckusick #endif
85922861Smckusick 		for(q = p->extp ; q ; q = q->nextp)
86022861Smckusick 			{
86122861Smckusick 			v = (Namep) (q->datap);
86222861Smckusick 			if(v->vdcldone == NO)
86322861Smckusick 				vardcl(v);
86422861Smckusick 			type = v->vtype;
86522861Smckusick 			if(p->extleng % typealign[type] != 0)
86622861Smckusick 				{
86722861Smckusick 				dclerr("common alignment", v);
86822861Smckusick 				p->extleng = roundup(p->extleng, typealign[type]);
86922861Smckusick 				}
87022861Smckusick 			v->voffset = p->extleng;
87122861Smckusick 			v->vardesc.varno = p - extsymtab;
87222861Smckusick 			if(type == TYCHAR)
87322861Smckusick 				size = v->vleng->constblock.const.ci;
87422861Smckusick 			else	size = typesize[type];
87522861Smckusick 			if(t = v->vdim)
87622861Smckusick 				if( (neltp = t->nelt) && ISCONST(neltp) )
87722861Smckusick 					size *= neltp->constblock.const.ci;
87822861Smckusick 				else
87922861Smckusick 					dclerr("adjustable array in common", v);
88022861Smckusick 			p->extleng += size;
88122861Smckusick #ifdef SDB
88222861Smckusick 			if(sdbflag)
88322861Smckusick 				{
88422861Smckusick 				namestab(v);
88522861Smckusick 				}
88622861Smckusick #endif
88722861Smckusick 			}
88822861Smckusick 
88922861Smckusick 		frchain( &(p->extp) );
89022861Smckusick #ifdef SDB
89122861Smckusick 		if(sdbflag)
89222861Smckusick 			prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
89322861Smckusick #endif
89422861Smckusick 		}
89522861Smckusick }
89622861Smckusick 
89722861Smckusick 
89822861Smckusick 
89922861Smckusick 
90022861Smckusick 
90122861Smckusick LOCAL docomleng()
90222861Smckusick {
90322861Smckusick register struct Extsym *p;
90422861Smckusick 
90522861Smckusick for(p = extsymtab ; p < nextext ; ++p)
90622861Smckusick 	if(p->extstg == STGCOMMON)
90722861Smckusick 		{
90822861Smckusick 		if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
90922861Smckusick 		    && !eqn(XL,"_BLNK__ ",p->extname) )
91022861Smckusick 			warn1("incompatible lengths for common block %s",
91122861Smckusick 				nounder(XL, p->extname) );
91222861Smckusick 		if(p->maxleng < p->extleng)
91322861Smckusick 			p->maxleng = p->extleng;
91422861Smckusick 		p->extleng = 0;
91522861Smckusick 	}
91622861Smckusick }
91722861Smckusick 
91822861Smckusick 
91922861Smckusick 
92022861Smckusick 
92122861Smckusick /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
92222861Smckusick 
92322861Smckusick /*  frees a temporary block  */
92422861Smckusick 
92522861Smckusick frtemp(p)
92622861Smckusick Tempp p;
92722861Smckusick {
92822861Smckusick Addrp t;
92922861Smckusick 
93022861Smckusick if (optimflag)
93122861Smckusick 	{
93222861Smckusick 	if (p->tag != TTEMP)
93322861Smckusick 		badtag ("frtemp",p->tag);
93422861Smckusick 	t = p->memalloc;
93522861Smckusick 	}
93622861Smckusick else
93722861Smckusick 	t = (Addrp) p;
93822861Smckusick 
93922861Smckusick /* restore clobbered character string lengths */
94022861Smckusick if(t->vtype==TYCHAR && t->varleng!=0)
94122861Smckusick 	{
94222861Smckusick 	frexpr(t->vleng);
94322861Smckusick 	t->vleng = ICON(t->varleng);
94422861Smckusick 	}
94522861Smckusick 
94622861Smckusick /* put block on chain of temps to be reclaimed */
94722861Smckusick holdtemps = mkchain(t, holdtemps);
94822861Smckusick }
94922861Smckusick 
95022861Smckusick 
95122861Smckusick 
95222861Smckusick /* allocate an automatic variable slot */
95322861Smckusick 
95422861Smckusick Addrp autovar(nelt, t, lengp)
95522861Smckusick register int nelt, t;
95622861Smckusick expptr lengp;
95722861Smckusick {
95822861Smckusick ftnint leng;
95922861Smckusick register Addrp q;
96022861Smckusick 
96122861Smckusick if(lengp)
96222861Smckusick 	if( ISICON(lengp) )
96322861Smckusick 		leng = lengp->constblock.const.ci;
96422861Smckusick 	else	{
96522861Smckusick 		fatal("automatic variable of nonconstant length");
96622861Smckusick 		}
96722861Smckusick else
96822861Smckusick 	leng = typesize[t];
96922861Smckusick autoleng = roundup( autoleng, typealign[t]);
97022861Smckusick 
97122861Smckusick q = ALLOC(Addrblock);
97222861Smckusick q->tag = TADDR;
97322861Smckusick q->vtype = t;
97422861Smckusick if(lengp)
97522861Smckusick 	{
97622861Smckusick 	q->vleng = ICON(leng);
97722861Smckusick 	q->varleng = leng;
97822861Smckusick 	}
97922861Smckusick q->vstg = STGAUTO;
98022861Smckusick q->memno = newlabel();
98122861Smckusick q->ntempelt = nelt;
98222861Smckusick #if TARGET==PDP11 || TARGET==VAX
98322861Smckusick 	/* stack grows downward */
98422861Smckusick 	autoleng += nelt*leng;
98522861Smckusick 	q->memoffset = ICON( - autoleng );
98622861Smckusick #else
98722861Smckusick 	q->memoffset = ICON( autoleng );
98822861Smckusick 	autoleng += nelt*leng;
98922861Smckusick #endif
99022861Smckusick 
99122861Smckusick return(q);
99222861Smckusick }
99322861Smckusick 
99422861Smckusick 
99522861Smckusick 
99622861Smckusick /*
99722861Smckusick  *  create a temporary block (TTEMP) when optimizing,
99822861Smckusick  *  an ordinary TADDR block when not optimizing
99922861Smckusick  */
100022861Smckusick 
100122861Smckusick Tempp mktmpn(nelt, type, lengp)
100222861Smckusick int nelt;
100322861Smckusick register int type;
100422861Smckusick expptr lengp;
100522861Smckusick {
100622861Smckusick ftnint leng;
100722861Smckusick chainp p, oldp;
100822861Smckusick register Tempp q;
100922861Smckusick Addrp altemp;
101022861Smckusick 
101122861Smckusick if (! optimflag)
101222861Smckusick 	return ( (Tempp) mkaltmpn(nelt,type,lengp) );
101322861Smckusick if(type==TYUNKNOWN || type==TYERROR)
101422861Smckusick 	badtype("mktmpn", type);
101522861Smckusick 
101622861Smckusick if(type==TYCHAR)
101722861Smckusick 	if( ISICON(lengp) )
101822861Smckusick 		leng = lengp->constblock.const.ci;
101922861Smckusick 	else	{
102022861Smckusick 		err("adjustable length");
102122861Smckusick 		return( (Tempp) errnode() );
102222861Smckusick 		}
102322861Smckusick else
102422861Smckusick 	leng = typesize[type];
102522861Smckusick 
102622861Smckusick q = ALLOC(Tempblock);
102722861Smckusick q->tag = TTEMP;
102822861Smckusick q->vtype = type;
102922861Smckusick if(type == TYCHAR)
103022861Smckusick 	{
103122861Smckusick 	q->vleng = ICON(leng);
103222861Smckusick 	q->varleng = leng;
103322861Smckusick 	}
103422861Smckusick 
103522861Smckusick altemp = ALLOC(Addrblock);
103622861Smckusick altemp->tag = TADDR;
103722861Smckusick altemp->vstg = STGUNKNOWN;
103822861Smckusick q->memalloc = altemp;
103922861Smckusick 
104022861Smckusick q->ntempelt = nelt;
104122861Smckusick q->istemp = YES;
104222861Smckusick return(q);
104322861Smckusick }
104422861Smckusick 
104522861Smckusick 
104622861Smckusick 
104722861Smckusick Addrp mktemp(type, lengp)
104822861Smckusick int type;
104922861Smckusick expptr lengp;
105022861Smckusick {
105122861Smckusick return( (Addrp) mktmpn(1,type,lengp) );
105222861Smckusick }
105322861Smckusick 
105422861Smckusick 
105522861Smckusick 
105622861Smckusick /*  allocate a temporary location for the given temporary block;
105722861Smckusick     if already allocated, return its location  */
105822861Smckusick 
105922861Smckusick Addrp altmpn(tp)
106022861Smckusick Tempp tp;
106122861Smckusick 
106222861Smckusick {
106322861Smckusick Addrp t, q;
106422861Smckusick 
106522861Smckusick if (tp->tag != TTEMP)
106622861Smckusick 	badtag ("altmpn",tp->tag);
106722861Smckusick 
106822861Smckusick t = tp->memalloc;
106922861Smckusick if (t->vstg != STGUNKNOWN)
107022861Smckusick 	{
107122861Smckusick 	if (tp->vtype == TYCHAR)
107222861Smckusick 		{
107322861Smckusick 		/*
107422861Smckusick 		 * Unformatted I/O parameters are treated like character
107522861Smckusick 		 *	strings (sigh) -- propagate type and length.
107622861Smckusick 		 */
107722861Smckusick 		t = (Addrp) cpexpr(t);
107822861Smckusick 		t->vtype = tp->vtype;
107922861Smckusick 		t->vleng = tp->vleng;
108022861Smckusick 		t->varleng = tp->varleng;
108122861Smckusick 		}
108222861Smckusick 	return (t);
108322861Smckusick 	}
108422861Smckusick 
108522861Smckusick q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
108622861Smckusick cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
108722861Smckusick free ( (charptr) q);
108822861Smckusick return(t);
108922861Smckusick }
109022861Smckusick 
109122861Smckusick 
109222861Smckusick 
109322861Smckusick /*  create and allocate space immediately for a temporary  */
109422861Smckusick 
109522861Smckusick Addrp mkaltemp(type,lengp)
109622861Smckusick int type;
109722861Smckusick expptr lengp;
109822861Smckusick {
109922861Smckusick return (mkaltmpn(1,type,lengp));
110022861Smckusick }
110122861Smckusick 
110222861Smckusick 
110322861Smckusick 
110422861Smckusick Addrp mkaltmpn(nelt,type,lengp)
110522861Smckusick int nelt;
110622861Smckusick register int type;
110722861Smckusick expptr lengp;
110822861Smckusick {
110922861Smckusick ftnint leng;
111022861Smckusick chainp p, oldp;
111122861Smckusick register Addrp q;
111222861Smckusick 
111322861Smckusick if(type==TYUNKNOWN || type==TYERROR)
111422861Smckusick 	badtype("mkaltmpn", type);
111522861Smckusick 
111622861Smckusick if(type==TYCHAR)
111722861Smckusick 	if( ISICON(lengp) )
111822861Smckusick 		leng = lengp->constblock.const.ci;
111922861Smckusick 	else	{
112022861Smckusick 		err("adjustable length");
112122861Smckusick 		return( (Addrp) errnode() );
112222861Smckusick 		}
112322861Smckusick 
112422861Smckusick /*
112522861Smckusick  * if a temporary of appropriate shape is on the templist,
112622861Smckusick  * remove it from the list and return it
112722861Smckusick  */
112822861Smckusick 
112922861Smckusick #ifdef notdef
113022861Smckusick /*
113122861Smckusick  * This code is broken until SKFRTEMP slots can be processed in putopt()
113222861Smckusick  *	instead of in optimize() -- all kinds of things in putpcc.c can
113322861Smckusick  *	bomb because of this.  Sigh.
113422861Smckusick  */
113522861Smckusick for(oldp=CHNULL, p=templist  ;  p  ;  oldp=p, p=p->nextp)
113622861Smckusick 	{
113722861Smckusick 	q = (Addrp) (p->datap);
113822861Smckusick 	if(q->vtype==type && q->ntempelt==nelt &&
113922861Smckusick 	    (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
114022861Smckusick 		{
114122861Smckusick 		if(oldp)
114222861Smckusick 			oldp->nextp = p->nextp;
114322861Smckusick 		else
114422861Smckusick 			templist = p->nextp;
114522861Smckusick 		free( (charptr) p);
114622861Smckusick 
114722861Smckusick 		if (debugflag[14])
114822861Smckusick 			fprintf(diagfile,"mkaltmpn reusing offset %d\n",
114922861Smckusick 				q->memoffset->constblock.const.ci);
115022861Smckusick 		return(q);
115122861Smckusick 		}
115222861Smckusick 	}
115322861Smckusick #endif notdef
115422861Smckusick q = autovar(nelt, type, lengp);
115522861Smckusick q->istemp = YES;
115622861Smckusick 
115722861Smckusick if (debugflag[14])
115822861Smckusick 	fprintf(diagfile,"mkaltmpn new offset %d\n",
115922861Smckusick 		q->memoffset->constblock.const.ci);
116022861Smckusick return(q);
116122861Smckusick }
116222861Smckusick 
116322861Smckusick 
116422861Smckusick 
116522861Smckusick /*  The following routine is a patch which is only needed because the	*/
116622861Smckusick /*  code for processing actual arguments for calls does not allocate	*/
116722861Smckusick /*  the temps it needs before optimization takes place.  A better	*/
116822861Smckusick /*  solution is possible, but I do not have the time to implement it	*/
116922861Smckusick /*  now.								*/
117022861Smckusick /*									*/
117122861Smckusick /*					Robert P. Corbett		*/
117222861Smckusick 
117322861Smckusick Addrp
117422861Smckusick mkargtemp(type, lengp)
117522861Smckusick int type;
117622861Smckusick expptr lengp;
117722861Smckusick {
117822861Smckusick   ftnint leng;
117922861Smckusick   chainp oldp, p;
118022861Smckusick   Addrp q;
118122861Smckusick 
118222861Smckusick   if (type == TYUNKNOWN || type == TYERROR)
118322861Smckusick     badtype("mkargtemp", type);
118422861Smckusick 
118522861Smckusick   if (type == TYCHAR)
118622861Smckusick     {
118722861Smckusick       if (ISICON(lengp))
118822861Smckusick 	leng = lengp->constblock.const.ci;
118922861Smckusick       else
119022861Smckusick 	{
119122861Smckusick 	  err("adjustable length");
119222861Smckusick 	  return ((Addrp) errnode());
119322861Smckusick 	}
119422861Smckusick     }
119522861Smckusick 
119622861Smckusick   oldp = CHNULL;
119722861Smckusick   p = argtemplist;
119822861Smckusick 
119922861Smckusick   while (p)
120022861Smckusick     {
120122861Smckusick       q = (Addrp) (p->datap);
120222861Smckusick       if (q->vtype == type
120322861Smckusick 	  && (type != TYCHAR || q->vleng->constblock.const.ci == leng))
120422861Smckusick 	{
120522861Smckusick 	  if (oldp)
120622861Smckusick 	    oldp->nextp = p->nextp;
120722861Smckusick 	  else
120822861Smckusick 	    argtemplist = p->nextp;
120922861Smckusick 
121022861Smckusick 	  p->nextp = activearglist;
121122861Smckusick 	  activearglist = p;
121222861Smckusick 
121322861Smckusick 	  return ((Addrp) cpexpr(q));
121422861Smckusick 	}
121522861Smckusick 
121622861Smckusick       oldp = p;
121722861Smckusick       p = p->nextp;
121822861Smckusick     }
121922861Smckusick 
122022861Smckusick   q = autovar(1, type, lengp);
122122861Smckusick   activearglist = mkchain(q, activearglist);
122222861Smckusick   return ((Addrp) cpexpr(q));
122322861Smckusick }
122422861Smckusick 
122522861Smckusick /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
122622861Smckusick 
122722861Smckusick struct Extsym *comblock(len, s)
122822861Smckusick register int len;
122922861Smckusick register char *s;
123022861Smckusick {
123122861Smckusick struct Extsym *p;
123222861Smckusick 
123322861Smckusick if(len == 0)
123422861Smckusick 	{
123522861Smckusick 	s = BLANKCOMMON;
123622861Smckusick 	len = strlen(s);
123722861Smckusick 	}
123822861Smckusick p = mkext( varunder(len, s) );
123922861Smckusick if(p->extstg == STGUNKNOWN)
124022861Smckusick 	p->extstg = STGCOMMON;
124122861Smckusick else if(p->extstg != STGCOMMON)
124222861Smckusick 	{
124322861Smckusick 	errstr("%s cannot be a common block name", s);
124422861Smckusick 	return(0);
124522861Smckusick 	}
124622861Smckusick 
124722861Smckusick return( p );
124822861Smckusick }
124922861Smckusick 
125022861Smckusick 
125122861Smckusick incomm(c, v)
125222861Smckusick struct Extsym *c;
125322861Smckusick Namep v;
125422861Smckusick {
125522861Smckusick if(v->vstg != STGUNKNOWN)
125622861Smckusick 	dclerr("incompatible common declaration", v);
125722861Smckusick else
125822861Smckusick 	{
125922861Smckusick 	if(c == (struct Extsym *) 0)
126022861Smckusick 		return;		/* Illegal common block name upstream */
126122861Smckusick 	v->vstg = STGCOMMON;
126222861Smckusick 	c->extp = hookup(c->extp, mkchain(v,CHNULL) );
126322861Smckusick 	}
126422861Smckusick }
126522861Smckusick 
126622861Smckusick 
126722861Smckusick 
126822861Smckusick 
126922861Smckusick settype(v, type, length)
127022861Smckusick register Namep  v;
127122861Smckusick register int type;
127222861Smckusick register int length;
127322861Smckusick {
127422861Smckusick if(type == TYUNKNOWN)
127522861Smckusick 	return;
127622861Smckusick 
127722861Smckusick if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
127822861Smckusick 	{
127922861Smckusick 	v->vtype = TYSUBR;
128022861Smckusick 	frexpr(v->vleng);
128122861Smckusick 	}
128222861Smckusick else if(type < 0)	/* storage class set */
128322861Smckusick 	{
128422861Smckusick 	if(v->vstg == STGUNKNOWN)
128522861Smckusick 		v->vstg = - type;
128622861Smckusick 	else if(v->vstg != -type)
128722861Smckusick 		dclerr("incompatible storage declarations", v);
128822861Smckusick 	}
128922861Smckusick else if(v->vtype == TYUNKNOWN)
129022861Smckusick 	{
129122861Smckusick 	if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
129222861Smckusick 		v->vleng = ICON(length);
129322861Smckusick 	}
129422861Smckusick else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
129522861Smckusick 	dclerr("incompatible type declarations", v);
129622861Smckusick }
129722861Smckusick 
129822861Smckusick 
129922861Smckusick 
130022861Smckusick 
130122861Smckusick 
130222861Smckusick lengtype(type, length)
130322861Smckusick register int type;
130422861Smckusick register int length;
130522861Smckusick {
130622861Smckusick switch(type)
130722861Smckusick 	{
130822861Smckusick 	case TYREAL:
130922861Smckusick 		if(length == 8)
131022861Smckusick 			return(TYDREAL);
131122861Smckusick 		if(length == 4)
131222861Smckusick 			goto ret;
131322861Smckusick 		break;
131422861Smckusick 
131522861Smckusick 	case TYCOMPLEX:
131622861Smckusick 		if(length == 16)
131722861Smckusick 			return(TYDCOMPLEX);
131822861Smckusick 		if(length == 8)
131922861Smckusick 			goto ret;
132022861Smckusick 		break;
132122861Smckusick 
132222861Smckusick 	case TYSHORT:
132322861Smckusick 	case TYDREAL:
132422861Smckusick 	case TYDCOMPLEX:
132522861Smckusick 	case TYCHAR:
132622861Smckusick 	case TYUNKNOWN:
132722861Smckusick 	case TYSUBR:
132822861Smckusick 	case TYERROR:
132922861Smckusick 		goto ret;
133022861Smckusick 
133122861Smckusick 	case TYLOGICAL:
133222861Smckusick 		if(length == typesize[TYLOGICAL])
133322861Smckusick 			goto ret;
133422861Smckusick 		break;
133522861Smckusick 
133622861Smckusick 	case TYLONG:
133722861Smckusick 		if(length == 0)
133822861Smckusick 			return(tyint);
133922861Smckusick 		if(length == 2)
134022861Smckusick 			return(TYSHORT);
134122861Smckusick 		if(length == 4)
134222861Smckusick 			goto ret;
134322861Smckusick 		break;
134422861Smckusick 	default:
134522861Smckusick 		badtype("lengtype", type);
134622861Smckusick 	}
134722861Smckusick 
134822861Smckusick if(length != 0)
134922861Smckusick 	err("incompatible type-length combination");
135022861Smckusick 
135122861Smckusick ret:
135222861Smckusick 	return(type);
135322861Smckusick }
135422861Smckusick 
135522861Smckusick 
135622861Smckusick 
135722861Smckusick 
135822861Smckusick 
135922861Smckusick setintr(v)
136022861Smckusick register Namep  v;
136122861Smckusick {
136222861Smckusick register int k;
136322861Smckusick 
136422861Smckusick if(v->vstg == STGUNKNOWN)
136522861Smckusick 	v->vstg = STGINTR;
136622861Smckusick else if(v->vstg!=STGINTR)
136722861Smckusick 	dclerr("incompatible use of intrinsic function", v);
136822861Smckusick if(v->vclass==CLUNKNOWN)
136922861Smckusick 	v->vclass = CLPROC;
137022861Smckusick if(v->vprocclass == PUNKNOWN)
137122861Smckusick 	v->vprocclass = PINTRINSIC;
137222861Smckusick else if(v->vprocclass != PINTRINSIC)
137322861Smckusick 	dclerr("invalid intrinsic declaration", v);
137422861Smckusick if(k = intrfunct(v->varname))
137522861Smckusick 	v->vardesc.varno = k;
137622861Smckusick else
137722861Smckusick 	dclerr("unknown intrinsic function", v);
137822861Smckusick }
137922861Smckusick 
138022861Smckusick 
138122861Smckusick 
138222861Smckusick setext(v)
138322861Smckusick register Namep  v;
138422861Smckusick {
138522861Smckusick if(v->vclass == CLUNKNOWN)
138622861Smckusick 	v->vclass = CLPROC;
138722861Smckusick else if(v->vclass != CLPROC)
138822861Smckusick 	dclerr("conflicting declarations", v);
138922861Smckusick 
139022861Smckusick if(v->vprocclass == PUNKNOWN)
139122861Smckusick 	v->vprocclass = PEXTERNAL;
139222861Smckusick else if(v->vprocclass != PEXTERNAL)
139322861Smckusick 	dclerr("conflicting declarations", v);
139422861Smckusick }
139522861Smckusick 
139622861Smckusick 
139722861Smckusick 
139822861Smckusick 
139922861Smckusick /* create dimensions block for array variable */
140022861Smckusick 
140122861Smckusick setbound(v, nd, dims)
140222861Smckusick register Namep  v;
140322861Smckusick int nd;
140422861Smckusick struct { expptr lb, ub; } dims[ ];
140522861Smckusick {
140622861Smckusick register expptr q, t;
140722861Smckusick register struct Dimblock *p;
140822861Smckusick int i;
140922861Smckusick 
141022861Smckusick if(v->vclass == CLUNKNOWN)
141122861Smckusick 	v->vclass = CLVAR;
141222861Smckusick else if(v->vclass != CLVAR)
141322861Smckusick 	{
141422861Smckusick 	dclerr("only variables may be arrays", v);
141522861Smckusick 	return;
141622861Smckusick 	}
141722861Smckusick if(v->vdim)
141822861Smckusick 	{
141922861Smckusick 	dclerr("redimensioned array", v);
142022861Smckusick 	return;
142122861Smckusick 	}
142222861Smckusick 
142322861Smckusick v->vdim = p = (struct Dimblock *)
142422861Smckusick 		ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
142522861Smckusick p->ndim = nd;
142622861Smckusick p->nelt = ICON(1);
142722861Smckusick 
142822861Smckusick for(i=0 ; i<nd ; ++i)
142922861Smckusick 	{
143022861Smckusick #ifdef SDB
143122861Smckusick         if(sdbflag) {
143222861Smckusick /* Save the bounds trees built up by the grammar routines for use in stabs */
143322861Smckusick 
143422861Smckusick 		if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
143522861Smckusick         	else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
143622861Smckusick                 if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
143722861Smckusick                 else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);
143822861Smckusick 
143922861Smckusick 		if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
144022861Smckusick         	else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
144122861Smckusick                 if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
144222861Smckusick                 else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
144322861Smckusick 	}
144422861Smckusick #endif
144522861Smckusick 	if( (q = dims[i].ub) == NULL)
144622861Smckusick 		{
144722861Smckusick 		if(i == nd-1)
144822861Smckusick 			{
144922861Smckusick 			frexpr(p->nelt);
145022861Smckusick 			p->nelt = NULL;
145122861Smckusick 			}
145222861Smckusick 		else
145322861Smckusick 			err("only last bound may be asterisk");
145422861Smckusick 		p->dims[i].dimsize = ICON(1);;
145522861Smckusick 		p->dims[i].dimexpr = NULL;
145622861Smckusick 		}
145722861Smckusick 	else
145822861Smckusick 		{
145922861Smckusick 		if(dims[i].lb)
146022861Smckusick 			{
146122861Smckusick 			q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
146222861Smckusick 			q = mkexpr(OPPLUS, q, ICON(1) );
146322861Smckusick 			}
146422861Smckusick 		if( ISCONST(q) )
146522861Smckusick 			{
146622861Smckusick 			if (!ISINT(q->headblock.vtype)) {
146722861Smckusick 			   dclerr("dimension bounds must be integer expression", v);
146822861Smckusick 			   frexpr(q);
146922861Smckusick 			   q = ICON(0);
147022861Smckusick 			   }
147122861Smckusick 			if ( q->constblock.const.ci <= 0)
147222861Smckusick 			   {
147322861Smckusick 			   dclerr("array bounds out of sequence", v);
147422861Smckusick 			   frexpr(q);
147522861Smckusick 			   q = ICON(0);
147622861Smckusick 			   }
147722861Smckusick 			p->dims[i].dimsize = q;
147822861Smckusick 			p->dims[i].dimexpr = (expptr) PNULL;
147922861Smckusick 			}
148022861Smckusick 		else	{
148122861Smckusick 			p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
148222861Smckusick 			p->dims[i].dimexpr = q;
148322861Smckusick 			}
148422861Smckusick 		if(p->nelt)
148522861Smckusick 			p->nelt = mkexpr(OPSTAR, p->nelt,
148622861Smckusick 					cpexpr(p->dims[i].dimsize) );
148722861Smckusick 		}
148822861Smckusick 	}
148922861Smckusick 
149022861Smckusick q = dims[nd-1].lb;
149122861Smckusick if(q == NULL)
149222861Smckusick 	q = ICON(1);
149322861Smckusick 
149422861Smckusick for(i = nd-2 ; i>=0 ; --i)
149522861Smckusick 	{
149622861Smckusick 	t = dims[i].lb;
149722861Smckusick 	if(t == NULL)
149822861Smckusick 		t = ICON(1);
149922861Smckusick 	if(p->dims[i].dimsize)
150022861Smckusick 		q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
150122861Smckusick 	}
150222861Smckusick 
150322861Smckusick if( ISCONST(q) )
150422861Smckusick 	{
150522861Smckusick 	p->baseoffset = q;
150622861Smckusick 	p->basexpr = NULL;
150722861Smckusick 	}
150822861Smckusick else
150922861Smckusick 	{
151022861Smckusick 	p->baseoffset = (expptr) autovar(1, tyint, PNULL);
151122861Smckusick 	p->basexpr = q;
151222861Smckusick 	}
151322861Smckusick }
151422861Smckusick 
151522861Smckusick 
151622861Smckusick 
151722861Smckusick /*
151822861Smckusick  * Check the dimensions of q to ensure that they are appropriately defined.
151922861Smckusick  */
152022861Smckusick LOCAL chkdim(q)
152122861Smckusick register Namep q;
152222861Smckusick {
152322861Smckusick   register struct Dimblock *p;
152422861Smckusick   register int i;
152522861Smckusick   expptr e;
152622861Smckusick 
152722861Smckusick   if (q == NULL)
152822861Smckusick     return;
152922861Smckusick   if (q->vclass != CLVAR)
153022861Smckusick     return;
153122861Smckusick   if (q->vdim == NULL)
153222861Smckusick     return;
153322861Smckusick   p = q->vdim;
153422861Smckusick   for (i = 0; i < p->ndim; ++i)
153522861Smckusick     {
153622861Smckusick #ifdef SDB
153722861Smckusick       if (sdbflag)
153822861Smckusick 	{
153922861Smckusick 	  if (e = p->dims[i].lb)
154022861Smckusick 	    chkdime(e, q);
154122861Smckusick 	  if (e = p->dims[i].ub)
154222861Smckusick 	    chkdime(e, q);
154322861Smckusick 	}
154422861Smckusick       else
154522861Smckusick #endif SDB
154622861Smckusick       if (e = p->dims[i].dimexpr)
154722861Smckusick 	chkdime(e, q);
154822861Smckusick     }
154922861Smckusick }
155022861Smckusick 
155122861Smckusick 
155222861Smckusick 
155322861Smckusick /*
155422861Smckusick  * The actual checking for chkdim() -- examines each expression.
155522861Smckusick  */
155622861Smckusick LOCAL chkdime(expr, q)
155722861Smckusick expptr expr;
155822861Smckusick Namep q;
155922861Smckusick {
156022861Smckusick   register expptr e;
156122861Smckusick 
156222861Smckusick   e = fixtype(cpexpr(expr));
156322861Smckusick   if (!ISINT(e->exprblock.vtype))
156422861Smckusick     dclerr("non-integer dimension", q);
156522861Smckusick   else if (!safedim(e))
156622861Smckusick     dclerr("undefined dimension", q);
156722861Smckusick   frexpr(e);
156822861Smckusick   return;
156922861Smckusick }
157022861Smckusick 
157122861Smckusick 
157222861Smckusick 
157322861Smckusick /*
157422861Smckusick  * A recursive routine to find undefined variables in dimension expressions.
157522861Smckusick  */
157622861Smckusick LOCAL safedim(e)
157722861Smckusick expptr e;
157822861Smckusick {
157922861Smckusick   chainp cp;
158022861Smckusick 
158122861Smckusick   if (e == NULL)
158222861Smckusick     return 1;
158322861Smckusick   switch (e->tag)
158422861Smckusick     {
158522861Smckusick       case TEXPR:
158622861Smckusick 	if (e->exprblock.opcode == OPCALL || e->exprblock.opcode == OPCCALL)
158722861Smckusick 	  return 0;
158822861Smckusick 	return safedim(e->exprblock.leftp) && safedim(e->exprblock.rightp);
158922861Smckusick       case TADDR:
159022861Smckusick 	switch (e->addrblock.vstg)
159122861Smckusick 	  {
159222861Smckusick 	    case STGCOMMON:
159322861Smckusick 	    case STGARG:
159422861Smckusick 	    case STGCONST:
159522861Smckusick 	    case STGEQUIV:
159622861Smckusick 	      if (e->addrblock.isarray)
159722861Smckusick 		return 0;
159822861Smckusick 	      return safedim(e->addrblock.memoffset);
159922861Smckusick 	    default:
160022861Smckusick 	      return 0;
160122861Smckusick 	  }
160222861Smckusick       case TCONST:
160322861Smckusick       case TTEMP:
160422861Smckusick 	return 1;
160522861Smckusick     }
160622861Smckusick   return 0;
160722861Smckusick }
160822861Smckusick 
160922861Smckusick 
161022861Smckusick 
161122861Smckusick LOCAL enlist(size, np, ep)
161222861Smckusick ftnint size;
161322861Smckusick Namep np;
161422861Smckusick struct Equivblock *ep;
161522861Smckusick {
161622861Smckusick   register sizelist *sp;
161722861Smckusick   register sizelist *t;
161822861Smckusick   register varlist *p;
161922861Smckusick 
162022861Smckusick   sp = varsizes;
162122861Smckusick 
162222861Smckusick   if (sp == NULL)
162322861Smckusick     {
162422861Smckusick       sp = ALLOC(SizeList);
162522861Smckusick       sp->size = size;
162622861Smckusick       varsizes = sp;
162722861Smckusick     }
162822861Smckusick   else
162922861Smckusick     {
163022861Smckusick       while (sp->size != size)
163122861Smckusick 	{
163222861Smckusick 	  if (sp->next != NULL && sp->next->size <= size)
163322861Smckusick 	    sp = sp->next;
163422861Smckusick 	  else
163522861Smckusick 	    {
163622861Smckusick 	      t = sp;
163722861Smckusick 	      sp = ALLOC(SizeList);
163822861Smckusick 	      sp->size = size;
163922861Smckusick 	      sp->next = t->next;
164022861Smckusick 	      t->next = sp;
164122861Smckusick 	    }
164222861Smckusick 	}
164322861Smckusick     }
164422861Smckusick 
164522861Smckusick   p = ALLOC(VarList);
164622861Smckusick   p->next = sp->vars;
164722861Smckusick   p->np = np;
164822861Smckusick   p->ep = ep;
164922861Smckusick 
165022861Smckusick   sp->vars = p;
165122861Smckusick 
165222861Smckusick   return;
165322861Smckusick }
165422861Smckusick 
165522861Smckusick 
165622861Smckusick 
165722861Smckusick outlocvars()
165822861Smckusick {
165922861Smckusick 
166022861Smckusick   register varlist *first, *last;
166122861Smckusick   register varlist *vp, *t;
166222861Smckusick   register sizelist *sp, *sp1;
166322861Smckusick   register Namep np;
166422861Smckusick   register struct Equivblock *ep;
166522861Smckusick   register int i;
166622861Smckusick   register int alt;
166722861Smckusick   register int type;
166822861Smckusick   char sname[100];
166922861Smckusick   char setbuff[100];
167022861Smckusick 
167122861Smckusick   sp = varsizes;
167222861Smckusick   if (sp == NULL)
167322861Smckusick     return;
167422861Smckusick 
167522861Smckusick   vp = sp->vars;
167622861Smckusick   if (vp->np != NULL)
167722861Smckusick     {
167822861Smckusick       np = vp->np;
167922861Smckusick       sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
168022861Smckusick 	      np->vardesc.varno);
168122861Smckusick     }
168222861Smckusick   else
168322861Smckusick     {
168422861Smckusick       i = vp->ep - eqvclass;
168522861Smckusick       sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
168622861Smckusick     }
168722861Smckusick 
168822861Smckusick   first = last = NULL;
168922861Smckusick   alt = NO;
169022861Smckusick 
169122861Smckusick   while (sp != NULL)
169222861Smckusick     {
169322861Smckusick       vp = sp->vars;
169422861Smckusick       while (vp != NULL)
169522861Smckusick 	{
169622861Smckusick 	  t = vp->next;
169722861Smckusick 	  if (alt == YES)
169822861Smckusick 	    {
169922861Smckusick 	      alt = NO;
170022861Smckusick 	      vp->next = first;
170122861Smckusick 	      first = vp;
170222861Smckusick 	    }
170322861Smckusick 	  else
170422861Smckusick 	    {
170522861Smckusick 	      alt = YES;
170622861Smckusick 	      if (last != NULL)
170722861Smckusick 	        last->next = vp;
170822861Smckusick 	      else
170922861Smckusick 		first = vp;
171022861Smckusick 	      vp->next = NULL;
171122861Smckusick 	      last = vp;
171222861Smckusick 	    }
171322861Smckusick 	  vp = t;
171422861Smckusick 	}
171522861Smckusick       sp1 = sp;
171622861Smckusick       sp = sp->next;
171722861Smckusick       free((char *) sp1);
171822861Smckusick     }
171922861Smckusick 
172022861Smckusick   vp = first;
172122861Smckusick   while(vp != NULL)
172222861Smckusick     {
172322861Smckusick       if (vp->np != NULL)
172422861Smckusick 	{
172522861Smckusick 	  np = vp->np;
172622861Smckusick 	  sprintf(sname, "v.%d", np->vardesc.varno);
172722861Smckusick 	  if (np->init)
172822861Smckusick 	    prlocdata(sname, np->varsize, np->vtype, np->initoffset,
172922861Smckusick 		      &(np->inlcomm));
173022861Smckusick 	  else
173122861Smckusick 	    {
173222861Smckusick 	      pralign(typealign[np->vtype]);
1733*25103Sdonn 	      fprintf(initfile, "%s:\n", sname);
1734*25103Sdonn 	      prspace(np->varsize);
173522861Smckusick 	    }
173622861Smckusick 	  np->inlcomm = NO;
173722861Smckusick 	}
173822861Smckusick       else
173922861Smckusick 	{
174022861Smckusick 	  ep = vp->ep;
174122861Smckusick 	  i = ep - eqvclass;
174222861Smckusick 	  if (ep->eqvleng >= 8)
174322861Smckusick 	    type = TYDREAL;
174422861Smckusick 	  else if (ep->eqvleng >= 4)
174522861Smckusick 	    type = TYLONG;
174622861Smckusick 	  else if (ep->eqvleng >= 2)
174722861Smckusick 	    type = TYSHORT;
174822861Smckusick 	  else
174922861Smckusick 	    type = TYCHAR;
175022861Smckusick 	  sprintf(sname, "q.%d", i + eqvstart);
175122861Smckusick 	  if (ep->init)
175222861Smckusick 	    prlocdata(sname, ep->eqvleng, type, ep->initoffset,
175322861Smckusick 		      &(ep->inlcomm));
175422861Smckusick 	  else
175522861Smckusick 	    {
175622861Smckusick 	      pralign(typealign[type]);
1757*25103Sdonn 	      fprintf(initfile, "%s:\n", sname);
1758*25103Sdonn 	      prspace(ep->eqvleng);
175922861Smckusick 	    }
176022861Smckusick 	  ep->inlcomm = NO;
176122861Smckusick 	}
176222861Smckusick       t = vp;
176322861Smckusick       vp = vp->next;
176422861Smckusick       free((char *) t);
176522861Smckusick     }
176622861Smckusick   fprintf(initfile, "%s\n", setbuff);
176722861Smckusick   return;
176822861Smckusick }
1769