exprtype.c

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

		/* Keep track of constant expressions */
    if( is_true(CONST_EXPR,term1->subclass)
	 && is_true(CONST_EXPR,term2->subclass)
         && !(op==tok_power && type2!=I) ) { /* exclude **REAL */
		make_true(CONST_EXPR,result->subclass);
    }

		/* Parameter expressions are like constant exprs
		   except we bend the rules to allow intrinsic functions
		   and **REAL */
    if( is_true(PARAMETER_EXPR,term1->subclass)
	 && is_true(PARAMETER_EXPR,term2->subclass) ) {
		make_true(PARAMETER_EXPR,result->subclass);
    }

    if( is_true(EVALUATED_EXPR,term1->subclass)
	 && is_true(EVALUATED_EXPR,term2->subclass) ) {
		make_true(EVALUATED_EXPR,result->subclass);
    }
#ifdef DEBUG_EXPRTYPE
if(debug_latest)
fprintf(list_fd,"\nconst param eval: (%d %d %d) %s (%d %d %d) = (%d %d %d)",
is_true(CONST_EXPR,term1->subclass),
is_true(PARAMETER_EXPR,term1->subclass),
is_true(EVALUATED_EXPR,term1->subclass),

op_string(op),

is_true(CONST_EXPR,term2->subclass),
is_true(PARAMETER_EXPR,term2->subclass),
is_true(EVALUATED_EXPR,term2->subclass),

is_true(CONST_EXPR,result->subclass),
is_true(PARAMETER_EXPR,result->subclass),
is_true(EVALUATED_EXPR,result->subclass));
#endif

  if(! INTRINS_ARGS) {		/* Remaining steps only applicable to exprs */

		/* Remember if integer division was used */
    if(result_type == type_INTEGER &&
	   (op == '/' ||
	    (is_true(INT_QUOTIENT_EXPR,term1->subclass) ||
	     is_true(INT_QUOTIENT_EXPR,term2->subclass))) ) {
		make_true(INT_QUOTIENT_EXPR,result->subclass);
    }
		/* Issue warning if integer expr involving division is
		   later converted to any real type, or if it is used
		   as an exponent. */
    if( is_true(INT_QUOTIENT_EXPR,term1->subclass)
	|| is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {

	int r=result_type;
	if(r == type_LOGICAL)		/* relational tests are equivalent */
	    r = arith_expr_type[type1][type2];		/* to subtraction */

	if(op == tok_power && is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
	  if(trunc_check)
	    warning(operator->line_num,operator->col_num,
			"integer quotient expr used in exponent");
	  if( ! is_true(INT_QUOTIENT_EXPR,term1->subclass) )
		make_false(INT_QUOTIENT_EXPR,result->subclass);
	}
	else if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
	  if(trunc_check)
	    warning(operator->line_num,operator->col_num,
	    		"integer quotient expr converted to real");
	}
    }

			/* If either term is an identifier, set use flag */
    if(is_true(ID_EXPR,term1->subclass))
	use_variable(term1);
    if(is_true(ID_EXPR,term2->subclass))
	use_variable(term2);

		/* Propagate the value of integer constant expressions */
    if(is_true(EVALUATED_EXPR,result->subclass)) {
	if(result_type == type_INTEGER) {	/* Only ints propagated */
	  int a = int_expr_value(term1),
	      b = int_expr_value(term2),
	      c;
	  switch(op) {
	    case '+': c = a+b; break;
	    case '-': c = a-b; break;
	    case '*': c = a*b; break;
	    case '/': if(b == 0) {
			syntax_error(term2->line_num,term2->col_num,
				"division by zero attempted");
			c = 0;
		      }
		      else {
			c = a/b;
		      }
		      break;
	    case tok_power: c = int_power(a,b); break;
	    case tok_AND: c = a&b; break;
	    case tok_OR: c = a|b; break;
	    case tok_EQV: c = ~(a^b); break;
	    case tok_NEQV: c = a^b; break;
	    default:
	      oops_message(OOPS_NONFATAL,
			   operator->line_num,operator->col_num,
			   "invalid int expr operator");
			c = 0; break;
	  }

	  make_true(EVALUATED_EXPR,result->subclass);
	  result->value.integer = c;	/* Result goes into token value */

				/* Integer division (including i**neg)
				   that yields 0 is suspicious.  */
	  if(trunc_check)
	    if(c==0 && (op=='/' || op==tok_power)) {
	      warning(operator->line_num,operator->col_num,
	    		"integer const expr yields result of 0");
	    }
	}
      }
				/* Also nonconstant**neg is 0 unless
				   nonconstant=1 */
      else if(trunc_check)
	if(result_type == type_INTEGER && op == tok_power
	      && is_true(EVALUATED_EXPR,term2->subclass)
	      && int_expr_value(term2) < 0) {
	  warning(operator->line_num,operator->col_num,
		  "integer to negative power usually yields 0");
	}
  }/* end if !INTRINS_ARGS */
}/*binexpr_type*/


	/* this routine propagates type in unary expressions */

void
unexpr_type(operator,term1,result)
	Token *term1, *operator, *result;
{
   int	op = operator->class,
	type1 = datatype_of(term1->class),
	result_type;

    if( ! is_computational_type(type1) ) {
		syntax_error(term1->line_num,term1->col_num,
			"noncomputational primary in expression:");
		report_type(term1);
		result_type = E;
    }
    else {
	switch(op) {
			/* arith operators: use diagonal of lookup table */
	    case '+':
	    case '-':
		result_type = arith_expr_type[type1][type1];
		break;

				/*  NOT: operand should be
				    logical, but allow integers with a
				    warning. */
	    case tok_NOT:
		if(type1 == L)
		    result_type = L;
		else if(type1 == I)
		    result_type = W+I;
		else
		    result_type = E;
		break;

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

	if( type1 != E )
	    if( result_type == E) {
		syntax_error(operator->line_num,operator->col_num,
			"expression incompatible with operator:");
		msg_tail(op_string(operator));
		msg_tail("used with");
		report_type(term1);
	    }
	    else if(result_type >= W) {
	      if(f77_standard) {
		warning(operator->line_num,operator->col_num,
			"nonstandard type used with operator:");
		msg_tail(op_string(operator));
		msg_tail("used with");
		report_type(term1);
	      }
	      result_type -= W;
	    }
    }

    result->class = type_byte(class_VAR, result_type);
    result->subclass = 0;	/* clear all flags */
    result->size = term1->size;	/* result is same size as operand */

		/* Keep track of constant expressions */
    copy_flag(CONST_EXPR,result->subclass,term1->subclass);
    copy_flag(PARAMETER_EXPR,result->subclass,term1->subclass);

		/* Remember if integer division was used */
    if(result_type == type_INTEGER)
	    copy_flag(INT_QUOTIENT_EXPR,result->subclass,term1->subclass);

    if(is_true(ID_EXPR,term1->subclass))
	use_variable(term1);

		/* Propagate the value of integer constant expressions */
    if(is_true(EVALUATED_EXPR,term1->subclass)) {
	if(result_type == type_INTEGER) {	/* Only ints propagated */
	  int a = int_expr_value(term1),
	      c;
	  switch(op) {
	    case '+': c = a; break;
	    case '-': c = -a; break;
	    case tok_NOT: c = ~a; break;
	    default: oops_message(OOPS_NONFATAL,
			     operator->line_num,operator->col_num,
			     "invalid int expr operator");
			c = 0; break;
	  }
	  make_true(EVALUATED_EXPR,result->subclass);
	  result->value.integer = c;	/* Result goes into token value */
	}
    }
}

	/* this routine checks type and size match in assignment statements
	   and in parameter assignments */

void
assignment_stmt_type(term1,equals,term2)
	Token *term1, *equals, *term2;
{
    int type1 = datatype_of(term1->class),
	type2 = datatype_of(term2->class),
	result_type;


    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 {
	result_type = (unsigned)assignment_type[type1][type2];


	if( (type1 != E && type2 != E) ) {
	    if( result_type == E) {
		syntax_error(equals->line_num,equals->col_num,
			"type mismatch:");
		report_type(term2);
		msg_tail("assigned to");
		report_type(term1);
	    }
	    else {
	      if(result_type >= W) {		/* W result */
		if(f77_standard) {
		  warning(equals->line_num,equals->col_num,
		     "nonstandard type combination:");
		  report_type(term2);
		  msg_tail("assigned to");
		  report_type(term1);
		}
		result_type -= W;
	      }

			/* Watch for truncation to lower precision type */
	      if(trunc_check || port_check || local_wordsize==0) {
		long size1 = term1->size;
		long size2 = term2->size;
		int type_trunc=FALSE, /* flags for kind of truncation */
		    size_trunc=FALSE,
		    mixed_size=FALSE,
		    promotion=FALSE,
		    trunc_warn,mixed_warn;

		if(size1 == size_DEFAULT && size2 == size_DEFAULT) {
		  type_trunc = ( is_numeric_type(type1) &&
				 is_numeric_type(type2) &&
				(type1 < type2 ||
					/* C = D truncates precision of D */
				(type1 == C && type2 == D)) );

				/* Watch for promotions also */
		  if(type_category[type2] == R) {
		    if(type_category[type1] == R) /* R|D = R|D */
		      promotion = (type1 > type2);
		    else if(type_category[type1] == C) /* C|Z = R|D */
		      promotion = (type_size[type1] > 2*type_size[type2]);
		  }
		  else if(type_category[type2] == C) /* any = C|Z */
		    promotion = (type1 > type2);
		}
		else if(type1 == S) { /* character strings */
		  if(size1>0 && size2>0) /* ignore ADJUSTABLE and UNKNOWN */
		    size_trunc = size1 < size2;
		} else {
		  int tc1,tc2;/* type categories: D->R, Z->C, H->I */
		  int ls1,ls2;/* local sizes */

				/* Assign type categories and local sizes */
		  tc1 = type_category[type1];
		  tc2 = type_category[type2];
		  ls1 = size1; if(ls1 == size_DEFAULT)  ls1 = type_size[type1];
		  ls2 = size2; if(ls2 == size_DEFAULT)  ls2 = type_size[type2];

				/* type truncation: any numeric type category
				   to a lower category. */
		  type_trunc = ( /***is_numeric_type(type1) &&
				 is_numeric_type(type2) &&***/
				 tc1 < tc2 );

				/* size truncation: assigned to smaller
				   local size.  For C = R correct test is
				   Csize < 2*Rsize */
		  if(tc1 == C && tc2 == R) {
		    size_trunc = (ls1 < ls2*2);
		    promotion = (ls1 > ls2*2);
		  }
		  else {
		    size_trunc = (ls1 < ls2);
		    promotion = ((tc2 == R || tc2 == C) && (ls1 > ls2));
		  }
				/* mixed size: default size assigned to
				   declared size of like type category
				   or vice-versa. -port only, and superseded
				   by truncation warning if any. */
		  mixed_size = (tc1 == tc2) &&
			   (size1==size_DEFAULT ||
			   (size2==size_DEFAULT &&
			    !is_true(CONST_EXPR,term2->subclass)));

		}

			/* Under -trunc, report type truncation or size
			   truncation.  Say "possibly" if -nowordsize.
			   Also report promotions under -trunc.
			   If no truncation warning given and under -port,
			   report mixed assignment */
#ifdef DEBUG_EXPRTYPE
#define TorF(x) ((x)?"":"no")
if(debug_latest) {
fprintf(list_fd,"\nassign %s =",sized_typename(type1,size1));
fprintf(list_fd," %s : ",sized_typename(type2,size2));
fprintf(list_fd,"%s type %s size %s mixed",
	TorF(type_trunc),
	TorF(size_trunc),
	TorF(mixed_size));
}
#endif
		trunc_warn = (trunc_check &&
			      (type_trunc || size_trunc || promotion));
		mixed_warn = ((port_check || local_wordsize==0) && mixed_size);
		if( trunc_warn ) {
		  warning(equals->line_num,equals->col_num,"");
		  report_type(term2);
		  if(trunc_warn && !type_trunc && mixed_size
		       && local_wordsize == 0)
		    msg_tail("possibly");
		  if(promotion)
		    msg_tail("promoted to");
		  else
		    msg_tail("truncated to");
		  report_type(term1);
		  if(promotion)
		    msg_tail(": may not give desired precision");
		}
		else if(mixed_warn) {
		  nonportable(equals->line_num,equals->col_num,
		    "mixed default and explicit");
		  msg_tail((is_numeric_type(type1)&&is_numeric_type(type2))?
			 "precision":"size");
		  msg_tail("items:");
		  report_type(term2);
		  msg_tail("assigned to");
		  report_type(term1);
		}
	      }
	    }/*end else (result_type != E)*/
	}/*end if (type1,type2 != E)*/
    }/*end else (is_computational_type(type2))*/


		/* Issue warning if integer expr involving division is
		   later converted to any real type. */
    if(trunc_check)
      if( is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {

	int r=result_type;

	if( r == type_REAL || r == type_DP || r == type_COMPLEX)
	    warning(equals->line_num,equals->col_num,
			"integer quotient expr converted to real");
      }


    if(is_true(ID_EXPR,term2->subclass))
	use_variable(term2);

    use_lvalue(term1);
}

	/* Make an expression-token for a function invocation */

void
func_ref_expr(id,args,result)
	Token *id,*args,*result;
{
	Lsymtab *symt;
	IntrinsInfo *defn;
	int rettype, retsize;

	symt = hashtab[id->value.integer].loc_symtab;

	if( symt->intrinsic ) {
	    defn = symt->info.intrins_info;
			/* Intrinsic functions: type stored in info field */
	    rettype = defn->result_type;
	    retsize = size_DEFAULT;

		/* Generic Intrinsic functions: use propagated arg type */
	    if(rettype == type_GENERIC) {
		if(args->next_token == NULL) {
		  rettype = type_UNDECL;
		  retsize = size_DEFAULT;
		}
		else {
#ifdef OLDSTUFF
		  rettype = args->next_token->class;
		  retsize = args->next_token->size;
#else
		  rettype = args->class;
		  retsize = args->size;
#endif
		}
				/* special cases: ABS([d]complex) -> [d]real */
		if(rettype == type_COMPLEX && (defn->intrins_flags&I_C_TO_R)) {
			rettype = type_REAL;
			retsize = retsize/2;
		}
		if(rettype == type_DCOMPLEX &&(defn->intrins_flags&I_C_TO_R)) {
			rettype = type_DP;
			retsize = size_DEFAULT;
		}
	    }
	}
	else {
	    rettype = get_type(symt);
	    retsize = get_size(symt,rettype);
	}
		/* referencing function makes it no longer a class_SUBPROGRAM
		   but an expression. */
	result->class = type_byte(class_VAR,rettype);
	result->subclass = 0;	/* clear all flags */
	result->size = retsize;
#ifdef DEBUG_EXPRTYPE
if(debug_latest) {
fprintf(list_fd,"\n%sFunction %s() = %s",
symt->intrinsic?"Intrinsic ":"",
symt->name,sized_typename(rettype,retsize));
}
#endif

		/* If intrinsic and all arguments are PARAMETER_EXPRs,
		   then result is one too. */
	if( symt->intrinsic ) {
				/* Evaluate intrinsic if result is
				   integer, the args are const (except for
				   LEN), and a handler is defined.
				 */
	    if(rettype == type_INTEGER &&
	           (defn->intrins_flags&I_EVALUATED) )
	    {
		     result->value.integer = eval_intrins(defn,args);
				/* Evaluation routines can affect the flags */
		     copy_flag(EVALUATED_EXPR,result->subclass,args->subclass);
	    }
	    copy_flag(PARAMETER_EXPR,result->subclass,args->subclass);
#ifdef DEBUG_EXPRTYPE
if(debug_latest) {
fprintf(list_fd,"\n%s(...) ",defn->name);
if(is_true(EVALUATED_EXPR,args->subclass))
  fprintf(list_fd,"=%d",result->value.integer);
else
  fprintf(list_fd,"not evaluated");
fprintf(list_fd,": const param eval=(%d %d %d)",