From patchwork Fri May 27 06:10:50 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 97655 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 25E0CB6F8E for ; Fri, 27 May 2011 16:11:19 +1000 (EST) Received: (qmail 11556 invoked by alias); 27 May 2011 06:11:14 -0000 Received: (qmail 11533 invoked by uid 22791); 27 May 2011 06:11:12 -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 mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 27 May 2011 06:10:55 +0000 Received: from [192.168.178.22] (port-92-204-35-67.dynamic.qsc.de [92.204.35.67]) by mx01.qsc.de (Postfix) with ESMTP id BDEC23CE04; Fri, 27 May 2011 08:10:53 +0200 (CEST) Message-ID: <4DDF406A.604@net-b.de> Date: Fri, 27 May 2011 08:10:50 +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 f , gfortran Subject: [Patch, Fortran] Minor coarray fix: Constraint check, wrong "restrict" 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 Attached is a small coarray fix, solving two issues: - For -fcoarray=single, nonallocatable coarrays are nonpointer - but currently they get set the "restrict" qualifier. (With -fcoarray=lib, nonallocatble coarrays are always pointers.) Fixed by not setting "restricted" in this case. - The pointer association status may not be checked/modified on remote images. And remote (de)allocate is also invalid. However, some of those constraint checks were missing OK for the trunk? Tobias 2011-05-27 Tobias Burnus PR fortran/18918 * check.c (gfc_check_associated, gfc_check_null): Add coindexed check. * match.c (gfc_match_nullify): Ditto. * resolve.c (resolve_deallocate_expr): Ditto. * trans-types.c (gfc_get_nodesc_array_type): Don't set restricted for nonpointers. 2011-05-27 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_22.f90: New. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 8641142..544253c 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -875,6 +875,15 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) return FAILURE; } + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (pointer)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "conindexed", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &pointer->where); + return FAILURE; + } + /* Target argument is optional. */ if (target == NULL) return SUCCESS; @@ -902,6 +911,15 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) return FAILURE; } + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (target)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "conindexed", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &target->where); + return FAILURE; + } + t = SUCCESS; if (same_type_check (pointer, 0, target, 1) == FAILURE) t = FAILURE; @@ -2651,6 +2669,15 @@ gfc_check_null (gfc_expr *mold) return FAILURE; } + /* F2008, C1242. */ + if (gfc_is_coindexed (mold)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "conindexed", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &mold->where); + return FAILURE; + } + return SUCCESS; } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 9c4f5f6..94b9a59 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1543,13 +1543,12 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, if (as->rank == 0) { if (packed != PACKED_STATIC || gfc_option.coarray == GFC_FCOARRAY_LIB) - type = build_pointer_type (type); + { + type = build_pointer_type (type); - if (restricted) - type = build_qualified_type (type, TYPE_QUAL_RESTRICT); + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); - if (packed != PACKED_STATIC || gfc_option.coarray == GFC_FCOARRAY_LIB) - { GFC_ARRAY_TYPE_P (type) = 1; TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 75f2a7f..f275239 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3194,6 +3194,13 @@ gfc_match_nullify (void) if (gfc_check_do_variable (p->symtree)) goto cleanup; + /* F2008, C1242. */ + if (gfc_is_coindexed (p)) + { + gfc_error ("Pointer object at %C shall not be conindexed"); + goto cleanup; + } + /* build ' => NULL() '. */ e = gfc_get_null_expr (&gfc_current_locus); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3483bc7..4b18529 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6494,6 +6494,13 @@ resolve_deallocate_expr (gfc_expr *e) return FAILURE; } + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", &e->where); + return FAILURE; + } + if (pointer && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE) return FAILURE; --- /dev/null 2011-05-27 07:14:06.059892443 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_22.f90 2011-05-27 08:03:48.000000000 +0200 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Constraint checks for invalid access of remote pointers +! (Accessing the value is ok, checking/changing association +! status is invalid) +! +! PR fortran/18918 +! +type t + integer, pointer :: ptr => null() +end type t +type(t) :: x[*], y[*] + +if (associated(x%ptr)) stop 0 +if (associated(x%ptr,y%ptr)) stop 0 + +if (associated(x[1]%ptr)) stop 0 ! { dg-error "shall not be conindexed" } +if (associated(x%ptr,y[1]%ptr)) stop 0 ! { dg-error "shall not be conindexed" } + +nullify (x%ptr) +nullify (x[1]%ptr) ! { dg-error "shall not be conindexed" } + +x%ptr => null(x%ptr) +x%ptr => null(x[1]%ptr) ! { dg-error "shall not be conindexed" } +x[1]%ptr => null(x%ptr) ! { dg-error "shall not have a coindex" } + +allocate(x%ptr) +deallocate(x%ptr) + +allocate(x[1]%ptr) ! { dg-error "Coindexed allocatable object" } +deallocate(x[1]%ptr) ! { dg-error "Coindexed allocatable object" } +end