===================================================================
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
attribute = 2;
if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
{
! if (attr.pointer)
attribute = 0;
! else if (attr.allocatable)
attribute = 1;
}
attribute = 2;
if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
{
! if (fsym->attr.pointer)
attribute = 0;
! else if (fsym->attr.allocatable)
attribute = 1;
}
===================================================================
***************
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
! type(*), DIMENSION(..) :: a
END FUNCTION c_deallocate
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
! type(*), DIMENSION(..) :: a
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
END FUNCTION c_allocate
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
! INTEGER(C_INT), DIMENSION(..), allocatable :: a
END FUNCTION c_deallocate
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
! INTEGER(C_INT), DIMENSION(..), allocatable :: a
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
END FUNCTION c_allocate
***************
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), dimension(2) :: lbounds
! type(*), DIMENSION(..) :: a
END FUNCTION c_setpointer
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), dimension(2) :: lbounds
! INTEGER(C_INT), DIMENSION(..), pointer :: a
END FUNCTION c_setpointer
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
===================================================================
***************
+ /* Test the fix for PR89841. */
+
+ /* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+ #include "../../../libgfortran/ISO_Fortran_binding.h"
+ #include <stdio.h>
+ #include <stdlib.h>
+ #include <math.h>
+
+ typedef struct
+ {
+ int i;
+ float r[2];
+ } cstruct;
+
+
+ int Psuba(CFI_cdesc_t *this, CFI_cdesc_t *that, int Dcase) {
+ int status = 0;
+ cstruct *cu;
+ float *ct;
+ CFI_dim_t *dim;
+ if (this->elem_len != sizeof(float))
+ {
+ printf("FAIL: Dcase %i - this->elem_len %i\n",Dcase, (int) this->elem_len);
+ status++;
+ }
+ if (this->type != CFI_type_float)
+ {
+ printf("FAIL: Dcase %i - this->type\n", Dcase);
+ status++;
+ }
+ if (this->rank != 2)
+ {
+ printf("FAIL: Dcase %i - this->rank %i\n",Dcase,this->rank);
+ status++;
+ }
+ if (this->attribute != CFI_attribute_other)
+ {
+ printf("FAIL: Dcase %i - this->attribute\n", Dcase);
+ status++;
+ }
+
+ dim = this->dim;
+ if (dim[0].lower_bound != 0 || dim[0].extent != 3)
+ {
+ printf("FAIL: Dcase %i - dim[0] %i %i %i\n",Dcase, (int) dim[0].lower_bound,
+ (int)dim[0].extent,(int)dim[0].sm);
+ status++;
+ }
+ if (dim[1].lower_bound != 0 || dim[1].extent != 7)
+ {
+ printf("FAIL: Dcase %i - dim[1] %i %i %i\n",Dcase,(int) dim[1].lower_bound,
+ (int) dim[1].extent,(int) dim[1].sm);
+ status++;
+ }
+
+ if (that->elem_len != sizeof(cstruct))
+ {
+ printf("FAIL: Dcase %i - that->elem_len\n", Dcase);
+ status++;
+ }
+ if (that->type != CFI_type_struct)
+ {
+ printf("FAIL: Dcase %i - that->type\n",Dcase);
+ status++;
+ }
+ if (that->rank != 1)
+ {
+ printf("FAIL: Dcase %i - that->rank\n", Dcase);
+ status++;
+ }
+ if (that->attribute != CFI_attribute_other)
+ {
+ printf("FAIL: Dcase %i - that->attribute %i\n",Dcase,that->attribute);
+ status++;
+ }
+
+ dim = that->dim;
+ if (dim[0].lower_bound != 0 || dim[0].extent != 1)
+ {
+ printf("FAIL: Dcase %i - dim[0] %i %i\n",Dcase,(int)dim[0].lower_bound,dim[0].extent);
+ status++;
+ }
+
+ cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr;
+ if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6)
+ {
+ printf("FAIL: Dcase %i - value of that %i %f %f\n",Dcase,cu->i,cu->r[0],cu->r[1]);
+ status++;
+ }
+
+ ct = (float *) ((CFI_cdesc_t *) this)->base_addr;
+ if ( fabs(ct[5] + 2.0) > 1.0e-6)
+ {
+ printf("FAIL: Dcase %i - value of this %f\n",Dcase,ct[5]);
+ status++;
+ }
+
+ return status;
+ }
+
+
===================================================================
***************
+ ! { dg-do run { target c99_runtime } }
+ ! { dg-additional-sources ISO_Fortran_binding_7.c }
+ !
+ ! Test the fix for PR89841.
+ !
+ ! Contributed by Reinhold Bader <Bader@lrz.de>
+ !
+ program assumed_shape_01
+ use, intrinsic :: iso_c_binding
+ implicit none
+ type, bind(c) :: cstruct
+ integer(c_int) :: i
+ real(c_float) :: r(2)
+ end type cstruct
+ interface
+ function psub(this, that, case) bind(c, name='Psuba') result(status)
+ import :: c_float, c_int, cstruct
+ real(c_float) :: this(:,:)
+ type(cstruct) :: that(:)
+ integer(c_int), value :: case
+ integer(c_int) :: status
+ end function psub
+ end interface
+
+ real(c_float) :: t(3,7)
+ type(cstruct), pointer :: u(:)
+ type(cstruct), allocatable :: v(:)
+ integer(c_int) :: st
+
+ allocate(u(1), source=[cstruct( 4, [1.1,2.2] ) ])
+ allocate(v(1), source=[cstruct( 4, [1.1,2.2] ) ])
+ t = 0.0
+ t(3,2) = -2.0
+ st = psub(t, u, 1)
+ if (st .ne. 0) stop 1
+ st = psub(t, v, 2)
+ if (st .ne. 0) stop 2
+ deallocate (u)
+ deallocate (v)
+
+ end program assumed_shape_01
+
This corrects a screw-up on my part. The attribute field of the CFI descriptor must be set by the formal argument in the interface and not the actual argument. Most of the work was in correcting Bootstrapped and regtested on FC29/x86_64 - OK for trunk? Cheers Paul 2019-03-27 Paul Thomas <pault@gcc.gnu.org> PR fortran/89841 * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Use the formal argument attributes rather than those of the actual argument. 2019-03-27 Paul Thomas <pault@gcc.gnu.org> PR fortran/89841 * gfortran.dg/ISO_Fortran_binding_1.f90: Change the interfaces for c_deallocate, c_allocate and c_assumed_size so that the attributes of the array arguments are correct and are typed. * gfortran.dg/ISO_Fortran_binding_7.f90: New test. * gfortran.dg/ISO_Fortran_binding_7.c: Additional source.