resolve.c

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

  sym->attr.proc = PROC_EXTERNAL;
  expr->value.function.name = sym->name;
  expr->value.function.esym = expr->symtree->n.sym;

  if (sym->as != NULL)
    expr->rank = sym->as->rank;

  /* Type of the expression is either the type of the symbol or the
     default type of the symbol.  */

set_type:
  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

  if (sym->ts.type != BT_UNKNOWN)
    expr->ts = sym->ts;
  else
    {
      ts = gfc_get_default_type (sym, sym->ns);

      if (ts->type == BT_UNKNOWN)
	{
	  gfc_error ("Function '%s' at %L has no IMPLICIT type",
		     sym->name, &expr->where);
	  return FAILURE;
	}
      else
	expr->ts = *ts;
    }

  return SUCCESS;
}


/* Figure out if a function reference is pure or not.  Also set the name
   of the function for a potential error message.  Return nonzero if the
   function is PURE, zero if not.  */

static int
pure_function (gfc_expr * e, const char **name)
{
  int pure;

  if (e->value.function.esym)
    {
      pure = gfc_pure (e->value.function.esym);
      *name = e->value.function.esym->name;
    }
  else if (e->value.function.isym)
    {
      pure = e->value.function.isym->pure
	|| e->value.function.isym->elemental;
      *name = e->value.function.isym->name;
    }
  else
    {
      /* Implicit functions are not pure.  */
      pure = 0;
      *name = e->value.function.name;
    }

  return pure;
}


/* Resolve a function call, which means resolving the arguments, then figuring
   out which entity the name refers to.  */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
   to INTENT(OUT) or INTENT(INOUT).  */

static try
resolve_function (gfc_expr * expr)
{
  gfc_actual_arglist *arg;
  gfc_symbol * sym;
  const char *name;
  try t;
  int temp;

  sym = NULL;
  if (expr->symtree)
    sym = expr->symtree->n.sym;

  /* If the procedure is not internal, a statement function or a module
     procedure,it must be external and should be checked for usage.  */
  if (sym && !sym->attr.dummy && !sym->attr.contained
	&& sym->attr.proc != PROC_ST_FUNCTION
	&& !sym->attr.use_assoc)
    resolve_global_procedure (sym, &expr->where, 0);

  /* Switch off assumed size checking and do this again for certain kinds
     of procedure, once the procedure itself is resolved.  */
  need_full_assumed_size++;

  if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
    return FAILURE;

  /* Resume assumed_size checking. */
  need_full_assumed_size--;

  if (sym && sym->ts.type == BT_CHARACTER
	  && sym->ts.cl && sym->ts.cl->length == NULL)
    {
      if (sym->attr.if_source == IFSRC_IFBODY)
	{
	  /* This follows from a slightly odd requirement at 5.1.1.5 in the
	     standard that allows assumed character length functions to be
	     declared in interfaces but not used.  Picking up the symbol here,
	     rather than resolve_symbol, accomplishes that.  */
	  gfc_error ("Function '%s' can be declared in an interface to "
		     "return CHARACTER(*) but cannot be used at %L",
		     sym->name, &expr->where);
	  return FAILURE;
	}

      /* Internal procedures are taken care of in resolve_contained_fntype.  */
      if (!sym->attr.dummy && !sym->attr.contained)
	{
	  gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
		     "be used at %L since it is not a dummy argument",
		     sym->name, &expr->where);
	  return FAILURE;
	}
    }

/* See if function is already resolved.  */

  if (expr->value.function.name != NULL)
    {
      if (expr->ts.type == BT_UNKNOWN)
	expr->ts = sym->ts;
      t = SUCCESS;
    }
  else
    {
      /* Apply the rules of section 14.1.2.  */

      switch (procedure_kind (sym))
	{
	case PTYPE_GENERIC:
	  t = resolve_generic_f (expr);
	  break;

	case PTYPE_SPECIFIC:
	  t = resolve_specific_f (expr);
	  break;

	case PTYPE_UNKNOWN:
	  t = resolve_unknown_f (expr);
	  break;

	default:
	  gfc_internal_error ("resolve_function(): bad function type");
	}
    }

  /* If the expression is still a function (it might have simplified),
     then we check to see if we are calling an elemental function.  */

  if (expr->expr_type != EXPR_FUNCTION)
    return t;

  temp = need_full_assumed_size;
  need_full_assumed_size = 0;

  if (expr->value.function.actual != NULL
      && ((expr->value.function.esym != NULL
	   && expr->value.function.esym->attr.elemental)
	  || (expr->value.function.isym != NULL
	      && expr->value.function.isym->elemental)))
    {

      /* The rank of an elemental is the rank of its array argument(s).  */
      for (arg = expr->value.function.actual; arg; arg = arg->next)
	{
	  if (arg->expr != NULL && arg->expr->rank > 0)
	    {
	      expr->rank = arg->expr->rank;
	      break;
	    }
	}

      /* Being elemental, the last upper bound of an assumed size array
	 argument must be present.  */
      for (arg = expr->value.function.actual; arg; arg = arg->next)
	{
	  if (arg->expr != NULL
		&& arg->expr->rank > 0
		&& resolve_assumed_size_actual (arg->expr))
	    return FAILURE;
	}
    }

  else if (expr->value.function.actual != NULL
	     && expr->value.function.isym != NULL
	     && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
	     && expr->value.function.isym->generic_id != GFC_ISYM_LOC
	     && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
    {
      /* Array instrinsics must also have the last upper bound of an
	 asumed size array argument.  UBOUND and SIZE have to be
	 excluded from the check if the second argument is anything
	 than a constant.  */
      int inquiry;
      inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
		  || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
	    
      for (arg = expr->value.function.actual; arg; arg = arg->next)
	{
	  if (inquiry && arg->next != NULL && arg->next->expr
		&& arg->next->expr->expr_type != EXPR_CONSTANT)
	    break;
	  
	  if (arg->expr != NULL
		&& arg->expr->rank > 0
		&& resolve_assumed_size_actual (arg->expr))
	    return FAILURE;
	}
    }

  need_full_assumed_size = temp;

  if (!pure_function (expr, &name))
    {
      if (forall_flag)
	{
	  gfc_error
	    ("Function reference to '%s' at %L is inside a FORALL block",
	     name, &expr->where);
	  t = FAILURE;
	}
      else if (gfc_pure (NULL))
	{
	  gfc_error ("Function reference to '%s' at %L is to a non-PURE "
		     "procedure within a PURE procedure", name, &expr->where);
	  t = FAILURE;
	}
    }

  /* Character lengths of use associated functions may contains references to
     symbols not referenced from the current program unit otherwise.  Make sure
     those symbols are marked as referenced.  */

  if (expr->ts.type == BT_CHARACTER && expr->value.function.esym 
      && expr->value.function.esym->attr.use_assoc)
    {
      gfc_expr_set_symbols_referenced (expr->ts.cl->length);
    }

  return t;
}


/************* Subroutine resolution *************/

static void
pure_subroutine (gfc_code * c, gfc_symbol * sym)
{

  if (gfc_pure (sym))
    return;

  if (forall_flag)
    gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
	       sym->name, &c->loc);
  else if (gfc_pure (NULL))
    gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
	       &c->loc);
}


static match
resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
{
  gfc_symbol *s;

  if (sym->attr.generic)
    {
      s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
      if (s != NULL)
	{
          c->resolved_sym = s;
	  pure_subroutine (c, s);
	  return MATCH_YES;
	}

      /* TODO: Need to search for elemental references in generic interface.  */
    }

  if (sym->attr.intrinsic)
    return gfc_intrinsic_sub_interface (c, 0);

  return MATCH_NO;
}


static try
resolve_generic_s (gfc_code * c)
{
  gfc_symbol *sym;
  match m;

  sym = c->symtree->n.sym;

  m = resolve_generic_s0 (c, sym);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_ERROR)
    return FAILURE;

  if (sym->ns->parent != NULL)
    {
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
      if (sym != NULL)
	{
	  m = resolve_generic_s0 (c, sym);
	  if (m == MATCH_YES)
	    return SUCCESS;
	  if (m == MATCH_ERROR)
	    return FAILURE;
	}
    }

  /* Last ditch attempt.  */

  if (!gfc_generic_intrinsic (sym->name))
    {
      gfc_error
	("Generic subroutine '%s' at %L is not an intrinsic subroutine",
	 sym->name, &c->loc);
      return FAILURE;
    }

  m = gfc_intrinsic_sub_interface (c, 0);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_NO)
    gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
	       "intrinsic subroutine interface", sym->name, &c->loc);

  return FAILURE;
}


/* Resolve a subroutine call known to be specific.  */

static match
resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
{
  match m;

  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
    {
      if (sym->attr.dummy)
	{
	  sym->attr.proc = PROC_DUMMY;
	  goto found;
	}

      sym->attr.proc = PROC_EXTERNAL;
      goto found;
    }

  if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
    goto found;

  if (sym->attr.intrinsic)
    {
      m = gfc_intrinsic_sub_interface (c, 1);
      if (m == MATCH_YES)
	return MATCH_YES;
      if (m == MATCH_NO)
	gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
		   "with an intrinsic", sym->name, &c->loc);

      return MATCH_ERROR;
    }

  return MATCH_NO;

found:
  gfc_procedure_use (sym, &c->ext.actual, &c->loc);

  c->resolved_sym = sym;
  pure_subroutine (c, sym);

  return MATCH_YES;
}


static try
resolve_specific_s (gfc_code * c)
{
  gfc_symbol *sym;
  match m;

  sym = c->symtree->n.sym;

  m = resolve_specific_s0 (c, sym);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_ERROR)
    return FAILURE;

  gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

  if (sym != NULL)
    {
      m = resolve_specific_s0 (c, sym);
      if (m == MATCH_YES)
	return SUCCESS;
      if (m == MATCH_ERROR)
	return FAILURE;
    }

  gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
	     sym->name, &c->loc);

  return FAILURE;
}


/* Resolve a subroutine call not known to be generic nor specific.  */

static try
resolve_unknown_s (gfc_code * c)
{
  gfc_symbol *sym;

  sym = c->symtree->n.sym;

  if (sym->attr.dummy)
    {
      sym->attr.proc = PROC_DUMMY;
      goto found;
    }

  /* See if we have an intrinsic function reference.  */

  if (gfc_intrinsic_name (sym->name, 1))
    {
      if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
	return SUCCESS;
      return FAILURE;
    }

  /* The reference is to an external name.  */

found:
  gfc_procedure_use (sym, &c->ext.actual, &c->loc);

  c->resolved_sym = sym;

  pure_subroutine (c, sym);

  return SUCCESS;
}


/* Resolve a subroutine call.  Although it was tempting to use the same code
   for functions, subroutines and functions are stored differently and this
   makes things awkward.  */

static try
resolve_call (gfc_code * c)
{
  try t;

  if (c->symtree && c->symtree->n.sym
	&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
    {
      gfc_error ("'%s' at %L has a type, which is not consistent with "
		 "the CALL at %L", c->symtree->n.sym->name,
		 &c->symtree->n.sym->declared_at, &c->loc);
      return FAILURE;
    }

  /* If the procedure is not internal or module, it must be external and
     should be checked for usage.  */
  if (c->symtree && c->symtree->n.sym
	&& !c->symtree->n.sym->attr.dummy
	&& !c->symtree->n.sym->attr.contained
	&& !c->symtree->n.sym->attr.use_assoc)
    resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);

  /* Switch off assumed size checking and do this again for certain kinds
     of procedure, once the procedure itself is resolved.  */
  need_full_assumed_size++;

  if (resolve_actual_arglist (c->ext.actual) == FAILURE)
    return FAILURE;

  /* Resume assumed_size checking. */
  need_full_assumed_size--;

  if (c->resolved_sym != NULL)
    return SUCCESS;

  switch (procedure_kind (c->symtree->n.sym))
    {
    case PTYPE_GENERIC:
      t = resolve_generic_s (c);
      break;

    case PTYPE_SPECIFIC:
      t = resolve_specific_s (c);
      break;

    case PTYPE_UNKNOWN:
      t = resolve_unknown_s (c);
      break;

    default:
      gfc_internal_error ("resolve_subroutine(): bad function type");
    }

  if (c->ext.actual != NULL
      && c->symtree->n.sym->attr.elemental)
    {
      gfc_actual_arglist * a;
      /* Being elemental, the last upper bound of an assumed size array
	 argument must be present.  */
      for (a = c->ext.actual; a; a = a->next)
	{
	  if (a->expr != NULL
		&& a->expr->rank > 0
		&& resolve_assumed_size_actual (a->expr))
	    return FAILURE;
	}
    }

  return t;
}

/* Compare the shapes of two arrays that have non-NULL shapes.  If both
   op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
   match.  If both op1->shape and op2->shape are non-NULL return FAILURE
   if their shapes do not match.  If either op1->shape or op2->shape is
   NULL, return SUCCESS.  */

static try
compare_shapes (gfc_expr * op1, gfc_expr * op2)
{
  try t;
  int i;

  t = SUCCESS;
		  
  if (op1->shape != NULL && op2->shape != NULL)
    {
      for (i = 0; i < op1->rank; i++)
	{