commit 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Jul 26 14:20:46 2021 +0200
PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling
Fortran: Fix attributes and bounds in ISO_Fortran_binding.
2021-07-26 José Rui Faustino de Sousa <jrfsousa@gmail.com>
Tobias Burnus <tobias@codesourcery.com>
PR fortran/93308
PR fortran/93963
PR fortran/94327
PR fortran/94331
PR fortran/97046
gcc/fortran/ChangeLog:
* 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:
* 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:
* 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.
---
gcc/fortran/trans-decl.c | 32 +--
gcc/fortran/trans-expr.c | 24 +-
.../gfortran.dg/ISO_Fortran_binding_1.f90 | 2 +-
gcc/testsuite/gfortran.dg/PR93308.f90 | 52 +++++
gcc/testsuite/gfortran.dg/PR93963.f90 | 150 ++++++++++++
gcc/testsuite/gfortran.dg/PR94327.c | 70 ++++++
gcc/testsuite/gfortran.dg/PR94327.f90 | 195 ++++++++++++++++
gcc/testsuite/gfortran.dg/PR94331.c | 73 ++++++
gcc/testsuite/gfortran.dg/PR94331.f90 | 252 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/PR97046.f90 | 58 +++++
.../gfortran.dg/bind_c_array_params_2.f90 | 2 +-
libgfortran/runtime/ISO_Fortran_binding.c | 56 ++++-
12 files changed, 933 insertions(+), 33 deletions(-)
@@ -4539,22 +4539,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);
@@ -5502,13 +5502,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)
{
@@ -5616,10 +5615,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 /* CFI_attribute_other. */
+ && !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
@@ -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)
new file mode 100644
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Test the fix for PR94331
+!
+! Contributed by Robin Hogan <r.j.hogan@reading.ac.uk>
+!
+
+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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,70 @@
+/* Test the fix for PR94327. */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdlib.h>
+
+#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; i<ex; i++)
+ if (*ip++ != i+1)
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (int*)CFI_address(auxp, &i);
+ if (*ip != i-lb+1)
+ return false;
+ }
+ return true;
+}
+
+char
+get_attr (const CFI_cdesc_t *restrict auxp, bool alloc)
+{
+ char attr;
+
+ assert (auxp);
+ assert (auxp->elem_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;
+}
+
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,73 @@
+/* Test the fix for PR94331. */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdlib.h>
+
+#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; i<ex; i++)
+ if (*ip++ != i+1)
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (int*)CFI_address(auxp, &i);
+ if (*ip != i-lb+1)
+ return false;
+ }
+ return true;
+}
+
+bool
+check_bounds (const CFI_cdesc_t *restrict auxp, const int lb, const int ub)
+{
+ CFI_index_t ex = ub-lb+1;
+ size_t el;
+ bool is_ok = false;
+
+ assert (auxp);
+ el = auxp->elem_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;
+}
+
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,58 @@
+! { dg-do run }
+!
+! Test the fix for PR94331
+!
+! Contributed by Igor Gayday <igor.gayday@mu.edu>
+!
+
+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
@@ -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" } }
@@ -43,6 +43,24 @@ 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;
+ runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
+ "dummy argument where the effective argument is either "
+ "not allocated or not associated");
+ break;
+ default:
+ runtime_error ("Invalid attribute type %d in CFI_cdesc_t descriptor",
+ (int) s->attribute);
+ 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 +92,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 +125,23 @@ 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;
+ runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
+ "dummy argument where the effective argument is either "
+ "not allocated or not associated");
+ break;
+ default:
+ internal_error (NULL, "Invalid attribute in gfc_array descriptor");
+ break;
+ }
d->base_addr = GFC_DESCRIPTOR_DATA (s);
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
d->version = CFI_VERSION;