exprtype.c

这是一个Linux下的集成开发环境

/*

Copyright (c) 2000, Red Hat, Inc.

This file is part of Source-Navigator.

Source-Navigator is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published
by the Free Software Foundation; either version 2, or (at your option)
any later version.

Source-Navigator is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with Source-Navigator; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.



*/

/* exprtype.c -- propagates datatype thru expressions.

    Copyright (C) 1992 by Robert K. Moniot.
    This program is free software.  Permission is granted to
    modify it and/or redistribute it, retaining this notice.
    No guarantees accompany this software.


*/

/* I. */

/*  exprtype.c:

	Routines to propagate datatype through expressions.

	binexpr_type()		Yields result type of binary expression.
	unexpr_type()		Yields result type of unary expression.
	assignment_stmt_type()	Checks assignment statement type.
	func_ref_expr(id,args,result) Forms token for a function invocation.
	primary_id_expr()	Forms token for primary which is an identifier.
	stmt_fun_arg_cmp(t1,t2) Checks agreement between stmt func args.
    int	int_power(x,n)		Computes x**n for value propagation.
        init_typesizes(wdsize)	Sets standard type sizes
*/

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "ftnchek.h"
#define EXPRTYPE
#include "symtab.h"
#include "fortran.h"

PRIVATE int int_power();
PRIVATE char *sized_typename(),*op_string();
PRIVATE void report_mismatch(),report_type();

extern int in_assignment_stmt;	/* shared with fortran.y */

#define max(x,y) ((y)>(x)?(y):(x))

	/* shorthand for datatypes.  must match those in symtab.h */
	/* N.B. Also, the fact that type_DEFAULT=0 is assumed in size
	   propagation code. */
#define E 0	/*  Error for invalid type combos  */
#define I 1
#define R 2
#define D 3
#define C 4
#define Z 5
#define L 6
#define S 7
#define H 8
#define NumT (H+1)		/* number of types in tables below */

#define W 10		/*  Warning for nonstandard type combos: W>NumT */

			/* for  + - / * **	ANSI book pp. 6-5,6-6	*/
			    /* Mixed double+complex = double complex with
			       warning, double + double complex is OK */
unsigned char arith_expr_type[NumT][NumT]={
/*E   I   R   D   C   Z   L   S   H   */
{ E,  E,  E,  E,  E,  E,  E,  E,  E },	/* E */
{ E,  I,  R,  D,  C,  Z,  E,  E,  E },	/* I */
{ E,  R,  R,  D,  C,  Z,  E,  E,  E },	/* R */
{ E,  D,  D,  D,W+Z,  Z,  E,  E,  E },	/* D */
{ E,  C,  C,W+Z,  C,  Z,  E,  E,  E },	/* C */
{ E,  Z,  Z,  Z,  Z,  Z,  E,  E,  E },	/* Z */
{ E,  E,  E,  E,  E,  E,  E,  E,  E },	/* L */
{ E,  E,  E,  E,  E,  E,  E,  E,  E },	/* S */
{ E,  E,  E,  E,  E,  E,  E,  E,  E }	/* H */
};

			/* for  relops.  Corresponds to arith type table
			   except that nonstandard comparisons of like
			   types have warning, not error. */
unsigned char rel_expr_type[NumT][NumT]={
/*E   I   R   D   C   Z   L   S   H   */
{ E,  E,  E,  E,  E,  E,  E,  E,  E },	/* E */
{ E,  L,  L,  L,  L,  L,  E,  E,W+L },	/* I */
{ E,  L,  L,  L,  L,  L,  E,  E,  E },	/* R */
{ E,  L,  L,  L,W+L,  L,  E,  E,  E },	/* D */
{ E,  L,  L,W+L,  L,  L,  E,  E,  E },	/* C */
{ E,  L,  L,  L,  L,  L,  E,  E,  E },	/* Z */
{ E,  E,  E,  E,  E,  E,W+L,  E,W+L },	/* L */
{ E,  E,  E,  E,  E,  E,  E,  L,  E },	/* S */
{ E,W+L,  E,  E,  E,  E,W+L,  E,W+L }	/* H */
};

			/* Result of assignment:  lvalue = expr.  Here rows
			   correspond to type of lvalue, columns to type
			   of expr */
unsigned char assignment_type[NumT][NumT]={
/*E   I   R   D   C   Z   L   S   H   */
{ E,  E,  E,  E,  E,  E,  E,  E,  E },	/* E */
{ E,  I,  I,  I,  I,  I,  E,  E,W+I },	/* I */
{ E,  R,  R,  R,  R,  R,  E,  E,W+R },	/* R */
{ E,  D,  D,  D,  D,  D,  E,  E,W+D },	/* D */
{ E,  C,  C,  C,  C,  C,  E,  E,W+C },	/* C */
{ E,  Z,  Z,  Z,  Z,  Z,  E,  E,W+Z },	/* Z */
{ E,  E,  E,  E,  E,  E,  L,  E,W+L },	/* L */
{ E,  E,  E,  E,  E,  E,  E,  S,  E },	/* S */
{ E,  E,  E,  E,  E,  E,  E,  E,  E }	/* H not possible for lvalue */
};


#define INTRINS_ARGS (op == ',') /* Flag to modify behavior of binexpr_type */

	/* Routine used in printing diagnostics: returns string "type" for
	   unsized objects, "type*size" for explicitly sized things.  Due
	   to use of local static variable, cannot be invoked twice in the
	   same expression.  */
PRIVATE char*
sized_typename(type,size)
  int type; long size;
{
  static char strbuf[]="type*000000"; /* template */
  static char *char_unk="char*(?)";
  static char *char_adj="char*(*)";
  if(size == size_DEFAULT) {
    return type_name[type];	/* no explicit size */
  }
  else {
    if(type != S || size > 0) {
      sprintf(strbuf,"%4s*%ld",	/* type*size */
	    type_name[type],
	    size%1000000);
    }
    else {			/* handle special character size codes */
      if(size == size_ADJUSTABLE)
	return char_adj;
      else /*size_UNKNOWN*/
	return char_unk;
    }
  }
  return strbuf;
}

PRIVATE char*			/* Returns string containing the operator */
op_string(op_token)
     Token *op_token;
{
  int op=op_token->class;
  static char op_str[]=".AND.";	/* Longest instance */
  if(ispunct(op)) {
    op_str[0] = op;
    op_str[1] = '\0';
    return op_str;
  }
  else switch(op) {
    case tok_power:
      return "**";
      break;

    case tok_concat:
      return "//";
      break;

    case tok_relop:
    case tok_AND:
    case tok_OR:
    case tok_EQV:
    case tok_NEQV:
    case tok_NOT:
      sprintf(op_str,".%s.",op_token->value.string);
      return op_str;
      break;

    default:
      return "?";
      break;
    }
  return NULL;/*NOTREACHED*/
}

void
init_typesizes()
		/* Only executes once.  Thus cannot change wordsize
		   after processing starts. */
{
  static int trapdoor=FALSE;
  if(trapdoor) {
    if(given_wordsize != local_wordsize) {
      fprintf(stderr,
	      "\nSorry-Cannot change wordsize after processing starts");
    }
    given_wordsize = local_wordsize;
  }
  else {
    trapdoor = TRUE;
    local_wordsize = given_wordsize;
    if(given_wordsize != 0) {
      if(given_wordsize != BpW) {
	type_size[I] = type_size[R] = type_size[L] = given_wordsize;
	type_size[D] = type_size[C] = 2*given_wordsize;
	type_size[Z] = 4*given_wordsize;
      }
    }
  }
}

	/* this routine propagates type in binary expressions */

void
binexpr_type(term1,operator,term2,result)
	Token *term1, *operator, *term2, *result;
{
    int	op = operator->class,
	type1 = datatype_of(term1->class),
	type2 = datatype_of(term2->class),
	result_type;
    long
	size1 = term1->size,
	size2 = term2->size,
        result_size;
    if( ! is_computational_type(type1) ) {
		syntax_error(term1->line_num,term1->col_num,
			"noncomputational primary in expression:");
		report_type(term1);
		result_type = E;
    }
    else if( ! is_computational_type(type2) ) {
		syntax_error(term2->line_num,term2->col_num,
			"noncomputational primary in expression:");
		report_type(term2);
		result_type = E;
    }
    else {
	switch(op) {
				/* arithmetic operators: use lookup table */
	    case '+':
	    case '-':
	    case '*':
	    case '/':
	    case tok_power:
		result_type = (unsigned)arith_expr_type[type1][type2];
		break;

				/* relational operators: use lookup table */
 	    case tok_relop:
		result_type = (unsigned)rel_expr_type[type1][type2];
		break;

				/*  logical operators: operands should be
				    logical, but allow integers with a
				    warning. */
	    case tok_AND:
	    case tok_OR:
	    case tok_EQV:
	    case tok_NEQV:
		if(type1 == L && type2 == L)
		    result_type = L;
		else if(type1 == I && type2 == I)
		    result_type = W+I;
		else
		    result_type = E;
		break;

				/*  // operator: operands must be strings */
	    case tok_concat:
		if(type1 == S && type2 == S)
		    result_type = S;
		else
		    result_type = E;
		break;

			/* Intrinsic function argument list: no promotion
			   across type categories.  Accept matching type
			   categories: size match will be checked later. */
	    case ',':
		if( type_category[type1] != type_category[type2] )
		  result_type = E;
		else if(type1 == S)
		  result_type = S;
		else
		  result_type = (unsigned)arith_expr_type[type1][type2];
		break;

	    default:
		oops_message(OOPS_NONFATAL,
			     operator->line_num,operator->col_num,
			     "operator unknown: type not propagated");
		result_type = type1;
		break;
	}

	if( (type1 != E && type2 != E) ) {
	    if( result_type == E) {
		syntax_error(operator->line_num,operator->col_num,
			"type mismatch");
		if(INTRINS_ARGS) {
		  msg_tail("between intrinsic function arguments:");
		}
		else {
		  msg_tail("in expression:");
		}
		report_mismatch(term1,operator,term2);
	    }
	    else if(result_type >= W) {	/* W result */
	      if(f77_standard) {
		warning(operator->line_num,operator->col_num,
			"nonstandard type combination in expression:");
		report_mismatch(term1,operator,term2);
	      }
	      result_type -= W;
	    }
				/* Obscure standard rule */
	    else if(f77_standard && op == tok_concat && !in_assignment_stmt &&
		  (size1 == size_ADJUSTABLE || size2 == size_ADJUSTABLE) ) {
		nonstandard(operator->line_num,operator->col_num);
		msg_tail("adjustable size cannot be concatenated here");
	    }
	}
    }

				/* Figure out the size of result */
    result_size = size_DEFAULT;
    if(result_type != E &&	/* Error type gets DEFAULT size */
       op != tok_relop) {	/* Result of compare gets DEFAULT size */

      if(op == tok_concat) {	/* string//string yields sum of lengths */
	if(size1 == size_UNKNOWN || size2 == size_UNKNOWN)
	  result_size = size_UNKNOWN;
	else
	  if(size1 == size_ADJUSTABLE || size2 == size_ADJUSTABLE)
	    result_size = size_ADJUSTABLE;
	  else
	    result_size = size1 + size2;
      }
			/* DEFAULT op DEFAULT always yields DEFAULT. So need
			   to handle only explicitly sized expressions,
			   except intrinsic arglists, where no promotion
			   of plain real to dble or plain complex to dcpx,
			   and check for promotions of real types.
			 */
      else if(INTRINS_ARGS?
	      (type1 != type2) :
	      ((size1 != size_DEFAULT || size2 != size_DEFAULT) ||
	        (trunc_check && is_float_type(type1) && is_float_type(type2))))
     {
				/* Local variables for convenience.
				   N.B. Use tc1/2,ls1/2 for tests,
				   t1/2,s1/2 for assigning result.
				 */
	int t1,t2;	/* sorted types: t1 <= t2. */
	long s1,s2;	/* sizes of t1 and t2. */
	int tc1,tc2;	/* type categories: D->R and Z->C */
	long ls1,ls2;	/* local sizes = declared size else type_size */
	int defsize1,defsize2; /* flags for default size */

				/* Sort so that t1 <= t2 */
	if(type1 <= type2) {
	  t1 = type1; s1 = size1;
	  t2 = type2; s2 = size2;
	}
	else {
	  t1 = type2; s1 = size2;
	  t2 = type1; s2 = size1;
	}
				/* Assign type categories and local sizes */
	tc1 = type_category[t1];
	tc2 = type_category[t2];

	defsize1 = (s1 == size_DEFAULT);
	defsize2 = (s2 == size_DEFAULT);
	ls1 = (defsize1? type_size[t1]: s1);
	ls2 = (defsize2? type_size[t2]: s2);

#ifdef DEBUG_EXPRTYPE
if(debug_latest)
  fprintf(list_fd,"\nt1=%s s1=%d ls1=%d t2=%s s2=%d ls2=%d",
	  type_name[t1],s1,ls1, type_name[t2], s2, ls2);
#endif
	if(tc1 == tc2) {/* same type category */
				/* Intrins args: size promotion illegal */
	  if(INTRINS_ARGS && ls1 != ls2) {
	    syntax_error(operator->line_num,operator->col_num,
			 "precision mismatch in intrinsic argument list:");
	    report_mismatch(term1,operator,term2);
	  }
				/* Give -port warning if e.g. plain I+I*2
				   (variables only) */
	  else if(port_check || local_wordsize==0) {
	    if(defsize1 != defsize2
	        && !is_true(CONST_EXPR,term1->subclass)
	        && !is_true(CONST_EXPR,term2->subclass))
	    {
	      nonportable(operator->line_num,operator->col_num,
			  INTRINS_ARGS?"intrinsic argument list":"expr");
	      msg_tail("mixes default and explicit");
	      msg_tail((is_numeric_type(t1)&&is_numeric_type(t2))?
			 "precision":"size");
	      msg_tail("operands:");
	      report_mismatch(term1,operator,term2);
	    }
	  }

		/* If same type category, use the larger of the two sizes if
		   both declared.  If only one size declared, use the
		   larger of the declared size and the default size.
		   If result is equal in size to default, use size_DEFAULT.
		*/
	  if(ls1 > ls2) {
	    result_size = s1;
	  }
	  else if(ls2 > ls1) {
	    result_size = s2;
	  }
	  else /*ls1 == ls2*/{
	    if(!defsize1 && !defsize2)
	      result_size = s1;	/* otherwise DEFAULT */
	  }
	}/* end(tc1==tc2) */
	else /* tc1!=tc2 */ {
			/* Differing type categories: only two cases. */

				/* Case 1:  I + R|D|C|Z
				   Result: size of dominant type */
	  if(tc1 == I) {
	    result_size = s2;
	  }
				/* Case 2:  R|D + C|Z
				   Result: larger of C|Z and 2*size of R|D */
	  else {
	    if(ls2 >= 2*ls1)
	      result_size = s2;
	    else
	      result_size = 2*s1; /* 2*size_DEFAULT = 0 is still DEFAULT */
	  }
	}/* end tc1 != tc2 */
				/* change D or Z to default size or else
				   to explicitly sized R or C
				 */
	if(result_type == D || result_type == Z) {
	  if(result_size != size_DEFAULT
	     && result_size != type_size[result_type])
	       result_type = (result_type==D)?R:C;
	     else
	       result_size = size_DEFAULT;
	}

				/* Give -trunc warning if a real or
				   complex type is promoted to double. */
	if(trunc_check && !INTRINS_ARGS && is_float_type(t1) ) {
		  /* First clause checks R+R size agreement */
	  if( (type_category[result_type] == R && ls1 != ls2)
		     /* Second clause checks R+C and C+C */
	     || (type_category[result_type] == C &&
		 (type_category[t1] == R? ls2 != 2*ls1 : ls2 != ls1)) ){
	    warning(operator->line_num,operator->col_num,
		    "promotion may not give desired precision:");
	    report_mismatch(term1,operator,term2);
	  }
	}

      }/*end if(non-DEFAULT sizes)*/

    }/*end if(result_size != E)*/

#ifdef DEBUG_EXPRTYPE
if(debug_latest) {
fprintf(list_fd,"\nsize of %s %c",sized_typename(type1,size1),
	ispunct(op)?op:'~');
fprintf(list_fd," %s = ",sized_typename(type2,size2));
fprintf(list_fd,"%s",sized_typename(result_type,result_size));
}
#endif

    result->class = type_byte(class_VAR, result_type);
    result->subclass = 0;	/* clear all flags */
    result->size = result_size;