2010-07-08 Tobias Burnus <burnus@net-b.de>

        PR fortran/18918
        * array.c (gfc_match_array_ref): Better error message for
        coarrays with too few ranks.
        (match_subscript): Move one diagnostic to caller.
        * gfortran.h (gfc_get_corank): Add prottype.
        * expr.c (gfc_get_corank): New function.
        * iresolve.c (resolve_bound): Fix rank for cobounds.
        (gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound,
        gfc_resolve_ucobound, gfc_resolve_this_image): Update
        resolve_bound call.

2010-07-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_10.f90: Add an additional test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161960 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1b60c02..34dff47 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2010-07-08  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
+       * array.c (gfc_match_array_ref): Better error message for
+       coarrays with too few ranks.
+       (match_subscript): Move one diagnostic to caller.
+       * gfortran.h (gfc_get_corank): Add prottype.
+       * expr.c (gfc_get_corank): New function.
+       * iresolve.c (resolve_bound): Fix rank for cobounds.
+       (gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound,
+       gfc_resolve_ucobound, gfc_resolve_this_image): Update
+       resolve_bound call.
+
 2010-07-06  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/44742

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 0c36f54..68b6456 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -91,7 +91,9 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star)
   else if (!star)
     m = gfc_match_expr (&ar->start[i]);
 
-  if (m == MATCH_NO)
+  if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
+    return MATCH_NO;
+  else if (m == MATCH_NO)
     gfc_error ("Expected array subscript at %C");
   if (m != MATCH_YES)
     return MATCH_ERROR;
@@ -229,12 +231,28 @@ coarray:
       if (gfc_match_char (']') == MATCH_YES)
        {
          ar->codimen++;
+         if (ar->codimen < corank)
+           {
+             gfc_error ("Too few codimensions at %C, expected %d not %d",
+                        corank, ar->codimen);
+             return MATCH_ERROR;
+           }
          return MATCH_YES;
        }
 
       if (gfc_match_char (',') != MATCH_YES)
        {
-         gfc_error ("Invalid form of coarray reference at %C");
+         if (gfc_match_char ('*') == MATCH_YES)
+           gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+                      ar->codimen + 1, corank);
+         else
+           gfc_error ("Invalid form of coarray reference at %C");
+         return MATCH_ERROR;
+       }
+      if (ar->codimen >= corank)
+       {
+         gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
+                    ar->codimen + 1, corank);
          return MATCH_ERROR;
        }
     }

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 12a46a9..acbec8d 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4022,6 +4022,22 @@ gfc_is_coindexed (gfc_expr *e)
 }
 
 
+bool
+gfc_get_corank (gfc_expr *e)
+{
+  int corank;
+  gfc_ref *ref;
+  corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+       corank = ref->u.ar.as->corank;
+      gcc_assert (ref->type != REF_SUBSTRING);
+    }
+  return corank;
+}
+
+
 /* Check whether the expression has an ultimate allocatable component.
    Being itself allocatable does not count.  */
 bool

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a63f97e..82703e6 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2670,6 +2670,7 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
 bool gfc_is_coindexed (gfc_expr *);
+bool gfc_get_corank (gfc_expr *);
 bool gfc_has_ultimate_allocatable (gfc_expr *);
 bool gfc_has_ultimate_pointer (gfc_expr *);
 

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 8f764ef..f354312 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -122,7 +122,7 @@ resolve_mask_arg (gfc_expr *mask)
 
 static void
 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
-              const char *name)
+              const char *name, bool coarray)
 {
   f->ts.type = BT_INTEGER;
   if (kind)
@@ -134,7 +134,8 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
     {
       f->rank = 1;
       f->shape = gfc_get_shape (1);
-      mpz_init_set_ui (f->shape[0], array->rank);
+      mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
+                                           : array->rank);
     }
 
   f->value.function.name = xstrdup (name);
@@ -1268,14 +1269,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
 void
 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  resolve_bound (f, array, dim, kind, "__lbound");
+  resolve_bound (f, array, dim, kind, "__lbound", false);
 }
 
 
 void
 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  resolve_bound (f, array, dim, kind, "__lcobound");
+  resolve_bound (f, array, dim, kind, "__lcobound", true);
 }
 
 
@@ -2401,7 +2402,7 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 void
 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
 {
-  resolve_bound (f, array, dim, NULL, "__this_image");
+  resolve_bound (f, array, dim, NULL, "__this_image", true);
 }
 
 
@@ -2540,14 +2541,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 void
 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  resolve_bound (f, array, dim, kind, "__ubound");
+  resolve_bound (f, array, dim, kind, "__ubound", false);
 }
 
 
 void
 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  resolve_bound (f, array, dim, kind, "__ucobound");
+  resolve_bound (f, array, dim, kind, "__ucobound", true);
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f49130..a33b9a5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-07-08  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
+       * gfortran.dg/coarray_10.f90: Add an additional test.
+
 2010-07-08  Peter Bergner  <bergner@vnet.ibm.com>
 
        PR middle-end/44828

diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90
index 7a50c89..6ee425d 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_10.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_10.f90
@@ -24,5 +24,23 @@ subroutine this_image_check()
   j = this_image(dim=3) ! { dg-error "DIM argument without ARRAY argument" }
   i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
   i = image_index(z, 2) ! { dg-error "must be a rank one array" }
-
 end subroutine this_image_check
+
+
+subroutine rank_mismatch()
+  implicit none
+  integer,allocatable :: A(:)[:,:,:,:]
+  allocate(A(1)[1,1,1:*])     ! { dg-error "Unexpected ... for codimension" }
+  allocate(A(1)[1,1,1,1,1,*]) ! { dg-error "Invalid codimension 5" }
+  allocate(A(1)[1,1,1,*])
+  allocate(A(1)[1,1])     ! { dg-error "Too few codimensions" }
+  allocate(A(1)[1,*])     ! { dg-error "Too few codimensions" }
+  allocate(A(1)[1,1:*])   ! { dg-error "Unexpected ... for codimension" }
+
+  A(1)[1,1,1] = 1       ! { dg-error "Too few codimensions" }
+  A(1)[1,1,1,1,1,1] = 1 ! { dg-error "Invalid codimension 5" }
+  A(1)[1,1,1,1] = 1
+  A(1)[1,1] = 1         ! { dg-error "Too few codimensions" }
+  A(1)[1,1] = 1         ! { dg-error "Too few codimensions" }
+  A(1)[1,1:1] = 1       ! { dg-error "Too few codimensions" }
+end subroutine rank_mismatch