FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix incompatible types between INTEGER(8) and TYPE(c_ptr)

Browse source 
In the context of an OpenMP declare variant directive, arguments of type C_PTR
are sometimes recognised as C_PTR in the base function and as INTEGER(8) in the
variant - or the other way around, depending on the parsing order.
This patch prevents such situation from turning into a compile error.

2023-10-20  Paul-Antoine Arras  <pa@codesourcery.com>
	    Tobias Burnus  <tobias@codesourcery.com>

gcc/fortran/ChangeLog:

	* interface.cc (gfc_compare_types): Return true if one type is C_PTR
	and the other is a compatible INTEGER(8).
	* misc.cc (gfc_typename): Handle the case where an INTEGER(8) actually
	holds a TYPE(C_PTR).

gcc/testsuite/ChangeLog:

	* gfortran.dg/c_ptr_tests_20.f90: New test, checking that INTEGER(8)
	and TYPE(C_PTR) are recognised as compatible.
	* gfortran.dg/c_ptr_tests_21.f90: New test, exercising the error
	detection for C_FUNPTR.
This commit is contained in:
Paul-Antoine Arras 2023-10-20 12:42:49 +02:00
parent a4ca869133
commit 8d2130a4e5
4 changed files with 132 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
gcc/fortran/interface.cc
View file

@ -736,10 +736,18 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
better way of doing this. When ISO C binding is cleared up,
this can probably be removed. See PR 57048. */
if (((ts1->type == BT_INTEGER && ts2->type == BT_DERIVED)
|| (ts1->type == BT_DERIVED && ts2->type == BT_INTEGER))
&& ts1->u.derived && ts2->u.derived
&& ts1->u.derived == ts2->u.derived)
if ((ts1->type == BT_INTEGER
&& ts2->type == BT_DERIVED
&& ts1->f90_type == BT_VOID
&& ts2->u.derived->from_intmod == INTMOD_ISO_C_BINDING
&& ts1->u.derived
&& strcmp (ts1->u.derived->name, ts2->u.derived->name) == 0)
|| (ts2->type == BT_INTEGER
&& ts1->type == BT_DERIVED
&& ts2->f90_type == BT_VOID
&& ts1->u.derived->from_intmod == INTMOD_ISO_C_BINDING
&& ts2->u.derived
&& strcmp (ts1->u.derived->name, ts2->u.derived->name) == 0))
return true;
/* The _data component is not always present, therefore check for its

7
gcc/fortran/misc.cc
View file

@ -138,7 +138,12 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
switch (ts->type)
{
case BT_INTEGER:
sprintf (buffer, "INTEGER(%d)", ts->kind);
if (ts->f90_type == BT_VOID
&& ts->u.derived
&& ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
else
sprintf (buffer, "INTEGER(%d)", ts->kind);
break;
case BT_REAL:
sprintf (buffer, "REAL(%d)", ts->kind);

57
gcc/testsuite/gfortran.dg/c_ptr_tests_20.f90 Normal file
View file

@ -0,0 +1,57 @@
! { dg-do compile }
! { dg-additional-options "-fopenmp" }
!
! This failed to compile the declare variant directive due to the C_PTR
! arguments to foo being recognised as INTEGER(8)
program adjust_args
use iso_c_binding, only: c_loc
implicit none
integer, parameter :: N = 1024
real, allocatable, target :: av(:), bv(:), cv(:)
call foo(c_loc(bv), c_loc(av), N)
!$omp target data map(to: av(:N)) map(from: cv(:N))
!$omp parallel
call foo(c_loc(cv), c_loc(av), N)
!$omp end parallel
!$omp end target data
contains
subroutine foo_variant(c_d_bv, c_d_av, n)
use iso_c_binding, only: c_ptr, c_f_pointer
type(c_ptr), intent(in) :: c_d_bv, c_d_av
integer, intent(in) :: n
real, pointer :: f_d_bv(:)
real, pointer :: f_d_av(:)
integer :: i
call c_f_pointer(c_d_bv, f_d_bv, [n])
call c_f_pointer(c_d_av, f_d_av, [n])
!$omp target teams loop is_device_ptr(f_d_bv, f_d_av)
do i = 1, n
f_d_bv(i) = f_d_av(i) * i
end do
end subroutine
subroutine foo(c_bv, c_av, n)
use iso_c_binding, only: c_ptr, c_f_pointer
type(c_ptr), intent(in) :: c_bv, c_av
integer, intent(in) :: n
real, pointer :: f_bv(:)
real, pointer :: f_av(:)
integer :: i
!$omp declare variant(foo_variant) &
!$omp match(construct={parallel})
call c_f_pointer(c_bv, f_bv, [n])
call c_f_pointer(c_av, f_av, [n])
!$omp parallel loop
do i = 1, n
f_bv(i) = f_av(i) * i
end do
end subroutine
end program

57
gcc/testsuite/gfortran.dg/c_ptr_tests_21.f90 Normal file
View file

@ -0,0 +1,57 @@
! { dg-do compile }
! { dg-additional-options "-fopenmp" }
!
! Ensure that C_PTR and C_FUNPTR are reported as incompatible types in variant
! argument lists
program adjust_args
use iso_c_binding, only: c_loc
implicit none
integer, parameter :: N = 1024
real, allocatable, target :: av(:), bv(:), cv(:)
call foo(c_loc(bv), c_loc(av), N)
!$omp target data map(to: av(:N)) map(from: cv(:N))
!$omp parallel
call foo(c_loc(cv), c_loc(av), N)
!$omp end parallel
!$omp end target data
contains
subroutine foo_variant(c_d_bv, c_d_av, n)
use iso_c_binding, only: c_funptr, c_f_pointer
type(c_funptr), intent(in) :: c_d_bv, c_d_av
integer, intent(in) :: n
real, pointer :: f_d_bv(:)
real, pointer :: f_d_av(:)
integer :: i
! call c_f_pointer(c_d_bv, f_d_bv, [n])
! call c_f_pointer(c_d_av, f_d_av, [n])
!$omp target teams loop is_device_ptr(f_d_bv, f_d_av)
do i = 1, n
f_d_bv(i) = f_d_av(i) * i
end do
end subroutine
subroutine foo(c_bv, c_av, n)
use iso_c_binding, only: c_ptr, c_f_pointer
type(c_ptr), intent(in) :: c_bv, c_av
integer, intent(in) :: n
real, pointer :: f_bv(:)
real, pointer :: f_av(:)
integer :: i
!$omp declare variant(foo_variant) & ! { dg-error "variant 'foo_variant' and base 'foo' at .1. have incompatible types: Type mismatch in argument 'c_bv' .TYPE.c_ptr./TYPE.c_funptr.." }
!$omp match(construct={parallel})
call c_f_pointer(c_bv, f_bv, [n])
call c_f_pointer(c_av, f_av, [n])
!$omp parallel loop
do i = 1, n
f_bv(i) = f_av(i) * i
end do
end subroutine
end program