proc.c

来自「<B>Digital的Unix操作系统VAX 4.2源码</B>」· C语言 代码 · 共 1,806 行 · 第 1/3 页

#ifndef lint
static char	*sccsid = " @(#)proc.c	1.3	(ULTRIX)	1/15/86";
#endif lint

/************************************************************************
 *									*
 *			Copyright (c) 1986 by				*
 *		Digital Equipment Corporation, Maynard, MA		*
 *			All rights reserved.				*
 *									*
 *   This software is furnished under a license and may be used and	*
 *   copied  only  in accordance with the terms of such license and	*
 *   with the  inclusion  of  the  above  copyright  notice.   This	*
 *   software  or  any  other copies thereof may not be provided or	*
 *   otherwise made available to any other person.  No title to and	*
 *   ownership of the software is hereby transferred.			*
 *									*
 *   This software is  derived  from  software  received  from  the	*
 *   University    of   California,   Berkeley,   and   from   Bell	*
 *   Laboratories.  Use, duplication, or disclosure is  subject  to	*
 *   restrictions  under  license  agreements  with  University  of	*
 *   California and with AT&T.						*
 *									*
 *   The information in this software is subject to change  without	*
 *   notice  and should not be construed as a commitment by Digital	*
 *   Equipment Corporation.						*
 *									*
 *   Digital assumes no responsibility for the use  or  reliability	*
 *   of its software on equipment which is not supplied by Digital.	*
 *									*
 ************************************************************************/

/************************************************************************
*
*			Modification History
*
*	Sid Maxwell		29-Sep-88
*
* 002	Changed dobss to look for variable length CHARACTER variables
*	defined BSS and generate an error.
*
*	David Metsky		14-Jan-86
*
* 001	Replaced old version with BSD 4.3 version as part of upgrade.
*
*	Based on:	proc.c		5.3		8/29/85
*
*************************************************************************/

/*
 * proc.c
 *
 * Routines for handling procedures, f77 compiler, pass 1.
 *
 * University of Utah CS Dept modification history:
 *
 * $Header: proc.c,v 5.2 85/08/10 05:03:34 donn Exp $
 * $Log:	proc.c,v $
 * Revision 5.2  85/08/10  05:03:34  donn
 * Support for NAMELIST i/o from Jerry Berkman.
 * 
 * Revision 5.1  85/08/10  03:49:14  donn
 * 4.3 alpha
 * 
 * Revision 3.11  85/06/04  03:45:29  donn
 * Changed retval() to recognize that a function declaration might have
 * bombed out earlier, leaving an error node behind...
 * 
 * Revision 3.10  85/03/08  23:13:06  donn
 * Finally figured out why function calls and array elements are not legal
 * dummy array dimension declarator elements.  Hacked safedim() to stop 'em.
 * 
 * Revision 3.9  85/02/02  00:26:10  donn
 * Removed the call to entrystab() in enddcl() -- this was redundant (it was
 * also done in startproc()) and confusing to dbx to boot.
 * 
 * Revision 3.8  85/01/14  04:21:53  donn
 * Added changes to implement Jerry's '-q' option.
 * 
 * Revision 3.7  85/01/11  21:10:35  donn
 * In conjunction with other changes to implement SAVE statements, function
 * nameblocks were changed to make it appear that they are 'saved' too --
 * this arranges things so that function return values are forced out of
 * register before a return.
 * 
 * Revision 3.6  84/12/10  19:27:20  donn
 * comblock() signals an illegal common block name by returning a null pointer,
 * but incomm() wasn't able to handle it, leading to core dumps.  I put the
 * fix in incomm() to pick up null common blocks.
 * 
 * Revision 3.5  84/11/21  20:33:31  donn
 * It seems that I/O elements are treated as character strings so that their
 * length can be passed to the I/O routines...  Unfortunately the compiler
 * assumes that no temporaries can be of type CHARACTER and casually tosses
 * length and type info away when removing TEMP blocks.  This has been fixed...
 * 
 * Revision 3.4  84/11/05  22:19:30  donn
 * Fixed a silly bug in the last fix.
 * 
 * Revision 3.3  84/10/29  08:15:23  donn
 * Added code to check the type and shape of subscript declarations,
 * per Jerry Berkman's suggestion.
 * 
 * Revision 3.2  84/10/29  05:52:07  donn
 * Added change suggested by Jerry Berkman to report an error when an array
 * is redimensioned.
 * 
 * Revision 3.1  84/10/13  02:12:31  donn
 * Merged Jerry Berkman's version into mine.
 * 
 * Revision 2.1  84/07/19  12:04:09  donn
 * Changed comment headers for UofU.
 * 
 * Revision 1.6  84/07/19  11:32:15  donn
 * Incorporated fix to setbound() to detect backward array subscript limits.
 * The fix is by Bob Corbett, donated by Jerry Berkman.
 * 
 * Revision 1.5  84/07/18  18:25:50  donn
 * Fixed problem with doentry() where a placeholder for a return value
 * was not allocated if the first entry didn't require one but a later
 * entry did.
 * 
 * Revision 1.4  84/05/24  20:52:09  donn
 * Installed firewall #ifdef around the code that recycles stack temporaries,
 * since it seems to be broken and lacks a good fix for the time being.
 * 
 * Revision 1.3  84/04/16  09:50:46  donn
 * Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
 * the original for its own use.  This fixes a set of bugs that are caused by
 * elements in the argtemplist getting stomped on.
 * 
 * Revision 1.2  84/02/28  21:12:58  donn
 * Added Berkeley changes for subroutine call argument temporaries fix.
 * 
 */

#include "defs.h"

#ifdef SDB
#	include <a.out.h>
#	ifndef N_SO
#		include <stab.h>
#	endif
#endif

extern flag namesflag;

typedef
  struct SizeList
    {
      struct SizeList *next;
      ftnint size;
      struct VarList *vars;
    }
  sizelist;


typedef
  struct VarList
    {
      struct VarList *next;
      Namep np;
      struct Equivblock *ep;
    }
  varlist;


LOCAL sizelist *varsizes;


/* start a new procedure */

newproc()
{
if(parstate != OUTSIDE)
	{
	execerr("missing end statement", CNULL);
	endproc();
	}

parstate = INSIDE;
procclass = CLMAIN;	/* default */
}



/* end of procedure. generate variables, epilogs, and prologs */

endproc()
{
struct Labelblock *lp;

if(parstate < INDATA)
	enddcl();
if(ctlstack >= ctls)
	err("DO loop or BLOCK IF not closed");
for(lp = labeltab ; lp < labtabend ; ++lp)
	if(lp->stateno!=0 && lp->labdefined==NO)
		errstr("missing statement number %s", convic(lp->stateno) );

if (optimflag)
  optimize();

outiodata();
epicode();
procode();
donmlist();
dobss();

#if FAMILY == PCC
	putbracket();
#endif
fixlwm();
procinit();	/* clean up for next procedure */
}



/* End of declaration section of procedure.  Allocate storage. */

enddcl()
{
register struct Entrypoint *ep;

parstate = INEXEC;
docommon();
doequiv();
docomleng();
for(ep = entries ; ep ; ep = ep->entnextp) {
	doentry(ep);
}
}

/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */

/* Main program or Block data */

startproc(prgname, class)
Namep prgname;
int class;
{
struct Extsym *progname;
register struct Entrypoint *p;

if(prgname)
	procname = prgname->varname;
if(namesflag == YES) {
	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
	if(prgname)
		fprintf(diagfile, " %s", varstr(XL, procname) );
	fprintf(diagfile, ":\n");
	}

if( prgname ) 
	progname = newentry( prgname );
else
	progname = NULL;

p = ALLOC(Entrypoint);
if(class == CLMAIN)
	puthead("MAIN_", CLMAIN);
else
	puthead(CNULL, CLBLOCK);
if(class == CLMAIN)
	newentry( mkname(5, "MAIN") );
p->entryname = progname;
p->entrylabel = newlabel();
entries = p;

procclass = class;
retlabel = newlabel();
#ifdef SDB
if(sdbflag) {
         entrystab(p,class);
}
#endif
}

/* subroutine or function statement */

struct Extsym *newentry(v)
register Namep v;
{
register struct Extsym *p;

p = mkext( varunder(VL, v->varname) );

if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
	{
	if(p == 0)
		dclerr("invalid entry name", v);
	else	dclerr("external name already used", v);
	return(0);
	}
v->vstg = STGAUTO;
v->vprocclass = PTHISPROC;
v->vclass = CLPROC;
p->extstg = STGEXT;
p->extinit = YES;
return(p);
}


entrypt(class, type, length, entname, args)
int class, type;
ftnint length;
Namep entname;
chainp args;
{
struct Extsym *entry;
register Namep q;
register struct Entrypoint *p, *ep;

if(namesflag == YES) {
	if(class == CLENTRY)
		fprintf(diagfile, "       entry ");
	if(entname)
		fprintf(diagfile, "   %s", varstr(XL, entname->varname) );
	fprintf(diagfile, ":\n");
	}

if( entname->vclass == CLPARAM ) {
	errstr("entry name %s used in 'parameter' statement", 
		varstr(XL, entname->varname) );
	return;
	}
if( ((type == TYSUBR) || (class == CLENTRY && proctype == TYSUBR)) 
	&& (entname->vtype != TYUNKNOWN && entname->vtype != TYSUBR) ) {
	errstr("subroutine entry %s previously declared",
		varstr(XL, entname->varname) );
	return;
	}
if(  (entname->vstg != STGEXT && entname->vstg != STGUNKNOWN)
	||  (entname->vdim != NULL) ) {
	errstr("subroutine or function entry %s previously declared",
		varstr(XL, entname->varname) );
	return;
	}

if( (class == CLPROC || class == CLENTRY) && type != TYSUBR )
	/* arrange to save function return values */
	entname->vsave = YES;
	
entry = newentry( entname );

if(class != CLENTRY)
	puthead( varstr(XL, procname = entry->extname), class);
q = mkname(VL, nounder(XL,entry->extname) );

if( (type = lengtype(type, (int) length)) != TYCHAR)
	length = 0;
if(class == CLPROC)
	{
	procclass = CLPROC;
	proctype = type;
	procleng = length;

	retlabel = newlabel();
	if(type == TYSUBR)
		ret0label = newlabel();
	}

p = ALLOC(Entrypoint);
if(entries)	/* put new block at end of entries list */
	{
	for(ep = entries; ep->entnextp; ep = ep->entnextp)
		;
	ep->entnextp = p;
	}
else
	entries = p;

p->entryname = entry;
p->arglist = args;
p->entrylabel = newlabel();
p->enamep = q;

if(class == CLENTRY)
	{
	class = CLPROC;
	if(proctype == TYSUBR)
		type = TYSUBR;
	}

q->vclass = class;
q->vprocclass = PTHISPROC;
settype(q, type, (int) length);
/* hold all initial entry points till end of declarations */
if(parstate >= INDATA) {
	doentry(p);
}
#ifdef SDB
	if(sdbflag)
	{ /* may need to preserve CLENTRY here */
	entrystab(p,class);
	}
#endif
}

/* generate epilogs */

LOCAL epicode()
{
register int i;

if(procclass==CLPROC)
	{
	if(proctype==TYSUBR)
		{
		putlabel(ret0label);
		if(substars)
			putforce(TYINT, ICON(0) );
		putlabel(retlabel);
		goret(TYSUBR);
		}
	else	{
		putlabel(retlabel);
		if(multitype)
			{
			typeaddr = autovar(1, TYADDR, PNULL);
			putbranch( cpexpr(typeaddr) );
			for(i = 0; i < NTYPES ; ++i)
				if(rtvlabel[i] != 0)
					{
					putlabel(rtvlabel[i]);
					retval(i);
					}
			}
		else
			retval(proctype);
		}
	}

else if(procclass != CLBLOCK)
	{
	putlabel(retlabel);
	goret(TYSUBR);
	}
}


/* generate code to return value of type  t */

LOCAL retval(t)
register int t;
{
register Addrp p;

switch(t)
	{
	case TYCHAR:
	case TYCOMPLEX:
	case TYDCOMPLEX:
		break;

	case TYLOGICAL:
		t = tylogical;
	case TYADDR:
	case TYSHORT:
	case TYLONG:
		p = (Addrp) cpexpr(retslot);
		p->vtype = t;
		putforce(t, p);
		break;

	case TYREAL:
	case TYDREAL:
		p = (Addrp) cpexpr(retslot);
		p->vtype = t;
		putforce(t, p);
		break;

	case TYERROR:
		return;		/* someone else already complained */

	default:
		badtype("retval", t);
	}
goret(t);
}


/* Allocate extra argument array if needed. Generate prologs. */

LOCAL procode()
{
register struct Entrypoint *p;
Addrp argvec;

#if TARGET==GCOS
	argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
#else
	if(lastargslot>0 && nentry>1)
#if TARGET == VAX
		argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
#else
		argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
#endif
	else
		argvec = NULL;
#endif


#if TARGET == PDP11
	/* for the optimizer */
	if(fudgelabel)
		putlabel(fudgelabel);
#endif

for(p = entries ; p ; p = p->entnextp)
	prolog(p, argvec);

#if FAMILY == PCC
	putrbrack(procno);
#endif

prendproc();
}


/*
   manipulate argument lists (allocate argument slot positions)
 * keep track of return types and labels
 */

LOCAL doentry(ep)
struct Entrypoint *ep;
{
register int type;
register Namep np;
chainp p;
register Namep q;
Addrp mkarg();

++nentry;
if(procclass == CLMAIN)
	{
	if (optimflag)
		optbuff (SKLABEL, 0, ep->entrylabel, 0);
	else
		putlabel(ep->entrylabel);
	return;
	}
else if(procclass == CLBLOCK)
	return;

impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
type = np->vtype;
if(proctype == TYUNKNOWN)
	if( (proctype = type) == TYCHAR)
		procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));

if(proctype == TYCHAR)
	{
	if(type != TYCHAR)
		err("noncharacter entry of character function");
	else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
		err("mismatched character entry lengths");
	}
else if(type == TYCHAR)
	err("character entry of noncharacter function");
else if(type != proctype)
	multitype = YES;
if(rtvlabel[type] == 0)
	rtvlabel[type] = newlabel();
ep->typelabel = rtvlabel[type];

if(type == TYCHAR)
	{
	if(chslot < 0)
		{
		chslot = nextarg(TYADDR);
		chlgslot = nextarg(TYLENG);
		}
	np->vstg = STGARG;
	np->vardesc.varno = chslot;
	if(procleng < 0)
		np->vleng = (expptr) mkarg(TYLENG, chlgslot);
	}
else if( ISCOMPLEX(type) )
	{
	np->vstg = STGARG;
	if(cxslot < 0)
		cxslot = nextarg(TYADDR);
	np->vardesc.varno = cxslot;
	}
else if(type != TYSUBR)
	{
	if(retslot == NULL)
		retslot = autovar(1, TYDREAL, PNULL);
	np->vstg = STGAUTO;
	np->voffset = retslot->memoffset->constblock.const.ci;
	}

for(p = ep->arglist ; p ; p = p->nextp)
	if(! (( q = (Namep) (p->datap) )->vdcldone) )
		q->vardesc.varno = nextarg(TYADDR);

for(p = ep->arglist ; p ; p = p->nextp)
	if(! (( q = (Namep) (p->datap) )->vdcldone) )
		{
		impldcl(q);