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 <pa...@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 <pa...@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.
Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 269962) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 4998,5006 **** attribute = 2; if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) { ! if (attr.pointer) attribute = 0; ! else if (attr.allocatable) attribute = 1; } --- 4998,5006 ---- 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; } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (revision 269961) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (working copy) *************** *** 25,37 **** 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 --- 25,37 ---- 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 *************** *** 67,73 **** 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) --- 67,73 ---- 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) Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c (working copy) *************** *** 0 **** --- 1,102 ---- + /* Test the fix for PR89841. */ + + /* Contributed by Reinhold Bader <ba...@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; + } + + Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 (working copy) *************** *** 0 **** --- 1,42 ---- + ! { dg-do run { target c99_runtime } } + ! { dg-additional-sources ISO_Fortran_binding_7.c } + ! + ! Test the fix for PR89841. + ! + ! Contributed by Reinhold Bader <ba...@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 +