interface.c (check_intents): Fix diagnostic with coindexed coarrays.

gcc/fortran/
2014-06-25  Tobias Burnus  <burnus@net-b.de>

        * interface.c (check_intents): Fix diagnostic with
        coindexed coarrays.

gcc/testsuite/
2014-06-25  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_33.f90: New.

From-SVN: r211994

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d92a88f31a074de6a7d4c6f301651e379582115f..f1ac53257680b7de8ce6f545b79d4282183dd004 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2014-06-25  Tobias Burnus  <burnus@net-b.de>
+
+       * interface.c (check_intents): Fix diagnostic with
+       coindexed coarrays.
+
 2014-06-25  Tobias Burnus  <burnus@net-b.de>
 
        * resolve.c (resolve_ordinary_assign): Don't invoke caf_send

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 67548c062eb4c1ccac2cc60b9244d9feadf5ea30..b210d18256d59b69cb5e45c7d5b9cac3c167c28f 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3170,17 +3170,26 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 
   for (;; f = f->next, a = a->next)
     {
+      gfc_expr *expr;
+
       if (f == NULL && a == NULL)
        break;
       if (f == NULL || a == NULL)
        gfc_internal_error ("check_intents(): List mismatch");
 
-      if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
+      if (a->expr && a->expr->expr_type == EXPR_FUNCTION
+         && a->expr->value.function.isym
+         && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+       expr = a->expr->value.function.actual->expr;
+      else
+       expr = a->expr;
+
+      if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
        continue;
 
       f_intent = f->sym->attr.intent;
 
-      if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
+      if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
        {
          if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
               && CLASS_DATA (f->sym)->attr.class_pointer)
@@ -3188,19 +3197,19 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
            {
              gfc_error ("Procedure argument at %L is local to a PURE "
                         "procedure and has the POINTER attribute",
-                        &a->expr->where);
+                        &expr->where);
              return false;
            }
        }
 
        /* Fortran 2008, C1283.  */
-       if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+       if (gfc_pure (NULL) && gfc_is_coindexed (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));
+                        &expr->where, gfc_intent_string (f_intent));
              return false;
            }
 
@@ -3210,18 +3219,18 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
            {
              gfc_error ("Coindexed actual argument at %L in PURE procedure "
                         "is passed to a POINTER dummy argument",
-                        &a->expr->where);
+                        &expr->where);
              return false;
            }
        }
 
        /* F2008, Section 12.5.2.4.  */
-       if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
-          && gfc_is_coindexed (a->expr))
+       if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+          && gfc_is_coindexed (expr))
         {
           gfc_error ("Coindexed polymorphic actual argument at %L is passed "
                      "polymorphic dummy argument '%s'",
-                        &a->expr->where, f->sym->name);
+                        &expr->where, f->sym->name);
           return false;
         }
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0735c448cc1948e8430cdbd4012b5ba0d62bb856..301077bc1b440d346592f7a936814fac11889af2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2014-06-25  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray_33.f90: New.
+
 2014-06-25  Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.dg/coarray/coindexed_1.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/coarray_33.f90 b/gcc/testsuite/gfortran.dg/coarray_33.f90
new file mode 100644 (file)
index 0000000..9bd87f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_33.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+type t
+  integer :: x
+end type t
+
+class(t), allocatable :: a[:]
+allocate(t :: a[*])
+a%x = this_image()
+
+call foo(a[i]) ! { dg-error "Coindexed polymorphic actual argument at .1. is passed polymorphic dummy argument" }
+contains
+subroutine foo(y)
+  class(t) :: y
+  print *, y%x
+end subroutine foo
+end