Patchwork [Fortran] PR 18918 - Minor coarray patch: Fix expression rank and improve diagnostics

login
register
mail settings
Submitter Tobias Burnus
Date July 7, 2010, 9:14 p.m.
Message ID <4C34EE4D.2050501@net-b.de>
Download mbox | patch
Permalink /patch/58183/
State New
Headers show

Comments

Tobias Burnus - July 7, 2010, 9:14 p.m.
This patch improves two things:

a) The error messages if the codimensions are wrongly specified -
instead of a rather misleading generic message ("Error: Expected array
subscript at (1)") a more explicit message is printed.

b) In iresolve.c the rank of the result of the (l,u)cobound/this_image
intrinsics was wrong. (Currently, the code is unreachable as those
intrinsics do not support nonconstant cobounds.)

Bootstrapped and regtested on x86-64-linux.
OK for the trunk?

Tobias
Daniel Kraft - July 8, 2010, 2:07 p.m.
Tobias Burnus wrote:
> This patch improves two things:
> 
> a) The error messages if the codimensions are wrongly specified -
> instead of a rather misleading generic message ("Error: Expected array
> subscript at (1)") a more explicit message is printed.
> 
> b) In iresolve.c the rank of the result of the (l,u)cobound/this_image
> intrinsics was wrong. (Currently, the code is unreachable as those
> intrinsics do not support nonconstant cobounds.)
> 
> Bootstrapped and regtested on x86-64-linux.
> OK for the trunk?

Ok. Thanks for the patch!

Daniel

Patch

2010-07-07  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-07  Tobias Burnus  <burnus@net-b.de>

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

Index: gcc/fortran/array.c
===================================================================
--- gcc/fortran/array.c	(Revision 161931)
+++ gcc/fortran/array.c	(Arbeitskopie)
@@ -91,7 +91,9 @@  match_subscript (gfc_array_ref *ar, int
   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;
 	}
     }
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 161931)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -2670,6 +2670,7 @@  void gfc_expr_replace_comp (gfc_expr *,
 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 *);
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 161931)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -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
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(Revision 161931)
+++ gcc/fortran/iresolve.c	(Arbeitskopie)
@@ -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 *ar
     {
       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
 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, gf
 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
 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);
 }
 
 
Index: gcc/testsuite/gfortran.dg/coarray_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_10.f90	(Revision 161931)
+++ gcc/testsuite/gfortran.dg/coarray_10.f90	(Arbeitskopie)
@@ -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