2011-04-04 Tobias Burnus <burnus@net-b.de>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / interface.c

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 519251e..00fd24a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1,5 +1,6 @@
 /* Deal with interfaces.
 /* Deal with interfaces.

-   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010

    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 


@@ -95,32 +96,32 @@ gfc_free_interface (gfc_interface *intr)
    minus respectively, leaving the rest unchanged.  */
 
 static gfc_intrinsic_op
    minus respectively, leaving the rest unchanged.  */
 
 static gfc_intrinsic_op

-fold_unary (gfc_intrinsic_op operator)
+fold_unary_intrinsic (gfc_intrinsic_op op)

 {
 {

-  switch (operator)
+  switch (op)

     {
     case INTRINSIC_UPLUS:
     {
     case INTRINSIC_UPLUS:

-      operator = INTRINSIC_PLUS;
+      op = INTRINSIC_PLUS;

       break;
     case INTRINSIC_UMINUS:
       break;
     case INTRINSIC_UMINUS:

-      operator = INTRINSIC_MINUS;
+      op = INTRINSIC_MINUS;

       break;
     default:
       break;
     }
 
       break;
     default:
       break;
     }
 

-  return operator;
+  return op;

 }
 
 
 /* Match a generic specification.  Depending on which type of
 }
 
 
 /* Match a generic specification.  Depending on which type of

-   interface is found, the 'name' or 'operator' pointers may be set.
+   interface is found, the 'name' or 'op' pointers may be set.

    This subroutine doesn't return MATCH_NO.  */
 
 match
 gfc_match_generic_spec (interface_type *type,
                        char *name,
    This subroutine doesn't return MATCH_NO.  */
 
 match
 gfc_match_generic_spec (interface_type *type,
                        char *name,

-                       gfc_intrinsic_op *operator)
+                       gfc_intrinsic_op *op)

 {
   char buffer[GFC_MAX_SYMBOL_LEN + 1];
   match m;
 {
   char buffer[GFC_MAX_SYMBOL_LEN + 1];
   match m;


@@ -129,17 +130,18 @@ gfc_match_generic_spec (interface_type *type,
   if (gfc_match (" assignment ( = )") == MATCH_YES)
     {
       *type = INTERFACE_INTRINSIC_OP;
   if (gfc_match (" assignment ( = )") == MATCH_YES)
     {
       *type = INTERFACE_INTRINSIC_OP;

-      *operator = INTRINSIC_ASSIGN;
+      *op = INTRINSIC_ASSIGN;

       return MATCH_YES;
     }
 
   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
     {                          /* Operator i/f */
       *type = INTERFACE_INTRINSIC_OP;
       return MATCH_YES;
     }
 
   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
     {                          /* Operator i/f */
       *type = INTERFACE_INTRINSIC_OP;

-      *operator = fold_unary (i);
+      *op = fold_unary_intrinsic (i);

       return MATCH_YES;
     }
 
       return MATCH_YES;
     }
 

+  *op = INTRINSIC_NONE;

   if (gfc_match (" operator ( ") == MATCH_YES)
     {
       m = gfc_match_defined_op_name (buffer, 1);
   if (gfc_match (" operator ( ") == MATCH_YES)
     {
       m = gfc_match_defined_op_name (buffer, 1);


@@ -184,12 +186,12 @@ gfc_match_interface (void)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;
   gfc_symbol *sym;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;
   gfc_symbol *sym;

-  gfc_intrinsic_op operator;
+  gfc_intrinsic_op op;

   match m;
 
   m = gfc_match_space ();
 
   match m;
 
   m = gfc_match_space ();
 

-  if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
+  if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)

     return MATCH_ERROR;
 
   /* If we're not looking at the end of the statement now, or if this
     return MATCH_ERROR;
 
   /* If we're not looking at the end of the statement now, or if this


@@ -229,7 +231,7 @@ gfc_match_interface (void)
       break;
 
     case INTERFACE_INTRINSIC_OP:
       break;
 
     case INTERFACE_INTRINSIC_OP:

-      current_interface.op = operator;
+      current_interface.op = op;

       break;
 
     case INTERFACE_NAMELESS:
       break;
 
     case INTERFACE_NAMELESS:


@@ -275,12 +277,12 @@ gfc_match_end_interface (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;

-  gfc_intrinsic_op operator;
+  gfc_intrinsic_op op;

   match m;
 
   m = gfc_match_space ();
 
   match m;
 
   m = gfc_match_space ();
 

-  if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
+  if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)

     return MATCH_ERROR;
 
   /* If we're not looking at the end of the statement now, or if this
     return MATCH_ERROR;
 
   /* If we're not looking at the end of the statement now, or if this


@@ -308,16 +310,46 @@ gfc_match_end_interface (void)
       break;
 
     case INTERFACE_INTRINSIC_OP:
       break;
 
     case INTERFACE_INTRINSIC_OP:

-      if (type != current_interface.type || operator != current_interface.op)
+      if (type != current_interface.type || op != current_interface.op)

        {
 
          if (current_interface.op == INTRINSIC_ASSIGN)
        {
 
          if (current_interface.op == INTRINSIC_ASSIGN)

-           gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+           {
+             m = MATCH_ERROR;
+             gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+           }

          else
          else

-           gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
-                      gfc_op2string (current_interface.op));
+           {
+             const char *s1, *s2;
+             s1 = gfc_op2string (current_interface.op);
+             s2 = gfc_op2string (op);
+
+             /* The following if-statements are used to enforce C1202
+                from F2003.  */
+             if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
+                 || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
+               break;
+             if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
+                 || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
+               break;
+             if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
+                 || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
+               break;
+             if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
+                 || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
+               break;
+             if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
+                 || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
+               break;
+             if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
+                 || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
+               break;

 
 

-         m = MATCH_ERROR;
+             m = MATCH_ERROR;
+             gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
+                        "but got %s", s1, s2);
+           }
+               

        }
 
       break;
        }
 
       break;


@@ -359,6 +391,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
 {
   gfc_component *dt1, *dt2;
 
 {
   gfc_component *dt1, *dt2;
 

+  if (derived1 == derived2)
+    return 1;
+

   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */
   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */


@@ -392,34 +427,34 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
       if (strcmp (dt1->name, dt2->name) != 0)
        return 0;
 
       if (strcmp (dt1->name, dt2->name) != 0)
        return 0;
 

-      if (dt1->access != dt2->access)
+      if (dt1->attr.access != dt2->attr.access)

        return 0;
 
        return 0;
 

-      if (dt1->pointer != dt2->pointer)
+      if (dt1->attr.pointer != dt2->attr.pointer)

        return 0;
 
        return 0;
 

-      if (dt1->dimension != dt2->dimension)
+      if (dt1->attr.dimension != dt2->attr.dimension)

        return 0;
 
        return 0;
 

-     if (dt1->allocatable != dt2->allocatable)
+     if (dt1->attr.allocatable != dt2->attr.allocatable)

        return 0;
 
        return 0;
 

-      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
+      if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)

        return 0;
 
       /* Make sure that link lists do not put this function into an 
         endless recursive loop!  */
        return 0;
 
       /* Make sure that link lists do not put this function into an 
         endless recursive loop!  */

-      if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-           && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+      if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+           && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)

            && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
        return 0;
 
            && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
        return 0;
 

-      else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-               && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+      else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+               && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))

        return 0;
 
        return 0;
 

-      else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-               && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+      else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+               && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))

        return 0;
 
       dt1 = dt1->next;
        return 0;
 
       dt1 = dt1->next;


@@ -447,16 +482,18 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     return 1;
    
   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     return 1;
    

-  if (ts1->type != ts2->type)
+  if (ts1->type != ts2->type
+      && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+         || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))

     return 0;
     return 0;

-  if (ts1->type != BT_DERIVED)
+  if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)

     return (ts1->kind == ts2->kind);
 
   /* Compare derived types.  */
     return (ts1->kind == ts2->kind);
 
   /* Compare derived types.  */

-  if (ts1->derived == ts2->derived)
+  if (gfc_type_compatible (ts1, ts2))

     return 1;
 
     return 1;
 

-  return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+  return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);

 }
 
 
 }
 
 


@@ -479,9 +516,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 }
 
 
 }
 
 

-static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
-static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
-

 /* Given two symbols that are formal arguments, compare their types
    and rank and their formal interfaces if they are both dummy
    procedures.  Returns nonzero if the same, zero if different.  */
 /* Given two symbols that are formal arguments, compare their types
    and rank and their formal interfaces if they are both dummy
    procedures.  Returns nonzero if the same, zero if different.  */


@@ -492,17 +526,26 @@ compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
   if (s1 == NULL || s2 == NULL)
     return s1 == s2 ? 1 : 0;
 
   if (s1 == NULL || s2 == NULL)
     return s1 == s2 ? 1 : 0;
 

+  if (s1 == s2)
+    return 1;
+

   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
     return compare_type_rank (s1, s2);
 
   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
     return 0;
 
   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
     return compare_type_rank (s1, s2);
 
   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
     return 0;
 

-  /* At this point, both symbols are procedures.  */
-  if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
-      || (s2->attr.function == 0 && s2->attr.subroutine == 0))
-    return 0;
+  /* At this point, both symbols are procedures.  It can happen that
+     external procedures are compared, where one is identified by usage
+     to be a function or subroutine but the other is not.  Check TKR
+     nonetheless for these cases.  */
+  if (s1->attr.function == 0 && s1->attr.subroutine == 0)
+    return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+
+  if (s2->attr.function == 0 && s2->attr.subroutine == 0)
+    return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;

 
 

+  /* Now the type of procedure has been identified.  */

   if (s1->attr.function != s2->attr.function
       || s1->attr.subroutine != s2->attr.subroutine)
     return 0;
   if (s1->attr.function != s2->attr.function
       || s1->attr.subroutine != s2->attr.subroutine)
     return 0;


@@ -537,17 +580,16 @@ find_keyword_arg (const char *name, gfc_formal_arglist *f)
 /* Given an operator interface and the operator, make sure that all
    interfaces for that operator are legal.  */
 
 /* Given an operator interface and the operator, make sure that all
    interfaces for that operator are legal.  */
 

-static void
-check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+                             locus opwhere)

 {
   gfc_formal_arglist *formal;
   sym_intent i1, i2;
 {
   gfc_formal_arglist *formal;
   sym_intent i1, i2;

-  gfc_symbol *sym;

   bt t1, t2;
   int args, r1, r2, k1, k2;
 
   bt t1, t2;
   int args, r1, r2, k1, k2;
 

-  if (intr == NULL)
-    return;
+  gcc_assert (sym);

 
   args = 0;
   t1 = t2 = BT_UNKNOWN;
 
   args = 0;
   t1 = t2 = BT_UNKNOWN;


@@ -555,71 +597,76 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
   r1 = r2 = -1;
   k1 = k2 = -1;
 
   r1 = r2 = -1;
   k1 = k2 = -1;
 

-  for (formal = intr->sym->formal; formal; formal = formal->next)
+  for (formal = sym->formal; formal; formal = formal->next)

     {
     {

-      sym = formal->sym;
-      if (sym == NULL)
+      gfc_symbol *fsym = formal->sym;
+      if (fsym == NULL)

        {
          gfc_error ("Alternate return cannot appear in operator "
        {
          gfc_error ("Alternate return cannot appear in operator "

-                    "interface at %L", &intr->where);
-         return;
+                    "interface at %L", &sym->declared_at);
+         return false;

        }
       if (args == 0)
        {
        }
       if (args == 0)
        {

-         t1 = sym->ts.type;
-         i1 = sym->attr.intent;
-         r1 = (sym->as != NULL) ? sym->as->rank : 0;
-         k1 = sym->ts.kind;
+         t1 = fsym->ts.type;
+         i1 = fsym->attr.intent;
+         r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+         k1 = fsym->ts.kind;

        }
       if (args == 1)
        {
        }
       if (args == 1)
        {

-         t2 = sym->ts.type;
-         i2 = sym->attr.intent;
-         r2 = (sym->as != NULL) ? sym->as->rank : 0;
-         k2 = sym->ts.kind;
+         t2 = fsym->ts.type;
+         i2 = fsym->attr.intent;
+         r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+         k2 = fsym->ts.kind;

        }
       args++;
     }
 
        }
       args++;
     }
 

-  sym = intr->sym;
-

   /* Only +, - and .not. can be unary operators.
      .not. cannot be a binary operator.  */
   /* Only +, - and .not. can be unary operators.
      .not. cannot be a binary operator.  */

-  if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
-                               && operator != INTRINSIC_MINUS
-                               && operator != INTRINSIC_NOT)
-      || (args == 2 && operator == INTRINSIC_NOT))
+  if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
+                               && op != INTRINSIC_MINUS
+                               && op != INTRINSIC_NOT)
+      || (args == 2 && op == INTRINSIC_NOT))

     {
       gfc_error ("Operator interface at %L has the wrong number of arguments",
     {
       gfc_error ("Operator interface at %L has the wrong number of arguments",

-                &intr->where);
-      return;
+                &sym->declared_at);
+      return false;

     }
 
   /* Check that intrinsics are mapped to functions, except
      INTRINSIC_ASSIGN which should map to a subroutine.  */
     }
 
   /* Check that intrinsics are mapped to functions, except
      INTRINSIC_ASSIGN which should map to a subroutine.  */

-  if (operator == INTRINSIC_ASSIGN)
+  if (op == INTRINSIC_ASSIGN)

     {
       if (!sym->attr.subroutine)
        {
          gfc_error ("Assignment operator interface at %L must be "
     {
       if (!sym->attr.subroutine)
        {
          gfc_error ("Assignment operator interface at %L must be "

-                    "a SUBROUTINE", &intr->where);
-         return;
+                    "a SUBROUTINE", &sym->declared_at);
+         return false;

        }
       if (args != 2)
        {
          gfc_error ("Assignment operator interface at %L must have "
        }
       if (args != 2)
        {
          gfc_error ("Assignment operator interface at %L must have "

-                    "two arguments", &intr->where);
-         return;
+                    "two arguments", &sym->declared_at);
+         return false;

        }
        }

+
+      /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
+        - First argument an array with different rank than second,
+        - First argument is a scalar and second an array,
+        - Types and kinds do not conform, or
+        - First argument is of derived type.  */

       if (sym->formal->sym->ts.type != BT_DERIVED
       if (sym->formal->sym->ts.type != BT_DERIVED

-         && sym->formal->next->sym->ts.type != BT_DERIVED
+         && sym->formal->sym->ts.type != BT_CLASS
+         && (r2 == 0 || r1 == r2)

          && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
              || (gfc_numeric_ts (&sym->formal->sym->ts)
                  && gfc_numeric_ts (&sym->formal->next->sym->ts))))
        {
          gfc_error ("Assignment operator interface at %L must not redefine "
          && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
              || (gfc_numeric_ts (&sym->formal->sym->ts)
                  && gfc_numeric_ts (&sym->formal->next->sym->ts))))
        {
          gfc_error ("Assignment operator interface at %L must not redefine "

-                    "an INTRINSIC type assignment", &intr->where);
-         return;
+                    "an INTRINSIC type assignment", &sym->declared_at);
+         return false;

        }
     }
   else
        }
     }
   else


@@ -627,31 +674,43 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       if (!sym->attr.function)
        {
          gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
       if (!sym->attr.function)
        {
          gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",

-                    &intr->where);
-         return;
+                    &sym->declared_at);
+         return false;

        }
     }
 
   /* Check intents on operator interfaces.  */
        }
     }
 
   /* Check intents on operator interfaces.  */

-  if (operator == INTRINSIC_ASSIGN)
+  if (op == INTRINSIC_ASSIGN)

     {
       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
     {
       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)

-       gfc_error ("First argument of defined assignment at %L must be "
-                  "INTENT(IN) or INTENT(INOUT)", &intr->where);
+       {
+         gfc_error ("First argument of defined assignment at %L must be "
+                    "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+         return false;
+       }

 
       if (i2 != INTENT_IN)
 
       if (i2 != INTENT_IN)

-       gfc_error ("Second argument of defined assignment at %L must be "
-                  "INTENT(IN)", &intr->where);
+       {
+         gfc_error ("Second argument of defined assignment at %L must be "
+                    "INTENT(IN)", &sym->declared_at);
+         return false;
+       }

     }
   else
     {
       if (i1 != INTENT_IN)
     }
   else
     {
       if (i1 != INTENT_IN)

-       gfc_error ("First argument of operator interface at %L must be "
-                  "INTENT(IN)", &intr->where);
+       {
+         gfc_error ("First argument of operator interface at %L must be "
+                    "INTENT(IN)", &sym->declared_at);
+         return false;
+       }

 
       if (args == 2 && i2 != INTENT_IN)
 
       if (args == 2 && i2 != INTENT_IN)

-       gfc_error ("Second argument of operator interface at %L must be "
-                  "INTENT(IN)", &intr->where);
+       {
+         gfc_error ("Second argument of operator interface at %L must be "
+                    "INTENT(IN)", &sym->declared_at);
+         return false;
+       }

     }
 
   /* From now on, all we have to do is check that the operator definition
     }
 
   /* From now on, all we have to do is check that the operator definition


@@ -669,35 +728,35 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
 
   /* Unary ops are easy, do them first.  */
   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
 
   /* Unary ops are easy, do them first.  */

-  if (operator == INTRINSIC_NOT)
+  if (op == INTRINSIC_NOT)

     {
       if (t1 == BT_LOGICAL)
        goto bad_repl;
       else
     {
       if (t1 == BT_LOGICAL)
        goto bad_repl;
       else

-       return;
+       return true;

     }
 
     }
 

-  if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
+  if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))

     {
       if (IS_NUMERIC_TYPE (t1))
        goto bad_repl;
       else
     {
       if (IS_NUMERIC_TYPE (t1))
        goto bad_repl;
       else

-       return;
+       return true;

     }
 
   /* Character intrinsic operators have same character kind, thus
      operator definitions with operands of different character kinds
      are always safe.  */
   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
     }
 
   /* Character intrinsic operators have same character kind, thus
      operator definitions with operands of different character kinds
      are always safe.  */
   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)

-    return;
+    return true;

 
   /* Intrinsic operators always perform on arguments of same rank,
      so different ranks is also always safe.  (rank == 0) is an exception
      to that, because all intrinsic operators are elemental.  */
   if (r1 != r2 && r1 != 0 && r2 != 0)
 
   /* Intrinsic operators always perform on arguments of same rank,
      so different ranks is also always safe.  (rank == 0) is an exception
      to that, because all intrinsic operators are elemental.  */
   if (r1 != r2 && r1 != 0 && r2 != 0)

-    return;
+    return true;

 
 

-  switch (operator)
+  switch (op)

   {
     case INTRINSIC_EQ:
     case INTRINSIC_EQ_OS:
   {
     case INTRINSIC_EQ:
     case INTRINSIC_EQ_OS:


@@ -748,14 +807,14 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       break;
   }
 
       break;
   }
 

-  return;
+  return true;

 
 #undef IS_NUMERIC_TYPE
 
 bad_repl:
   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
 
 #undef IS_NUMERIC_TYPE
 
 bad_repl:
   gfc_error ("Operator interface at %L conflicts with intrinsic interface",

-            &intr->where);
-  return;
+            &opwhere);
+  return false;

 }
 
 
 }
 
 


@@ -766,7 +825,7 @@ bad_repl:
    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
    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.  */
+   14.1.2.3 in the Fortran 95 standard.  */

 
 static int
 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 
 static int
 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)


@@ -790,7 +849,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 
   /* Build an array of integers that gives the same integer to
      arguments of the same type/rank.  */
 
   /* Build an array of integers that gives the same integer to
      arguments of the same type/rank.  */

-  arg = gfc_getmem (n1 * sizeof (arginfo));
+  arg = XCNEWVEC (arginfo, n1);

 
   f = f1;
   for (i = 0; i < n1; i++, f = f->next)
 
   f = f1;
   for (i = 0; i < n1; i++, f = f->next)


@@ -814,7 +873,8 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
       /* Find other nonoptional arguments of the same type/rank.  */
       for (j = i + 1; j < n1; j++)
        if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
       /* Find other nonoptional arguments of the same type/rank.  */
       for (j = i + 1; j < n1; j++)
        if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)

-           && compare_type_rank_if (arg[i].sym, arg[j].sym))
+           && (compare_type_rank_if (arg[i].sym, arg[j].sym)
+               || compare_type_rank_if (arg[j].sym, arg[i].sym)))

          arg[j].flag = k;
 
       k++;
          arg[j].flag = k;
 
       k++;


@@ -839,7 +899,8 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
       ac2 = 0;
 
       for (f = f2; f; f = f->next)
       ac2 = 0;
 
       for (f = f2; f; f = f->next)

-       if (compare_type_rank_if (arg[i].sym, f->sym))
+       if (compare_type_rank_if (arg[i].sym, f->sym)
+           || compare_type_rank_if (f->sym, arg[i].sym))

          ac2++;
 
       if (ac1 > ac2)
          ac2++;
 
       if (ac1 > ac2)


@@ -857,36 +918,6 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 }
 
 
 }
 
 

-/* 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.
 /* 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.


@@ -920,7 +951,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
       if (f1->sym->attr.optional)
        goto next;
 
       if (f1->sym->attr.optional)
        goto next;
 

-      if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
+      if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
+                        || compare_type_rank (f2->sym, f1->sym)))

        goto next;
 
       /* Now search for a disambiguating keyword argument starting at
        goto next;
 
       /* Now search for a disambiguating keyword argument starting at


@@ -947,159 +979,123 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 
 /* 'Compare' two formal interfaces associated with a pair of symbols.
    We return nonzero if there exists an actual argument list that
 
 /* '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.  */
+   would be ambiguous between the two interfaces, zero otherwise.
+   'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
+   required to match, which is not the case for ambiguity checks.*/

 
 

-static int
-compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+int
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+                       int generic_flag, int intent_flag,
+                       char *errmsg, int err_len)

 {
   gfc_formal_arglist *f1, *f2;
 
 {
   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;
+  gcc_assert (name2 != NULL);

 
 

-  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 (s1->attr.function && (s2->attr.subroutine
+      || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
+         && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))

     {
     {

-      if (generic_correspondence (f1, f2))
-       return 0;
-      if (generic_correspondence (f2, f1))
-       return 0;
+      if (errmsg != NULL)
+       snprintf (errmsg, err_len, "'%s' is not a function", name2);
+      return 0;

     }
     }

-  else
+
+  if (s1->attr.subroutine && s2->attr.function)

     {
     {

-      if (operator_correspondence (f1, f2))
-       return 0;
+      if (errmsg != NULL)
+       snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
+      return 0;

     }
 
     }
 

-  return 1;
-}
-
-
-static int
-compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
-{
-  gfc_formal_arglist *f, *f1;
-  gfc_intrinsic_arg *fi, *f2;
-  gfc_intrinsic_sym *isym;
-
-  if (s1->attr.function != s2->attr.function
-      || s1->attr.subroutine != s2->attr.subroutine)
-    return 0;          /* Disagreement between function/subroutine.  */
-  
-  /* If the arguments are functions, check type and kind.  */
-  
-  if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+  /* If the arguments are functions, check type and kind
+     (only for dummy procedures and procedure pointer assignments).  */
+  if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)

     {
     {

-      if (s1->ts.type != s2->ts.type)
-       return 0;
-      if (s1->ts.kind != s2->ts.kind)
-       return 0;
-      if (s1->attr.if_source == IFSRC_DECL)
+      if (s1->ts.type == BT_UNKNOWN)

        return 1;
        return 1;

+      if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
+       {
+         if (errmsg != NULL)
+           snprintf (errmsg, err_len, "Type/kind mismatch in return value "
+                     "of '%s'", name2);
+         return 0;
+       }

     }
 
     }
 

-  isym = gfc_find_function (s2->name);
-  
-  /* This should already have been checked in
-     resolve.c (resolve_actual_arglist).  */
-  gcc_assert (isym);
+  if (s1->attr.if_source == IFSRC_UNKNOWN
+      || s2->attr.if_source == IFSRC_UNKNOWN)
+    return 1;

 
   f1 = s1->formal;
 
   f1 = s1->formal;

-  f2 = isym->formal;
+  f2 = s2->formal;

 
 

-  /* Special case.  */

   if (f1 == NULL && f2 == NULL)
   if (f1 == NULL && f2 == NULL)

-    return 1;
-  
-  /* First scan through the formal argument list and check the intrinsic.  */
-  fi = f2;
-  for (f = f1; f; f = f->next)
-    {
-      if (fi == NULL)
-       return 0;
-      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
-       return 0;
-      fi = fi->next;
-    }
+    return 1;                  /* Special case: No arguments.  */

 
 

-  /* Now scan through the intrinsic argument list and check the formal.  */
-  f = f1;
-  for (fi = f2; fi; fi = fi->next)
+  if (generic_flag)

     {
     {

-      if (f == NULL)
+      if (count_types_test (f1, f2) || count_types_test (f2, f1))

        return 0;
        return 0;

-      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
+      if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))

        return 0;
        return 0;

-      f = f->next;

     }
     }

+  else
+    /* Perform the abbreviated correspondence test for operators (the
+       arguments cannot be optional and are always ordered correctly).
+       This is also done when comparing interfaces for dummy procedures and in
+       procedure pointer assignments.  */

 
 

-  return 1;
-}
-
-
-/* Compare an actual argument list with an intrinsic argument list.  */
-
-static int
-compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
-{
-  gfc_actual_arglist *a;
-  gfc_intrinsic_arg *fi, *f2;
-  gfc_intrinsic_sym *isym;
+    for (;;)
+      {
+       /* Check existence.  */
+       if (f1 == NULL && f2 == NULL)
+         break;
+       if (f1 == NULL || f2 == NULL)
+         {
+           if (errmsg != NULL)
+             snprintf (errmsg, err_len, "'%s' has the wrong number of "
+                       "arguments", name2);
+           return 0;
+         }

 
 

-  isym = gfc_find_function (s2->name);
-  
-  /* This should already have been checked in
-     resolve.c (resolve_actual_arglist).  */
-  gcc_assert (isym);
+       /* Check type and rank.  */
+       if (!compare_type_rank (f2->sym, f1->sym))
+         {
+           if (errmsg != NULL)
+             snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+                       f1->sym->name);
+           return 0;
+         }

 
 

-  f2 = isym->formal;
+       /* Check INTENT.  */
+       if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+         {
+           snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+                     f1->sym->name);
+           return 0;
+         }

 
 

-  /* Special case.  */
-  if (*ap == NULL && f2 == NULL)
-    return 1;
-  
-  /* First scan through the actual argument list and check the intrinsic.  */
-  fi = f2;
-  for (a = *ap; a; a = a->next)
-    {
-      if (fi == NULL)
-       return 0;
-      if ((fi->ts.type != a->expr->ts.type)
-         || (fi->ts.kind != a->expr->ts.kind))
-       return 0;
-      fi = fi->next;
-    }
+       /* Check OPTIONAL.  */
+       if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
+         {
+           snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+                     f1->sym->name);
+           return 0;
+         }

 
 

-  /* Now scan through the intrinsic argument list and check the formal.  */
-  a = *ap;
-  for (fi = f2; fi; fi = fi->next)
-    {
-      if (a == NULL)
-       return 0;
-      if ((fi->ts.type != a->expr->ts.type)
-         || (fi->ts.kind != a->expr->ts.kind))
-       return 0;
-      a = a->next;
-    }
+       f1 = f1->next;
+       f2 = f2->next;
+      }

 
   return 1;
 }
 
 
 /* Given a pointer to an interface pointer, remove duplicate
 
   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.  */
+   interfaces and make sure that all symbols are either functions
+   or subroutines, and all of the same kind.  Returns nonzero if
+   something goes wrong.  */

 
 static int
 check_interface0 (gfc_interface *p, const char *interface_name)
 
 static int
 check_interface0 (gfc_interface *p, const char *interface_name)


@@ -1107,21 +1103,32 @@ check_interface0 (gfc_interface *p, const char *interface_name)
   gfc_interface *psave, *q, *qlast;
 
   psave = p;
   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)
   for (; p; p = p->next)

-    if ((!p->sym->attr.function && !p->sym->attr.subroutine)
-       || !p->sym->attr.if_source)
-      {
-       if (p->sym->attr.external)
-         gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
-                    p->sym->name, interface_name, &p->sym->declared_at);
-       else
-         gfc_error ("Procedure '%s' in %s at %L is neither function nor "
-                    "subroutine", p->sym->name, interface_name,
-                    &p->sym->declared_at);
-       return 1;
-      }
+    {
+      /* Make sure all symbols in the interface have been defined as
+        functions or subroutines.  */
+      if ((!p->sym->attr.function && !p->sym->attr.subroutine)
+         || !p->sym->attr.if_source)
+       {
+         if (p->sym->attr.external)
+           gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+                      p->sym->name, interface_name, &p->sym->declared_at);
+         else
+           gfc_error ("Procedure '%s' in %s at %L is neither function nor "
+                      "subroutine", p->sym->name, interface_name,
+                     &p->sym->declared_at);
+         return 1;
+       }
+
+      /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
+      if ((psave->sym->attr.function && !p->sym->attr.function)
+         || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
+       {
+         gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
+                    " or all FUNCTIONs", interface_name, &p->sym->declared_at);
+         return 1;
+       }
+    }

   p = psave;
 
   /* Remove duplicate interfaces in this interface list.  */
   p = psave;
 
   /* Remove duplicate interfaces in this interface list.  */


@@ -1168,19 +1175,20 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
        if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
          continue;
 
        if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
          continue;
 

-       if (compare_interfaces (p->sym, q->sym, generic_flag))
+       if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
+                                   0, NULL, 0))

          {
            if (referenced)
          {
            if (referenced)

-             {
-               gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
-                          p->sym->name, q->sym->name, interface_name,
-                          &p->where);
-             }
-
-           if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
+             gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+                        p->sym->name, q->sym->name, interface_name,
+                        &p->where);
+           else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)

              gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
                           p->sym->name, q->sym->name, interface_name,
                           &p->where);
              gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
                           p->sym->name, q->sym->name, interface_name,
                           &p->where);

+           else
+             gfc_warning ("Although not referenced, '%s' has ambiguous "
+                          "interfaces at %L", interface_name, &p->where);

            return 1;
          }
       }
            return 1;
          }
       }


@@ -1196,7 +1204,6 @@ static void
 check_sym_interfaces (gfc_symbol *sym)
 {
   char interface_name[100];
 check_sym_interfaces (gfc_symbol *sym)
 {
   char interface_name[100];

-  bool k;

   gfc_interface *p;
 
   if (sym->ns != gfc_current_ns)
   gfc_interface *p;
 
   if (sym->ns != gfc_current_ns)


@@ -1223,9 +1230,8 @@ check_sym_interfaces (gfc_symbol *sym)
       /* Originally, this test was applied to host interfaces too;
         this is incorrect since host associated symbols, from any
         source, cannot be ambiguous with local symbols.  */
       /* Originally, this test was applied to host interfaces too;
         this is incorrect since host associated symbols, from any
         source, cannot be ambiguous with local symbols.  */

-      k = sym->attr.referenced || !sym->attr.use_assoc;
-      if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
-       sym->attr.ambiguous_interfaces = 1;
+      check_interface1 (sym->generic, sym->generic, 1, interface_name,
+                       sym->attr.referenced || !sym->attr.use_assoc);

     }
 }
 
     }
 }
 


@@ -1238,7 +1244,7 @@ check_uop_interfaces (gfc_user_op *uop)
   gfc_namespace *ns;
 
   sprintf (interface_name, "operator interface '%s'", uop->name);
   gfc_namespace *ns;
 
   sprintf (interface_name, "operator interface '%s'", uop->name);

-  if (check_interface0 (uop->operator, interface_name))
+  if (check_interface0 (uop->op, interface_name))

     return;
 
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     return;
 
   for (ns = gfc_current_ns; ns; ns = ns->parent)


@@ -1247,7 +1253,7 @@ check_uop_interfaces (gfc_user_op *uop)
       if (uop2 == NULL)
        continue;
 
       if (uop2 == NULL)
        continue;
 

-      check_interface1 (uop->operator, uop2->operator, 0,
+      check_interface1 (uop->op, uop2->op, 0,

                        interface_name, true);
     }
 }
                        interface_name, true);
     }
 }


@@ -1263,7 +1269,7 @@ gfc_check_interfaces (gfc_namespace *ns)
 {
   gfc_namespace *old_ns, *ns2;
   char interface_name[100];
 {
   gfc_namespace *old_ns, *ns2;
   char interface_name[100];

-  gfc_intrinsic_op i;
+  int i;

 
   old_ns = gfc_current_ns;
   gfc_current_ns = ns;
 
   old_ns = gfc_current_ns;
   gfc_current_ns = ns;


@@ -1281,78 +1287,80 @@ gfc_check_interfaces (gfc_namespace *ns)
        strcpy (interface_name, "intrinsic assignment operator");
       else
        sprintf (interface_name, "intrinsic '%s' operator",
        strcpy (interface_name, "intrinsic assignment operator");
       else
        sprintf (interface_name, "intrinsic '%s' operator",

-                gfc_op2string (i));
+                gfc_op2string ((gfc_intrinsic_op) i));

 
 

-      if (check_interface0 (ns->operator[i], interface_name))
+      if (check_interface0 (ns->op[i], interface_name))

        continue;
 
        continue;
 

-      check_operator_interface (ns->operator[i], i);
+      if (ns->op[i])
+       gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+                                     ns->op[i]->where);

 
       for (ns2 = ns; ns2; ns2 = ns2->parent)
        {
 
       for (ns2 = ns; ns2; ns2 = ns2->parent)
        {

-         if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
+         if (check_interface1 (ns->op[i], ns2->op[i], 0,

                                interface_name, true))
            goto done;
 
          switch (i)
            {
              case INTRINSIC_EQ:
                                interface_name, true))
            goto done;
 
          switch (i)
            {
              case INTRINSIC_EQ:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_EQ_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_EQ_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_NE:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_NE:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_NE_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_NE_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GT:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GT:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GT_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GT_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GE:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GE:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GE_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_GE_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LT:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LT:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LT_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LT_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LE:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LE:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],

                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LE_OS:
                                      0, interface_name, true)) goto done;
                break;
 
              case INTRINSIC_LE_OS:

-               if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
+               if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],

                                      0, interface_name, true)) goto done;
                break;
 
                                      0, interface_name, true)) goto done;
                break;
 


@@ -1383,7 +1391,8 @@ compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
 {
   symbol_attribute attr;
 
 {
   symbol_attribute attr;
 

-  if (formal->attr.allocatable)
+  if (formal->attr.allocatable
+      || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))

     {
       attr = gfc_expr_attr (actual);
       if (!attr.allocatable)
     {
       attr = gfc_expr_attr (actual);
       if (!attr.allocatable)


@@ -1406,6 +1415,11 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
   if (formal->attr.pointer)
     {
       attr = gfc_expr_attr (actual);
   if (formal->attr.pointer)
     {
       attr = gfc_expr_attr (actual);

+
+      /* Fortran 2008 allows non-pointer actual arguments.  */
+      if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
+       return 2;
+

       if (!attr.pointer)
        return 0;
     }
       if (!attr.pointer)
        return 0;
     }


@@ -1414,15 +1428,40 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 }
 
 
 }
 
 

+/* Emit clear error messages for rank mismatch.  */
+
+static void
+argument_rank_mismatch (const char *name, locus *where,
+                       int rank1, int rank2)
+{
+  if (rank1 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(scalar and rank-%d)", name, where, rank2);
+    }
+  else if (rank2 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(rank-%d and scalar)", name, where, rank1);
+    }
+  else
+    {    
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(rank-%d and rank-%d)", name, where, rank1, rank2);
+    }
+}
+
+

 /* 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,
 /* 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)
+                  int ranks_must_agree, int is_elemental, locus *where)

 {
   gfc_ref *ref;
 {
   gfc_ref *ref;

+  bool rank_check, is_pointer;

 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most


@@ -1431,89 +1470,270 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     return 1;
 
   if (formal->ts.type == BT_DERIVED
     return 1;
 
   if (formal->ts.type == BT_DERIVED

-      && formal->ts.derived && formal->ts.derived->ts.is_iso_c
+      && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c

       && actual->ts.type == BT_DERIVED
       && actual->ts.type == BT_DERIVED

-      && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
+      && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)

     return 1;
 
     return 1;
 

+  if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
+    /* Make sure the vtab symbol is present when
+       the module variables are generated.  */
+    gfc_find_derived_vtab (actual->ts.u.derived);
+

   if (actual->ts.type == BT_PROCEDURE)
     {
   if (actual->ts.type == BT_PROCEDURE)
     {

+      char err[200];
+      gfc_symbol *act_sym = actual->symtree->n.sym;
+

       if (formal->attr.flavor != FL_PROCEDURE)
       if (formal->attr.flavor != FL_PROCEDURE)

-       return 0;
+       {
+         if (where)
+           gfc_error ("Invalid procedure argument at %L", &actual->where);
+         return 0;
+       }

 
 

-      if (formal->attr.function
-         && !compare_type_rank (formal, actual->symtree->n.sym))
-       return 0;
+      if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
+                                  sizeof(err)))
+       {
+         if (where)
+           gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+                      formal->name, &actual->where, err);
+         return 0;
+       }

 
 

-      if (formal->attr.if_source == IFSRC_UNKNOWN
-         || actual->symtree->n.sym->attr.external)
-       return 1;               /* Assume match.  */
+      if (formal->attr.function && !act_sym->attr.function)
+       {
+         gfc_add_function (&act_sym->attr, act_sym->name,
+         &act_sym->declared_at);
+         if (act_sym->ts.type == BT_UNKNOWN
+             && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
+           return 0;
+       }
+      else if (formal->attr.subroutine && !act_sym->attr.subroutine)
+       gfc_add_subroutine (&act_sym->attr, act_sym->name,
+                           &act_sym->declared_at);

 
 

-      if (actual->symtree->n.sym->attr.intrinsic)
-       return compare_intr_interfaces (formal, actual->symtree->n.sym);
-      else
-       return compare_interfaces (formal, actual->symtree->n.sym, 0);
+      return 1;
+    }
+
+  /* F2008, C1241.  */
+  if (formal->attr.pointer && formal->attr.contiguous
+      && !gfc_is_simply_contiguous (actual, true))
+    {
+      if (where)
+       gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+                  "must be simply contigous", formal->name, &actual->where);
+      return 0;

     }
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
     }
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)

+      && actual->ts.type != BT_HOLLERITH

       && !gfc_compare_types (&formal->ts, &actual->ts))
       && !gfc_compare_types (&formal->ts, &actual->ts))

-    return 0;
+    {
+      if (where)
+       gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
+                  formal->name, &actual->where, gfc_typename (&actual->ts),
+                  gfc_typename (&formal->ts));
+      return 0;
+    }
+    
+  /* F2003, 12.5.2.5.  */
+  if (formal->ts.type == BT_CLASS
+      && (CLASS_DATA (formal)->attr.class_pointer
+          || CLASS_DATA (formal)->attr.allocatable))
+    {
+      if (actual->ts.type != BT_CLASS)
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+                       formal->name, &actual->where);
+         return 0;
+       }
+      if (CLASS_DATA (actual)->ts.u.derived
+         != CLASS_DATA (formal)->ts.u.derived)
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must have the same "
+                      "declared type", formal->name, &actual->where);
+         return 0;
+       }
+    }

 
 

-  if (symbol_rank (formal) == actual->rank)
-    return 1;
+  if (formal->attr.codimension)
+    {
+      gfc_ref *last = NULL;

 
 

-  /* At this point the ranks didn't agree.  */
-  if (ranks_must_agree || formal->attr.pointer)
-    return 0;
+      if (actual->expr_type != EXPR_VARIABLE
+         || !gfc_expr_attr (actual).codimension)
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must be a coarray",
+                      formal->name, &actual->where);
+         return 0;
+       }

 
 

-  if (actual->rank != 0)
-    return is_elemental || formal->attr.dimension;
+      if (gfc_is_coindexed (actual))
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must be a coarray "
+                      "and not coindexed", formal->name, &actual->where);
+         return 0;
+       }

 
 

-  /* 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_ARRAY && ref->u.ar.as->corank
+             && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+           {
+             if (where)
+               gfc_error ("Actual argument to '%s' at %L must be a coarray "
+                          "and thus shall not have an array designator",
+                          formal->name, &ref->u.ar.where);
+             return 0;
+           }
+         if (ref->type == REF_COMPONENT)
+           last = ref;
+       }

 
 

-  for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_SUBSTRING)
-      return 0;
+      /* F2008, 12.5.2.6.  */
+      if (formal->attr.allocatable &&
+         ((last && last->u.c.component->as->corank != formal->as->corank)
+          || (!last
+              && actual->symtree->n.sym->as->corank != formal->as->corank)))
+       {
+         if (where)
+           gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+                  formal->name, &actual->where, formal->as->corank,
+                  last ? last->u.c.component->as->corank
+                       : actual->symtree->n.sym->as->corank);
+         return 0;
+       }

 
 

-  for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
-      break;
+      /* F2008, 12.5.2.8.  */
+      if (formal->attr.dimension
+         && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+         && !gfc_is_simply_contiguous (actual, true))
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must be simply "
+                      "contiguous", formal->name, &actual->where);
+         return 0;
+       }
+    }

 
 

-  if (ref == NULL)
-    return 0;                  /* Not an array element.  */
+  /* F2008, C1239/C1240.  */
+  if (actual->expr_type == EXPR_VARIABLE
+      && (actual->symtree->n.sym->attr.asynchronous
+         || actual->symtree->n.sym->attr.volatile_)
+      &&  (formal->attr.asynchronous || formal->attr.volatile_)
+      && actual->rank && !gfc_is_simply_contiguous (actual, true)
+      && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+         || formal->attr.contiguous))
+    {
+      if (where)
+       gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+                  "array without CONTIGUOUS attribute - as actual argument at"
+                  " %L is not simply contiguous and both are ASYNCHRONOUS "
+                  "or VOLATILE", formal->name, &actual->where);
+      return 0;
+    }

 
 

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

 
 

+  rank_check = where != NULL && !is_elemental && formal->as
+              && (formal->as->type == AS_ASSUMED_SHAPE
+                  || formal->as->type == AS_DEFERRED)
+              && actual->expr_type != EXPR_NULL;
+
+  /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
+  if (rank_check || ranks_must_agree
+      || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
+      || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
+      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
+         && actual->expr_type != EXPR_NULL)
+      || (actual->rank == 0 && formal->attr.dimension
+         && gfc_is_coindexed (actual)))
+    {
+      if (where)
+       argument_rank_mismatch (formal->name, &actual->where,
+                               symbol_rank (formal), actual->rank);
+      return 0;
+    }
+  else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
+    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.  */
+  /* At this point, we are considering a scalar passed to an array.   This
+     is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
+     - if the actual argument is (a substring of) an element of a
+       non-assumed-shape/non-pointer/non-polymorphic array; or
+     - (F2003) if the actual argument is of type character of default/c_char
+       kind.  */

 
 

-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
-  if (actual->expr_type != EXPR_VARIABLE)
-    return 1;
+  is_pointer = actual->expr_type == EXPR_VARIABLE
+              ? actual->symtree->n.sym->attr.pointer : false;

 
 

-  if (!actual->symtree->n.sym->attr.protected)
-    return 1;
+  for (ref = actual->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+       is_pointer = ref->u.c.component->attr.pointer;
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+              && ref->u.ar.dimen > 0
+              && (!ref->next 
+                  || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+        break;
+    }

 
 

-  if (!actual->symtree->n.sym->attr.use_assoc)
-    return 1;
+  if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
+    {
+      if (where)
+       gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+                  "at %L", formal->name, &actual->where);
+      return 0;
+    }

 
 

-  if (formal->attr.intent == INTENT_IN
-      || formal->attr.intent == INTENT_UNKNOWN)
-    return 1;
+  if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+      && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+    {
+      if (where)
+       gfc_error ("Element of assumed-shaped or pointer "
+                  "array passed to array dummy argument '%s' at %L",
+                  formal->name, &actual->where);
+      return 0;
+    }
+
+  if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+      && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+    {
+      if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+       {
+         if (where)
+           gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+                      "CHARACTER actual argument with array dummy argument "
+                      "'%s' at %L", formal->name, &actual->where);
+         return 0;
+       }

 
 

-  if (!actual->symtree->n.sym->attr.pointer)
-    return 0;
+      if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+       {
+         gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
+                    "array dummy argument '%s' at %L",
+                    formal->name, &actual->where);
+         return 0;
+       }
+      else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+       return 0;
+      else
+       return 1;
+    }

 
 

-  if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
-    return 0;
+  if (ref == NULL && actual->expr_type != EXPR_NULL)
+    {
+      if (where)
+       argument_rank_mismatch (formal->name, &actual->where,
+                               symbol_rank (formal), actual->rank);
+      return 0;
+    }

 
   return 1;
 }
 
   return 1;
 }


@@ -1530,9 +1750,9 @@ get_sym_storage_size (gfc_symbol *sym)
 
   if (sym->ts.type == BT_CHARACTER)
     {
 
   if (sym->ts.type == BT_CHARACTER)
     {

-      if (sym->ts.cl && sym->ts.cl->length
-          && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
-       strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+      if (sym->ts.u.cl && sym->ts.u.cl->length
+          && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+       strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);

       else
        return 0;
     }
       else
        return 0;
     }


@@ -1551,8 +1771,8 @@ get_sym_storage_size (gfc_symbol *sym)
          || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
        return 0;
 
          || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
        return 0;
 

-      elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
-                 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+      elements *= mpz_get_si (sym->as->upper[i]->value.integer)
+                 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;

     }
 
   return strlen*elements;
     }
 
   return strlen*elements;


@@ -1569,6 +1789,8 @@ get_expr_storage_size (gfc_expr *e)
 {
   int i;
   long int strlen, elements;
 {
   int i;
   long int strlen, elements;

+  long int substrlen = 0;
+  bool is_str_storage = false;

   gfc_ref *ref;
 
   if (e == NULL)
   gfc_ref *ref;
 
   if (e == NULL)


@@ -1576,11 +1798,11 @@ get_expr_storage_size (gfc_expr *e)
   
   if (e->ts.type == BT_CHARACTER)
     {
   
   if (e->ts.type == BT_CHARACTER)
     {

-      if (e->ts.cl && e->ts.cl->length
-          && e->ts.cl->length->expr_type == EXPR_CONSTANT)
-       strlen = mpz_get_si (e->ts.cl->length->value.integer);
+      if (e->ts.u.cl && e->ts.u.cl->length
+          && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+       strlen = mpz_get_si (e->ts.u.cl->length->value.integer);

       else if (e->expr_type == EXPR_CONSTANT
       else if (e->expr_type == EXPR_CONSTANT

-              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))

        strlen = e->value.character.length;
       else
        return 0;
        strlen = e->value.character.length;
       else
        return 0;


@@ -1603,6 +1825,23 @@ get_expr_storage_size (gfc_expr *e)
 
   for (ref = e->ref; ref; ref = ref->next)
     {
 
   for (ref = e->ref; ref; ref = ref->next)
     {

+      if (ref->type == REF_SUBSTRING && ref->u.ss.start
+         && ref->u.ss.start->expr_type == EXPR_CONSTANT)
+       {
+         if (is_str_storage)
+           {
+             /* The string length is the substring length.
+                Set now to full string length.  */
+             if (ref->u.ss.length == NULL
+                 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+               return 0;
+
+             strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+           }
+         substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+         continue;
+       }
+

       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
          && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
          && ref->u.ar.as->upper)
       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
          && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
          && ref->u.ar.as->upper)


@@ -1660,14 +1899,45 @@ get_expr_storage_size (gfc_expr *e)
            else
              return 0;
          }
            else
              return 0;
          }

-      else
-        /* TODO: Determine the number of remaining elements in the element
-           sequence for array element designators.
-           See also get_array_index in data.c.  */
-       return 0;
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+              && e->expr_type == EXPR_VARIABLE)
+       {
+         if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
+             || e->symtree->n.sym->attr.pointer)
+           {
+             elements = 1;
+             continue;
+           }
+
+         /* Determine the number of remaining elements in the element
+            sequence for array element designators.  */
+         is_str_storage = true;
+         for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+           {
+             if (ref->u.ar.start[i] == NULL
+                 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+                 || ref->u.ar.as->upper[i] == NULL
+                 || ref->u.ar.as->lower[i] == NULL
+                 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+                 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+               return 0;
+
+             elements
+                  = elements
+                    * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+                       - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+                       + 1L)
+                    - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+                       - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+           }
+        }

     }
 
     }
 

-  return elements*strlen;
+  if (substrlen)
+    return (is_str_storage) ? substrlen + (elements-1)*strlen
+                           : elements*strlen;
+  else
+    return elements*strlen;

 }
 
 
 }
 
 


@@ -1675,8 +1945,8 @@ get_expr_storage_size (gfc_expr *e)
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
 
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
 

-static int
-has_vector_subscript (gfc_expr *e)
+int
+gfc_has_vector_subscript (gfc_expr *e)

 {
   int i;
   gfc_ref *ref;
 {
   int i;
   gfc_ref *ref;


@@ -1703,12 +1973,11 @@ has_vector_subscript (gfc_expr *e)
 
 static int
 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
 static int
 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,

-                      int ranks_must_agree, int is_elemental, locus *where)
+                      int ranks_must_agree, int is_elemental, locus *where)

 {
 {

-  gfc_actual_arglist **new, *a, *actual, temp;
+  gfc_actual_arglist **new_arg, *a, *actual, temp;

   gfc_formal_arglist *f;
   int i, n, na;
   gfc_formal_arglist *f;
   int i, n, na;

-  bool rank_check;

   unsigned long actual_size, formal_size;
 
   actual = *ap;
   unsigned long actual_size, formal_size;
 
   actual = *ap;


@@ -1720,10 +1989,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   for (f = formal; f; f = f->next)
     n++;
 
   for (f = formal; f; f = f->next)
     n++;
 

-  new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
+  new_arg = XALLOCAVEC (gfc_actual_arglist *, n);

 
   for (i = 0; i < n; i++)
 
   for (i = 0; i < n; i++)

-    new[i] = NULL;
+    new_arg[i] = NULL;

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


@@ -1751,7 +2020,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
              return 0;
            }
 
              return 0;
            }
 

-         if (new[i] != NULL)
+         if (new_arg[i] != NULL)

            {
              if (where)
                gfc_error ("Keyword argument '%s' at %L is already associated "
            {
              if (where)
                gfc_error ("Keyword argument '%s' at %L is already associated "


@@ -1789,73 +2058,103 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          return 0;
        }
 
          return 0;
        }
 

-      rank_check = where != NULL && !is_elemental && f->sym->as
-                  && (f->sym->as->type == AS_ASSUMED_SHAPE
-                      || f->sym->as->type == AS_DEFERRED);
-
-      if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
-         && a->expr->rank == 0 && !ranks_must_agree
-         && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
+      if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
+         && (f->sym->attr.allocatable || !f->sym->attr.optional
+             || (gfc_option.allow_std & GFC_STD_F2008) == 0))

        {
        {

-         if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
-           {
-             gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
-                        "with array dummy argument '%s' at %L",
-                        f->sym->name, &a->expr->where);
-             return 0;
-           }
-         else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
-           return 0;
+         if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+           gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+                      where, f->sym->name);
+         else if (where)
+           gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
+                      "dummy '%s'", where, f->sym->name);

 
 

-       }
-      else if (!compare_parameter (f->sym, a->expr,
-                                  ranks_must_agree || rank_check, is_elemental))
-       {
-         if (where)
-           gfc_error ("Type/rank mismatch in argument '%s' at %L",
-                      f->sym->name, &a->expr->where);

          return 0;
        }
          return 0;
        }

+      
+      if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+                             is_elemental, where))
+       return 0;

 
 

+      /* Special case for character arguments.  For allocatable, pointer
+        and assumed-shape dummies, the string length needs to match
+        exactly.  */

       if (a->expr->ts.type == BT_CHARACTER
       if (a->expr->ts.type == BT_CHARACTER

-          && a->expr->ts.cl && a->expr->ts.cl->length
-          && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
-          && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
-          && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+          && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+          && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+          && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
+          && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
+          && (f->sym->attr.pointer || f->sym->attr.allocatable
+              || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+          && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
+                       f->sym->ts.u.cl->length->value.integer) != 0))

         {
         {

-          if ((f->sym->attr.pointer || f->sym->attr.allocatable)
-              && (mpz_cmp (a->expr->ts.cl->length->value.integer,
-                          f->sym->ts.cl->length->value.integer) != 0))
-            {
-               if (where)
-                 gfc_warning ("Character length mismatch between actual "
-                              "argument and pointer or allocatable dummy "
-                              "argument '%s' at %L",
-                              f->sym->name, &a->expr->where);
-               return 0;
-            }
+          if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+            gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+                         "argument and pointer or allocatable dummy argument "
+                         "'%s' at %L",
+                         mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+                         mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+                         f->sym->name, &a->expr->where);
+          else if (where)
+            gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+                         "argument and assumed-shape dummy argument '%s' "
+                         "at %L",
+                         mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+                         mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+                         f->sym->name, &a->expr->where);
+          return 0;

         }
 
         }
 

+      if ((f->sym->attr.pointer || f->sym->attr.allocatable)
+           && f->sym->ts.deferred != a->expr->ts.deferred
+           && a->expr->ts.type == BT_CHARACTER)
+       {
+         if (where)
+           gfc_error ("Actual argument argument at %L to allocatable or "
+                      "pointer dummy argument '%s' must have a deferred "
+                      "length type parameter if and only if the dummy has one",
+                      &a->expr->where, f->sym->name);
+         return 0;
+       }
+

       actual_size = get_expr_storage_size (a->expr);
       formal_size = get_sym_storage_size (f->sym);
       actual_size = get_expr_storage_size (a->expr);
       formal_size = get_sym_storage_size (f->sym);

-      if (actual_size != 0 && actual_size < formal_size)
+      if (actual_size != 0 && actual_size < formal_size
+         && a->expr->ts.type != BT_PROCEDURE
+         && f->sym->attr.flavor != FL_PROCEDURE)

        {
          if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
            gfc_warning ("Character length of actual argument shorter "
        {
          if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
            gfc_warning ("Character length of actual argument shorter "

-                       "than of dummy argument '%s' (%lu/%lu) at %L",
-                       f->sym->name, actual_size, formal_size,
-                       &a->expr->where);
+                        "than of dummy argument '%s' (%lu/%lu) at %L",
+                        f->sym->name, actual_size, formal_size,
+                        &a->expr->where);

           else if (where)
            gfc_warning ("Actual argument contains too few "
           else if (where)
            gfc_warning ("Actual argument contains too few "

-                       "elements for dummy argument '%s' (%lu/%lu) at %L",
-                       f->sym->name, actual_size, formal_size,
-                       &a->expr->where);
+                        "elements for dummy argument '%s' (%lu/%lu) at %L",
+                        f->sym->name, actual_size, formal_size,
+                        &a->expr->where);

          return  0;
        }
 
          return  0;
        }
 

+      /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+        is provided for a procedure pointer formal argument.  */
+      if (f->sym->attr.proc_pointer
+         && !((a->expr->expr_type == EXPR_VARIABLE
+               && a->expr->symtree->n.sym->attr.proc_pointer)
+              || (a->expr->expr_type == EXPR_FUNCTION
+                  && a->expr->symtree->n.sym->result->attr.proc_pointer)
+              || gfc_is_proc_ptr_comp (a->expr, NULL)))
+       {
+         if (where)
+           gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+                      f->sym->name, &a->expr->where);
+         return 0;
+       }
+

       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
         provided for a procedure formal argument.  */
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
         provided for a procedure formal argument.  */

-      if (a->expr->ts.type != BT_PROCEDURE
+      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)

          && a->expr->expr_type == EXPR_VARIABLE
          && f->sym->attr.flavor == FL_PROCEDURE)
        {
          && a->expr->expr_type == EXPR_VARIABLE
          && f->sym->attr.flavor == FL_PROCEDURE)
        {


@@ -1899,44 +2198,104 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
        }
 
       if (a->expr->expr_type != EXPR_NULL
        }
 
       if (a->expr->expr_type != EXPR_NULL

-         && compare_allocatable (f->sym, a->expr) == 0)
+         && (gfc_option.allow_std & GFC_STD_F2008) == 0
+         && compare_pointer (f->sym, a->expr) == 2)

        {
          if (where)
        {
          if (where)

-           gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
-                      f->sym->name, &a->expr->where);
+           gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+                      "pointer dummy '%s'", &a->expr->where,f->sym->name);

          return 0;
        }
          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))
+      /* Fortran 2008, C1242.  */
+      if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))

        {
          if (where)
        {
          if (where)

-           gfc_error ("Actual argument at %L must be definable to "
-                      "match dummy INTENT = OUT/INOUT", &a->expr->where);
+           gfc_error ("Coindexed actual argument at %L to pointer "
+                      "dummy '%s'",
+                      &a->expr->where, f->sym->name);

          return 0;
        }
 
          return 0;
        }
 

-      if (!compare_parameter_protected(f->sym, a->expr))
+      /* Fortran 2008, 12.5.2.5 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+         && f->sym->attr.intent != INTENT_IN
+         && f->sym->attr.allocatable
+         && gfc_is_coindexed (a->expr))

        {
          if (where)
        {
          if (where)

-           gfc_error ("Actual argument at %L is use-associated with "
-                      "PROTECTED attribute and dummy argument '%s' is "
-                      "INTENT = OUT/INOUT",
-                      &a->expr->where,f->sym->name);
+           gfc_error ("Coindexed actual argument at %L to allocatable "
+                      "dummy '%s' requires INTENT(IN)",
+                      &a->expr->where, f->sym->name);
+         return 0;
+       }
+
+      /* Fortran 2008, C1237.  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+         && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+         && gfc_is_coindexed (a->expr)
+         && (a->expr->symtree->n.sym->attr.volatile_
+             || a->expr->symtree->n.sym->attr.asynchronous))
+       {
+         if (where)
+           gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+                      "at %L requires that dummy %s' has neither "
+                      "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+                      f->sym->name);
+         return 0;
+       }
+
+      /* Fortran 2008, 12.5.2.4 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+         && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+         && gfc_is_coindexed (a->expr)
+         && gfc_has_ultimate_allocatable (a->expr))
+       {
+         if (where)
+           gfc_error ("Coindexed actual argument at %L with allocatable "
+                      "ultimate component to dummy '%s' requires either VALUE "
+                      "or INTENT(IN)", &a->expr->where, f->sym->name);
+         return 0;
+       }
+
+      if (a->expr->expr_type != EXPR_NULL
+         && compare_allocatable (f->sym, a->expr) == 0)
+       {
+         if (where)
+           gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+                      f->sym->name, &a->expr->where);

          return 0;
        }
 
          return 0;
        }
 

+      /* Check intent = OUT/INOUT for definable actual argument.  */
+      if ((f->sym->attr.intent == INTENT_OUT
+         || f->sym->attr.intent == INTENT_INOUT))
+       {
+         const char* context = (where
+                                ? _("actual argument to INTENT = OUT/INOUT")
+                                : NULL);
+
+         if (f->sym->attr.pointer
+             && gfc_check_vardef_context (a->expr, true, context)
+                  == FAILURE)
+           return 0;
+         if (gfc_check_vardef_context (a->expr, false, context)
+               == FAILURE)
+           return 0;
+       }
+

       if ((f->sym->attr.intent == INTENT_OUT
           || f->sym->attr.intent == INTENT_INOUT
       if ((f->sym->attr.intent == INTENT_OUT
           || f->sym->attr.intent == INTENT_INOUT

-          || f->sym->attr.volatile_)
-          && has_vector_subscript (a->expr))
+          || f->sym->attr.volatile_
+          || f->sym->attr.asynchronous)
+         && gfc_has_vector_subscript (a->expr))

        {
          if (where)
        {
          if (where)

-           gfc_error ("Array-section actual argument with vector subscripts "
-                      "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
-                      "or VOLATILE attribute of the dummy argument '%s'",
+           gfc_error ("Array-section actual argument with vector "
+                      "subscripts at %L is incompatible with INTENT(OUT), "
+                      "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
+                      "of the dummy argument '%s'",

                       &a->expr->where, f->sym->name);
          return 0;
        }
                       &a->expr->where, f->sym->name);
          return 0;
        }


@@ -1993,14 +2352,14 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       if (a == actual)
        na = i;
 
       if (a == actual)
        na = i;
 

-      new[i++] = a;
+      new_arg[i++] = a;

     }
 
   /* Make sure missing actual arguments are optional.  */
   i = 0;
   for (f = formal; f; f = f->next, i++)
     {
     }
 
   /* Make sure missing actual arguments are optional.  */
   i = 0;
   for (f = formal; f; f = f->next, i++)
     {

-      if (new[i] != NULL)
+      if (new_arg[i] != NULL)

        continue;
       if (f->sym == NULL)
        {
        continue;
       if (f->sym == NULL)
        {


@@ -2022,30 +2381,30 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
      argument list with null arguments in the right places.  The head
      of the list remains the head.  */
   for (i = 0; i < n; i++)
      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 (new_arg[i] == NULL)
+      new_arg[i] = gfc_get_actual_arglist ();

 
   if (na != 0)
     {
 
   if (na != 0)
     {

-      temp = *new[0];
-      *new[0] = *actual;
+      temp = *new_arg[0];
+      *new_arg[0] = *actual;

       *actual = temp;
 
       *actual = temp;
 

-      a = new[0];
-      new[0] = new[na];
-      new[na] = a;
+      a = new_arg[0];
+      new_arg[0] = new_arg[na];
+      new_arg[na] = a;

     }
 
   for (i = 0; i < n - 1; i++)
     }
 
   for (i = 0; i < n - 1; i++)

-    new[i]->next = new[i + 1];
+    new_arg[i]->next = new_arg[i + 1];

 
 

-  new[i]->next = NULL;
+  new_arg[i]->next = NULL;

 
   if (*ap == NULL && n > 0)
 
   if (*ap == NULL && n > 0)

-    *ap = new[0];
+    *ap = new_arg[0];

 
   /* Note the types of omitted optional arguments.  */
 
   /* Note the types of omitted optional arguments.  */

-  for (a = actual, f = formal; a; a = a->next, f = f->next)
+  for (a = *ap, f = formal; a; a = a->next, f = f->next)

     if (a->expr == NULL && a->label == NULL)
       a->missing_arg_type = f->sym->ts.type;
 
     if (a->expr == NULL && a->label == NULL)
       a->missing_arg_type = f->sym->ts.type;
 


@@ -2098,7 +2457,7 @@ pair_cmp (const void *p1, const void *p2)
    refer to the same expression. The analysis is conservative.
    Returning FAILURE will produce no warning.  */
 
    refer to the same expression. The analysis is conservative.
    Returning FAILURE will produce no warning.  */
 

-static try
+static gfc_try

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


@@ -2147,7 +2506,7 @@ compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
    another, check that identical actual arguments aren't not
    associated with some incompatible INTENTs.  */
 
    another, check that identical actual arguments aren't not
    associated with some incompatible INTENTs.  */
 

-static try
+static gfc_try

 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
 {
   sym_intent f1_intent, f2_intent;
 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
 {
   sym_intent f1_intent, f2_intent;


@@ -2155,7 +2514,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
   gfc_actual_arglist *a1;
   size_t n, i, j;
   argpair *p;
   gfc_actual_arglist *a1;
   size_t n, i, j;
   argpair *p;

-  try t = SUCCESS;
+  gfc_try t = SUCCESS;

 
   n = 0;
   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
 
   n = 0;
   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)


@@ -2168,7 +2527,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
     }
   if (n == 0)
     return t;
     }
   if (n == 0)
     return t;

-  p = (argpair *) alloca (n * sizeof (argpair));
+  p = XALLOCAVEC (argpair, n);

 
   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
     {
 
   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
     {


@@ -2235,7 +2594,7 @@ compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
 
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
 

-static try
+static gfc_try

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


@@ -2270,7 +2629,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
              return FAILURE;
            }
 
              return FAILURE;
            }
 

-         if (a->expr->symtree->n.sym->attr.pointer)
+         if (f->sym->attr.pointer)

            {
              gfc_error ("Procedure argument at %L is local to a PURE "
                         "procedure and has the POINTER attribute",
            {
              gfc_error ("Procedure argument at %L is local to a PURE "
                         "procedure and has the POINTER attribute",


@@ -2278,6 +2637,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
              return FAILURE;
            }
        }
              return FAILURE;
            }
        }

+
+       /* Fortran 2008, C1283.  */
+       if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+       {
+         if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+           {
+             gfc_error ("Coindexed actual argument at %L in PURE procedure "
+                        "is passed to an INTENT(%s) argument",
+                        &a->expr->where, gfc_intent_string (f_intent));
+             return FAILURE;
+           }
+
+         if (f->sym->attr.pointer)
+           {
+             gfc_error ("Coindexed actual argument at %L in PURE procedure "
+                        "is passed to a POINTER dummy argument",
+                        &a->expr->where);
+             return FAILURE;
+           }
+       }
+
+       /* F2008, Section 12.5.2.4.  */
+       if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+          && gfc_is_coindexed (a->expr))
+        {
+          gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+                     "polymorphic dummy argument '%s'",
+                        &a->expr->where, f->sym->name);
+          return FAILURE;
+        }

     }
 
   return SUCCESS;
     }
 
   return SUCCESS;


@@ -2292,29 +2681,63 @@ void
 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
 
 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
 

-  /* 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);
+  /* Warn about calls with an implicit interface.  Special case
+     for calling a ISO_C_BINDING becase c_loc and c_funloc
+     are pseudo-unknown.  Additionally, warn about procedures not
+     explicitly declared at all if requested.  */
+  if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
+    {
+      if (gfc_option.warn_implicit_interface)
+       gfc_warning ("Procedure '%s' called with an implicit interface at %L",
+                    sym->name, where);
+      else if (gfc_option.warn_implicit_procedure
+              && sym->attr.proc == PROC_UNKNOWN)
+       gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
+                    sym->name, where);
+    }

 
 

-  if (sym->interface && sym->interface->attr.intrinsic)
+  if (sym->attr.if_source == IFSRC_UNKNOWN)

     {
     {

-      gfc_intrinsic_sym *isym;
-      isym = gfc_find_function (sym->interface->name);
-      if (isym != NULL)
+      gfc_actual_arglist *a;
+
+      if (sym->attr.pointer)

        {
        {

-         if (compare_actual_formal_intr (ap, sym->interface))
-           return;
-         gfc_error ("Type/rank mismatch in argument '%s' at %L",
-                    sym->name, where);
+         gfc_error("The pointer object '%s' at %L must have an explicit "
+                   "function interface or be declared as array",
+                   sym->name, where);
+         return;
+       }
+
+      if (sym->attr.allocatable && !sym->attr.external)
+       {
+         gfc_error("The allocatable object '%s' at %L must have an explicit "
+                   "function interface or be declared as array",
+                   sym->name, where);
+         return;
+       }
+
+      if (sym->attr.allocatable)
+       {
+         gfc_error("Allocatable function '%s' at %L must have an explicit "
+                   "function interface", sym->name, where);

          return;
        }
          return;
        }

+
+      for (a = *ap; a; a = a->next)
+       {
+         /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
+         if (a->name != NULL && a->name[0] != '%')
+           {
+             gfc_error("Keyword argument requires explicit interface "
+                       "for procedure '%s' at %L", sym->name, &a->expr->where);
+             break;
+           }
+       }
+
+      return;

     }
 
     }
 

-  if (sym->attr.if_source == IFSRC_UNKNOWN
-      || !compare_actual_formal (ap, sym->formal, 0,
-                                sym->attr.elemental, where))
+  if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))

     return;
 
   check_intents (sym->formal, *ap);
     return;
 
   check_intents (sym->formal, *ap);


@@ -2323,6 +2746,74 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 }
 
 
 }
 
 

+/* Check how a procedure pointer component is used against its interface.
+   If all goes well, the actual argument list will also end up being properly
+   sorted. Completely analogous to gfc_procedure_use.  */
+
+void
+gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
+{
+
+  /* Warn about calls with an implicit interface.  Special case
+     for calling a ISO_C_BINDING becase c_loc and c_funloc
+     are pseudo-unknown.  */
+  if (gfc_option.warn_implicit_interface
+      && comp->attr.if_source == IFSRC_UNKNOWN
+      && !comp->attr.is_iso_c)
+    gfc_warning ("Procedure pointer component '%s' called with an implicit "
+                "interface at %L", comp->name, where);
+
+  if (comp->attr.if_source == IFSRC_UNKNOWN)
+    {
+      gfc_actual_arglist *a;
+      for (a = *ap; a; a = a->next)
+       {
+         /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
+         if (a->name != NULL && a->name[0] != '%')
+           {
+             gfc_error("Keyword argument requires explicit interface "
+                       "for procedure pointer component '%s' at %L",
+                       comp->name, &a->expr->where);
+             break;
+           }
+       }
+
+      return;
+    }
+
+  if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
+    return;
+
+  check_intents (comp->formal, *ap);
+  if (gfc_option.warn_aliasing)
+    check_some_aliasing (comp->formal, *ap);
+}
+
+
+/* Try if an actual argument list matches the formal list of a symbol,
+   respecting the symbol's attributes like ELEMENTAL.  This is used for
+   GENERIC resolution.  */
+
+bool
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+{
+  bool r;
+
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+  r = !sym->attr.elemental;
+  if (compare_actual_formal (args, sym->formal, r, !r, NULL))
+    {
+      check_intents (sym->formal, *args);
+      if (gfc_option.warn_aliasing)
+       check_some_aliasing (sym->formal, *args);
+      return true;
+    }
+
+  return false;
+}
+
+

 /* 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
 /* 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


@@ -2332,8 +2823,7 @@ gfc_symbol *
 gfc_search_interface (gfc_interface *intr, int sub_flag,
                      gfc_actual_arglist **ap)
 {
 gfc_search_interface (gfc_interface *intr, int sub_flag,
                      gfc_actual_arglist **ap)
 {

-  int r;
-
+  gfc_symbol *elem_sym = NULL;

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


@@ -2341,18 +2831,20 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
       if (!sub_flag && intr->sym->attr.subroutine)
        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))
+      if (gfc_arglist_matches_symbol (ap, intr->sym))

        {
        {

-         check_intents (intr->sym->formal, *ap);
-         if (gfc_option.warn_aliasing)
-           check_some_aliasing (intr->sym->formal, *ap);
+         /* Satisfy 12.4.4.1 such that an elemental match has lower
+            weight than a non-elemental match.  */ 
+         if (intr->sym->attr.elemental)
+           {
+             elem_sym = intr->sym;
+             continue;
+           }

          return intr->sym;
        }
     }
 
          return intr->sym;
        }
     }
 

-  return NULL;
+  return elem_sym ? elem_sym : NULL;

 }
 
 
 }
 
 


@@ -2377,8 +2869,8 @@ find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
 
 /* Find a symtree for a symbol.  */
 
 
 /* Find a symtree for a symbol.  */
 

-static gfc_symtree *
-find_sym_in_symtree (gfc_symbol *sym)
+gfc_symtree *
+gfc_find_sym_in_symtree (gfc_symbol *sym)

 {
   gfc_symtree *st;
   gfc_namespace *ns;
 {
   gfc_symtree *st;
   gfc_namespace *ns;


@@ -2402,35 +2894,153 @@ find_sym_in_symtree (gfc_symbol *sym)
 }
 
 
 }
 
 

+/* See if the arglist to an operator-call contains a derived-type argument
+   with a matching type-bound operator.  If so, return the matching specific
+   procedure defined as operator-target as well as the base-object to use
+   (which is the found derived-type argument with operator).  The generic
+   name, if any, is transmitted to the final expression via 'gname'.  */
+
+static gfc_typebound_proc*
+matching_typebound_op (gfc_expr** tb_base,
+                      gfc_actual_arglist* args,
+                      gfc_intrinsic_op op, const char* uop,
+                      const char ** gname)
+{
+  gfc_actual_arglist* base;
+
+  for (base = args; base; base = base->next)
+    if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
+      {
+       gfc_typebound_proc* tb;
+       gfc_symbol* derived;
+       gfc_try result;
+
+       if (base->expr->ts.type == BT_CLASS)
+         {
+           if (!gfc_expr_attr (base->expr).class_ok)
+             continue;
+           derived = CLASS_DATA (base->expr)->ts.u.derived;
+         }
+       else
+         derived = base->expr->ts.u.derived;
+
+       if (op == INTRINSIC_USER)
+         {
+           gfc_symtree* tb_uop;
+
+           gcc_assert (uop);
+           tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
+                                                false, NULL);
+
+           if (tb_uop)
+             tb = tb_uop->n.tb;
+           else
+             tb = NULL;
+         }
+       else
+         tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
+                                               false, NULL);
+
+       /* This means we hit a PRIVATE operator which is use-associated and
+          should thus not be seen.  */
+       if (result == FAILURE)
+         tb = NULL;
+
+       /* Look through the super-type hierarchy for a matching specific
+          binding.  */
+       for (; tb; tb = tb->overridden)
+         {
+           gfc_tbp_generic* g;
+
+           gcc_assert (tb->is_generic);
+           for (g = tb->u.generic; g; g = g->next)
+             {
+               gfc_symbol* target;
+               gfc_actual_arglist* argcopy;
+               bool matches;
+
+               gcc_assert (g->specific);
+               if (g->specific->error)
+                 continue;
+
+               target = g->specific->u.specific->n.sym;
+
+               /* Check if this arglist matches the formal.  */
+               argcopy = gfc_copy_actual_arglist (args);
+               matches = gfc_arglist_matches_symbol (&argcopy, target);
+               gfc_free_actual_arglist (argcopy);
+
+               /* Return if we found a match.  */
+               if (matches)
+                 {
+                   *tb_base = base->expr;
+                   *gname = g->specific_st->name;
+                   return g->specific;
+                 }
+             }
+         }
+      }
+
+  return NULL;
+}
+
+
+/* For the 'actual arglist' of an operator call and a specific typebound
+   procedure that has been found the target of a type-bound operator, build the
+   appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
+   type-bound procedures rather than resolving type-bound operators 'directly'
+   so that we can reuse the existing logic.  */
+
+static void
+build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
+                            gfc_expr* base, gfc_typebound_proc* target,
+                            const char *gname)
+{
+  e->expr_type = EXPR_COMPCALL;
+  e->value.compcall.tbp = target;
+  e->value.compcall.name = gname ? gname : "$op";
+  e->value.compcall.actual = actual;
+  e->value.compcall.base_object = base;
+  e->value.compcall.ignore_pass = 1;
+  e->value.compcall.assign = 0;
+}
+
+

 /* 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
 /* 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.  */
+   the appropriate function call.
+   real_error is an additional output argument that specifies if FAILURE
+   is because of some real error and not because no match was found.  */

 
 

-try
-gfc_extend_expr (gfc_expr *e)
+gfc_try
+gfc_extend_expr (gfc_expr *e, bool *real_error)

 {
   gfc_actual_arglist *actual;
   gfc_symbol *sym;
   gfc_namespace *ns;
   gfc_user_op *uop;
   gfc_intrinsic_op i;
 {
   gfc_actual_arglist *actual;
   gfc_symbol *sym;
   gfc_namespace *ns;
   gfc_user_op *uop;
   gfc_intrinsic_op i;

+  const char *gname;

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

+  *real_error = false;
+  gname = NULL;
+

   if (e->value.op.op2 != NULL)
     {
       actual->next = gfc_get_actual_arglist ();
       actual->next->expr = e->value.op.op2;
     }
 
   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);
+  i = fold_unary_intrinsic (e->value.op.op);

 
   if (i == INTRINSIC_USER)
     {
 
   if (i == INTRINSIC_USER)
     {


@@ -2440,7 +3050,7 @@ gfc_extend_expr (gfc_expr *e)
          if (uop == NULL)
            continue;
 
          if (uop == NULL)
            continue;
 

-         sym = gfc_search_interface (uop->operator, 0, &actual);
+         sym = gfc_search_interface (uop->op, 0, &actual);

          if (sym != NULL)
            break;
        }
          if (sym != NULL)
            break;
        }


@@ -2453,50 +3063,23 @@ gfc_extend_expr (gfc_expr *e)
             to check if either is defined.  */
          switch (i)
            {
             to check if either is defined.  */
          switch (i)
            {

-             case INTRINSIC_EQ:
-             case INTRINSIC_EQ_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
-               break;
-
-             case INTRINSIC_NE:
-             case INTRINSIC_NE_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
-               break;
-
-             case INTRINSIC_GT:
-             case INTRINSIC_GT_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
-               break;
-
-             case INTRINSIC_GE:
-             case INTRINSIC_GE_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
-               break;
-
-             case INTRINSIC_LT:
-             case INTRINSIC_LT_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
-               break;
-
-             case INTRINSIC_LE:
-             case INTRINSIC_LE_OS:
-               sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
-               if (sym == NULL)
-                 sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
-               break;
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
+    if (!sym) \
+      sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
+    break;
+             CHECK_OS_COMPARISON(EQ)
+             CHECK_OS_COMPARISON(NE)
+             CHECK_OS_COMPARISON(GT)
+             CHECK_OS_COMPARISON(GE)
+             CHECK_OS_COMPARISON(LT)
+             CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON

 
              default:
 
              default:

-               sym = gfc_search_interface (ns->operator[i], 0, &actual);
+               sym = gfc_search_interface (ns->op[i], 0, &actual);

            }
 
          if (sym != NULL)
            }
 
          if (sym != NULL)


@@ -2504,8 +3087,59 @@ gfc_extend_expr (gfc_expr *e)
        }
     }
 
        }
     }
 

+  /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
+     found rather than just taking the first one and not checking further.  */
+

   if (sym == NULL)
     {
   if (sym == NULL)
     {

+      gfc_typebound_proc* tbo;
+      gfc_expr* tb_base;
+
+      /* See if we find a matching type-bound operator.  */
+      if (i == INTRINSIC_USER)
+       tbo = matching_typebound_op (&tb_base, actual,
+                                    i, e->value.op.uop->name, &gname);
+      else
+       switch (i)
+         {
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    tbo = matching_typebound_op (&tb_base, actual, \
+                                INTRINSIC_##comp, NULL, &gname); \
+    if (!tbo) \
+      tbo = matching_typebound_op (&tb_base, actual, \
+                                  INTRINSIC_##comp##_OS, NULL, &gname); \
+    break;
+           CHECK_OS_COMPARISON(EQ)
+           CHECK_OS_COMPARISON(NE)
+           CHECK_OS_COMPARISON(GT)
+           CHECK_OS_COMPARISON(GE)
+           CHECK_OS_COMPARISON(LT)
+           CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+           default:
+             tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
+             break;
+         }
+             
+      /* If there is a matching typebound-operator, replace the expression with
+        a call to it and succeed.  */
+      if (tbo)
+       {
+         gfc_try result;
+
+         gcc_assert (tb_base);
+         build_compcall_for_operator (e, actual, tb_base, tbo, gname);
+
+         result = gfc_resolve_expr (e);
+         if (result == FAILURE)
+           *real_error = true;
+
+         return result;
+       }
+

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


@@ -2516,22 +3150,19 @@ gfc_extend_expr (gfc_expr *e)
 
   /* Change the expression node to a function call.  */
   e->expr_type = EXPR_FUNCTION;
 
   /* Change the expression node to a function call.  */
   e->expr_type = EXPR_FUNCTION;

-  e->symtree = find_sym_in_symtree (sym);
+  e->symtree = gfc_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;
   e->value.function.actual = actual;
   e->value.function.esym = NULL;
   e->value.function.isym = NULL;
   e->value.function.name = NULL;

+  e->user_operator = 1;

 
 

-  if (gfc_pure (NULL) && !gfc_pure (sym))
+  if (gfc_resolve_expr (e) == FAILURE)

     {
     {

-      gfc_error ("Function '%s' called in lieu of an operator at %L must "
-                "be PURE", sym->name, &e->where);
+      *real_error = true;

       return FAILURE;
     }
 
       return FAILURE;
     }
 

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

   return SUCCESS;
 }
 
   return SUCCESS;
 }
 


@@ -2541,18 +3172,22 @@ gfc_extend_expr (gfc_expr *e)
    SUCCESS if the node was replaced.  On FAILURE, no error is
    generated.  */
 
    SUCCESS if the node was replaced.  On FAILURE, no error is
    generated.  */
 

-try
+gfc_try

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

+  const char *gname;

 
 

-  lhs = c->expr;
+  gname = NULL;
+
+  lhs = c->expr1;

   rhs = c->expr2;
 
   /* Don't allow an intrinsic assignment to be replaced.  */
   rhs = c->expr2;
 
   /* Don't allow an intrinsic assignment to be replaced.  */

-  if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
+  if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
+      && (rhs->rank == 0 || rhs->rank == lhs->rank)

       && (lhs->ts.type == rhs->ts.type
          || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
     return FAILURE;
       && (lhs->ts.type == rhs->ts.type
          || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
     return FAILURE;


@@ -2567,13 +3202,38 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
   for (; ns; ns = ns->parent)
     {
 
   for (; ns; ns = ns->parent)
     {

-      sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
+      sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);

       if (sym != NULL)
        break;
     }
 
       if (sym != NULL)
        break;
     }
 

+  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
+

   if (sym == NULL)
     {
   if (sym == NULL)
     {

+      gfc_typebound_proc* tbo;
+      gfc_expr* tb_base;
+
+      /* See if we find a matching type-bound assignment.  */
+      tbo = matching_typebound_op (&tb_base, actual,
+                                  INTRINSIC_ASSIGN, NULL, &gname);
+             
+      /* If there is one, replace the expression with a call to it and
+        succeed.  */
+      if (tbo)
+       {
+         gcc_assert (tb_base);
+         c->expr1 = gfc_get_expr ();
+         build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+         c->expr1->value.compcall.assign = 1;
+         c->expr2 = NULL;
+         c->op = EXEC_COMPCALL;
+
+         /* c is resolved from the caller, so no need to do it here.  */
+
+         return SUCCESS;
+       }
+

       gfc_free (actual->next);
       gfc_free (actual);
       return FAILURE;
       gfc_free (actual->next);
       gfc_free (actual);
       return FAILURE;


@@ -2581,8 +3241,8 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
   /* Replace the assignment with the call.  */
   c->op = EXEC_ASSIGN_CALL;
 
   /* Replace the assignment with the call.  */
   c->op = EXEC_ASSIGN_CALL;

-  c->symtree = find_sym_in_symtree (sym);
-  c->expr = NULL;
+  c->symtree = gfc_find_sym_in_symtree (sym);
+  c->expr1 = NULL;

   c->expr2 = NULL;
   c->ext.actual = actual;
 
   c->expr2 = NULL;
   c->ext.actual = actual;
 


@@ -2594,17 +3254,17 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
    the given interface list.  Ambiguity isn't checked yet since module
    procedures can be present without interfaces.  */
 
    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)
+static gfc_try
+check_new_interface (gfc_interface *base, gfc_symbol *new_sym)

 {
   gfc_interface *ip;
 
   for (ip = base; ip; ip = ip->next)
     {
 {
   gfc_interface *ip;
 
   for (ip = base; ip; ip = ip->next)
     {

-      if (ip->sym == new)
+      if (ip->sym == new_sym)

        {
          gfc_error ("Entity '%s' at %C is already present in the interface",
        {
          gfc_error ("Entity '%s' at %C is already present in the interface",

-                    new->name);
+                    new_sym->name);

          return FAILURE;
        }
     }
          return FAILURE;
        }
     }


@@ -2615,8 +3275,8 @@ check_new_interface (gfc_interface *base, gfc_symbol *new)
 
 /* Add a symbol to the current interface.  */
 
 
 /* Add a symbol to the current interface.  */
 

-try
-gfc_add_interface (gfc_symbol *new)
+gfc_try
+gfc_add_interface (gfc_symbol *new_sym)

 {
   gfc_interface **head, *intr;
   gfc_namespace *ns;
 {
   gfc_interface **head, *intr;
   gfc_namespace *ns;


@@ -2634,52 +3294,52 @@ gfc_add_interface (gfc_symbol *new)
          {
            case INTRINSIC_EQ:
            case INTRINSIC_EQ_OS:
          {
            case INTRINSIC_EQ:
            case INTRINSIC_EQ_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            case INTRINSIC_NE:
            case INTRINSIC_NE_OS:
                return FAILURE;
              break;
 
            case INTRINSIC_NE:
            case INTRINSIC_NE_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            case INTRINSIC_GT:
            case INTRINSIC_GT_OS:
                return FAILURE;
              break;
 
            case INTRINSIC_GT:
            case INTRINSIC_GT_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            case INTRINSIC_GE:
            case INTRINSIC_GE_OS:
                return FAILURE;
              break;
 
            case INTRINSIC_GE:
            case INTRINSIC_GE_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            case INTRINSIC_LT:
            case INTRINSIC_LT_OS:
                return FAILURE;
              break;
 
            case INTRINSIC_LT:
            case INTRINSIC_LT_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            case INTRINSIC_LE:
            case INTRINSIC_LE_OS:
                return FAILURE;
              break;
 
            case INTRINSIC_LE:
            case INTRINSIC_LE_OS:

-             if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
-                 check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
+             if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
+                 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)

                return FAILURE;
              break;
 
            default:
                return FAILURE;
              break;
 
            default:

-             if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
+             if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)

                return FAILURE;
          }
 
                return FAILURE;
          }
 

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

       break;
 
     case INTERFACE_GENERIC:
       break;
 
     case INTERFACE_GENERIC:


@@ -2689,7 +3349,7 @@ gfc_add_interface (gfc_symbol *new)
          if (sym == NULL)
            continue;
 
          if (sym == NULL)
            continue;
 

-         if (check_new_interface (sym->generic, new) == FAILURE)
+         if (check_new_interface (sym->generic, new_sym) == FAILURE)

            return FAILURE;
        }
 
            return FAILURE;
        }
 


@@ -2697,11 +3357,11 @@ gfc_add_interface (gfc_symbol *new)
       break;
 
     case INTERFACE_USER_OP:
       break;
 
     case INTERFACE_USER_OP:

-      if (check_new_interface (current_interface.uop->operator, new)
+      if (check_new_interface (current_interface.uop->op, new_sym)

          == FAILURE)
        return FAILURE;
 
          == FAILURE)
        return FAILURE;
 

-      head = &current_interface.uop->operator;
+      head = &current_interface.uop->op;

       break;
 
     default:
       break;
 
     default:


@@ -2709,7 +3369,7 @@ gfc_add_interface (gfc_symbol *new)
     }
 
   intr = gfc_get_interface ();
     }
 
   intr = gfc_get_interface ();

-  intr->sym = new;
+  intr->sym = new_sym;

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


@@ -2725,7 +3385,7 @@ gfc_current_interface_head (void)
   switch (current_interface.type)
     {
       case INTERFACE_INTRINSIC_OP:
   switch (current_interface.type)
     {
       case INTERFACE_INTRINSIC_OP:

-       return current_interface.ns->operator[current_interface.op];
+       return current_interface.ns->op[current_interface.op];

        break;
 
       case INTERFACE_GENERIC:
        break;
 
       case INTERFACE_GENERIC:


@@ -2733,7 +3393,7 @@ gfc_current_interface_head (void)
        break;
 
       case INTERFACE_USER_OP:
        break;
 
       case INTERFACE_USER_OP:

-       return current_interface.uop->operator;
+       return current_interface.uop->op;

        break;
 
       default:
        break;
 
       default:


@@ -2748,7 +3408,7 @@ gfc_set_current_interface_head (gfc_interface *i)
   switch (current_interface.type)
     {
       case INTERFACE_INTRINSIC_OP:
   switch (current_interface.type)
     {
       case INTERFACE_INTRINSIC_OP:

-       current_interface.ns->operator[current_interface.op] = i;
+       current_interface.ns->op[current_interface.op] = i;

        break;
 
       case INTERFACE_GENERIC:
        break;
 
       case INTERFACE_GENERIC:


@@ -2756,7 +3416,7 @@ gfc_set_current_interface_head (gfc_interface *i)
        break;
 
       case INTERFACE_USER_OP:
        break;
 
       case INTERFACE_USER_OP:

-       current_interface.uop->operator = i;
+       current_interface.uop->op = i;

        break;
 
       default:
        break;
 
       default: