From patchwork Wed Jul 7 21:14:53 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 58183 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id BCC11B6EF7 for ; Thu, 8 Jul 2010 07:15:07 +1000 (EST) Received: (qmail 15016 invoked by alias); 7 Jul 2010 21:15:04 -0000 Received: (qmail 14887 invoked by uid 22791); 7 Jul 2010 21:15:01 -0000 X-SWARE-Spam-Status: No, hits=-1.0 required=5.0 tests=AWL, BAYES_40, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 07 Jul 2010 21:14:56 +0000 Received: from [192.168.178.22] (port-92-204-41-181.dynamic.qsc.de [92.204.41.181]) by mx02.qsc.de (Postfix) with ESMTP id 2EF4221876; Wed, 7 Jul 2010 23:14:54 +0200 (CEST) Message-ID: <4C34EE4D.2050501@net-b.de> Date: Wed, 07 Jul 2010 23:14:53 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.1.10) Gecko/20100520 SUSE/3.0.5 Thunderbird/3.0.5 MIME-Version: 1.0 To: gfortran , gcc patches Subject: [Patch, Fortran] PR 18918 - Minor coarray patch: Fix expression rank and improve diagnostics Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 2010-07-07 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-07 Tobias Burnus 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