expr.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

   NOTE: Will return SUCCESS even if the expression can not be simplified.  */

try
gfc_simplify_expr (gfc_expr * p, int type)
{
  gfc_actual_arglist *ap;

  if (p == NULL)
    return SUCCESS;

  switch (p->expr_type)
    {
    case EXPR_CONSTANT:
    case EXPR_NULL:
      break;

    case EXPR_FUNCTION:
      for (ap = p->value.function.actual; ap; ap = ap->next)
	if (gfc_simplify_expr (ap->expr, type) == FAILURE)
	  return FAILURE;

      if (p->value.function.isym != NULL
	  && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
	return FAILURE;

      break;

    case EXPR_SUBSTRING:
      if (simplify_ref_chain (p->ref, type) == FAILURE)
	return FAILURE;

      if (gfc_is_constant_expr (p))
	{
	  char *s;
	  int start, end;

	  gfc_extract_int (p->ref->u.ss.start, &start);
	  start--;  /* Convert from one-based to zero-based.  */
	  gfc_extract_int (p->ref->u.ss.end, &end);
	  s = gfc_getmem (end - start + 1);
	  memcpy (s, p->value.character.string + start, end - start);
	  s[end] = '\0';  /* TODO: C-style string for debugging.  */
	  gfc_free (p->value.character.string);
	  p->value.character.string = s;
	  p->value.character.length = end - start;
	  p->ts.cl = gfc_get_charlen ();
	  p->ts.cl->next = gfc_current_ns->cl_list;
	  gfc_current_ns->cl_list = p->ts.cl;
	  p->ts.cl->length = gfc_int_expr (p->value.character.length);
	  gfc_free_ref_list (p->ref);
	  p->ref = NULL;
	  p->expr_type = EXPR_CONSTANT;
	}
      break;

    case EXPR_OP:
      if (simplify_intrinsic_op (p, type) == FAILURE)
	return FAILURE;
      break;

    case EXPR_VARIABLE:
      /* Only substitute array parameter variables if we are in an
         initialization expression, or we want a subsection.  */
      if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
	  && (gfc_init_expr || p->ref
	      || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
	{
	  if (simplify_parameter_variable (p, type) == FAILURE)
	    return FAILURE;
	  break;
	}

      if (type == 1)
	{
	  gfc_simplify_iterator_var (p);
	}

      /* Simplify subcomponent references.  */
      if (simplify_ref_chain (p->ref, type) == FAILURE)
	return FAILURE;

      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      if (simplify_ref_chain (p->ref, type) == FAILURE)
	return FAILURE;

      if (simplify_constructor (p->value.constructor, type) == FAILURE)
	return FAILURE;

      if (p->expr_type == EXPR_ARRAY)
	  gfc_expand_constructor (p);

      if (simplify_const_ref (p) == FAILURE)
	return FAILURE;

      break;
    }

  return SUCCESS;
}


/* Returns the type of an expression with the exception that iterator
   variables are automatically integers no matter what else they may
   be declared as.  */

static bt
et0 (gfc_expr * e)
{

  if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
    return BT_INTEGER;

  return e->ts.type;
}


/* Check an intrinsic arithmetic operation to see if it is consistent
   with some type of expression.  */

static try check_init_expr (gfc_expr *);

static try
check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
{
  gfc_expr *op1 = e->value.op.op1;
  gfc_expr *op2 = e->value.op.op2;

  if ((*check_function) (op1) == FAILURE)
    return FAILURE;

  switch (e->value.op.operator)
    {
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
      if (!numeric_type (et0 (op1)))
	goto not_numeric;
      break;

    case INTRINSIC_EQ:
    case INTRINSIC_NE:
    case INTRINSIC_GT:
    case INTRINSIC_GE:
    case INTRINSIC_LT:
    case INTRINSIC_LE:
      if ((*check_function) (op2) == FAILURE)
	return FAILURE;
      
      if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
	  && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
	{
	  gfc_error ("Numeric or CHARACTER operands are required in "
		     "expression at %L", &e->where);
         return FAILURE;
	}
      break;

    case INTRINSIC_PLUS:
    case INTRINSIC_MINUS:
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:
    case INTRINSIC_POWER:
      if ((*check_function) (op2) == FAILURE)
	return FAILURE;

      if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
	goto not_numeric;

      if (e->value.op.operator == INTRINSIC_POWER
	  && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
	{
	  gfc_error ("Exponent at %L must be INTEGER for an initialization "
		     "expression", &op2->where);
	  return FAILURE;
	}

      break;

    case INTRINSIC_CONCAT:
      if ((*check_function) (op2) == FAILURE)
	return FAILURE;

      if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
	{
	  gfc_error ("Concatenation operator in expression at %L "
		     "must have two CHARACTER operands", &op1->where);
	  return FAILURE;
	}

      if (op1->ts.kind != op2->ts.kind)
	{
	  gfc_error ("Concat operator at %L must concatenate strings of the "
		     "same kind", &e->where);
	  return FAILURE;
	}

      break;

    case INTRINSIC_NOT:
      if (et0 (op1) != BT_LOGICAL)
	{
	  gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
		     "operand", &op1->where);
	  return FAILURE;
	}

      break;

    case INTRINSIC_AND:
    case INTRINSIC_OR:
    case INTRINSIC_EQV:
    case INTRINSIC_NEQV:
      if ((*check_function) (op2) == FAILURE)
	return FAILURE;

      if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
	{
	  gfc_error ("LOGICAL operands are required in expression at %L",
		     &e->where);
	  return FAILURE;
	}

      break;

    case INTRINSIC_PARENTHESES:
      break;

    default:
      gfc_error ("Only intrinsic operators can be used in expression at %L",
		 &e->where);
      return FAILURE;
    }

  return SUCCESS;

not_numeric:
  gfc_error ("Numeric operands are required in expression at %L", &e->where);

  return FAILURE;
}



/* Certain inquiry functions are specifically allowed to have variable
   arguments, which is an exception to the normal requirement that an
   initialization function have initialization arguments.  We head off
   this problem here.  */

static try
check_inquiry (gfc_expr * e, int not_restricted)
{
  const char *name;

  /* FIXME: This should be moved into the intrinsic definitions,
     to eliminate this ugly hack.  */
  static const char * const inquiry_function[] = {
    "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
    "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
    "lbound", "ubound", NULL
  };

  int i;

  /* An undeclared parameter will get us here (PR25018).  */
  if (e->symtree == NULL)
    return FAILURE;

  name = e->symtree->n.sym->name;

  for (i = 0; inquiry_function[i]; i++)
    if (strcmp (inquiry_function[i], name) == 0)
      break;

  if (inquiry_function[i] == NULL)
    return FAILURE;

  e = e->value.function.actual->expr;

  if (e == NULL || e->expr_type != EXPR_VARIABLE)
    return FAILURE;

  /* At this point we have an inquiry function with a variable argument.  The
     type of the variable might be undefined, but we need it now, because the
     arguments of these functions are allowed to be undefined.  */

  if (e->ts.type == BT_UNKNOWN)
    {
      if (e->symtree->n.sym->ts.type == BT_UNKNOWN
	  && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
            == FAILURE)
	return FAILURE;

      e->ts = e->symtree->n.sym->ts;
    }

  /* Assumed character length will not reduce to a constant expression
     with LEN,as required by the standard.  */
  if (i == 4 && not_restricted
	&& e->symtree->n.sym->ts.type == BT_CHARACTER
	&& e->symtree->n.sym->ts.cl->length == NULL)
    gfc_notify_std (GFC_STD_GNU, "The F95 does not permit the assumed character "
		    "length variable '%s' in constant expression at %L.",
		    e->symtree->n.sym->name, &e->where);

  return SUCCESS;
}


/* Verify that an expression is an initialization expression.  A side
   effect is that the expression tree is reduced to a single constant
   node if all goes well.  This would normally happen when the
   expression is constructed but function references are assumed to be
   intrinsics in the context of initialization expressions.  If
   FAILURE is returned an error message has been generated.  */

static try
check_init_expr (gfc_expr * e)
{
  gfc_actual_arglist *ap;
  match m;
  try t;

  if (e == NULL)
    return SUCCESS;

  switch (e->expr_type)
    {
    case EXPR_OP:
      t = check_intrinsic_op (e, check_init_expr);
      if (t == SUCCESS)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_FUNCTION:
      t = SUCCESS;

      if (check_inquiry (e, 1) != SUCCESS)
	{
	  t = SUCCESS;
	  for (ap = e->value.function.actual; ap; ap = ap->next)
	    if (check_init_expr (ap->expr) == FAILURE)
	      {
		t = FAILURE;
		break;
	      }
	}

      if (t == SUCCESS)
	{
	  m = gfc_intrinsic_func_interface (e, 0);

	  if (m == MATCH_NO)
	    gfc_error ("Function '%s' in initialization expression at %L "
		       "must be an intrinsic function",
                       e->symtree->n.sym->name, &e->where);

	  if (m != MATCH_YES)
	    t = FAILURE;
	}

      break;

    case EXPR_VARIABLE:
      t = SUCCESS;

      if (gfc_check_iter_variable (e) == SUCCESS)
	break;

      if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
	{
	  t = simplify_parameter_variable (e, 0);
	  break;
	}

      gfc_error ("Parameter '%s' at %L has not been declared or is "
		 "a variable, which does not reduce to a constant "
		 "expression", e->symtree->n.sym->name, &e->where);
      t = FAILURE;
      break;

    case EXPR_CONSTANT:
    case EXPR_NULL:
      t = SUCCESS;
      break;

    case EXPR_SUBSTRING:
      t = check_init_expr (e->ref->u.ss.start);
      if (t == FAILURE)
	break;

      t = check_init_expr (e->ref->u.ss.end);
      if (t == SUCCESS)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_STRUCTURE:
      t = gfc_check_constructor (e, check_init_expr);
      break;

    case EXPR_ARRAY:
      t = gfc_check_constructor (e, check_init_expr);
      if (t == FAILURE)
	break;

      t = gfc_expand_constructor (e);
      if (t == FAILURE)
	break;

      t = gfc_check_constructor_type (e);
      break;

    default:
      gfc_internal_error ("check_init_expr(): Unknown expression type");
    }

  return t;
}


/* Match an initialization expression.  We work by first matching an
   expression, then reducing it to a constant.  */

match
gfc_match_init_expr (gfc_expr ** result)
{
  gfc_expr *expr;
  match m;
  try t;

  m = gfc_match_expr (&expr);
  if (m != MATCH_YES)
    return m;

  gfc_init_expr = 1;
  t = gfc_resolve_expr (expr);
  if (t == SUCCESS)
    t = check_init_expr (expr);
  gfc_init_expr = 0;

  if (t == FAILURE)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  if (expr->expr_type == EXPR_ARRAY
      && (gfc_check_constructor_type (expr) == FAILURE
	  || gfc_expand_constructor (expr) == FAILURE))
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* Not all inquiry functions are simplified to constant expressions
     so it is necessary to call check_inquiry again.  */ 
  if (!gfc_is_constant_expr (expr)
	&& check_inquiry (expr, 1) == FAILURE)
    {
      gfc_error ("Initialization expression didn't reduce %C");
      return MATCH_ERROR;
    }

  *result = expr;

  return MATCH_YES;
}



static try check_restricted (gfc_expr *);

/* Given an actual argument list, test to see that each argument is a
   restricted expression and optionally if the expression type is
   integer or character.  */

static try
restricted_args (gfc_actual_arglist * a)
{
  for (; a; a = a->next)
    {
      if (check_restricted (a->expr) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


/************* Restricted/specification expressions *************/


/* Make sure a non-intrinsic function is a specification function.  */

static try
external_spec_function (gfc_expr * e)
{
  gfc_symbol *f;

  f = e->value.function.esym;

  if (f->attr.proc == PROC_ST_FUNCTION)
    {
      gfc_error ("Specification function '%s' at %L cannot be a statement "
		 "function", f->name, &e->where);
      return FAILURE;
    }

  if (f->attr.proc == PROC_INTERNAL)
    {
      gfc_error ("Specification function '%s' at %L cannot be an internal "
		 "function", f->name, &e->where);
      return FAILURE;
    }

  if (!f->attr.pure)
    {
      gfc_error ("Specification function '%s' at %L must be PURE", f->name,
		 &e->where);
      return FAILURE;
    }

  if (f->attr.recursive)
    {
      gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
		 f->name, &e->where);
      return FAILURE;
    }

  return restricted_args (e->value.function.actual);
}


/* Check to see that a function reference to an intrinsic is a
   restricted expression.  */

static try
restricted_intrinsic (gfc_expr * e)
{
  /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
  if (check_inquiry (e, 0) == SUCCESS)
    return SUCCESS;

  return restricted_args (e->value.function.actual);
}


/* Verify that an expression is a restricted expression.  Like its
   cousin check_init_expr(), an error message is generated if we
   return FAILURE.  */

static try
check_restricted (gfc_expr * e)
{
  gfc_symbol *sym;
  try t;