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.
===================================================================
@@ -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;
}
}
===================================================================
@@ -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 *);
===================================================================
@@ -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
===================================================================
@@ -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);
}
===================================================================
@@ -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
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