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 <[email protected]>
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 <[email protected]>
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 <[email protected]> */
+
+ #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 <[email protected]>
+ !
+ 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
+
