expr.c

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

#ifndef lint
static char	*sccsid = " @(#)expr.c	1.5	(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
*
*	David Metsky		14-Jan-86
*
* 001	Replaced old version with BSD 4.3 version as part of upgrade.
*
*	Based on:	expr.c		5.4		8/29/85
*
*************************************************************************/

/*
 * expr.c
 *
 * Routines for handling expressions, f77 compiler pass 1.
 *
 * University of Utah CS Dept modification history:
 *
 * $Log:	expr.c,v $
 * Revision 5.3  85/08/10  05:48:16  donn
 * Fixed another of my goofs in the substring parameter conversion code.
 * 
 * Revision 5.2  85/08/10  04:13:51  donn
 * Jerry Berkman's change to call pow() directly rather than indirectly
 * through pow_dd, in mkpower().
 * 
 * Revision 5.1  85/08/10  03:44:19  donn
 * 4.3 alpha
 * 
 * Revision 3.16  85/06/21  16:38:09  donn
 * The fix to mkprim() didn't handle null substring parameters (sigh).
 * 
 * Revision 3.15  85/06/04  04:37:03  donn
 * Changed mkprim() to force substring parameters to be integral types.
 * 
 * Revision 3.14  85/06/04  03:41:52  donn
 * Change impldcl() to handle functions of type 'undefined'.
 * 
 * Revision 3.13  85/05/06  23:14:55  donn
 * Changed mkconv() so that it calls mkaltemp() instead of mktemp() to get
 * a temporary when converting character strings to integers; previously we
 * were having problems because mkconv() was called after tempalloc().
 * 
 * Revision 3.12  85/03/18  08:07:47  donn
 * Fixes to help out with short integers -- if integers are by default short,
 * then so are constants; and if addresses can't be stored in shorts, complain.
 * 
 * Revision 3.11  85/03/16  22:31:27  donn
 * Added hack to mkconv() to allow character values of length > 1 to be
 * converted to numeric types, for Helge Skrivervik.  Note that this does
 * not affect use of the intrinsic ichar() conversion.
 * 
 * Revision 3.10  85/01/15  21:06:47  donn
 * Changed mkconv() to comment on implicit conversions; added intrconv() for
 * use with explicit conversions by intrinsic functions.
 * 
 * Revision 3.9  85/01/11  21:05:49  donn
 * Added changes to implement SAVE statements.
 * 
 * Revision 3.8  84/12/17  02:21:06  donn
 * Added a test to prevent constant folding from being done on expressions
 * whose type is not known at that point in mkexpr().
 * 
 * Revision 3.7  84/12/11  21:14:17  donn
 * Removed obnoxious 'excess precision' warning.
 * 
 * Revision 3.6  84/11/23  01:00:36  donn
 * Added code to trim excess precision from single-precision constants, and
 * to warn the user when this occurs.
 * 
 * Revision 3.5  84/11/23  00:10:39  donn
 * Changed stfcall() to remark on argument type clashes in 'calls' to
 * statement functions.
 * 
 * Revision 3.4  84/11/22  21:21:17  donn
 * Fixed bug in fix to mkexpr() that caused IMPLICIT to affect intrinsics.
 * 
 * Revision 3.3  84/11/12  18:26:14  donn
 * Shuffled some code around so that the compiler remembers to free some vleng
 * structures which used to just sit around.
 * 
 * Revision 3.2  84/10/16  19:24:15  donn
 * Fix for Peter Montgomery's bug with -C and invalid subscripts -- prevent
 * core dumps by replacing bad subscripts with good ones.
 * 
 * Revision 3.1  84/10/13  01:31:32  donn
 * Merged Jerry Berkman's version into mine.
 * 
 * Revision 2.7  84/09/27  15:42:52  donn
 * The last fix for multiplying undeclared variables by 0 isn't sufficient,
 * since the type of the 0 may not be the (implicit) type of the variable.
 * I added a hack to check the implicit type of implicitly declared
 * variables...
 * 
 * Revision 2.6  84/09/14  19:34:03  donn
 * Problem noted by Mike Vevea -- mkexpr will sometimes attempt to convert
 * 0 to type UNKNOWN, which is illegal.  Fix is to use native type instead.
 * Not sure how correct (or important) this is...
 * 
 * Revision 2.5  84/08/05  23:05:27  donn
 * Added fixes to prevent fixexpr() from slicing and dicing complex conversions
 * with two operands.
 * 
 * Revision 2.4  84/08/05  17:34:48  donn
 * Added an optimization to mklhs() to detect substrings of the form ch(i:i)
 * and assign constant length 1 to them.
 * 
 * Revision 2.3  84/07/19  19:38:33  donn
 * Added a typecast to the last fix.  Somehow I missed it the first time...
 * 
 * Revision 2.2  84/07/19  17:19:57  donn
 * Caused OPPAREN expressions to inherit the length of their operands, so
 * that parenthesized character expressions work correctly.
 * 
 * Revision 2.1  84/07/19  12:03:02  donn
 * Changed comment headers for UofU.
 * 
 * Revision 1.2  84/04/06  20:12:17  donn
 * Fixed bug which caused programs with mixed-type multiplications involving
 * the constant 0 to choke the compiler.
 * 
 */

#include "defs.h"


/* little routines to create constant blocks */

Constp mkconst(t)
register int t;
{
register Constp p;

p = ALLOC(Constblock);
p->tag = TCONST;
p->vtype = t;
return(p);
}


expptr mklogcon(l)
register int l;
{
register Constp  p;

p = mkconst(TYLOGICAL);
p->const.ci = l;
return( (expptr) p );
}



expptr mkintcon(l)
ftnint l;
{
register Constp p;
int usetype;

if(tyint == TYSHORT)
  {
    short s = l;
    if(l != s)
      usetype = TYLONG;
    else
      usetype = TYSHORT;
  }
else
  usetype = tyint;
p = mkconst(usetype);
p->const.ci = l;
return( (expptr) p );
}



expptr mkaddcon(l)
register int l;
{
register Constp p;

p = mkconst(TYADDR);
p->const.ci = l;
return( (expptr) p );
}



expptr mkrealcon(t, d)
register int t;
double d;
{
register Constp p;

if(t == TYREAL)
  {
    float f = d;
    if(f != d)
      {
#ifdef notdef
	warn("excess precision in real constant lost");
#endif notdef
	d = f;
      }
  }
p = mkconst(t);
p->const.cd[0] = d;
return( (expptr) p );
}


expptr mkbitcon(shift, leng, s)
int shift;
register int leng;
register char *s;
{
  Constp p;
  register int i, j, k;
  register char *bp;
  int size;

  size = (shift*leng + BYTESIZE -1)/BYTESIZE;
  bp = (char *) ckalloc(size);

  i = 0;

#if (TARGET == PDP11 || TARGET == VAX)
  j = 0;
#else
  j = size;
#endif

  k = 0;

  while (leng > 0)
    {
      k |= (hextoi(s[--leng]) << i);
      i += shift;
      if (i >= BYTESIZE)
	{
#if (TARGET == PDP11 || TARGET == VAX)
	  bp[j++] = k & MAXBYTE;
#else
	  bp[--j] = k & MAXBYTE;
#endif
	  k = k >> BYTESIZE;
	  i -= BYTESIZE;
	}
    }

  if (k != 0)
#if (TARGET == PDP11 || TARGET == VAX)
    bp[j++] = k;
#else
    bp[--j] = k;
#endif

  p = mkconst(TYBITSTR);
  p->vleng = ICON(size);
  p->const.ccp = bp;

  return ((expptr) p);
}



expptr mkstrcon(l,v)
int l;
register char *v;
{
register Constp p;
register char *s;

p = mkconst(TYCHAR);
p->vleng = ICON(l);
p->const.ccp = s = (char *) ckalloc(l);
while(--l >= 0)
	*s++ = *v++;
return( (expptr) p );
}


expptr mkcxcon(realp,imagp)
register expptr realp, imagp;
{
int rtype, itype;
register Constp p;

rtype = realp->headblock.vtype;
itype = imagp->headblock.vtype;

if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
	{
	p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX);
	if( ISINT(rtype) )
		p->const.cd[0] = realp->constblock.const.ci;
	else	p->const.cd[0] = realp->constblock.const.cd[0];
	if( ISINT(itype) )
		p->const.cd[1] = imagp->constblock.const.ci;
	else	p->const.cd[1] = imagp->constblock.const.cd[0];
	}
else
	{
	err("invalid complex constant");
	p = (Constp) errnode();
	}

frexpr(realp);
frexpr(imagp);
return( (expptr) p );
}


expptr errnode()
{
struct Errorblock *p;
p = ALLOC(Errorblock);
p->tag = TERROR;
p->vtype = TYERROR;
return( (expptr) p );
}





expptr mkconv(t, p)
register int t;
register expptr p;
{
register expptr q;
Addrp r, s;
register int pt;
expptr opconv();

if(t==TYUNKNOWN || t==TYERROR)
	badtype("mkconv", t);
pt = p->headblock.vtype;
if(t == pt)
	return(p);

if( pt == TYCHAR && ISNUMERIC(t) )
	{
	warn("implicit conversion of character to numeric type");

	/*
	 * Ugly kluge to copy character values into numerics.
	 */
	s = mkaltemp(t, ENULL);
	r = (Addrp) cpexpr(s);
	r->vtype = TYCHAR;
	r->varleng = typesize[t];
	r->vleng = mkintcon(r->varleng);
	q = mkexpr(OPASSIGN, r, p);
	q = mkexpr(OPCOMMA, q, s);
	return(q);
	}

#if SZADDR > SZSHORT
if( pt == TYADDR && t == TYSHORT)
	{
	err("insufficient precision to hold address type");
	return( errnode() );
	}
#endif
if( pt == TYADDR && ISNUMERIC(t) )
	warn("implicit conversion of address to numeric type");

if( ISCONST(p) && pt!=TYADDR)
	{
	q = (expptr) mkconst(t);
	consconv(t, &(q->constblock.const),
		p->constblock.vtype, &(p->constblock.const) );
	frexpr(p);
	}
#if TARGET == PDP11
else if(ISINT(t) && pt==TYCHAR)
	{
	q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
	if(t == TYLONG)
		q = opconv(q, TYLONG);
	}
#endif
else
	q = opconv(p, t);

if(t == TYCHAR)
	q->constblock.vleng = ICON(1);
return(q);
}



/* intrinsic conversions */
expptr intrconv(t, p)
register int t;
register expptr p;
{
register expptr q;
register int pt;
expptr opconv();

if(t==TYUNKNOWN || t==TYERROR)
	badtype("intrconv", t);
pt = p->headblock.vtype;
if(t == pt)
	return(p);

else if( ISCONST(p) && pt!=TYADDR)
	{
	q = (expptr) mkconst(t);
	consconv(t, &(q->constblock.const),
		p->constblock.vtype, &(p->constblock.const) );
	frexpr(p);
	}
#if TARGET == PDP11
else if(ISINT(t) && pt==TYCHAR)
	{
	q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
	if(t == TYLONG)
		q = opconv(q, TYLONG);
	}
#endif
else
	q = opconv(p, t);

if(t == TYCHAR)
	q->constblock.vleng = ICON(1);
return(q);
}



expptr opconv(p, t)
expptr p;
int t;
{
register expptr q;

q = mkexpr(OPCONV, p, PNULL);
q->headblock.vtype = t;
return(q);
}



expptr addrof(p)
expptr p;
{
return( mkexpr(OPADDR, p, PNULL) );
}



tagptr cpexpr(p)
register tagptr p;
{
register tagptr e;
int tag;
register chainp ep, pp;
tagptr cpblock();

static int blksize[ ] =
	{	0,
		sizeof(struct Nameblock),
		sizeof(struct Constblock),
		sizeof(struct Exprblock),
		sizeof(struct Addrblock),
		sizeof(struct Tempblock),
		sizeof(struct Primblock),
		sizeof(struct Listblock),
		sizeof(struct Errorblock)
	};

if(p == NULL)
	return(NULL);

if( (tag = p->tag) == TNAME)
	return(p);

e = cpblock( blksize[p->tag] , p);

switch(tag)
	{
	case TCONST:
		if(e->constblock.vtype == TYCHAR)
			{
			e->constblock.const.ccp =
				copyn(1+strlen(e->constblock.const.ccp),
					e->constblock.const.ccp);
			e->constblock.vleng =
				(expptr) cpexpr(e->constblock.vleng);
			}
	case TERROR:
		break;

	case TEXPR:
		e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
		e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
		break;

	case TLIST:
		if(pp = p->listblock.listp)
			{
			ep = e->listblock.listp =
				mkchain( cpexpr(pp->datap), CHNULL);
			for(pp = pp->nextp ; pp ; pp = pp->nextp)
				ep = ep->nextp =
					mkchain( cpexpr(pp->datap), CHNULL);
			}
		break;

	case TADDR:
		e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
		e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
		e->addrblock.istemp = NO;
		break;

	case TTEMP:
		e->tempblock.vleng = (expptr)  cpexpr(e->tempblock.vleng);
		e->tempblock.istemp = NO;
		break;

	case TPRIM:
		e->primblock.argsp = (struct Listblock *)
					cpexpr(e->primblock.argsp);
		e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
		e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
		break;

	default:
		badtag("cpexpr", tag);
	}

return(e);
}

frexpr(p)
register tagptr p;
{
register chainp q;

if(p == NULL)
	return;

switch(p->tag)
	{
	case TCONST:
		switch (p->constblock.vtype)
			{
			case TYBITSTR:
			case TYCHAR:
			case TYHOLLERITH:
				free( (charptr) (p->constblock.const.ccp) );
				frexpr(p->constblock.vleng);
			}
		break;

	case TADDR:
		if (!optimflag && p->addrblock.istemp)
			{
			frtemp(p);
			return;
			}
		frexpr(p->addrblock.vleng);
		frexpr(p->addrblock.memoffset);
		break;

	case TTEMP:
		frexpr(p->tempblock.vleng);
		break;

	case TERROR:
		break;

	case TNAME:
		return;

	case TPRIM:
		frexpr(p->primblock.argsp);
		frexpr(p->primblock.fcharp);
		frexpr(p->primblock.lcharp);
		break;

	case TEXPR:
		frexpr(p->exprblock.leftp);
		if(p->exprblock.rightp)
			frexpr(p->exprblock.rightp);
		break;

	case TLIST:
		for(q = p->listblock.listp ; q ; q = q->nextp)
			frexpr(q->datap);
		frchain( &(p->listblock.listp) );
		break;

	default:
		badtag("frexpr", p->tag);
	}

free( (charptr) p );
}

/* fix up types in expression; replace subtrees and convert
   names to address blocks */

expptr fixtype(p)
register tagptr p;
{

if(p == 0)
	return(0);

switch(p->tag)
	{
	case TCONST:
		return( (expptr) p );

	case TADDR:
		p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
		return( (expptr) p);

	case TTEMP:
		return( (expptr) p);

	case TERROR:
		return( (expptr) p);

	default:
		badtag("fixtype", p->tag);

	case TEXPR:
		return( fixexpr(p) );

	case TLIST:
		return( (expptr) p );

	case TPRIM:
		if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
			{
			if(p->primblock.namep->vtype == TYSUBR)
				{
				err("function invocation of subroutine");
				return( errnode() );
				}
			else
				return( mkfunct(p) );
			}
		else	return( mklhs(p) );
	}
}





/* special case tree transformations and cleanups of expression trees */

expptr fixexpr(p)
register Exprp p;
{
expptr lp;
register expptr rp;
register expptr q;
int opcode, ltype, rtype, ptype, mtype;
expptr lconst, rconst;
expptr mkpower();

if( ISERROR(p) )
	return( (expptr) p );
else if(p->tag != TEXPR)
	badtag("fixexpr", p->tag);
opcode = p->opcode;
if (ISCONST(p->leftp))
	lconst = (expptr) cpexpr(p->leftp);
else
	lconst = NULL;
if (p->rightp && ISCONST(p->rightp))
	rconst = (expptr) cpexpr(p->rightp);
else
	rconst = NULL;
lp = p->leftp = fixtype(p->leftp);
ltype = lp->headblock.vtype;
if(opcode==OPASSIGN && lp->tag!=TADDR && lp->tag!=TTEMP)
	{
	err("left side of assignment must be variable");
	frexpr(p);
	return( errnode() );
	}