re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

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.

From-SVN: r161960

gcc/fortran/ChangeLog

+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

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;
 	}
     }

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

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 *);
 

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);
 }
 
 

gcc/testsuite/ChangeLog

+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

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