From 0324a4978e151e4a1cb5aa93265d2876af581baa Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 30 Mar 2019 15:39:00 +0000 Subject: [PATCH] re PR fortran/89841 (improper descriptor information passed to C) 2019-03-30 Paul Thomas 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. PR fortran/89842 * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Call 'set_dtype_for_unallocated' for any type of arrayspec. 2019-03-30 Paul Thomas 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. PR fortran/89842 * gfortran.dg/ISO_Fortran_binding_8.f90: New test. * gfortran.dg/ISO_Fortran_binding_8.c: Additional source. From-SVN: r270037 --- gcc/fortran/ChangeLog | 10 ++ gcc/fortran/trans-expr.c | 5 +- gcc/testsuite/ChangeLog | 13 +++ .../gfortran.dg/ISO_Fortran_binding_1.f90 | 6 +- .../gfortran.dg/ISO_Fortran_binding_7.c | 102 ++++++++++++++++++ .../gfortran.dg/ISO_Fortran_binding_7.f90 | 42 ++++++++ .../gfortran.dg/ISO_Fortran_binding_8.c | 37 +++++++ .../gfortran.dg/ISO_Fortran_binding_8.f90 | 50 +++++++++ 8 files changed, 259 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c create mode 100644 gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.c create mode 100644 gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 372c517487f..191451346f7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2019-03-30 Paul Thomas + + 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. + + PR fortran/89842 + * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Call + 'set_dtype_for_unallocated' for any type of arrayspec. + 2019-03-27 Janus Weil PR fortran/85537 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 19fb16feebe..434c9898d89 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4998,9 +4998,9 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) attribute = 2; if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) { - if (attr.pointer) + if (fsym->attr.pointer) attribute = 0; - else if (attr.allocatable) + else if (fsym->attr.allocatable) attribute = 1; } @@ -5021,7 +5021,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) need their dtype setting if they are argument associated with assumed rank dummies. */ if (fsym && fsym->as - && fsym->as->type == AS_ASSUMED_RANK && (gfc_expr_attr (e).pointer || gfc_expr_attr (e).allocatable)) set_dtype_for_unallocated (parmse, e); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9c583a38e74..390ae076ac8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2019-03-30 Paul Thomas + + 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. + + PR fortran/89842 + * gfortran.dg/ISO_Fortran_binding_8.f90: New test. + * gfortran.dg/ISO_Fortran_binding_8.c: Additional source. + 2019-03-30 Thomas Koenig PR fortran/89866 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 79d133d7ac0..d3a7b2b34c2 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -25,13 +25,13 @@ FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err) USE, INTRINSIC :: ISO_C_BINDING INTEGER(C_INT) :: err - type(*), DIMENSION(..) :: a + 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 - type(*), DIMENSION(..) :: a + INTEGER(C_INT), DIMENSION(..), allocatable :: a integer(C_INTPTR_T), DIMENSION(15) :: lower, upper END FUNCTION c_allocate @@ -67,7 +67,7 @@ USE, INTRINSIC :: ISO_C_BINDING INTEGER(C_INT) :: err INTEGER(C_INT), dimension(2) :: lbounds - type(*), DIMENSION(..) :: a + INTEGER(C_INT), DIMENSION(..), pointer :: a END FUNCTION c_setpointer FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err) diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c new file mode 100644 index 00000000000..d68428fce13 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c @@ -0,0 +1,102 @@ +/* Test the fix for PR89841. */ + +/* Contributed by Reinhold Bader */ + +#include "../../../libgfortran/ISO_Fortran_binding.h" +#include +#include +#include + +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; +} + + diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 new file mode 100644 index 00000000000..296cad4dd18 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90 @@ -0,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 +! +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 + diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.c new file mode 100644 index 00000000000..dc80cd332a1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.c @@ -0,0 +1,37 @@ +/* Test the fix for PR89841. */ + +/* Contributed by Reinhold Bader */ + +#include "../../../libgfortran/ISO_Fortran_binding.h" +#include + +float Cxgl[] = { 1.1, 2.3, 5.1, 4.2 }; + +void globalp(CFI_cdesc_t *this) +{ + int i, status; + float *pt; + CFI_index_t lb[] = { 3 }; + CFI_index_t ub[] = { 6 }; + + if (this->base_addr == NULL) + { + status = CFI_allocate(this, lb, ub, 0); + } + else + { + printf("FAIL C: already allocated.\n"); + return; + } + + if (status != CFI_SUCCESS) + { + printf("FAIL C: status is %i\n",status); + } + + pt = (float *) this->base_addr; + for (i=0; i<4; i++) + { + pt[i] = Cxgl[i]; + } +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.f90 new file mode 100644 index 00000000000..899a6954361 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_8.f90 @@ -0,0 +1,50 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_8.c } +! +! Test the fix for PR89842. +! +! Contributed by Reinhold Bader +! +module mod_alloc_01 + use, intrinsic :: iso_c_binding + implicit none + + interface + subroutine globalp(this) bind(c) + import :: c_float + real(c_float), allocatable :: this(:) + end subroutine globalp + end interface +end module mod_alloc_01 + +program alloc_01 + use mod_alloc_01 + implicit none + + real(c_float), allocatable :: myp(:) + integer :: status + + status = 0 + call globalp(myp) + +! write(*,*) 'globalp done' + if (.not. allocated(myp)) then + write(*,*) 'FAIL 1' + stop 1 + end if + if (lbound(myp,1) /= 3 .or. size(myp,1) /= 4) then + write(*,*) 'FAIL 2: ', lbound(myp), size(myp,1) + status = status + 1 + else +! write(*,*) 'Now checking data', myp(3) + if (maxval(abs(myp - [1.1, 2.3, 5.1, 4.2])) > 1.0e-6) then + write(*,*) 'FAIL 3: ', myp + status = status + 1 + end if + end if + + if (status .ne. 0) then + stop status + end if +end program alloc_01 + -- 2.30.2