From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id A78473857407; Mon, 14 Jun 2021 23:10:00 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org A78473857407 Received: by mail-wm1-x32b.google.com with SMTP id l7-20020a05600c1d07b02901b0e2ebd6deso858970wms.1; Mon, 14 Jun 2021 16:10:00 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:to:from:subject:message-id:date:user-agent :mime-version:content-language; bh=8/TZmURnPCXIZsl7FoDR9As6AdxUdSZVla/crdl1Zag=; b=uZYtOfGH+hz7O04o40XrHwB1qKDKBRAFegvsOnSLaV5hjVSy/Os5xCtOOPFIHKHs56 wXHHsrtqdH9LW/WZlstnzgMJZkDFfyzhiFyJij4A33N89O93p2eIC/onlL9YNGiXqNc7 DN9aSx4rXVFatoUsjOjioeTngTaZH2sqdXmHMAMDxa00fW9H9cAMEUb1w/RrOYwX1hQx 22/RBksteh63EgHXnho24BxBR42j7ncxvz1SnhG5rxavbqpFp69NpUi2bjqEYBAE1URs d+9Vi7RWUMYM0hLLA7FcCkTKi8MBCxLAPuz8ZH+yBDUd3cAm9oCoutVHUofQVAr2zcJC KiKQ== X-Gm-Message-State: AOAM533evuA8nZlwNyUk0brzrmOIk7wk9OQ+ionUowZvJoWw1ZaNPx6I H8P6AHtJeDGKgNtTbZlr7hTzvqQ40pM= X-Google-Smtp-Source: ABdhPJw1OO7xJHt+1TkWCKiPmVhngfSZkAHc3yBdfKyfAU7CP0kFKXA75crbira6USRtsgSuyWluXw== X-Received: by 2002:a05:600c:3795:: with SMTP id o21mr19035170wmr.99.1623712199384; Mon, 14 Jun 2021 16:09:59 -0700 (PDT) Received: from ?IPv6:2001:8a0:7d79:6000:7d63:4f76:b234:4d55? ([2001:8a0:7d79:6000:7d63:4f76:b234:4d55]) by smtp.googlemail.com with ESMTPSA id k25sm752421wmi.36.2021.06.14.16.09.58 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Mon, 14 Jun 2021 16:09:58 -0700 (PDT) To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org From: =?UTF-8?Q?Jos=c3=a9_Rui_Faustino_de_Sousa?= Subject: [Patch, fortran V2] PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling Message-ID: <0b4b1feb-aa45-31ab-9185-546bd0cc551a@gmail.com> Date: Mon, 14 Jun 2021 23:09:57 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.8.1 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------35512F7D17641DBF0D25ADAA" Content-Language: en-US X-Spam-Status: No, score=-12.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: fortran@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Fortran mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 14 Jun 2021 23:10:06 -0000 This is a multi-part message in MIME format. --------------35512F7D17641DBF0D25ADAA Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 8bit Hi all! Update to a proposed patch to: Bug 93308 - bind(c) subroutine changes lower bound of array argument in caller Bug 93963 - Select rank mishandling allocatable and pointer arguments with bind(c) Bug 94327 - Bind(c) argument attributes are incorrectly set Bug 94331 - Bind(C) corrupts array descriptors Bug 97046 - Bad interaction between lbound/ubound, allocatable arrays and bind(C) subroutine with dimension(..) parameter due to errors found in one of the tests by Dominique d'Humieres. Patch tested only on x86_64-pc-linux-gnu. Fix attribute handling, which reflect a prior intermediate version of the Fortran standard. CFI descriptors, in most cases, should not be copied out has they can corrupt the Fortran descriptor. Bounds will vary and the original Fortran bounds are definitively lost on conversion. Thank you very much. Best regards, José Rui Fortran: Fix attributtes and bounds in ISO_Fortran_binding. gcc/fortran/ChangeLog: PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046 * trans-decl.c (convert_CFI_desc): Only copy out the descriptor if necessary. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute handling which reflect a previous intermediate version of the standard. Only copy out the descriptor if necessary. libgfortran/ChangeLog: PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046 * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code to verify the descriptor. Correct bounds calculation. (gfc_desc_to_cfi_desc): Add code to verify the descriptor. gcc/testsuite/ChangeLog: PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046 * gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute, this test is still erroneous but now it compiles. * gfortran.dg/bind_c_array_params_2.f90: Update regex to match code changes. * gfortran.dg/PR93308.f90: New test. * gfortran.dg/PR93963.f90: New test. * gfortran.dg/PR94327.c: New test. * gfortran.dg/PR94327.f90: New test. * gfortran.dg/PR94331.c: New test. * gfortran.dg/PR94331.f90: New test. * gfortran.dg/PR97046.f90: New test. --------------35512F7D17641DBF0D25ADAA Content-Type: text/x-patch; charset=UTF-8; name="PR93308-93963-94327-94331-97046.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="PR93308-93963-94327-94331-97046.patch" diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index c32bd05..97aafe3 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4526,22 +4526,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) gfc_add_expr_to_block (&outer_block, incoming); incoming = gfc_finish_block (&outer_block); - /* Convert the gfc descriptor back to the CFI type before going out of scope, if the CFI type was present at entry. */ - gfc_init_block (&outer_block); - gfc_init_block (&tmpblock); - - tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); - outgoing = build_call_expr_loc (input_location, - gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); - gfc_add_expr_to_block (&tmpblock, outgoing); + outgoing = NULL_TREE; + if ((sym->attr.pointer || sym->attr.allocatable) + && !sym->attr.value + && sym->attr.intent != INTENT_IN) + { + gfc_init_block (&outer_block); + gfc_init_block (&tmpblock); - outgoing = build3_v (COND_EXPR, present, - gfc_finish_block (&tmpblock), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&outer_block, outgoing); - outgoing = gfc_finish_block (&outer_block); + tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); + outgoing = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, + tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&tmpblock, outgoing); + + outgoing = build3_v (COND_EXPR, present, + gfc_finish_block (&tmpblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&outer_block, outgoing); + outgoing = gfc_finish_block (&outer_block); + } /* Add the lot to the procedure init and finally blocks. */ gfc_add_init_cleanup (block, incoming, outgoing); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index de406ad..52e243b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5501,13 +5501,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) attribute = 1; } - /* If the formal argument is assumed shape and neither a pointer nor - allocatable, it is unconditionally CFI_attribute_other. */ - if (fsym->as->type == AS_ASSUMED_SHAPE - && !fsym->attr.pointer && !fsym->attr.allocatable) - cfi_attribute = 2; + if (fsym->attr.pointer) + cfi_attribute = 0; + else if (fsym->attr.allocatable) + cfi_attribute = 1; else - cfi_attribute = attribute; + cfi_attribute = 2; if (e->rank != 0) { @@ -5615,10 +5614,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_prepend_expr_to_block (&parmse->post, tmp); /* Transfer values back to gfc descriptor. */ - tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); - gfc_prepend_expr_to_block (&parmse->post, tmp); + if (cfi_attribute != 2 + && !fsym->attr.value + && fsym->attr.intent != INTENT_IN) + { + tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_prepend_expr_to_block (&parmse->post, tmp); + } /* Deal with an optional dummy being passed to an optional formal arg by finishing the pre and post blocks and making their execution diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 102bc60..0cf3b2c 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -39,7 +39,7 @@ USE, INTRINSIC :: ISO_C_BINDING import INTEGER(C_INT) :: err - type (T), DIMENSION(..), intent(out) :: a + type (T), pointer, DIMENSION(..), intent(out) :: a END FUNCTION c_establish FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err) diff --git a/gcc/testsuite/gfortran.dg/PR93308.f90 b/gcc/testsuite/gfortran.dg/PR93308.f90 new file mode 100644 index 0000000..ee116f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93308.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Robin Hogan +! + +program test + + use, intrinsic :: iso_c_binding, only: & + c_int, c_float + + implicit none + + integer :: i + integer, parameter :: n = 11 + real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)] + + real(kind=c_float), allocatable :: A(:) + real(kind=c_float) :: E(n) + integer(kind=c_int) :: l1, l2, l3 + + allocate(A, source=u) + l1 = lbound(A, 1) + call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A... + l3 = lbound(A, 1) + if (l1 /= 1) stop 1 + if (l1 /= l2) stop 2 + if (l1 /= l3) stop 3 + if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4 + deallocate(A) + ! + E = u + l1 = lbound(E, 1) + call routine_bindc(E, l2) ! ...but does not change lbound of E + l3 = lbound(E, 1) + if (l1 /= 1) stop 5 + if (l1 /= l2) stop 6 + if (l1 /= l3) stop 7 + if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8 + +contains + + subroutine routine_bindc(v, l) bind(c) + real(kind=c_float), intent(inout) :: v(:) + integer(kind=c_int), intent(out) :: l + + l = lbound(v, 1) + if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9 + end subroutine routine_bindc + +end program test diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90 new file mode 100644 index 0000000..4e1b06f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93963.f90 @@ -0,0 +1,150 @@ +! { dg-do run } +! +! Test the fix for PR93963 +! + +function rank_p(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), pointer, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_p + +function rank_a(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), allocatable, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_a + +program selr_p + + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + interface + function rank_p(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(kind=c_int), pointer, intent(in) :: this(..) + integer(kind=c_int) :: rnk + end function rank_p + end interface + + interface + function rank_a(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(kind=c_int), allocatable, intent(in) :: this(..) + integer(kind=c_int) :: rnk + end function rank_a + end interface + + integer(kind=c_int), parameter :: siz = 7 + integer(kind=c_int), parameter :: rnk = 1 + + integer(kind=c_int), pointer :: intp(:) + integer(kind=c_int), allocatable :: inta(:) + integer(kind=c_int) :: irnk + + nullify(intp) + irnk = rank_p(intp) + if (irnk /= rnk) stop 1 + if (irnk /= rank(intp)) stop 2 + ! + irnk = rank_a(inta) + if (irnk /= rnk) stop 3 + if (irnk /= rank(inta)) stop 4 + ! + allocate(intp(siz)) + irnk = rank_p(intp) + if (irnk /= rnk) stop 5 + if (irnk /= rank(intp)) stop 6 + deallocate(intp) + nullify(intp) + ! + allocate(inta(siz)) + if (irnk /= rnk) stop 7 + if (irnk /= rank(inta)) stop 8 + deallocate(inta) + +end program selr_p diff --git a/gcc/testsuite/gfortran.dg/PR94327.c b/gcc/testsuite/gfortran.dg/PR94327.c new file mode 100644 index 0000000..6791c37 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.c @@ -0,0 +1,70 @@ +/* Test the fix for PR94327. */ + +#include +#include +#include + +#include "../../../libgfortran/ISO_Fortran_binding.h" + +bool c_vrfy (const CFI_cdesc_t *restrict); + +char get_attr (const CFI_cdesc_t*restrict, bool); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; ielem_len == 4); + assert (auxp->rank == 1); + assert (auxp->type == CFI_type_int); + attr = '\0'; + switch (auxp->attribute) + { + case CFI_attribute_pointer: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'p'; + break; + case CFI_attribute_allocatable: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'a'; + break; + case CFI_attribute_other: + assert (alloc); + if (!c_vrfy (auxp)) + break; + attr = 'o'; + break; + default: + break; + } + return attr; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90 new file mode 100644 index 0000000..3cb3ac3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! { dg-additional-sources PR94327.c } +! +! Test the fix for PR94327 +! + +program attr_p + + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + + implicit none + + integer :: i + integer, parameter :: n = 11 + integer, parameter :: u(*) = [(i, i=1,n)] + + interface + function attr_p_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_as + function attr_a_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_as + function attr_o_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_as + function attr_p_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_ar + function attr_a_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_ar + function attr_o_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_ar + end interface + + integer(kind=c_int), target :: a(n) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + character(kind=c_char) :: c + + a = u + c = attr_p_as(a, .true._c_bool) + if(c/='p') stop 1 + if(any(a/=u)) stop 2 + ! + a = u + c = attr_p_ar(a, .true._c_bool) + if(c/='p') stop 3 + if(any(a/=u)) stop 4 + ! + a = u + c = attr_o_as(a, .true._c_bool) + if(c/='o') stop 5 + if(any(a/=u)) stop 6 + ! + a = u + c = attr_o_ar(a, .true._c_bool) + if(c/='o') stop 7 + if(any(a/=u)) stop 8 + ! + allocate(b, source=u) + c = attr_p_as(b, .true._c_bool) + if(c/='p') stop 9 + if(.not.allocated(b)) stop 10 + if(any(b/=u)) stop 11 + ! + deallocate(b) + allocate(b, source=u) + c = attr_p_ar(b, .true._c_bool) + if(c/='p') stop 12 + if(.not.allocated(b)) stop 13 + if(any(b/=u)) stop 14 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_as(b, .true._c_bool) + if(c/='a') stop 15 + if(.not.allocated(b)) stop 16 + if(any(b/=u)) stop 17 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_ar(b, .true._c_bool) + if(c/='a') stop 18 + if(.not.allocated(b)) stop 19 + if(any(b/=u)) stop 20 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_as(b, .true._c_bool) + if(c/='o') stop 21 + if(.not.allocated(b)) stop 22 + if(any(b/=u)) stop 23 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_ar(b, .true._c_bool) + if(c/='o') stop 24 + if(.not.allocated(b)) stop 25 + if(any(b/=u)) stop 26 + ! + deallocate(b) + c = attr_a_as(b, .false._c_bool) + if(c/='a') stop 27 + if(allocated(b)) stop 28 + ! + c = attr_a_ar(b, .false._c_bool) + if(c/='a') stop 29 + if(allocated(b)) stop 30 + ! + nullify(p) + p => a + c = attr_p_as(p, .true._c_bool) + if(c/='p') stop 31 + if(.not.associated(p)) stop 32 + if(.not.associated(p, a)) stop 33 + if(any(p/=u)) stop 34 + ! + nullify(p) + p => a + c = attr_p_ar(p, .true._c_bool) + if(c/='p') stop 35 + if(.not.associated(p)) stop 36 + if(.not.associated(p, a)) stop 37 + if(any(p/=u)) stop 38 + ! + nullify(p) + p => a + c = attr_o_as(p, .true._c_bool) + if(c/='o') stop 39 + if(.not.associated(p)) stop 40 + if(.not.associated(p, a)) stop 41 + if(any(p/=u)) stop 42 + ! + nullify(p) + p => a + c = attr_o_ar(p, .true._c_bool) + if(c/='o') stop 43 + if(.not.associated(p)) stop 44 + if(.not.associated(p, a)) stop 45 + if(any(p/=u)) stop 46 + ! + nullify(p) + c = attr_p_as(p, .false._c_bool) + if(c/='p') stop 47 + if(associated(p)) stop 48 + if(associated(p, a)) stop 49 + ! + nullify(p) + c = attr_p_ar(p, .false._c_bool) + if(c/='p') stop 50 + if(associated(p)) stop 51 + if(associated(p, a)) stop 52 + stop + +end program attr_p diff --git a/gcc/testsuite/gfortran.dg/PR94331.c b/gcc/testsuite/gfortran.dg/PR94331.c new file mode 100644 index 0000000..4e13051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.c @@ -0,0 +1,73 @@ +/* Test the fix for PR94331. */ + +#include +#include +#include + +#include "../../../libgfortran/ISO_Fortran_binding.h" + +bool c_vrfy (const CFI_cdesc_t *restrict); + +bool check_bounds(const CFI_cdesc_t*restrict, const int, const int); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; ielem_len; + assert (auxp->rank==1); + assert (auxp->type==CFI_type_int); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==el); + if (auxp->dim[0].extent==ex + && auxp->dim[0].lower_bound==lb) + { + switch(auxp->attribute) + { + case CFI_attribute_pointer: + case CFI_attribute_allocatable: + if (!c_vrfy (auxp)) + break; + is_ok = true; + break; + case CFI_attribute_other: + if (!c_vrfy (auxp)) + break; + is_ok = (lb==0); + break; + default: + assert (false); + break; + } + } + return is_ok; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90 new file mode 100644 index 0000000..6185031 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.f90 @@ -0,0 +1,252 @@ +! { dg-do run } +! { dg-additional-sources PR94331.c } +! +! Test the fix for PR94331 +! + +program main_p + + use, intrinsic :: iso_c_binding, only: & + c_int + + implicit none + + integer :: i + integer, parameter :: ex = 11 + integer, parameter :: lb = 11 + integer, parameter :: ub = ex+lb-1 + integer, parameter :: u(*) = [(i, i=1,ex)] + + interface + function checkb_p_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_as + function checkb_a_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_as + function checkb_o_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_as + function checkb_p_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_ar + function checkb_a_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_ar + function checkb_o_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_ar + end interface + + integer(kind=c_int), target :: a(lb:ub) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + + a = u + if(lbound(a,1)/=lb) stop 1 + if(ubound(a,1)/=ub) stop 2 + if(any(shape(a)/=[ex])) stop 3 + if(.not.checkb_p_as(a, lb, ub)) stop 4 + if(lbound(a,1)/=lb) stop 5 + if(ubound(a,1)/=ub) stop 6 + if(any(shape(a)/=[ex])) stop 7 + if(any(a/=u)) stop 8 + ! + a = u + if(lbound(a,1)/=lb) stop 9 + if(ubound(a,1)/=ub) stop 10 + if(any(shape(a)/=[ex])) stop 11 + if(.not.checkb_p_ar(a, lb, ub)) stop 12 + if(lbound(a,1)/=lb) stop 13 + if(ubound(a,1)/=ub) stop 14 + if(any(shape(a)/=[ex])) stop 15 + if(any(a/=u)) stop 16 + ! + a = u + if(lbound(a,1)/=lb) stop 17 + if(ubound(a,1)/=ub) stop 18 + if(any(shape(a)/=[ex])) stop 19 + if(.not.checkb_o_as(a, 0, ex-1))stop 20 + if(lbound(a,1)/=lb) stop 21 + if(ubound(a,1)/=ub) stop 22 + if(any(shape(a)/=[ex])) stop 23 + if(any(a/=u)) stop 24 + ! + a = u + if(lbound(a,1)/=lb) stop 25 + if(ubound(a,1)/=ub) stop 26 + if(any(shape(a)/=[ex])) stop 27 + if(.not.checkb_o_ar(a, 0, ex-1))stop 28 + if(lbound(a,1)/=lb) stop 29 + if(ubound(a,1)/=ub) stop 30 + if(any(shape(a)/=[ex])) stop 31 + if(any(a/=u)) stop 32 + ! + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 33 + if(ubound(b,1)/=ub) stop 34 + if(any(shape(b)/=[ex])) stop 35 + if(.not.checkb_p_as(b, lb, ub)) stop 36 + if(.not.allocated(b)) stop 37 + if(lbound(b,1)/=lb) stop 38 + if(ubound(b,1)/=ub) stop 39 + if(any(shape(b)/=[ex])) stop 40 + if(any(b/=u)) stop 41 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 42 + if(ubound(b,1)/=ub) stop 43 + if(any(shape(b)/=[ex])) stop 44 + if(.not.checkb_p_ar(b, lb, ub)) stop 45 + if(.not.allocated(b)) stop 46 + if(lbound(b,1)/=lb) stop 47 + if(ubound(b,1)/=ub) stop 48 + if(any(shape(b)/=[ex])) stop 49 + if(any(b/=u)) stop 50 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 51 + if(ubound(b,1)/=ub) stop 52 + if(any(shape(b)/=[ex])) stop 53 + if(.not.checkb_a_as(b, lb, ub)) stop 54 + if(.not.allocated(b)) stop 55 + if(lbound(b,1)/=lb) stop 56 + if(ubound(b,1)/=ub) stop 57 + if(any(shape(b)/=[ex])) stop 58 + if(any(b/=u)) stop 59 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 60 + if(ubound(b,1)/=ub) stop 61 + if(any(shape(b)/=[ex])) stop 62 + if(.not.checkb_a_ar(b, lb, ub)) stop 63 + if(.not.allocated(b)) stop 64 + if(lbound(b,1)/=lb) stop 65 + if(ubound(b,1)/=ub) stop 66 + if(any(shape(b)/=[ex])) stop 67 + if(any(b/=u)) stop 68 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 69 + if(ubound(b,1)/=ub) stop 70 + if(any(shape(b)/=[ex])) stop 71 + if(.not.checkb_o_as(b, 0, ex-1))stop 72 + if(.not.allocated(b)) stop 73 + if(lbound(b,1)/=lb) stop 74 + if(ubound(b,1)/=ub) stop 75 + if(any(shape(b)/=[ex])) stop 76 + if(any(b/=u)) stop 77 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 78 + if(ubound(b,1)/=ub) stop 79 + if(any(shape(b)/=[ex])) stop 80 + if(.not.checkb_o_ar(b, 0, ex-1))stop 81 + if(.not.allocated(b)) stop 82 + if(lbound(b,1)/=lb) stop 83 + if(ubound(b,1)/=ub) stop 84 + if(any(shape(b)/=[ex])) stop 85 + if(any(b/=u)) stop 86 + deallocate(b) + ! + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 87 + if(ubound(p,1)/=ub) stop 88 + if(any(shape(p)/=[ex])) stop 89 + if(.not.checkb_p_as(p, lb, ub)) stop 90 + if(.not.associated(p)) stop 91 + if(.not.associated(p, a)) stop 92 + if(lbound(p,1)/=lb) stop 93 + if(ubound(p,1)/=ub) stop 94 + if(any(shape(p)/=[ex])) stop 95 + if(any(p/=u)) stop 96 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 97 + if(ubound(p,1)/=ub) stop 98 + if(any(shape(p)/=[ex])) stop 99 + if(.not.checkb_p_ar(p, lb, ub)) stop 100 + if(.not.associated(p)) stop 101 + if(.not.associated(p, a)) stop 102 + if(lbound(p,1)/=lb) stop 103 + if(ubound(p,1)/=ub) stop 104 + if(any(shape(p)/=[ex])) stop 105 + if(any(p/=u)) stop 106 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 107 + if(ubound(p,1)/=ub) stop 108 + if(any(shape(p)/=[ex])) stop 109 + if(.not.checkb_o_as(p, 0, ex-1))stop 110 + if(.not.associated(p)) stop 111 + if(.not.associated(p, a)) stop 112 + if(lbound(p,1)/=lb) stop 113 + if(ubound(p,1)/=ub) stop 114 + if(any(shape(p)/=[ex])) stop 115 + if(any(p/=u)) stop 116 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 117 + if(ubound(p,1)/=ub) stop 118 + if(any(shape(p)/=[ex])) stop 119 + if(.not.checkb_o_ar(p, 0, ex-1))stop 120 + if(.not.associated(p)) stop 121 + if(.not.associated(p, a)) stop 122 + if(lbound(p,1)/=lb) stop 123 + if(ubound(p,1)/=ub) stop 124 + if(any(shape(p)/=[ex])) stop 125 + if(any(p/=u)) stop 126 + nullify(p) + stop + +end program main_p diff --git a/gcc/testsuite/gfortran.dg/PR97046.f90 b/gcc/testsuite/gfortran.dg/PR97046.f90 new file mode 100644 index 0000000..7d133a5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR97046.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Igor Gayday +! + +MODULE FOO + + implicit none + + INTEGER, parameter :: n = 11 + +contains + + SUBROUTINE dummyc(x0) BIND(C) + type(*), dimension(..) :: x0 + if(LBOUND(x0,1)/=1) stop 5 + if(UBOUND(x0,1)/=n) stop 6 + if(rank(x0)/=1) stop 7 + END SUBROUTINE dummyc + + SUBROUTINE dummy(x0) + type(*), dimension(..) :: x0 + call dummyc(x0) + END SUBROUTINE dummy + +END MODULE + +PROGRAM main + USE FOO + IMPLICIT NONE + integer :: before(2), after(2) + + DOUBLE PRECISION, ALLOCATABLE :: buf(:) + DOUBLE PRECISION :: buf2(n) + + ALLOCATE(buf(n)) + before(1) = LBOUND(buf,1) + before(2) = UBOUND(buf,1) + CALL dummy (buf) + after(1) = LBOUND(buf,1) + after(2) = UBOUND(buf,1) + deallocate(buf) + + if (before(1) .NE. after(1)) stop 1 + if (before(2) .NE. after(2)) stop 2 + + before(1) = LBOUND(buf2,1) + before(2) = UBOUND(buf2,1) + CALL dummy (buf2) + after(1) = LBOUND(buf2,1) + after(2) = UBOUND(buf2,1) + + if (before(1) .NE. after(1)) stop 3 + if (before(2) .NE. after(2)) stop 4 + +END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 00628c1..ede6eff 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -22,4 +22,4 @@ end ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } } ! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } } ! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } } -! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } } +! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } } diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 20833ad..db9b32b 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -43,6 +43,20 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr) if (!s) return; + /* Verify descriptor. */ + switch(s->attribute) + { + case CFI_attribute_pointer: + case CFI_attribute_allocatable: + break; + case CFI_attribute_other: + if (s->base_addr) + break; + /* FALL THROUGH */ + default: + internal_error (NULL, "INVALID CFI DESCRIPTOR"); + break; + } GFC_DESCRIPTOR_DATA (d) = s->base_addr; GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask); kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift); @@ -74,14 +88,19 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr) } d->offset = 0; - for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++) - { - GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound; - GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent - + s->dim[n].lower_bound - 1); - GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len); - d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n); - } + if (GFC_DESCRIPTOR_DATA (d)) + for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++) + { + CFI_index_t lb = 1; + + if (s->attribute != CFI_attribute_other) + lb = s->dim[n].lower_bound; + + GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)lb; + GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent + lb - 1); + GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len); + d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n); + } } extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *); @@ -102,6 +121,20 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s) else d = *d_ptr; + /* Verify descriptor. */ + switch (s->dtype.attribute) + { + case CFI_attribute_pointer: + case CFI_attribute_allocatable: + break; + case CFI_attribute_other: + if (s->base_addr) + break; + /* FALL THROUGH */ + default: + internal_error (NULL, "INVALID GFC DESCRIPTOR"); + break; + } d->base_addr = GFC_DESCRIPTOR_DATA (s); d->elem_len = GFC_DESCRIPTOR_SIZE (s); d->version = s->dtype.version; --------------35512F7D17641DBF0D25ADAA--