re PR fortran/89841 (improper descriptor information passed to C)
2019-03-30 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. 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 <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. PR fortran/89842 * gfortran.dg/ISO_Fortran_binding_8.f90: New test. * gfortran.dg/ISO_Fortran_binding_8.c: Additional source. From-SVN: r270037
This commit is contained in:
parent
26b81a446f
commit
0324a4978e
|
@ -1,3 +1,13 @@
|
||||||
|
2019-03-30 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.
|
||||||
|
|
||||||
|
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 <janus@gcc.gnu.org>
|
2019-03-27 Janus Weil <janus@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/85537
|
PR fortran/85537
|
||||||
|
|
|
@ -4998,9 +4998,9 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
|
||||||
attribute = 2;
|
attribute = 2;
|
||||||
if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
|
if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
|
||||||
{
|
{
|
||||||
if (attr.pointer)
|
if (fsym->attr.pointer)
|
||||||
attribute = 0;
|
attribute = 0;
|
||||||
else if (attr.allocatable)
|
else if (fsym->attr.allocatable)
|
||||||
attribute = 1;
|
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
|
need their dtype setting if they are argument associated with
|
||||||
assumed rank dummies. */
|
assumed rank dummies. */
|
||||||
if (fsym && fsym->as
|
if (fsym && fsym->as
|
||||||
&& fsym->as->type == AS_ASSUMED_RANK
|
|
||||||
&& (gfc_expr_attr (e).pointer
|
&& (gfc_expr_attr (e).pointer
|
||||||
|| gfc_expr_attr (e).allocatable))
|
|| gfc_expr_attr (e).allocatable))
|
||||||
set_dtype_for_unallocated (parmse, e);
|
set_dtype_for_unallocated (parmse, e);
|
||||||
|
|
|
@ -1,3 +1,16 @@
|
||||||
|
2019-03-30 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.
|
||||||
|
|
||||||
|
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 <tkoenig@gcc.gnu.org>
|
2019-03-30 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/89866
|
PR fortran/89866
|
||||||
|
|
|
@ -25,13 +25,13 @@
|
||||||
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
|
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
|
||||||
USE, INTRINSIC :: ISO_C_BINDING
|
USE, INTRINSIC :: ISO_C_BINDING
|
||||||
INTEGER(C_INT) :: err
|
INTEGER(C_INT) :: err
|
||||||
type(*), DIMENSION(..) :: a
|
INTEGER(C_INT), DIMENSION(..), allocatable :: a
|
||||||
END FUNCTION c_deallocate
|
END FUNCTION c_deallocate
|
||||||
|
|
||||||
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
|
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
|
||||||
USE, INTRINSIC :: ISO_C_BINDING
|
USE, INTRINSIC :: ISO_C_BINDING
|
||||||
INTEGER(C_INT) :: err
|
INTEGER(C_INT) :: err
|
||||||
type(*), DIMENSION(..) :: a
|
INTEGER(C_INT), DIMENSION(..), allocatable :: a
|
||||||
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
|
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
|
||||||
END FUNCTION c_allocate
|
END FUNCTION c_allocate
|
||||||
|
|
||||||
|
@ -67,7 +67,7 @@
|
||||||
USE, INTRINSIC :: ISO_C_BINDING
|
USE, INTRINSIC :: ISO_C_BINDING
|
||||||
INTEGER(C_INT) :: err
|
INTEGER(C_INT) :: err
|
||||||
INTEGER(C_INT), dimension(2) :: lbounds
|
INTEGER(C_INT), dimension(2) :: lbounds
|
||||||
type(*), DIMENSION(..) :: a
|
INTEGER(C_INT), DIMENSION(..), pointer :: a
|
||||||
END FUNCTION c_setpointer
|
END FUNCTION c_setpointer
|
||||||
|
|
||||||
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
|
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
|
||||||
|
|
|
@ -0,0 +1,102 @@
|
||||||
|
/* 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;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
|
@ -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 <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
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
/* Test the fix for PR89841. */
|
||||||
|
|
||||||
|
/* Contributed by Reinhold Bader <Bader@lrz.de> */
|
||||||
|
|
||||||
|
#include "../../../libgfortran/ISO_Fortran_binding.h"
|
||||||
|
#include <stdio.h>
|
||||||
|
|
||||||
|
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];
|
||||||
|
}
|
||||||
|
}
|
|
@ -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 <Bader@lrz.de>
|
||||||
|
!
|
||||||
|
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
|
||||||
|
|
Loading…
Reference in New Issue