@@ -4472,19 +4472,26 @@ convert_CFI_desc (gfc_wrapped_block * block,
gfc_symbol *sym)
/* 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);
+ 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);
- 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);
+ 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);
+ 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);
@@ -5238,13 +5238,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)
{
@@ -5352,10 +5351,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
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), DIMENSION(..), pointer, intent(out) :: a
END FUNCTION c_establish
FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
b/gcc/testsuite/gfortran.dg/PR94327.c
new file mode 100644
@@ -0,0 +1,102 @@
+#include <assert.h>
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+extern const int cfi_p;
+extern const int cfi_a;
+extern const int cfi_o;
+
+const int cfi_p = CFI_attribute_pointer;
+const int cfi_a = CFI_attribute_allocatable;
+const int cfi_o = CFI_attribute_other;
+
+static CFI_index_t size (const CFI_dim_t*, CFI_rank_t);
+
+static void vrfy_dims (const CFI_dim_t*, CFI_rank_t);
+static void vrfy_data (const void*, const CFI_index_t);
+static void vrfy_base (const void*, const CFI_dim_t*, CFI_rank_t);
+
+extern int attribute (const CFI_cdesc_t*);
+
+CFI_index_t
+size (const CFI_dim_t *dim, CFI_rank_t rank)
+{
+ CFI_rank_t k;
+ CFI_index_t e, s;
+
+ assert (dim);
+ s = 1;
+ for (k=0; k<rank; k++, dim++)
+ {
+ e = dim->extent;
+ assert (e>0);
+ s *= e;
+ }
+ return s;
+}
+
+void
+vrfy_data (const void *this, const CFI_index_t n)
+{
+ const int *p = NULL;
+ CFI_index_t i;
+
+ assert (this);
+ p = (const int*)this;
+ for (i=0; i<n; i++)
+ assert (*p++==1);
+ return;
+}
+
+void
+vrfy_base (const void *this, const CFI_dim_t *dim, CFI_rank_t rank)
+{
+ CFI_index_t n;
+
+ assert (this);
+ assert (dim);
+ n = size (dim, rank);
+ vrfy_data (this, n);
+ return;
+}
+
+void
+vrfy_dims (const CFI_dim_t *this, CFI_rank_t rank)
+{
+ CFI_rank_t i;
+ CFI_index_t s;
+
+ assert (this);
+ s = 4;
+ for (i=0; i<rank; i++, this++)
+ {
+ assert (this->lower_bound>=0);
+ assert (this->extent>0);
+ assert (s==this->sm);
+ s *= this->extent;
+ }
+ return;
+}
+
+int
+attribute (const CFI_cdesc_t *this)
+{
+ CFI_type_t type, kind;
+ int attr;
+
+ assert (this);
+ assert (this->base_addr);
+ assert (this->elem_len==4);
+ assert (this->version==0);
+ assert (this->rank==1);
+ attr = (int) this->attribute;
+ type = this->type & CFI_type_mask;
+ assert (type==1);
+ kind = (this->type>>CFI_type_kind_shift) & CFI_type_mask;
+ assert (kind==4);
+ assert (this->dim);
+ vrfy_dims (this->dim, this->rank);
+ vrfy_base (this->base_addr, this->dim, this->rank);
+ return attr;
+}
+
b/gcc/testsuite/gfortran.dg/PR94327.f90
new file mode 100644
@@ -0,0 +1,150 @@
+! { dg-do run }
+! { dg-additional-sources PR94327.c }
+!
+! PR fortran/
+!
+
+module attr_m
+
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ private
+
+ public :: &
+ cfi_p, &
+ cfi_a, &
+ cfi_o
+
+ public :: &
+ attr_p, &
+ attr_a, &
+ attr_o
+
+ integer(kind=c_int), protected, bind(c) :: cfi_p
+ integer(kind=c_int), protected, bind(c) :: cfi_a
+ integer(kind=c_int), protected, bind(c) :: cfi_o
+
+ interface
+ function attr_p(this) result(attr) bind(c, name="attribute")
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(kind=c_int), pointer, intent(in) :: this(:)
+ integer(kind=c_int) :: attr
+ end function attr_p
+ function attr_a(this) result(attr) bind(c, name="attribute")
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(kind=c_int), allocatable, intent(in) :: this(:)
+ integer(kind=c_int) :: attr
+ end function attr_a
+ function attr_o(this) result(attr) bind(c, name="attribute")
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(kind=c_int), intent(in) :: this(:)
+ integer(kind=c_int) :: attr
+ end function attr_o
+ end interface
+
+end module attr_m
+
+program attr_main
+
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ use attr_m
+
+ implicit none
+
+ integer, parameter :: n = 11
+
+ integer, parameter :: fpn = 1
+ integer, parameter :: fan = 2
+ integer, parameter :: fon = 3
+
+ integer :: i
+
+ do i = fpn, fon
+ call test_p(i)
+ end do
+ do i = fpn, fon
+ call test_a(i)
+ end do
+ do i = fpn, fon
+ call test_e(i)
+ end do
+ stop
+
+contains
+
+ subroutine test_p(t)
+ integer, intent(in) :: t
+
+ integer(kind=c_int), pointer :: a(:)
+
+ integer(kind=c_int) :: e
+
+ allocate(a(n)); a = 1
+ select case(t)
+ case(fpn)
+ e = attr_p(a)
+ if (e/=cfi_p) stop 11
+ case(fan)
+ case(fon)
+ e = attr_o(a)
+ if (e/=cfi_o) stop 13
+ case default
+ stop
+ end select
+ a = -1; deallocate(a)
+ return
+ end subroutine test_p
+
+ subroutine test_a(t)
+ integer, intent(in) :: t
+
+ integer(kind=c_int), allocatable, target :: a(:)
+
+ integer(kind=c_int) :: e
+
+ allocate(a(n)); a = 1
+ select case(t)
+ case(fpn)
+ e = attr_p(a)
+ if (e/=cfi_p) stop 21
+ case(fan)
+ e = attr_a(a)
+ if (e/=cfi_a) stop 22
+ case(fon)
+ e = attr_o(a)
+ if (e/=cfi_o) stop 23
+ case default
+ stop
+ end select
+ a = -1; deallocate(a)
+ return
+ end subroutine test_a
+
+ subroutine test_e(t)
+ integer, intent(in) :: t
+
+ integer(kind=c_int), target :: a(n)
+
+ integer(kind=c_int) :: e
+
+ a = 1
+ select case(t)
+ case(fpn)
+ e = attr_p(a)
+ if (e/=cfi_p) stop 31
+ case(fan)
+ case(fon)
+ e = attr_o(a)
+ if (e/=cfi_o) stop 33
+ case default
+ stop
+ end select
+ a = -1
+ return
+ end subroutine test_e
+
+end program attr_main
+
b/gcc/testsuite/gfortran.dg/PR94331.c
new file mode 100644
@@ -0,0 +1,146 @@
+#include <assert.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+static CFI_index_t size (const CFI_dim_t*, CFI_rank_t);
+
+static void vrfy_dat (const void *this, const ptrdiff_t n);
+static void vrfy_dim (const CFI_dim_t*, CFI_rank_t, CFI_index_t*,
CFI_index_t*);
+static void vrfy_cfi (const CFI_cdesc_t*, CFI_index_t*, CFI_index_t*);
+
+extern void iarrc_ox (const CFI_cdesc_t*, ptrdiff_t*, ptrdiff_t*);
+extern void iarrc_lx (const CFI_cdesc_t*, int*, ptrdiff_t*, ptrdiff_t*);
+extern void iarrc_ex (const void*, int*, int*, ptrdiff_t*);
+
+extern void iarrc_px (const CFI_cdesc_t*, ptrdiff_t*, ptrdiff_t*);
+
+extern void iarrc_ax (const CFI_cdesc_t*, ptrdiff_t*, ptrdiff_t*);
+
+CFI_index_t
+size (const CFI_dim_t *dim, CFI_rank_t rank)
+{
+ CFI_rank_t k;
+ CFI_index_t e, s;
+
+ assert (dim);
+ s = 1;
+ for (k=0; k<rank; k++, dim++)
+ {
+ assert (dim->extent>0);
+ e = dim->extent;
+ assert (e>0);
+ s *= e;
+ }
+ return s;
+}
+
+void
+vrfy_dat (const void *this, const ptrdiff_t n)
+{
+ const int *p = NULL;
+ ptrdiff_t i;
+
+ assert (this);
+ p = (const int*)this;
+ for (i=0; i<n; i++, p++)
+ assert(*p==1);
+ return;
+}
+
+void
+iarrc_ox (const CFI_cdesc_t *this, ptrdiff_t *lower, ptrdiff_t *extent)
+{
+ assert (this);
+ assert (lower);
+ assert (extent);
+ vrfy_cfi(this, lower, extent);
+ assert (this->attribute==CFI_attribute_other);
+ return;
+}
+
+void
+iarrc_lx (const CFI_cdesc_t *this, int *lb, ptrdiff_t *lower, ptrdiff_t
*extent)
+{
+ assert (this);
+ assert (lb);
+ assert (lower);
+ assert (extent);
+ vrfy_cfi(this, lower, extent);
+ assert (this->attribute==CFI_attribute_other);
+ return;
+}
+
+void
+iarrc_ex (const void *this, int* lb, int* ub, ptrdiff_t *size)
+{
+ assert (this);
+ assert (lb);
+ assert (ub);
+ assert (size);
+ assert (*size>0);
+ vrfy_dat (this, *size);
+ return;
+}
+
+void
+iarrc_px (const CFI_cdesc_t *this, ptrdiff_t *lower, ptrdiff_t *extent)
+{
+ assert (this);
+ assert (lower);
+ assert (extent);
+ vrfy_cfi(this, lower, extent);
+ assert (this->attribute==CFI_attribute_pointer);
+ return;
+}
+
+void
+iarrc_ax (const CFI_cdesc_t *this, ptrdiff_t *lower, ptrdiff_t *extent)
+{
+ assert (this);
+ assert (lower);
+ assert (extent);
+ vrfy_cfi(this, lower, extent);
+ assert (this->attribute==CFI_attribute_allocatable);
+ return;
+}
+
+void
+vrfy_dim (const CFI_dim_t *this, CFI_rank_t rank, CFI_index_t *lower,
CFI_index_t *extent)
+{
+ CFI_rank_t i;
+ CFI_index_t s;
+
+ assert (this);
+ s = 4;
+ for (i=0; i<rank; i++, this++, lower++, extent++)
+ {
+ assert (s==this->sm);
+ *lower = this->lower_bound;
+ *extent = this->extent;
+ s *= *extent;
+ }
+ return;
+}
+
+void
+vrfy_cfi (const CFI_cdesc_t *this, CFI_index_t *lower, CFI_index_t *extent)
+{
+ CFI_type_t type, kind;
+
+ assert (this);
+ assert (this->base_addr);
+ vrfy_dat (this->base_addr, (ptrdiff_t)size (this->dim, this->rank));
+ assert (this->elem_len==4);
+ assert (this->version==0);
+ assert (this->rank>0);
+ type = this->type & CFI_type_mask;
+ assert (type==1);
+ kind = (this->type>>CFI_type_kind_shift) & CFI_type_mask;
+ assert (kind==4);
+ vrfy_dim (this->dim, this->rank, lower, extent);
+ return;
+}
+
b/gcc/testsuite/gfortran.dg/PR94331.f90
new file mode 100644
@@ -0,0 +1,492 @@
+! { dg-do run }
+! { dg-additional-sources PR94331.c }
+!
+! PR fortran/PR94331
+!
+
+module bnds_m
+
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+
+ implicit none
+
+ integer(kind=c_int), parameter :: lb1 = 3
+ integer(kind=c_int), parameter :: lb2 = 5
+ integer(kind=c_int), parameter :: lb3 = 9
+ integer(kind=c_int), parameter :: ub1 = 4
+ integer(kind=c_int), parameter :: ub2 = 50
+ integer(kind=c_int), parameter :: ub3 = 11
+ integer(kind=c_int), parameter :: ex1 = ub1-lb1+1
+ integer(kind=c_int), parameter :: ex2 = ub2-lb2+1
+ integer(kind=c_int), parameter :: ex3 = ub3-lb3+1
+
+ integer(kind=c_int), parameter :: lc(*) = [0,0,0]
+ integer(kind=c_int), parameter :: lf(*) = [1,1,1]
+
+ integer(kind=c_int), parameter :: lb(*) = [lb1,lb2,lb3]
+ integer(kind=c_int), parameter :: ub(*) = [ub1,ub2,ub3]
+ integer(kind=c_int), parameter :: ex(*) = [ex1,ex2,ex3]
+
+ interface
+ subroutine iarrc_px(this, lower, upper) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), pointer, intent(in) :: this(:,:,:)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_px
+ subroutine iarrc_pn(this, lower, upper) bind(c, name="iarrc_px")
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), pointer, intent(in) :: this(..)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_pn
+ subroutine iarrc_ax(this, lower, upper) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), allocatable, intent(in) :: this(:,:,:)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_ax
+ subroutine iarrc_an(this, lower, upper) bind(c, name="iarrc_ax")
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), allocatable, intent(in) :: this(..)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_an
+ subroutine iarrc_ox(this, lower, upper) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), intent(in) :: this(:,:,:)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_ox
+ subroutine iarrc_lx(this, lb, lower, upper) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), intent(in) :: lb(3)
+ integer(kind=c_int), intent(in) :: this(lb(1):,lb(2):,lb(3):)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_lx
+ subroutine iarrc_ex(this, lb, ub, size) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), intent(in) :: lb(3)
+ integer(kind=c_int), intent(in) :: ub(3)
+ integer(kind=c_int), intent(in) ::
this(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
+ integer(kind=c_ptrdiff_t), intent(in) :: size
+ end subroutine iarrc_ex
+ subroutine iarrc_on(this, lower, upper) bind(c, name="iarrc_ox")
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+ integer(kind=c_int), intent(in) :: this(..)
+ integer(kind=c_ptrdiff_t), intent(out) :: lower(*)
+ integer(kind=c_ptrdiff_t), intent(out) :: upper(*)
+ end subroutine iarrc_on
+ end interface
+
+contains
+
+ subroutine bounds(a, lb, ub, n)
+ integer, pointer, intent(in) :: a(..)
+ integer, intent(in) :: lb(3)
+ integer, intent(in) :: ub(3)
+ integer, intent(in) :: n
+
+ integer, parameter :: p = 100
+
+ integer :: ex(3)
+
+ ex = max(ub-lb+1, 0)
+ if(any(lbound(a)/=lb)) stop n*p+1
+ if(any(ubound(a)/=ub)) stop n*p+2
+ if(any( shape(a)/=ex)) stop n*p+3
+ if(.not.is_contiguous(a))stop n*p+4
+ return
+ end subroutine bounds
+
+ subroutine bndc_p3(this) bind(c)
+ integer(kind=c_int), pointer, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 1010)
+ call iarrc_px(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 111005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 111006
+ call bounds(this, lb, ub, 1011)
+ return
+ end subroutine bndc_p3
+
+ subroutine bndc_pn(this) bind(c)
+ integer(kind=c_int), pointer, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 1020)
+ call iarrc_pn(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 102005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 102006
+ call bounds(this, lb, ub, 1021)
+ return
+ end subroutine bndc_pn
+
+ subroutine bndc_a3(this) bind(c)
+ integer(kind=c_int), allocatable, target, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 1110)
+ call iarrc_ax(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 111005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 111006
+ call bounds(this, lb, ub, 1111)
+ return
+ end subroutine bndc_a3
+
+ subroutine bndc_an(this) bind(c)
+ integer(kind=c_int), allocatable, target, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 1120)
+ call iarrc_an(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 112005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 112006
+ call bounds(this, lb, ub, 1121)
+ return
+ end subroutine bndc_an
+
+ subroutine bndc_o3(this) bind(c)
+ integer(kind=c_int), target, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lf, ex, 1210)
+ call iarrc_ox(this, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 121005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 121006
+ call bounds(this, lf, ex, 1211)
+ return
+ end subroutine bndc_o3
+
+ subroutine bndc_l3(this) bind(c)
+ integer(kind=c_int), target, intent(in) :: this(lb(1):,lb(2):,lb(3):)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 1220)
+ call iarrc_lx(this, lb, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 122005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 122006
+ call bounds(this, lb, ub, 1221)
+ return
+ end subroutine bndc_l3
+
+ subroutine bndc_e3(this) bind(c)
+ integer(kind=c_int), target, intent(in) ::
this(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
+
+ integer(kind=c_ptrdiff_t) :: sz
+
+ sz = size(this, kind=c_ptrdiff_t)
+ call bounds(this, lb, ub, 1230)
+ call iarrc_ex(this, lb, ub, sz)
+ call bounds(this, lb, ub, 1231)
+ return
+ end subroutine bndc_e3
+
+ subroutine bndc_on(this) !bind(c) PR93957
+ integer(kind=c_int), target, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lf, ex, 1240)
+ call iarrc_on(this, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 124005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 124006
+ call bounds(this, lf, ex, 1241)
+ return
+ end subroutine bndc_on
+
+ subroutine bndf_p3(this)
+ integer(kind=c_int), pointer, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 2010)
+ call iarrc_px(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 201005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 201006
+ call bounds(this, lb, ub, 2011)
+ return
+ end subroutine bndf_p3
+
+ subroutine bndf_pn(this)
+ integer(kind=c_int), pointer, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 2020)
+ call iarrc_pn(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 202005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 202006
+ call bounds(this, lb, ub, 2021)
+ return
+ end subroutine bndf_pn
+
+ subroutine bndf_a3(this)
+ integer(kind=c_int), allocatable, target, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 2110)
+ call iarrc_ax(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 211005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 211006
+ call bounds(this, lb, ub, 2111)
+ return
+ end subroutine bndf_a3
+
+ subroutine bndf_an(this)
+ integer(kind=c_int), allocatable, target, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 2120)
+ call iarrc_an(this, lower, extnt)
+ if(any(lower/=int(lb, kind=c_ptrdiff_t))) stop 212005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 212006
+ call bounds(this, lb, ub, 2122)
+ return
+ end subroutine bndf_an
+
+ subroutine bndf_o3(this)
+ integer(kind=c_int), target, intent(in) :: this(:,:,:)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lf, ex, 2210)
+ call iarrc_ox(this, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 221005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 221006
+ call bounds(this, lf, ex, 2211)
+ return
+ end subroutine bndf_o3
+
+ subroutine bndf_l3(this)
+ integer(kind=c_int), target, intent(in) :: this(lb(1):,lb(2):,lb(3):)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lb, ub, 2220)
+ call iarrc_lx(this, lb, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 222005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 222006
+ call bounds(this, lb, ub, 2221)
+ return
+ end subroutine bndf_l3
+
+ subroutine bndf_e3(this)
+ integer(kind=c_int), target, intent(in) ::
this(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
+
+ integer(kind=c_ptrdiff_t) :: sz
+
+ sz = size(this, kind=c_ptrdiff_t)
+ call bounds(this, lb, ub, 2230)
+ call iarrc_ex(this, lb, ub, sz)
+ call bounds(this, lb, ub, 2231)
+ return
+ end subroutine bndf_e3
+
+ subroutine bndf_on(this)
+ integer(kind=c_int), target, intent(in) :: this(..)
+
+ integer(kind=c_ptrdiff_t), dimension(3) :: lower, extnt
+
+ call bounds(this, lf, ex, 2240)
+ call iarrc_on(this, lower, extnt)
+ if(any(lower/=int(lc, kind=c_ptrdiff_t))) stop 224005
+ if(any(extnt/=int(ex, kind=c_ptrdiff_t))) stop 224006
+ call bounds(this, lf, ex, 2241)
+ return
+ end subroutine bndf_on
+
+end module bnds_m
+
+program bnds_p
+
+ use, intrinsic :: iso_c_binding, only: c_int, c_ptrdiff_t
+
+ use bnds_m
+
+ implicit none
+
+ integer, parameter :: fp3 = 1
+ integer, parameter :: fpn = 2
+ integer, parameter :: cp3 = 3
+ integer, parameter :: cpn = 4
+ integer, parameter :: fa3 = 5
+ integer, parameter :: fan = 6
+ integer, parameter :: ca3 = 7
+ integer, parameter :: can = 8
+ integer, parameter :: fo3 = 9
+ integer, parameter :: fl3 = 10
+ integer, parameter :: fe3 = 11
+ integer, parameter :: fon = 12
+ integer, parameter :: co3 = 13
+ integer, parameter :: cl3 = 14
+ integer, parameter :: ce3 = 15
+ integer, parameter :: con = 16
+
+ integer(kind=c_int) :: tn
+
+ do tn = fp3, con
+ call test_p(tn)
+ call test_a(tn)
+ call test_o(tn)
+ end do
+ stop
+
+contains
+
+ subroutine test_p(t)
+ integer(kind=c_int), intent(in) :: t
+
+ integer, parameter :: n = 100
+
+ integer(kind=c_int), pointer :: a(:,:,:)
+
+ allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))); a = 1
+ call bounds(a, lb, ub, n*t+10)
+ select case(t)
+ case(fp3)
+ call bndf_p3(a)
+ case(fpn)
+ call bndf_pn(a)
+ case(cp3)
+ call bndc_p3(a)
+ case(cpn)
+ call bndc_pn(a)
+ case(fa3,fan,ca3,can)
+ case(fo3)
+ call bndf_o3(a)
+ case(fl3)
+ call bndf_l3(a)
+ case(fe3)
+ call bndf_e3(a)
+ case(fon)
+ ! PR94289
+ ! call bndf_on(a)
+ case(co3)
+ call bndc_o3(a)
+ case(cl3)
+ call bndc_l3(a)
+ case(ce3)
+ call bndc_e3(a)
+ case(con)
+ ! PR93957
+ ! PR94289
+ ! call bndc_on(a)
+ case default
+ stop
+ end select
+ call bounds(a, lb, ub, n*t+11)
+ a = -1; deallocate(a)
+ return
+ end subroutine test_p
+
+ subroutine test_a(t)
+ integer(kind=c_int), intent(in) :: t
+
+ integer, parameter :: n = 100
+
+ integer(kind=c_int), allocatable, target :: a(:,:,:)
+
+ allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))); a = 1
+ call bounds(a, lb, ub, n*t+20)
+ select case(t)
+ case(fp3)
+ call bndf_p3(a)
+ case(fpn)
+ call bndf_pn(a)
+ case(cp3)
+ call bndc_p3(a)
+ case(cpn)
+ call bndc_pn(a)
+ case(fa3)
+ call bndf_a3(a)
+ case(fan)
+ call bndf_an(a)
+ case(ca3)
+ call bndc_a3(a)
+ case(can)
+ call bndc_an(a)
+ case(fo3)
+ call bndf_o3(a)
+ case(fl3)
+ call bndf_l3(a)
+ case(fe3)
+ call bndf_e3(a)
+ case(fon)
+ ! PR94289
+ ! call bndf_on(a)
+ case(co3)
+ call bndc_o3(a)
+ case(cl3)
+ call bndc_l3(a)
+ case(ce3)
+ call bndc_e3(a)
+ case(con)
+ ! PR93957
+ ! PR94289
+ ! call bndc_on(a)
+ case default
+ stop
+ end select
+ call bounds(a, lb, ub, n*t+21)
+ a = -1; deallocate(a)
+ return
+ end subroutine test_a
+
+ subroutine test_o(t)
+ integer(kind=c_int), intent(in) :: t
+
+ integer, parameter :: n = 100
+
+ integer(kind=c_int), target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
+
+ a = 1
+ call bounds(a, lb, ub, n*t+30)
+ select case(t)
+ case(fp3)
+ call bndf_p3(a)
+ case(fpn)
+ call bndf_pn(a)
+ case(cp3)
+ call bndc_p3(a)
+ case(cpn)
+ call bndc_pn(a)
+ case(fa3,fan,ca3,can)
+ case(fo3)
+ call bndf_o3(a)
+ case(fl3)
+ call bndf_l3(a)
+ case(fe3)
+ call bndf_e3(a)
+ case(fon)
+ ! PR94289
+ ! call bndf_on(a)
+ case(co3)
+ call bndc_o3(a)
+ case(cl3)
+ call bndc_l3(a)
+ case(ce3)
+ call bndc_e3(a)
+ case(con)
+ ! PR93957
+ ! PR94289
+ ! call bndc_on(a)
+ case default
+ stop
+ end select
+ call bounds(a, lb, ub, n*t+31)
+ a = -1
+ return
+ end subroutine test_o
+
+end program bnds_p
b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
@@ -21,4 +21,3 @@ end
! { dg-final { scan-assembler-times "call\tmyBindC" 1 { target {
*-*-cygwin* } } } }
! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 {
target { s390*-*-* } } } }
! { 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" } }
b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -76,9 +76,13 @@ 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;
+ if (s->attribute != CFI_attribute_other)
+ GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
+ else
+ GFC_DESCRIPTOR_LBOUND(d, n) = 1;
+
GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
- + s->dim[n].lower_bound - 1);
+ + GFC_DESCRIPTOR_LBOUND(d, n) - 1);
GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm /
s->elem_len);
Hi all! Proposed patch to: Bug 94327 - Bind(c) argument attributes are incorrectly set and to: Bug 94331 - Bind(C) corrupts array descriptors Patch tested only on x86_64-pc-linux-gnu. Sorry for the double patch but applying them separately would break things. Fixing 94327 is simple, just fix the if clause assigning cfi_attribute so that it will always have the attribute of the dummy argument not, sometimes, the attribute of the effective argument. The array descriptor corruption is caused by the overwriting of the GFC array descriptor, on exit, with the internal bounds of the CFI descriptor which will be different, if the attribute is CFI_attribute_other. This conversion is AFAICT unnecessary if the dummy argument has the CFI_attribute_other or the value attributes set or if the intent is in. Any other case I might have forgotten? The conversion procedures where adjusted so that on output, for attribute CFI_attribute_other, the lower bound is set to 1 not 0 and on input so that arrays are only marked as assumed-size if the attribute is also CFI_attribute_other. The ISO_Fortran_binding_1.f90 test c_establish procedure is somewhat problematic, passing a dissociated pointer was clearly undefined behavior, and I believe that the way CFI_establish is used and the allocations are done is not kosher either. Some of the tests are disabled because of PR93957 and PR94289, I have previously posted a patch to PR93957. Thank you very much. Best regards, José Rui 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * trans-decl.c (convert_CFI_desc): Only overwrite the array descriptor if the dummy argument has the pointer or allocatable attribute set and not if it has the value attribute set or if it is intent in. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94327 * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Change if clause in order to set the dummy argiment's attribute to the correct value and remove obsolete comment. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Only overwrite the array descriptor if the dummy argument's attribute is CFI_attribute_other and if it has not the value attribute set or if it is intent in. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Set the array descriptor lower bound to 1 if the attribute is CFI_attribute_other. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * ISO_Fortran_binding.c (gfc_desc_to_cfi_desc): Only mark the CFI descriptor as assumed-size if the attribute is CFI_attribute_other. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94327 * ISO_Fortran_binding_1.f90: Add pointer attribute to c_establish argument in the interface. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * bind_c_array_params_2.f90: Remove test for code that is no longer emitted. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94327 * PR94327.f90: New test. * PR94327.c: Additional source. 2020-3-25 José Rui Faustino de Sousa <jrfsousa@gmail.com> PR fortran/94331 * PR94331.f90: New test. * PR94331.c: Additional source. d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n); } @@ -129,7 +133,8 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s) d->dim[n].lower_bound = 0; /* Assumed size arrays have gfc ubound == 0 and CFI extent = -1. */ - if (n == GFC_DESCRIPTOR_RANK (s) - 1 + if (d->attribute == CFI_attribute_other + && n == GFC_DESCRIPTOR_RANK (s) - 1 && GFC_DESCRIPTOR_LBOUND(s, n) == 1 && GFC_DESCRIPTOR_UBOUND(s, n) == 0) d->dim[n].extent = -1;