exprtype.c

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

is_true(CONST_EXPR,result->subclass),
is_true(PARAMETER_EXPR,result->subclass),
is_true(EVALUATED_EXPR,result->subclass));
}
#endif
	}
}/*func_ref_expr*/



		/* Make an expression-token for primary consisting of
		   a symbolic name */

void
primary_id_expr(id,primary)
	Token *id,*primary;
{
	Lsymtab *symt;
	int id_type;
	symt = hashtab[id->value.integer].loc_symtab;
	id_type=get_type(symt);
	primary->class = type_byte(storage_class_of(symt->type),id_type);
	primary->subclass = 0;
	primary->size =get_size(symt,id_type);
	make_true(ID_EXPR,primary->subclass);

	if( storage_class_of(symt->type) == class_VAR) {
		if(symt->parameter) {
		    make_true(CONST_EXPR,primary->subclass);
		    make_true(PARAMETER_EXPR,primary->subclass);
		    make_true(EVALUATED_EXPR,primary->subclass);
		}
		else {
		    make_true(LVALUE_EXPR,primary->subclass);
		}
		if(symt->array_var)
		    make_true(ARRAY_ID_EXPR,primary->subclass);
		if(symt->set_flag || symt->common_var || symt->parameter
				  || symt->argument)
		    make_true(SET_FLAG,primary->subclass);
		if(symt->assigned_flag)
		    make_true(ASSIGNED_FLAG,primary->subclass);
		if(symt->used_before_set)
		    make_true(USED_BEFORE_SET,primary->subclass);
	}
	else if(storage_class_of(symt->type) == class_STMT_FUNCTION) {
		make_true(STMT_FUNCTION_EXPR,primary->subclass);
	}

#ifdef DEBUG_PARSER
if(debug_parser){
	fprintf(list_fd,"\nprimary %s: class=0x%x subclass=0x%x",
		symt->name,primary->class,primary->subclass);
      }
#endif
}/*primary_id_expr*/

int
intrins_arg_cmp(defn,t)
     IntrinsInfo *defn;		/* Definition */
     Token *t;			/* Argument */
{
  int defn_types=defn->arg_type;
  int a_type = datatype_of(t->class);
  int type_OK;
				/* Check for argument type mismatch.
				 */
	    type_OK = ( (1<<a_type) & defn_types );
	    if(! type_OK) {
	      int ct;/* compatible type */
				/* Accept compatible types if
				   sizes agree, e.g. DSQRT(REAL*8).
				   The macros check the two cases and
				   set ct to the compatible type.
				 */
#define EXCEPTION1 (a_type==type_REAL && ((1<<(ct=type_DP))&defn_types))
#define EXCEPTION2 (a_type==type_COMPLEX&&((1<<(ct=type_DCOMPLEX))&defn_types))

	      if(!( (EXCEPTION1||EXCEPTION2) && t->size==type_size[ct] )){
		syntax_error(t->line_num,t->col_num,
			"illegal argument data type for intrinsic function");
		msg_tail(defn->name);
		msg_tail(":");
		report_type(t);
	      }
	      else {
		if(port_check || local_wordsize==0) {
		  nonportable(t->line_num,t->col_num,
	      "argument precision may not be correct for intrinsic function");
		  msg_tail(defn->name);
		  msg_tail(":");
		  report_type(t);
		}
		type_OK = TRUE; /* Acceptable after all */
	      }
	    }/* end if type mismatch */

  return type_OK;
}/*intrins_arg_cmp*/


				/* Check agreement between statement function
				   dummy (t1) and actual (t2) args.  At this
				   time, checks only class, type and size,
				   not arrayness.  */
void
stmt_fun_arg_cmp(symt,d_arg,a_arg)
     Lsymtab *symt;
     Token *d_arg,*a_arg;
{
  int d_class = class_VAR,
      a_class = storage_class_of(a_arg->class),
      d_type = datatype_of(d_arg->class),
      a_type = datatype_of(a_arg->class),
      d_size = d_arg->size,
      a_size = a_arg->size,
      d_defsize = (d_size == size_DEFAULT),
      a_defsize = (a_size == size_DEFAULT);
  int d_cmptype= (d_type==type_HOLLERITH && a_type!=type_STRING)?
				a_type:type_category[d_type];
  int a_cmptype= (a_type==type_HOLLERITH && d_type!=type_STRING)?
				d_type:type_category[a_type];

  if(!(port_check || local_wordsize==0)) {
    if(d_defsize)
      d_size = type_size[d_type];
    if(a_defsize)
      a_size = type_size[a_type];
  }

  if(d_size < 0 || a_size < 0) { /* char size_ADJUSTABLE or UNKNOWN */
    d_size = a_size = size_DEFAULT;	/* suppress warnings on size */
    d_defsize = a_defsize = TRUE;
  }

  if(d_class != a_class || d_cmptype != a_cmptype ||
     (d_type == type_STRING? d_size > a_size: d_size != a_size) ) {
		syntax_error(a_arg->line_num,a_arg->col_num,
		  "argument mismatch in stmt function");
		msg_tail(symt->name); /* Give the stmt func name */
		msg_tail(": dummy");
		report_type(d_arg); /* Dummy arg type */
		msg_tail("vs actual");
		report_type(a_arg);
  }
}/*stmt_fun_arg_cmp*/


				/* Routine to document the types of
				   two terms and their operator */
PRIVATE void
report_mismatch(term1,operator,term2)
     Token *term1,*operator,*term2;
{
  report_type(term1);
  msg_tail(op_string(operator));
  report_type(term2);
}
				/* Routine to document the type
				   of a token, with its name if it
				   has one. */
PRIVATE void
report_type(t)
     Token *t;
{
  msg_tail(sized_typename(datatype_of(t->class),t->size));
  if(is_true(ID_EXPR,t->subclass))
    msg_tail(hashtab[t->value.integer].name);
  else if(is_true(LIT_CONST,t->subclass))
    msg_tail("const");
  else
    msg_tail("expr");
}


int
substring_size(id,limits)
     Token *id,*limits;
{
	Lsymtab *symt;
	int id_type,id_len;
	int startindex,endindex,substr_len;
	symt = hashtab[id->value.integer].loc_symtab;
	id_type=get_type(symt);

	substr_len=size_UNKNOWN;

	if(id_type != type_STRING) {
	  syntax_error(id->line_num,id->col_num,
		       "string variable expected");
	}
	else {
	  id_len = id->size;
		/* fortran.y stores (startindex:endindex) in class,subclass */
	  startindex = limits->class;
	  endindex = limits->subclass;
	  if(startindex != size_UNKNOWN && endindex != size_UNKNOWN) {
		/* Check limits unless endindex=0 */
	    if( startindex > endindex && endindex > 0 ) {
	      syntax_error(limits->line_num,limits->col_num,
		      "invalid substring limits");
	    }
	    else {
	      if(endindex == 0)	/* 0 means it was (startindex: ) */
		endindex=id_len;
	      substr_len = endindex-startindex+1;
	      if(id_len > 0 && substr_len > id_len)
		syntax_error(limits->line_num,limits->col_num,
		      "substring size exceeds string size");
	    }
	  }
	}
	return substr_len;
}

	/* Integer power: uses recursion x**n = (x**(n/2))**2 */
PRIVATE int
int_power(x,n)
	int x,n;
{
	int temp;
			/* Order of tests puts commonest cases first */
	if(n > 1) {
		temp = int_power(x,n>>1);
		temp *= temp;
		if(n&1) return temp*x;	/* Odd n */
		else	return temp;	/* Even n */
	}
	else if(n == 1) return x;
	else if(n < 0) return 1/int_power(x,-n);	/* Usually 0 */
	else return 1;
}

				/* Intrinsic function handlers */

PRIVATE int
    ii_abs(), ii_sign(),  ii_dim(),   ii_mod(),
    ii_max(), ii_min(),   ii_ichar(), ii_len(),  ii_index();

/* Array of pointers to functions for evaluating integer-valued intrinsic
   functions.  The order matches definitions of I_ABS thru I_INDEX in
   symtab.h */

PRIVATE int (*ii_fun[])()={
  NULL,
  ii_abs,
  ii_sign,
  ii_dim,
  ii_mod,
  ii_max,
  ii_min,
  ii_ichar,
  ii_len,
  ii_index,
};

int
eval_intrins(defn,args)
     IntrinsInfo *defn;
     Token *args;
{
    int index;
    index = (defn->intrins_flags & I_EVALUATED);

				/* Args must be evaluated, except for LEN */
    if( (is_true(EVALUATED_EXPR,args->subclass) || index==I_LEN) &&
       index > 0 && index < (sizeof(ii_fun)/sizeof(ii_fun[0])) ) {
      return (*ii_fun[index])(args);
    }
    else {
#ifdef DEBUG_EXPRTYPE
      if(debug_latest)
	fprintf(list_fd,"\nIntrinsic %s not handled",defn->name);
      make_false(EVALUATED_EXPR,args->subclass);
#endif
      return 0;
    }
}


PRIVATE int
ii_abs(args)
     Token *args;
{
  Token *t;
  int val, result=0;
  t = args->next_token;
  if(t->class != type_INTEGER) {/* wrong arg type: message given elsewhere */
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    val = int_expr_value(t);
    result = (val >= 0? val: -val);
  }
  return result;
}

PRIVATE int
ii_sign(args)			/* SIGN(value,sign) */
     Token *args;
{
  Token *t1,*t2;
  int val1,val2, result=0;
  t1 = args->next_token;
  t2 = t1->next_token;
  if(t2 == NULL || t1->class != type_INTEGER
     || t2->class != type_INTEGER) {/* wrong arg type: message given elswr */
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    val1 = int_expr_value(t1);
    if(val1 < 0) val1 = -val1;
    val2 = int_expr_value(t2);
    result = (val2 >= 0? val1: -val1);
  }
  return result;
}

PRIVATE int
ii_dim(args)			/* DIM(int,int) */
     Token *args;
{
  Token *t1,*t2;
  int val, result=0;
  t1 = args->next_token;
  t2 = t1->next_token;
  if(t2 == NULL || t1->class != type_INTEGER
     || t2->class != type_INTEGER) {/* wrong arg type: message given elswr */
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    val = int_expr_value(t1)-int_expr_value(t2);
    result = (val >= 0? val: 0);
  }
  return result;
}

PRIVATE int
ii_mod(args)			/* MOD(int,int) */
     Token *args;
{
  Token *t1,*t2;
  int val1,val2,quotient, result=0;
  t1 = args->next_token;
  t2 = t1->next_token;
  if(t2 == NULL || t1->class != type_INTEGER
     || t2->class != type_INTEGER) {/* wrong arg type: message given elswr */
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    val1 = int_expr_value(t1);
    val2 = int_expr_value(t2);
    if((val1 < 0) == (val2 < 0)) {
      quotient = val1/val2;	/* Both positive or both negative*/
    }
    else {
      quotient = -(-val1/val2);	/* Unlike signs */
    }
    result = val1 - quotient*val2;
  }
  return result;
}


PRIVATE int
ii_max(args)			/* MAX(int,int,...) */
     Token *args;
{
  Token *t=args;
  int val,result=0,n=0;
#ifdef DEBUG_EXPRTYPE
if(debug_latest)
fprintf(list_fd,"\nEvaluating MAX(");
#endif
  while( (t=t->next_token) != NULL) {

      if(t->class != type_INTEGER) {/* wrong arg type: message given elswr */
	make_false(EVALUATED_EXPR,args->subclass);
	break;
      }
      else {
	val = int_expr_value(t);
	if(n++ == 0 || val > result)
	  result = val;
#ifdef DEBUG_EXPRTYPE
if(debug_latest)
fprintf(list_fd,"%d ",val);
#endif
      }
  }
#ifdef DEBUG_EXPRTYPE
if(debug_latest)
fprintf(list_fd,") = %d",result);
#endif
  return result;
}

PRIVATE int
ii_min(args)			/* MIN(int,int,...) */
     Token *args;
{
  Token *t=args;
  int val,result=0,n=0;
  while( (t=t->next_token) != NULL) {
      if(t->class != type_INTEGER) {/* wrong arg type: message given elswr */
	make_false(EVALUATED_EXPR,args->subclass);
	break;
      }
      else {
	val = int_expr_value(t);
	if(n++ == 0 || val < result)
	  result = val;
      }
  }
  return result;
}

PRIVATE int
ii_ichar(args)		/* ICHAR(string) */
     Token *args;
{
  Token *t=args->next_token;

  if(t->class != type_STRING) {
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    return t->value.string[0];	/* Processor collating sequence is used */
  }
  return 0;
}

PRIVATE int
ii_len(args)		/* LEN(string) */
     Token *args;
{
  Token *t=args->next_token;
  int val,result=0;

		/* Set the PARAMETER_EXPR flag since LEN of string does
		   not require contents to be known */
  if( t->class == type_STRING && (val = t->size) > 0 ) {
    make_true(PARAMETER_EXPR,args->subclass);
    make_true(EVALUATED_EXPR,args->subclass);
    result = val;
  }
  else {			/* nonstring or adjustable or unknown */
    make_false(PARAMETER_EXPR,args->subclass);
    make_false(EVALUATED_EXPR,args->subclass);
  }

  return result;
}

PRIVATE int
ii_index(args)		/* INDEX(str1,str2) */
     Token *args;
{
  Token *t1,*t2;
  t1=args->next_token;
  t2=t1->next_token;

  if(t2 == NULL || t1->class != type_STRING
     || t2->class != type_STRING) {
    make_false(EVALUATED_EXPR,args->subclass);
  }
  else {
    int i;
    char *s1=t1->value.string;
    char *s2=t2->value.string;
    int n1=strlen(s1), n2=strlen(s2);

    for(i=1; n1 > 0 && n1 >= n2; i++,s1++,n1--) {
      if(strncmp(s1,s2,n2) == 0)
	return i;
    }
  }
  return 0;
}




				/* Undefine special macros */
#undef E
#undef I
#undef R
#undef D
#undef C
#undef L
#undef S
#undef H
#undef W