interface.c

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

	  if (where)
	    gfc_error ("Actual argument for '%s' must be a pointer at %L",
		       f->sym->name, &a->expr->where);
	  return 0;
	}

      /* Check intent = OUT/INOUT for definable actual argument.  */
      if (a->expr->expr_type != EXPR_VARIABLE
	     && (f->sym->attr.intent == INTENT_OUT
		   || f->sym->attr.intent == INTENT_INOUT))
	{
	  gfc_error ("Actual argument at %L must be definable to "
		     "match dummy INTENT = OUT/INOUT", &a->expr->where);
          return 0;
        }

    match:
      if (a == actual)
	na = i;

      new[i++] = a;
    }

  /* Make sure missing actual arguments are optional.  */
  i = 0;
  for (f = formal; f; f = f->next, i++)
    {
      if (new[i] != NULL)
	continue;
      if (!f->sym->attr.optional)
	{
	  if (where)
	    gfc_error ("Missing actual argument for argument '%s' at %L",
		       f->sym->name, where);
	  return 0;
	}
    }

  /* The argument lists are compatible.  We now relink a new actual
     argument list with null arguments in the right places.  The head
     of the list remains the head.  */
  for (i = 0; i < n; i++)
    if (new[i] == NULL)
      new[i] = gfc_get_actual_arglist ();

  if (na != 0)
    {
      temp = *new[0];
      *new[0] = *actual;
      *actual = temp;

      a = new[0];
      new[0] = new[na];
      new[na] = a;
    }

  for (i = 0; i < n - 1; i++)
    new[i]->next = new[i + 1];

  new[i]->next = NULL;

  if (*ap == NULL && n > 0)
    *ap = new[0];

  /* Note the types of omitted optional arguments.  */
  for (a = actual, f = formal; a; a = a->next, f = f->next)
    if (a->expr == NULL && a->label == NULL)
      a->missing_arg_type = f->sym->ts.type;

  return 1;
}


typedef struct
{
  gfc_formal_arglist *f;
  gfc_actual_arglist *a;
}
argpair;

/* qsort comparison function for argument pairs, with the following
   order:
    - p->a->expr == NULL
    - p->a->expr->expr_type != EXPR_VARIABLE
    - growing p->a->expr->symbol.  */

static int
pair_cmp (const void *p1, const void *p2)
{
  const gfc_actual_arglist *a1, *a2;

  /* *p1 and *p2 are elements of the to-be-sorted array.  */
  a1 = ((const argpair *) p1)->a;
  a2 = ((const argpair *) p2)->a;
  if (!a1->expr)
    {
      if (!a2->expr)
	return 0;
      return -1;
    }
  if (!a2->expr)
    return 1;
  if (a1->expr->expr_type != EXPR_VARIABLE)
    {
      if (a2->expr->expr_type != EXPR_VARIABLE)
	return 0;
      return -1;
    }
  if (a2->expr->expr_type != EXPR_VARIABLE)
    return 1;
  return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
}


/* Given two expressions from some actual arguments, test whether they
   refer to the same expression. The analysis is conservative.
   Returning FAILURE will produce no warning.  */

static try
compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
{
  const gfc_ref *r1, *r2;

  if (!e1 || !e2
      || e1->expr_type != EXPR_VARIABLE
      || e2->expr_type != EXPR_VARIABLE
      || e1->symtree->n.sym != e2->symtree->n.sym)
    return FAILURE;

  /* TODO: improve comparison, see expr.c:show_ref().  */
  for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
    {
      if (r1->type != r2->type)
	return FAILURE;
      switch (r1->type)
	{
	case REF_ARRAY:
	  if (r1->u.ar.type != r2->u.ar.type)
	    return FAILURE;
	  /* TODO: At the moment, consider only full arrays;
	     we could do better.  */
	  if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
	    return FAILURE;
	  break;

	case REF_COMPONENT:
	  if (r1->u.c.component != r2->u.c.component)
	    return FAILURE;
	  break;

	case REF_SUBSTRING:
	  return FAILURE;

	default:
	  gfc_internal_error ("compare_actual_expr(): Bad component code");
	}
    }
  if (!r1 && !r2)
    return SUCCESS;
  return FAILURE;
}

/* Given formal and actual argument lists that correspond to one
   another, check that identical actual arguments aren't not
   associated with some incompatible INTENTs.  */

static try
check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
  sym_intent f1_intent, f2_intent;
  gfc_formal_arglist *f1;
  gfc_actual_arglist *a1;
  size_t n, i, j;
  argpair *p;
  try t = SUCCESS;

  n = 0;
  for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
    {
      if (f1 == NULL && a1 == NULL)
	break;
      if (f1 == NULL || a1 == NULL)
	gfc_internal_error ("check_some_aliasing(): List mismatch");
      n++;
    }
  if (n == 0)
    return t;
  p = (argpair *) alloca (n * sizeof (argpair));

  for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
    {
      p[i].f = f1;
      p[i].a = a1;
    }

  qsort (p, n, sizeof (argpair), pair_cmp);

  for (i = 0; i < n; i++)
    {
      if (!p[i].a->expr
	  || p[i].a->expr->expr_type != EXPR_VARIABLE
	  || p[i].a->expr->ts.type == BT_PROCEDURE)
	continue;
      f1_intent = p[i].f->sym->attr.intent;
      for (j = i + 1; j < n; j++)
	{
	  /* Expected order after the sort.  */
	  if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
	    gfc_internal_error ("check_some_aliasing(): corrupted data");

	  /* Are the expression the same?  */
	  if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
	    break;
	  f2_intent = p[j].f->sym->attr.intent;
	  if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
	      || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
	    {
	      gfc_warning ("Same actual argument associated with INTENT(%s) "
			   "argument '%s' and INTENT(%s) argument '%s' at %L",
			   gfc_intent_string (f1_intent), p[i].f->sym->name,
			   gfc_intent_string (f2_intent), p[j].f->sym->name,
			   &p[i].a->expr->where);
	      t = FAILURE;
	    }
	}
    }

  return t;
}


/* Given formal and actual argument lists that correspond to one
   another, check that they are compatible in the sense that intents
   are not mismatched.  */

static try
check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
  sym_intent a_intent, f_intent;

  for (;; f = f->next, a = a->next)
    {
      if (f == NULL && a == NULL)
	break;
      if (f == NULL || a == NULL)
	gfc_internal_error ("check_intents(): List mismatch");

      if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
	continue;

      a_intent = a->expr->symtree->n.sym->attr.intent;
      f_intent = f->sym->attr.intent;

      if (a_intent == INTENT_IN
	  && (f_intent == INTENT_INOUT
	      || f_intent == INTENT_OUT))
	{

	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
		     "specifies INTENT(%s)", &a->expr->where,
		     gfc_intent_string (f_intent));
	  return FAILURE;
	}

      if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
	{
	  if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
	    {
	      gfc_error
		("Procedure argument at %L is local to a PURE procedure and "
		 "is passed to an INTENT(%s) argument", &a->expr->where,
		 gfc_intent_string (f_intent));
	      return FAILURE;
	    }

	  if (a->expr->symtree->n.sym->attr.pointer)
	    {
	      gfc_error
		("Procedure argument at %L is local to a PURE procedure and "
		 "has the POINTER attribute", &a->expr->where);
	      return FAILURE;
	    }
	}
    }

  return SUCCESS;
}


/* Check how a procedure is used against its interface.  If all goes
   well, the actual argument list will also end up being properly
   sorted.  */

void
gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
{
  int ranks_must_agree;
  ranks_must_agree = !sym->attr.elemental && (sym->attr.contained
			|| sym->attr.if_source == IFSRC_IFBODY);

  /* Warn about calls with an implicit interface.  */
  if (gfc_option.warn_implicit_interface
      && sym->attr.if_source == IFSRC_UNKNOWN)
    gfc_warning ("Procedure '%s' called with an implicit interface at %L",
                 sym->name, where);

  if (sym->attr.if_source == IFSRC_UNKNOWN
      || !compare_actual_formal (ap, sym->formal, ranks_must_agree,
				 sym->attr.elemental, where))
    return;

  check_intents (sym->formal, *ap);
  if (gfc_option.warn_aliasing)
    check_some_aliasing (sym->formal, *ap);
}


/* Given an interface pointer and an actual argument list, search for
   a formal argument list that matches the actual.  If found, returns
   a pointer to the symbol of the correct interface.  Returns NULL if
   not found.  */

gfc_symbol *
gfc_search_interface (gfc_interface * intr, int sub_flag,
		      gfc_actual_arglist ** ap)
{
  int r;

  for (; intr; intr = intr->next)
    {
      if (sub_flag && intr->sym->attr.function)
	continue;
      if (!sub_flag && intr->sym->attr.subroutine)
	continue;

      r = !intr->sym->attr.elemental;

      if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
	{
	  check_intents (intr->sym->formal, *ap);
	  if (gfc_option.warn_aliasing)
	    check_some_aliasing (intr->sym->formal, *ap);
	  return intr->sym;
	}
    }

  return NULL;
}


/* Do a brute force recursive search for a symbol.  */

static gfc_symtree *
find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
{
  gfc_symtree * st;

  if (root->n.sym == sym)
    return root;

  st = NULL;
  if (root->left)
    st = find_symtree0 (root->left, sym);
  if (root->right && ! st)
    st = find_symtree0 (root->right, sym);
  return st;
}


/* Find a symtree for a symbol.  */

static gfc_symtree *
find_sym_in_symtree (gfc_symbol * sym)
{
  gfc_symtree *st;
  gfc_namespace *ns;

  /* First try to find it by name.  */
  gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
  if (st && st->n.sym == sym)
    return st;

  /* if it's been renamed, resort to a brute-force search.  */
  /* TODO: avoid having to do this search.  If the symbol doesn't exist
     in the symtree for the current namespace, it should probably be added.  */
  for (ns = gfc_current_ns; ns; ns = ns->parent)
    {
      st = find_symtree0 (ns->sym_root, sym);
      if (st)
        return st;
    }
  gfc_internal_error ("Unable to find symbol %s", sym->name);
  /* Not reached */
}


/* This subroutine is called when an expression is being resolved.
   The expression node in question is either a user defined operator
   or an intrinsic operator with arguments that aren't compatible
   with the operator.  This subroutine builds an actual argument list
   corresponding to the operands, then searches for a compatible
   interface.  If one is found, the expression node is replaced with
   the appropriate function call.  */

try
gfc_extend_expr (gfc_expr * e)
{
  gfc_actual_arglist *actual;
  gfc_symbol *sym;
  gfc_namespace *ns;
  gfc_user_op *uop;
  gfc_intrinsic_op i;

  sym = NULL;

  actual = gfc_get_actual_arglist ();
  actual->expr = e->value.op.op1;

  if (e->value.op.op2 != NULL)
    {
      actual->next = gfc_get_actual_arglist ();
      actual->next->expr = e->value.op.op2;
    }

  i = fold_unary (e->value.op.operator);

  if (i == INTRINSIC_USER)
    {
      for (ns = gfc_current_ns; ns; ns = ns->parent)
	{
	  uop = gfc_find_uop (e->value.op.uop->name, ns);
	  if (uop == NULL)
	    continue;

	  sym = gfc_search_interface (uop->operator, 0, &actual);
	  if (sym != NULL)
	    break;
	}
    }
  else
    {
      for (ns = gfc_current_ns; ns; ns = ns->parent)
	{
	  sym = gfc_search_interface (ns->operator[i], 0, &actual);
	  if (sym != NULL)
	    break;
	}
    }

  if (sym == NULL)
    {
      /* Don't use gfc_free_actual_arglist() */
      if (actual->next != NULL)
	gfc_free (actual->next);
      gfc_free (actual);

      return FAILURE;
    }

  /* Change the expression node to a function call.  */
  e->expr_type = EXPR_FUNCTION;
  e->symtree = find_sym_in_symtree (sym);
  e->value.function.actual = actual;
  e->value.function.esym = NULL;
  e->value.function.isym = NULL;
  e->value.function.name = NULL;

  if (gfc_pure (NULL) && !gfc_pure (sym))
    {
      gfc_error
	("Function '%s' called in lieu of an operator at %L must be PURE",
	 sym->name, &e->where);
      return FAILURE;
    }

  if (gfc_resolve_expr (e) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* Tries to replace an assignment code node with a subroutine call to
   the subroutine associated with the assignment operator.  Return
   SUCCESS if the node was replaced.  On FAILURE, no error is
   generated.  */

try
gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
{
  gfc_actual_arglist *actual;
  gfc_expr *lhs, *rhs;
  gfc_symbol *sym;

  lhs = c->expr;
  rhs = c->expr2;

  /* Don't allow an intrinsic assignment to be replaced.  */
  if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
      && (lhs->ts.type == rhs->ts.type
          || (gfc_numeric_ts (&lhs->ts)
	      && gfc_numeric_ts (&rhs->ts))))
    return FAILURE;

  actual = gfc_get_actual_arglist ();
  actual->expr = lhs;

  actual->next = gfc_get_actual_arglist ();
  actual->next->expr = rhs;

  sym = NULL;

  for (; ns; ns = ns->parent)
    {
      sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
      if (sym != NULL)
	break;
    }

  if (sym == NULL)
    {
      gfc_free (actual->next);
      gfc_free (actual);
      return FAILURE;
    }

  /* Replace the assignment with the call.  */
  c->op = EXEC_CALL;
  c->symtree = find_sym_in_symtree (sym);
  c->expr = NULL;
  c->expr2 = NULL;
  c->ext.actual = actual;

  return SUCCESS;
}


/* Make sure that the interface just parsed is not already present in
   the given interface list.  Ambiguity isn't checked yet since module
   procedures can be present without interfaces.  */

static try
check_new_interface (gfc_interface * base, gfc_symbol * new)
{
  gfc_interface *ip;

  for (ip = base; ip; ip = ip->next)
    {
      if (ip->sym == new)
	{
	  gfc_error ("Entity '%s' at %C is already present in the interface",
		     new->name);
	  return FAILURE;
	}
    }

  return SUCCESS;
}


/* Add a symbol to the current interface.  */

try
gfc_add_interface (gfc_symbol * new)
{
  gfc_interface **head, *intr;
  gfc_namespace *ns;
  gfc_symbol *sym;

  switch (current_interface.type)
    {
    case INTERFACE_NAMELESS:
      return SUCCESS;

    case INTERFACE_INTRINSIC_OP:
      for (ns = current_interface.ns; ns; ns = ns->parent)
	if (check_new_interface (ns->operator[current_interface.op], new)
	    == FAILURE)
	  return FAILURE;

      head = &current_interface.ns->operator[current_interface.op];
      break;

    case INTERFACE_GENERIC:
      for (ns = current_interface.ns; ns; ns = ns->parent)
	{
	  gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
	  if (sym == NULL)
	    continue;

	  if (check_new_interface (sym->generic, new) == FAILURE)
	    return FAILURE;
	}

      head = &current_interface.sym->generic;
      break;

    case INTERFACE_USER_OP:
      if (check_new_interface (current_interface.uop->operator, new) ==
	  FAILURE)
	return FAILURE;

      head = &current_interface.uop->operator;
      break;

    default:
      gfc_internal_error ("gfc_add_interface(): Bad interface type");
    }

  intr = gfc_get_interface ();
  intr->sym = new;
  intr->where = gfc_current_locus;

  intr->next = *head;
  *head = intr;

  return SUCCESS;
}


/* Gets rid of a formal argument list.  We do not free symbols.
   Symbols are freed when a namespace is freed.  */

void
gfc_free_formal_arglist (gfc_formal_arglist * p)
{
  gfc_formal_arglist *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free (p);
    }
}