From patchwork Sat May 7 05:21:14 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 94471 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 670EDB703E for ; Sat, 7 May 2011 15:21:40 +1000 (EST) Received: (qmail 21664 invoked by alias); 7 May 2011 05:21:34 -0000 Received: (qmail 21643 invoked by uid 22791); 7 May 2011 05:21:32 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, 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; Sat, 07 May 2011 05:21:16 +0000 Received: from [192.168.178.22] (port-92-204-45-85.dynamic.qsc.de [92.204.45.85]) by mx02.qsc.de (Postfix) with ESMTP id A43181E3A2; Sat, 7 May 2011 07:21:14 +0200 (CEST) Message-ID: <4DC4D6CA.5040803@net-b.de> Date: Sat, 07 May 2011 07:21:14 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.14) Gecko/20110221 SUSE/3.1.8 Thunderbird/3.1.8 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Fixes for scalar coarrays 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 The interface.c patch is to avoid a strange error ("actual argument must be simply contiguous") which is a bit odd if the actual argument is a scalar. As the dummy was an array, a rank mismatch would have been the proper error. - The patch simply suppresses the error message such that the later error check becomes active. The rest of the patch: For scalar coarray dummy arguments, the cobounds were not properly saved - thus calling the one of the coindex intrinsics gave an ICE. Build and regtested on x86-64-linux. OK for the trunk? Tobias 2011-05-07 Tobias Burnus PR fortran/18918 * interface.c (compare_parameter): Skip diagnostic if actual argument is not an array; rank mismatch is diagnosted later. * trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Handle scalar coarrays. * trans-types.c (gfc_get_array_type_bounds): Ditto. 2011-05-07 Tobias Burnus PR fortran/18918 * gfortran.de/coarray_20.f90: New. * gfortran.dg/coarray/image_index_2.f90: New. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 1f75724..732a0c5 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1618,6 +1618,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, /* F2008, 12.5.2.8. */ if (formal->attr.dimension && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) + && gfc_expr_attr (actual).dimension && !gfc_is_simply_contiguous (actual, true)) { if (where) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 63f03de..a78b5ac 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1228,7 +1228,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) } /* Use a copy of the descriptor for dummy arrays. */ - if (sym->attr.dimension && !TREE_USED (sym->backend_decl)) + if ((sym->attr.dimension || sym->attr.codimension) + && !TREE_USED (sym->backend_decl)) { decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); /* Prevent the dummy from being detected as unused if it is copied. */ @@ -1316,7 +1317,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) DECL_IGNORED_P (decl) = 1; } - if (sym->attr.dimension) + if (sym->attr.dimension || sym->attr.codimension) { /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); @@ -3435,7 +3436,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->assoc) continue; - if (sym->attr.dimension) + if (sym->attr.dimension || sym->attr.codimension) { switch (sym->as->type) { diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 22a2c5b..4dd82ca 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1694,9 +1694,10 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, stride = gfc_index_one_node; else stride = NULL_TREE; - for (n = 0; n < dimen; n++) + for (n = 0; n < dimen + codimen; n++) { - GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; + if (n < dimen) + GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; if (lbound) lower = lbound[n]; @@ -1711,6 +1712,9 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, lower = NULL_TREE; } + if (codimen && n == dimen + codimen - 1) + break; + upper = ubound[n]; if (upper != NULL_TREE) { @@ -1720,6 +1724,9 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, upper = NULL_TREE; } + if (n >= dimen) + continue; + if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) { tmp = fold_build2_loc (input_location, MINUS_EXPR, --- /dev/null 2011-05-06 19:43:06.071892303 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_20.f90 2011-05-07 00:40:46.000000000 +0200 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Before a bogus error (argument not simply contiguous) +! was printed instead of the rank mismatch +! +! PR fortran/18918 +! +integer :: A[*] +call bar(A) ! { dg-error "Rank mismatch in argument" } +contains + subroutine bar(x) + integer :: x(1)[*] + end subroutine bar +end --- /dev/null 2011-05-06 19:43:06.071892303 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/image_index_2.f90 2011-05-07 00:28:14.000000000 +0200 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! Scalar coarray +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, save :: d[-1:3, *] +integer, save :: e[-1:-1, 3:*] + +one = num_images() == 1 + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + call abort() +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + call abort() + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + call abort() +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + call abort() + +call test(1, e, d, e) +call test(2, e, d, e) + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a[3*n:3*n, -4*n:-3*n, 88*n:*], b[-1*n:0*n,0*n:*], c[*] + + index1 = image_index(a, [3*n, -4*n, 88*n] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + + if (n == 1) then + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort() + else if (num_images() == 1) then + if (index1 /= 1 .or. index2 /= 0 .or. index3 /= 1) call abort() + else + if (index1 /= 1 .or. index2 /= 2 .or. index3 /= 1) call abort() + end if + + index1 = image_index(a, [3*n, -3*n, 88*n] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + call abort() + if (n == 1 .and. num_images() == 2) then + if (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2) & + call abort() + else if (n == 2 .and. num_images() == 2) then + if (index1 /= 0 .or. index2 /= 0 .or. index3 /= 2) & + call abort() + end if +end subroutine test +end program test_image_index