interface.c (compare_parameter, [...]): Fix handling of polymorphic arguments.

2012-07-19  Tobias Burnus  <burnus@net-b.de>

        * interface.c (compare_parameter, compare_actual_formal): Fix
        handling of polymorphic arguments.

From-SVN: r189669

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0f5e403ceaaf60aefc5006ab037c781e85253e65..3d6bf6dce96216f4539dd93e2371c23a98fa1f4c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2012-07-19  Tobias Burnus  <burnus@net-b.de>
+
+       * interface.c (compare_parameter, compare_actual_formal): Fix
+       handling of polymorphic arguments.
+
 2012-07-17  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/51081

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 922de039c2d771bf8943c913861a114e5b9d3445..2e181c9be878a2ab7796425827f19ebb84537d8a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1743,7 +1743,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     }
 
   /* F2008, 12.5.2.5; IR F08/0073.  */
-  if (formal->ts.type == BT_CLASS
+  if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
       && ((CLASS_DATA (formal)->attr.class_pointer
           && !formal->attr.intent == INTENT_IN)
           || CLASS_DATA (formal)->attr.allocatable))
@@ -2289,11 +2289,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          return 0;
        }
 
-      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 && (f->sym->attr.allocatable || !f->sym->attr.optional))
+      if (a->expr->expr_type == EXPR_NULL
+         && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
+              && (f->sym->attr.allocatable || !f->sym->attr.optional
+                  || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+             || (f->sym->ts.type == BT_CLASS
+                 && !CLASS_DATA (f->sym)->attr.class_pointer
+                 && (CLASS_DATA (f->sym)->attr.allocatable
+                     || !f->sym->attr.optional
+                     || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+       {
+         if (where
+             && (!f->sym->attr.optional
+                 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
+                 || (f->sym->ts.type == BT_CLASS
+                        && CLASS_DATA (f->sym)->attr.allocatable)))
            gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
                       where, f->sym->name);
          else if (where)