From: burnus Date: Thu, 8 Jul 2010 15:17:25 +0000 (+0000) Subject: 2010-07-08 Tobias Burnus X-Git-Tag: upstream/4.9.2~28041 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=1da1826b7789821567dedb4a5418c6d61c915d1c;p=platform%2Fupstream%2Flinaro-gcc.git 2010-07-08 Tobias Burnus 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 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 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-07-08 Tobias Burnus + + 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 PR fortran/44742 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 0c36f54..68b6456 100644 --- 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 --- 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 --- 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 --- 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 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-07-08 Tobias Burnus + + PR fortran/18918 + * gfortran.dg/coarray_10.f90: Add an additional test. + 2010-07-08 Peter Bergner 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 --- 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