interface.c

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

  return;

bad_repl:
  gfc_error ("Operator interface at %L conflicts with intrinsic interface",
	     &intr->where);
  return;

num_args:
  gfc_error ("Operator interface at %L has the wrong number of arguments",
	     &intr->where);
  return;
}


/* Given a pair of formal argument lists, we see if the two lists can
   be distinguished by counting the number of nonoptional arguments of
   a given type/rank in f1 and seeing if there are less then that
   number of those arguments in f2 (including optional arguments).
   Since this test is asymmetric, it has to be called twice to make it
   symmetric.  Returns nonzero if the argument lists are incompatible
   by this test.  This subroutine implements rule 1 of section
   14.1.2.3.  */

static int
count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
{
  int rc, ac1, ac2, i, j, k, n1;
  gfc_formal_arglist *f;

  typedef struct
  {
    int flag;
    gfc_symbol *sym;
  }
  arginfo;

  arginfo *arg;

  n1 = 0;

  for (f = f1; f; f = f->next)
    n1++;

  /* Build an array of integers that gives the same integer to
     arguments of the same type/rank.  */
  arg = gfc_getmem (n1 * sizeof (arginfo));

  f = f1;
  for (i = 0; i < n1; i++, f = f->next)
    {
      arg[i].flag = -1;
      arg[i].sym = f->sym;
    }

  k = 0;

  for (i = 0; i < n1; i++)
    {
      if (arg[i].flag != -1)
	continue;

      if (arg[i].sym->attr.optional)
	continue;		/* Skip optional arguments */

      arg[i].flag = k;

      /* Find other nonoptional arguments of the same type/rank.  */
      for (j = i + 1; j < n1; j++)
	if (!arg[j].sym->attr.optional
	    && compare_type_rank_if (arg[i].sym, arg[j].sym))
	  arg[j].flag = k;

      k++;
    }

  /* Now loop over each distinct type found in f1.  */
  k = 0;
  rc = 0;

  for (i = 0; i < n1; i++)
    {
      if (arg[i].flag != k)
	continue;

      ac1 = 1;
      for (j = i + 1; j < n1; j++)
	if (arg[j].flag == k)
	  ac1++;

      /* Count the number of arguments in f2 with that type, including
         those that are optional.  */
      ac2 = 0;

      for (f = f2; f; f = f->next)
	if (compare_type_rank_if (arg[i].sym, f->sym))
	  ac2++;

      if (ac1 > ac2)
	{
	  rc = 1;
	  break;
	}

      k++;
    }

  gfc_free (arg);

  return rc;
}


/* Perform the abbreviated correspondence test for operators.  The
   arguments cannot be optional and are always ordered correctly,
   which makes this test much easier than that for generic tests.

   This subroutine is also used when comparing a formal and actual
   argument list when an actual parameter is a dummy procedure.  At
   that point, two formal interfaces must be compared for equality
   which is what happens here.  */

static int
operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
{
  for (;;)
    {
      if (f1 == NULL && f2 == NULL)
	break;
      if (f1 == NULL || f2 == NULL)
	return 1;

      if (!compare_type_rank (f1->sym, f2->sym))
	return 1;

      f1 = f1->next;
      f2 = f2->next;
    }

  return 0;
}


/* Perform the correspondence test in rule 2 of section 14.1.2.3.
   Returns zero if no argument is found that satisfies rule 2, nonzero
   otherwise.

   This test is also not symmetric in f1 and f2 and must be called
   twice.  This test finds problems caused by sorting the actual
   argument list with keywords.  For example:

   INTERFACE FOO
       SUBROUTINE F1(A, B)
           INTEGER :: A ; REAL :: B
       END SUBROUTINE F1

       SUBROUTINE F2(B, A)
           INTEGER :: A ; REAL :: B
       END SUBROUTINE F1
   END INTERFACE FOO

   At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */

static int
generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
{

  gfc_formal_arglist *f2_save, *g;
  gfc_symbol *sym;

  f2_save = f2;

  while (f1)
    {
      if (f1->sym->attr.optional)
	goto next;

      if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
	goto next;

      /* Now search for a disambiguating keyword argument starting at
         the current non-match.  */
      for (g = f1; g; g = g->next)
	{
	  if (g->sym->attr.optional)
	    continue;

	  sym = find_keyword_arg (g->sym->name, f2_save);
	  if (sym == NULL || !compare_type_rank (g->sym, sym))
	    return 1;
	}

    next:
      f1 = f1->next;
      if (f2 != NULL)
	f2 = f2->next;
    }

  return 0;
}


/* 'Compare' two formal interfaces associated with a pair of symbols.
   We return nonzero if there exists an actual argument list that
   would be ambiguous between the two interfaces, zero otherwise.  */

static int
compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
{
  gfc_formal_arglist *f1, *f2;

  if (s1->attr.function != s2->attr.function
      && s1->attr.subroutine != s2->attr.subroutine)
    return 0;			/* disagreement between function/subroutine */

  f1 = s1->formal;
  f2 = s2->formal;

  if (f1 == NULL && f2 == NULL)
    return 1;			/* Special case */

  if (count_types_test (f1, f2))
    return 0;
  if (count_types_test (f2, f1))
    return 0;

  if (generic_flag)
    {
      if (generic_correspondence (f1, f2))
	return 0;
      if (generic_correspondence (f2, f1))
	return 0;
    }
  else
    {
      if (operator_correspondence (f1, f2))
	return 0;
    }

  return 1;
}


/* Given a pointer to an interface pointer, remove duplicate
   interfaces and make sure that all symbols are either functions or
   subroutines.  Returns nonzero if something goes wrong.  */

static int
check_interface0 (gfc_interface * p, const char *interface_name)
{
  gfc_interface *psave, *q, *qlast;

  psave = p;
  /* Make sure all symbols in the interface have been defined as
     functions or subroutines.  */
  for (; p; p = p->next)
    if (!p->sym->attr.function && !p->sym->attr.subroutine)
      {
	gfc_error ("Procedure '%s' in %s at %L is neither function nor "
		   "subroutine", p->sym->name, interface_name,
		   &p->sym->declared_at);
	return 1;
      }
  p = psave;

  /* Remove duplicate interfaces in this interface list.  */
  for (; p; p = p->next)
    {
      qlast = p;

      for (q = p->next; q;)
	{
	  if (p->sym != q->sym)
	    {
	      qlast = q;
	      q = q->next;

	    }
	  else
	    {
	      /* Duplicate interface */
	      qlast->next = q->next;
	      gfc_free (q);
	      q = qlast->next;
	    }
	}
    }

  return 0;
}


/* Check lists of interfaces to make sure that no two interfaces are
   ambiguous.  Duplicate interfaces (from the same symbol) are OK
   here.  */

static int
check_interface1 (gfc_interface * p, gfc_interface * q,
		  int generic_flag, const char *interface_name)
{

  for (; p; p = p->next)
    for (; q; q = q->next)
      {
	if (p->sym == q->sym)
	  continue;		/* Duplicates OK here */

	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
	  continue;

	if (compare_interfaces (p->sym, q->sym, generic_flag))
	  {
	    gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
		       p->sym->name, q->sym->name, interface_name, &p->where);
	    return 1;
	  }
      }

  return 0;
}


/* Check the generic and operator interfaces of symbols to make sure
   that none of the interfaces conflict.  The check has to be done
   after all of the symbols are actually loaded.  */

static void
check_sym_interfaces (gfc_symbol * sym)
{
  char interface_name[100];
  gfc_symbol *s2;

  if (sym->ns != gfc_current_ns)
    return;

  if (sym->generic != NULL)
    {
      sprintf (interface_name, "generic interface '%s'", sym->name);
      if (check_interface0 (sym->generic, interface_name))
	return;

      s2 = sym;
      while (s2 != NULL)
	{
	  if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
	    return;

	  if (s2->ns->parent == NULL)
	    break;
	  if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
	    break;
	}
    }
}


static void
check_uop_interfaces (gfc_user_op * uop)
{
  char interface_name[100];
  gfc_user_op *uop2;
  gfc_namespace *ns;

  sprintf (interface_name, "operator interface '%s'", uop->name);
  if (check_interface0 (uop->operator, interface_name))
    return;

  for (ns = gfc_current_ns; ns; ns = ns->parent)
    {
      uop2 = gfc_find_uop (uop->name, ns);
      if (uop2 == NULL)
	continue;

      check_interface1 (uop->operator, uop2->operator, 0, interface_name);
    }
}


/* For the namespace, check generic, user operator and intrinsic
   operator interfaces for consistency and to remove duplicate
   interfaces.  We traverse the whole namespace, counting on the fact
   that most symbols will not have generic or operator interfaces.  */

void
gfc_check_interfaces (gfc_namespace * ns)
{
  gfc_namespace *old_ns, *ns2;
  char interface_name[100];
  gfc_intrinsic_op i;

  old_ns = gfc_current_ns;
  gfc_current_ns = ns;

  gfc_traverse_ns (ns, check_sym_interfaces);

  gfc_traverse_user_op (ns, check_uop_interfaces);

  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    {
      if (i == INTRINSIC_USER)
	continue;

      if (i == INTRINSIC_ASSIGN)
	strcpy (interface_name, "intrinsic assignment operator");
      else
	sprintf (interface_name, "intrinsic '%s' operator",
		 gfc_op2string (i));

      if (check_interface0 (ns->operator[i], interface_name))
	continue;

      check_operator_interface (ns->operator[i], i);

      for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
	if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
			      interface_name))
	  break;
    }

  gfc_current_ns = old_ns;
}


static int
symbol_rank (gfc_symbol * sym)
{

  return (sym->as == NULL) ? 0 : sym->as->rank;
}


/* Given a symbol of a formal argument list and an expression, if the
   formal argument is a pointer, see if the actual argument is a
   pointer. Returns nonzero if compatible, zero if not compatible.  */

static int
compare_pointer (gfc_symbol * formal, gfc_expr * actual)
{
  symbol_attribute attr;

  if (formal->attr.pointer)
    {
      attr = gfc_expr_attr (actual);
      if (!attr.pointer)
	return 0;
    }

  return 1;
}


/* Given a symbol of a formal argument list and an expression, see if
   the two are compatible as arguments.  Returns nonzero if
   compatible, zero if not compatible.  */

static int
compare_parameter (gfc_symbol * formal, gfc_expr * actual,
		   int ranks_must_agree, int is_elemental)
{
  gfc_ref *ref;

  if (actual->ts.type == BT_PROCEDURE)
    {
      if (formal->attr.flavor != FL_PROCEDURE)
	return 0;

      if (formal->attr.function
	  && !compare_type_rank (formal, actual->symtree->n.sym))
	return 0;

      if (formal->attr.if_source == IFSRC_UNKNOWN)
	return 1;		/* Assume match */

      return compare_interfaces (formal, actual->symtree->n.sym, 0);
    }

  if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
      && !gfc_compare_types (&formal->ts, &actual->ts))
    return 0;

  if (symbol_rank (formal) == actual->rank)
    return 1;

  /* At this point the ranks didn't agree.  */
  if (ranks_must_agree || formal->attr.pointer)
    return 0;

  if (actual->rank != 0)
    return is_elemental || formal->attr.dimension;

  /* At this point, we are considering a scalar passed to an array.
     This is legal if the scalar is an array element of the right sort.  */
  if (formal->as->type == AS_ASSUMED_SHAPE)
    return 0;

  for (ref = actual->ref; ref; ref = ref->next)
    if (ref->type == REF_SUBSTRING)
      return 0;

  for (ref = actual->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
      break;

  if (ref == NULL)
    return 0;			/* Not an array element */

  return 1;
}


/* Given formal and actual argument lists, see if they are compatible.
   If they are compatible, the actual argument list is sorted to
   correspond with the formal list, and elements for missing optional
   arguments are inserted. If WHERE pointer is nonnull, then we issue
   errors when things don't match instead of just returning the status
   code.  */

static int
compare_actual_formal (gfc_actual_arglist ** ap,
		       gfc_formal_arglist * formal,
		       int ranks_must_agree, int is_elemental, locus * where)
{
  gfc_actual_arglist **new, *a, *actual, temp;
  gfc_formal_arglist *f;
  int i, n, na;

  actual = *ap;

  if (actual == NULL && formal == NULL)
    return 1;

  n = 0;
  for (f = formal; f; f = f->next)
    n++;

  new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));

  for (i = 0; i < n; i++)
    new[i] = NULL;

  na = 0;
  f = formal;
  i = 0;

  for (a = actual; a; a = a->next, f = f->next)
    {
      if (a->name != NULL)
	{
	  i = 0;
	  for (f = formal; f; f = f->next, i++)
	    {
	      if (f->sym == NULL)
		continue;
	      if (strcmp (f->sym->name, a->name) == 0)
		break;
	    }

	  if (f == NULL)
	    {
	      if (where)
		gfc_error
		  ("Keyword argument '%s' at %L is not in the procedure",
		   a->name, &a->expr->where);
	      return 0;
	    }

	  if (new[i] != NULL)
	    {
	      if (where)
		gfc_error
		  ("Keyword argument '%s' at %L is already associated "
		   "with another actual argument", a->name, &a->expr->where);
	      return 0;
	    }
	}

      if (f == NULL)
	{
	  if (where)
	    gfc_error
	      ("More actual than formal arguments in procedure call at %L",
	       where);

	  return 0;
	}

      if (f->sym == NULL && a->expr == NULL)
	goto match;

      if (f->sym == NULL)
	{
	  if (where)
	    gfc_error
	      ("Missing alternate return spec in subroutine call at %L",
	       where);
	  return 0;
	}

      if (a->expr == NULL)
	{
	  if (where)
	    gfc_error
	      ("Unexpected alternate return spec in subroutine call at %L",
	       where);
	  return 0;
	}

      if (!compare_parameter
	  (f->sym, a->expr,
	   ranks_must_agree && f->sym->as
	     && f->sym->as->type == AS_ASSUMED_SHAPE,
	   is_elemental))
	{
	  if (where)
	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
		       f->sym->name, &a->expr->where);
	  return 0;
	}

      if (f->sym->as
	  && f->sym->as->type == AS_ASSUMED_SHAPE
	  && a->expr->expr_type == EXPR_VARIABLE
	  && a->expr->symtree->n.sym->as
	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
	  && (a->expr->ref == NULL
	      || (a->expr->ref->type == REF_ARRAY
		  && a->expr->ref->u.ar.type == AR_FULL)))
	{
	  if (where)
	    gfc_error ("Actual argument for '%s' cannot be an assumed-size"
		       " array at %L", f->sym->name, where);
	  return 0;
	}

      if (a->expr->expr_type != EXPR_NULL
	  && compare_pointer (f->sym, a->expr) == 0)
	{