PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling
Fortran: Fix attributes and bounds in ISO_Fortran_binding. 2021-07-26 José Rui Faustino de Sousa <jrfsousa@gmail.com> Tobias Burnus <tobias@codesourcery.com> PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046 gcc/fortran/ChangeLog: * trans-decl.c (convert_CFI_desc): Only copy out the descriptor if necessary. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute handling which reflect a previous intermediate version of the standard. Only copy out the descriptor if necessary. libgfortran/ChangeLog: * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code to verify the descriptor. Correct bounds calculation. (gfc_desc_to_cfi_desc): Add code to verify the descriptor. gcc/testsuite/ChangeLog: * gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute, this test is still erroneous but now it compiles. * gfortran.dg/bind_c_array_params_2.f90: Update regex to match code changes. * gfortran.dg/PR93308.f90: New test. * gfortran.dg/PR93963.f90: New test. * gfortran.dg/PR94327.c: New test. * gfortran.dg/PR94327.f90: New test. * gfortran.dg/PR94331.c: New test. * gfortran.dg/PR94331.f90: New test. * gfortran.dg/PR97046.f90: New test.
This commit is contained in:
Tobias Burnus
parent
32f7506bdc
commit
0cbf03689e
12 changed files with 932 additions and 32 deletions
|
|
@ -4539,22 +4539,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
|
|||
gfc_add_expr_to_block (&outer_block, incoming);
|
||||
incoming = gfc_finish_block (&outer_block);
|
||||
|
||||
|
||||
/* Convert the gfc descriptor back to the CFI type before going
|
||||
out of scope, if the CFI type was present at entry. */
|
||||
gfc_init_block (&outer_block);
|
||||
gfc_init_block (&tmpblock);
|
||||
outgoing = NULL_TREE;
|
||||
if ((sym->attr.pointer || sym->attr.allocatable)
|
||||
&& !sym->attr.value
|
||||
&& sym->attr.intent != INTENT_IN)
|
||||
{
|
||||
gfc_init_block (&outer_block);
|
||||
gfc_init_block (&tmpblock);
|
||||
|
||||
tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
|
||||
outgoing = build_call_expr_loc (input_location,
|
||||
gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
|
||||
gfc_add_expr_to_block (&tmpblock, outgoing);
|
||||
tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
|
||||
outgoing = build_call_expr_loc (input_location,
|
||||
gfor_fndecl_gfc_to_cfi, 2,
|
||||
tmp, gfc_desc_ptr);
|
||||
gfc_add_expr_to_block (&tmpblock, outgoing);
|
||||
|
||||
outgoing = build3_v (COND_EXPR, present,
|
||||
gfc_finish_block (&tmpblock),
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&outer_block, outgoing);
|
||||
outgoing = gfc_finish_block (&outer_block);
|
||||
outgoing = build3_v (COND_EXPR, present,
|
||||
gfc_finish_block (&tmpblock),
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&outer_block, outgoing);
|
||||
outgoing = gfc_finish_block (&outer_block);
|
||||
}
|
||||
|
||||
/* Add the lot to the procedure init and finally blocks. */
|
||||
gfc_add_init_cleanup (block, incoming, outgoing);
|
||||
|
|
|
|||
|
|
@ -5502,13 +5502,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
|
|||
attribute = 1;
|
||||
}
|
||||
|
||||
/* If the formal argument is assumed shape and neither a pointer nor
|
||||
allocatable, it is unconditionally CFI_attribute_other. */
|
||||
if (fsym->as->type == AS_ASSUMED_SHAPE
|
||||
&& !fsym->attr.pointer && !fsym->attr.allocatable)
|
||||
cfi_attribute = 2;
|
||||
if (fsym->attr.pointer)
|
||||
cfi_attribute = 0;
|
||||
else if (fsym->attr.allocatable)
|
||||
cfi_attribute = 1;
|
||||
else
|
||||
cfi_attribute = attribute;
|
||||
cfi_attribute = 2;
|
||||
|
||||
if (e->rank != 0)
|
||||
{
|
||||
|
|
@ -5616,10 +5615,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
|
|||
gfc_prepend_expr_to_block (&parmse->post, tmp);
|
||||
|
||||
/* Transfer values back to gfc descriptor. */
|
||||
tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
|
||||
tmp = build_call_expr_loc (input_location,
|
||||
gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
|
||||
gfc_prepend_expr_to_block (&parmse->post, tmp);
|
||||
if (cfi_attribute != 2 /* CFI_attribute_other. */
|
||||
&& !fsym->attr.value
|
||||
&& fsym->attr.intent != INTENT_IN)
|
||||
{
|
||||
tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
|
||||
tmp = build_call_expr_loc (input_location,
|
||||
gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
|
||||
gfc_prepend_expr_to_block (&parmse->post, tmp);
|
||||
}
|
||||
|
||||
/* Deal with an optional dummy being passed to an optional formal arg
|
||||
by finishing the pre and post blocks and making their execution
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@
|
|||
USE, INTRINSIC :: ISO_C_BINDING
|
||||
import
|
||||
INTEGER(C_INT) :: err
|
||||
type (T), DIMENSION(..), intent(out) :: a
|
||||
type (T), pointer, DIMENSION(..), intent(out) :: a
|
||||
END FUNCTION c_establish
|
||||
|
||||
FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
|
||||
|
|
|
|||
52
gcc/testsuite/gfortran.dg/PR93308.f90
Normal file
52
gcc/testsuite/gfortran.dg/PR93308.f90
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR94331
|
||||
!
|
||||
! Contributed by Robin Hogan <r.j.hogan@reading.ac.uk>
|
||||
!
|
||||
|
||||
program test
|
||||
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_float
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i
|
||||
integer, parameter :: n = 11
|
||||
real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)]
|
||||
|
||||
real(kind=c_float), allocatable :: A(:)
|
||||
real(kind=c_float) :: E(n)
|
||||
integer(kind=c_int) :: l1, l2, l3
|
||||
|
||||
allocate(A, source=u)
|
||||
l1 = lbound(A, 1)
|
||||
call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A...
|
||||
l3 = lbound(A, 1)
|
||||
if (l1 /= 1) stop 1
|
||||
if (l1 /= l2) stop 2
|
||||
if (l1 /= l3) stop 3
|
||||
if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4
|
||||
deallocate(A)
|
||||
!
|
||||
E = u
|
||||
l1 = lbound(E, 1)
|
||||
call routine_bindc(E, l2) ! ...but does not change lbound of E
|
||||
l3 = lbound(E, 1)
|
||||
if (l1 /= 1) stop 5
|
||||
if (l1 /= l2) stop 6
|
||||
if (l1 /= l3) stop 7
|
||||
if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8
|
||||
|
||||
contains
|
||||
|
||||
subroutine routine_bindc(v, l) bind(c)
|
||||
real(kind=c_float), intent(inout) :: v(:)
|
||||
integer(kind=c_int), intent(out) :: l
|
||||
|
||||
l = lbound(v, 1)
|
||||
if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9
|
||||
end subroutine routine_bindc
|
||||
|
||||
end program test
|
||||
150
gcc/testsuite/gfortran.dg/PR93963.f90
Normal file
150
gcc/testsuite/gfortran.dg/PR93963.f90
Normal file
|
|
@ -0,0 +1,150 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR93963
|
||||
!
|
||||
|
||||
function rank_p(this) result(rnk) bind(c)
|
||||
use, intrinsic :: iso_c_binding, only: c_int
|
||||
|
||||
implicit none
|
||||
|
||||
integer(kind=c_int), pointer, intent(in) :: this(..)
|
||||
integer(kind=c_int) :: rnk
|
||||
|
||||
select rank(this)
|
||||
rank(0)
|
||||
rnk = 0
|
||||
rank(1)
|
||||
rnk = 1
|
||||
rank(2)
|
||||
rnk = 2
|
||||
rank(3)
|
||||
rnk = 3
|
||||
rank(4)
|
||||
rnk = 4
|
||||
rank(5)
|
||||
rnk = 5
|
||||
rank(6)
|
||||
rnk = 6
|
||||
rank(7)
|
||||
rnk = 7
|
||||
rank(8)
|
||||
rnk = 8
|
||||
rank(9)
|
||||
rnk = 9
|
||||
rank(10)
|
||||
rnk = 10
|
||||
rank(11)
|
||||
rnk = 11
|
||||
rank(12)
|
||||
rnk = 12
|
||||
rank(13)
|
||||
rnk = 13
|
||||
rank(14)
|
||||
rnk = 14
|
||||
rank(15)
|
||||
rnk = 15
|
||||
rank default
|
||||
rnk = -1000
|
||||
end select
|
||||
return
|
||||
end function rank_p
|
||||
|
||||
function rank_a(this) result(rnk) bind(c)
|
||||
use, intrinsic :: iso_c_binding, only: c_int
|
||||
|
||||
implicit none
|
||||
|
||||
integer(kind=c_int), allocatable, intent(in) :: this(..)
|
||||
integer(kind=c_int) :: rnk
|
||||
|
||||
select rank(this)
|
||||
rank(0)
|
||||
rnk = 0
|
||||
rank(1)
|
||||
rnk = 1
|
||||
rank(2)
|
||||
rnk = 2
|
||||
rank(3)
|
||||
rnk = 3
|
||||
rank(4)
|
||||
rnk = 4
|
||||
rank(5)
|
||||
rnk = 5
|
||||
rank(6)
|
||||
rnk = 6
|
||||
rank(7)
|
||||
rnk = 7
|
||||
rank(8)
|
||||
rnk = 8
|
||||
rank(9)
|
||||
rnk = 9
|
||||
rank(10)
|
||||
rnk = 10
|
||||
rank(11)
|
||||
rnk = 11
|
||||
rank(12)
|
||||
rnk = 12
|
||||
rank(13)
|
||||
rnk = 13
|
||||
rank(14)
|
||||
rnk = 14
|
||||
rank(15)
|
||||
rnk = 15
|
||||
rank default
|
||||
rnk = -1000
|
||||
end select
|
||||
return
|
||||
end function rank_a
|
||||
|
||||
program selr_p
|
||||
|
||||
use, intrinsic :: iso_c_binding, only: c_int
|
||||
|
||||
implicit none
|
||||
|
||||
interface
|
||||
function rank_p(this) result(rnk) bind(c)
|
||||
use, intrinsic :: iso_c_binding, only: c_int
|
||||
integer(kind=c_int), pointer, intent(in) :: this(..)
|
||||
integer(kind=c_int) :: rnk
|
||||
end function rank_p
|
||||
end interface
|
||||
|
||||
interface
|
||||
function rank_a(this) result(rnk) bind(c)
|
||||
use, intrinsic :: iso_c_binding, only: c_int
|
||||
integer(kind=c_int), allocatable, intent(in) :: this(..)
|
||||
integer(kind=c_int) :: rnk
|
||||
end function rank_a
|
||||
end interface
|
||||
|
||||
integer(kind=c_int), parameter :: siz = 7
|
||||
integer(kind=c_int), parameter :: rnk = 1
|
||||
|
||||
integer(kind=c_int), pointer :: intp(:)
|
||||
integer(kind=c_int), allocatable :: inta(:)
|
||||
integer(kind=c_int) :: irnk
|
||||
|
||||
nullify(intp)
|
||||
irnk = rank_p(intp)
|
||||
if (irnk /= rnk) stop 1
|
||||
if (irnk /= rank(intp)) stop 2
|
||||
!
|
||||
irnk = rank_a(inta)
|
||||
if (irnk /= rnk) stop 3
|
||||
if (irnk /= rank(inta)) stop 4
|
||||
!
|
||||
allocate(intp(siz))
|
||||
irnk = rank_p(intp)
|
||||
if (irnk /= rnk) stop 5
|
||||
if (irnk /= rank(intp)) stop 6
|
||||
deallocate(intp)
|
||||
nullify(intp)
|
||||
!
|
||||
allocate(inta(siz))
|
||||
if (irnk /= rnk) stop 7
|
||||
if (irnk /= rank(inta)) stop 8
|
||||
deallocate(inta)
|
||||
|
||||
end program selr_p
|
||||
70
gcc/testsuite/gfortran.dg/PR94327.c
Normal file
70
gcc/testsuite/gfortran.dg/PR94327.c
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
/* Test the fix for PR94327. */
|
||||
|
||||
#include <assert.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include "../../../libgfortran/ISO_Fortran_binding.h"
|
||||
|
||||
bool c_vrfy (const CFI_cdesc_t *restrict);
|
||||
|
||||
char get_attr (const CFI_cdesc_t*restrict, bool);
|
||||
|
||||
bool
|
||||
c_vrfy (const CFI_cdesc_t *restrict auxp)
|
||||
{
|
||||
CFI_index_t i, lb, ub, ex;
|
||||
int *ip = NULL;
|
||||
|
||||
assert (auxp);
|
||||
assert (auxp->base_addr);
|
||||
lb = auxp->dim[0].lower_bound;
|
||||
ex = auxp->dim[0].extent;
|
||||
ub = ex + lb - 1;
|
||||
ip = (int*)auxp->base_addr;
|
||||
for (i=0; i<ex; i++)
|
||||
if (*ip++ != i+1)
|
||||
return false;
|
||||
for (i=lb; i<ub+1; i++)
|
||||
{
|
||||
ip = (int*)CFI_address(auxp, &i);
|
||||
if (*ip != i-lb+1)
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
char
|
||||
get_attr (const CFI_cdesc_t *restrict auxp, bool alloc)
|
||||
{
|
||||
char attr;
|
||||
|
||||
assert (auxp);
|
||||
assert (auxp->elem_len == 4);
|
||||
assert (auxp->rank == 1);
|
||||
assert (auxp->type == CFI_type_int);
|
||||
attr = '\0';
|
||||
switch (auxp->attribute)
|
||||
{
|
||||
case CFI_attribute_pointer:
|
||||
if (alloc && !c_vrfy (auxp))
|
||||
break;
|
||||
attr = 'p';
|
||||
break;
|
||||
case CFI_attribute_allocatable:
|
||||
if (alloc && !c_vrfy (auxp))
|
||||
break;
|
||||
attr = 'a';
|
||||
break;
|
||||
case CFI_attribute_other:
|
||||
assert (alloc);
|
||||
if (!c_vrfy (auxp))
|
||||
break;
|
||||
attr = 'o';
|
||||
break;
|
||||
default:
|
||||
break;
|
||||
}
|
||||
return attr;
|
||||
}
|
||||
|
||||
195
gcc/testsuite/gfortran.dg/PR94327.f90
Normal file
195
gcc/testsuite/gfortran.dg/PR94327.f90
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
! { dg-do run }
|
||||
! { dg-additional-sources PR94327.c }
|
||||
!
|
||||
! Test the fix for PR94327
|
||||
!
|
||||
|
||||
program attr_p
|
||||
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i
|
||||
integer, parameter :: n = 11
|
||||
integer, parameter :: u(*) = [(i, i=1,n)]
|
||||
|
||||
interface
|
||||
function attr_p_as(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), pointer, intent(in) :: a(:)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_p_as
|
||||
function attr_a_as(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), allocatable, intent(in) :: a(:)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_a_as
|
||||
function attr_o_as(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), intent(in) :: a(:)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_o_as
|
||||
function attr_p_ar(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), pointer, intent(in) :: a(..)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_p_ar
|
||||
function attr_a_ar(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), allocatable, intent(in) :: a(..)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_a_ar
|
||||
function attr_o_ar(a, s) result(c) &
|
||||
bind(c, name="get_attr")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool, c_char
|
||||
implicit none
|
||||
integer(kind=c_int), intent(in) :: a(..)
|
||||
logical(kind=c_bool), value, intent(in) :: s
|
||||
character(kind=c_char) :: c
|
||||
end function attr_o_ar
|
||||
end interface
|
||||
|
||||
integer(kind=c_int), target :: a(n)
|
||||
integer(kind=c_int), allocatable, target :: b(:)
|
||||
integer(kind=c_int), pointer :: p(:)
|
||||
character(kind=c_char) :: c
|
||||
|
||||
a = u
|
||||
c = attr_p_as(a, .true._c_bool)
|
||||
if(c/='p') stop 1
|
||||
if(any(a/=u)) stop 2
|
||||
!
|
||||
a = u
|
||||
c = attr_p_ar(a, .true._c_bool)
|
||||
if(c/='p') stop 3
|
||||
if(any(a/=u)) stop 4
|
||||
!
|
||||
a = u
|
||||
c = attr_o_as(a, .true._c_bool)
|
||||
if(c/='o') stop 5
|
||||
if(any(a/=u)) stop 6
|
||||
!
|
||||
a = u
|
||||
c = attr_o_ar(a, .true._c_bool)
|
||||
if(c/='o') stop 7
|
||||
if(any(a/=u)) stop 8
|
||||
!
|
||||
allocate(b, source=u)
|
||||
c = attr_p_as(b, .true._c_bool)
|
||||
if(c/='p') stop 9
|
||||
if(.not.allocated(b)) stop 10
|
||||
if(any(b/=u)) stop 11
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b, source=u)
|
||||
c = attr_p_ar(b, .true._c_bool)
|
||||
if(c/='p') stop 12
|
||||
if(.not.allocated(b)) stop 13
|
||||
if(any(b/=u)) stop 14
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b, source=u)
|
||||
c = attr_a_as(b, .true._c_bool)
|
||||
if(c/='a') stop 15
|
||||
if(.not.allocated(b)) stop 16
|
||||
if(any(b/=u)) stop 17
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b, source=u)
|
||||
c = attr_a_ar(b, .true._c_bool)
|
||||
if(c/='a') stop 18
|
||||
if(.not.allocated(b)) stop 19
|
||||
if(any(b/=u)) stop 20
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b, source=u)
|
||||
c = attr_o_as(b, .true._c_bool)
|
||||
if(c/='o') stop 21
|
||||
if(.not.allocated(b)) stop 22
|
||||
if(any(b/=u)) stop 23
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b, source=u)
|
||||
c = attr_o_ar(b, .true._c_bool)
|
||||
if(c/='o') stop 24
|
||||
if(.not.allocated(b)) stop 25
|
||||
if(any(b/=u)) stop 26
|
||||
!
|
||||
deallocate(b)
|
||||
c = attr_a_as(b, .false._c_bool)
|
||||
if(c/='a') stop 27
|
||||
if(allocated(b)) stop 28
|
||||
!
|
||||
c = attr_a_ar(b, .false._c_bool)
|
||||
if(c/='a') stop 29
|
||||
if(allocated(b)) stop 30
|
||||
!
|
||||
nullify(p)
|
||||
p => a
|
||||
c = attr_p_as(p, .true._c_bool)
|
||||
if(c/='p') stop 31
|
||||
if(.not.associated(p)) stop 32
|
||||
if(.not.associated(p, a)) stop 33
|
||||
if(any(p/=u)) stop 34
|
||||
!
|
||||
nullify(p)
|
||||
p => a
|
||||
c = attr_p_ar(p, .true._c_bool)
|
||||
if(c/='p') stop 35
|
||||
if(.not.associated(p)) stop 36
|
||||
if(.not.associated(p, a)) stop 37
|
||||
if(any(p/=u)) stop 38
|
||||
!
|
||||
nullify(p)
|
||||
p => a
|
||||
c = attr_o_as(p, .true._c_bool)
|
||||
if(c/='o') stop 39
|
||||
if(.not.associated(p)) stop 40
|
||||
if(.not.associated(p, a)) stop 41
|
||||
if(any(p/=u)) stop 42
|
||||
!
|
||||
nullify(p)
|
||||
p => a
|
||||
c = attr_o_ar(p, .true._c_bool)
|
||||
if(c/='o') stop 43
|
||||
if(.not.associated(p)) stop 44
|
||||
if(.not.associated(p, a)) stop 45
|
||||
if(any(p/=u)) stop 46
|
||||
!
|
||||
nullify(p)
|
||||
c = attr_p_as(p, .false._c_bool)
|
||||
if(c/='p') stop 47
|
||||
if(associated(p)) stop 48
|
||||
if(associated(p, a)) stop 49
|
||||
!
|
||||
nullify(p)
|
||||
c = attr_p_ar(p, .false._c_bool)
|
||||
if(c/='p') stop 50
|
||||
if(associated(p)) stop 51
|
||||
if(associated(p, a)) stop 52
|
||||
stop
|
||||
|
||||
end program attr_p
|
||||
73
gcc/testsuite/gfortran.dg/PR94331.c
Normal file
73
gcc/testsuite/gfortran.dg/PR94331.c
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
/* Test the fix for PR94331. */
|
||||
|
||||
#include <assert.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include "../../../libgfortran/ISO_Fortran_binding.h"
|
||||
|
||||
bool c_vrfy (const CFI_cdesc_t *restrict);
|
||||
|
||||
bool check_bounds(const CFI_cdesc_t*restrict, const int, const int);
|
||||
|
||||
bool
|
||||
c_vrfy (const CFI_cdesc_t *restrict auxp)
|
||||
{
|
||||
CFI_index_t i, lb, ub, ex;
|
||||
int *ip = NULL;
|
||||
|
||||
assert (auxp);
|
||||
assert (auxp->base_addr);
|
||||
lb = auxp->dim[0].lower_bound;
|
||||
ex = auxp->dim[0].extent;
|
||||
ub = ex + lb - 1;
|
||||
ip = (int*)auxp->base_addr;
|
||||
for (i=0; i<ex; i++)
|
||||
if (*ip++ != i+1)
|
||||
return false;
|
||||
for (i=lb; i<ub+1; i++)
|
||||
{
|
||||
ip = (int*)CFI_address(auxp, &i);
|
||||
if (*ip != i-lb+1)
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
bool
|
||||
check_bounds (const CFI_cdesc_t *restrict auxp, const int lb, const int ub)
|
||||
{
|
||||
CFI_index_t ex = ub-lb+1;
|
||||
size_t el;
|
||||
bool is_ok = false;
|
||||
|
||||
assert (auxp);
|
||||
el = auxp->elem_len;
|
||||
assert (auxp->rank==1);
|
||||
assert (auxp->type==CFI_type_int);
|
||||
assert (auxp->dim[0].sm>0);
|
||||
assert ((size_t)auxp->dim[0].sm==el);
|
||||
if (auxp->dim[0].extent==ex
|
||||
&& auxp->dim[0].lower_bound==lb)
|
||||
{
|
||||
switch(auxp->attribute)
|
||||
{
|
||||
case CFI_attribute_pointer:
|
||||
case CFI_attribute_allocatable:
|
||||
if (!c_vrfy (auxp))
|
||||
break;
|
||||
is_ok = true;
|
||||
break;
|
||||
case CFI_attribute_other:
|
||||
if (!c_vrfy (auxp))
|
||||
break;
|
||||
is_ok = (lb==0);
|
||||
break;
|
||||
default:
|
||||
assert (false);
|
||||
break;
|
||||
}
|
||||
}
|
||||
return is_ok;
|
||||
}
|
||||
|
||||
252
gcc/testsuite/gfortran.dg/PR94331.f90
Normal file
252
gcc/testsuite/gfortran.dg/PR94331.f90
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
! { dg-do run }
|
||||
! { dg-additional-sources PR94331.c }
|
||||
!
|
||||
! Test the fix for PR94331
|
||||
!
|
||||
|
||||
program main_p
|
||||
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i
|
||||
integer, parameter :: ex = 11
|
||||
integer, parameter :: lb = 11
|
||||
integer, parameter :: ub = ex+lb-1
|
||||
integer, parameter :: u(*) = [(i, i=1,ex)]
|
||||
|
||||
interface
|
||||
function checkb_p_as(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), pointer, intent(in) :: a(:)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_p_as
|
||||
function checkb_a_as(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), allocatable, intent(in) :: a(:)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_a_as
|
||||
function checkb_o_as(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), intent(in) :: a(:)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_o_as
|
||||
function checkb_p_ar(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), pointer, intent(in) :: a(..)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_p_ar
|
||||
function checkb_a_ar(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), allocatable, intent(in) :: a(..)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_a_ar
|
||||
function checkb_o_ar(a, l, u) result(c) &
|
||||
bind(c, name="check_bounds")
|
||||
use, intrinsic :: iso_c_binding, only: &
|
||||
c_int, c_bool
|
||||
implicit none
|
||||
integer(kind=c_int), intent(in) :: a(..)
|
||||
integer(kind=c_int), value, intent(in) :: l
|
||||
integer(kind=c_int), value, intent(in) :: u
|
||||
logical(kind=c_bool) :: c
|
||||
end function checkb_o_ar
|
||||
end interface
|
||||
|
||||
integer(kind=c_int), target :: a(lb:ub)
|
||||
integer(kind=c_int), allocatable, target :: b(:)
|
||||
integer(kind=c_int), pointer :: p(:)
|
||||
|
||||
a = u
|
||||
if(lbound(a,1)/=lb) stop 1
|
||||
if(ubound(a,1)/=ub) stop 2
|
||||
if(any(shape(a)/=[ex])) stop 3
|
||||
if(.not.checkb_p_as(a, lb, ub)) stop 4
|
||||
if(lbound(a,1)/=lb) stop 5
|
||||
if(ubound(a,1)/=ub) stop 6
|
||||
if(any(shape(a)/=[ex])) stop 7
|
||||
if(any(a/=u)) stop 8
|
||||
!
|
||||
a = u
|
||||
if(lbound(a,1)/=lb) stop 9
|
||||
if(ubound(a,1)/=ub) stop 10
|
||||
if(any(shape(a)/=[ex])) stop 11
|
||||
if(.not.checkb_p_ar(a, lb, ub)) stop 12
|
||||
if(lbound(a,1)/=lb) stop 13
|
||||
if(ubound(a,1)/=ub) stop 14
|
||||
if(any(shape(a)/=[ex])) stop 15
|
||||
if(any(a/=u)) stop 16
|
||||
!
|
||||
a = u
|
||||
if(lbound(a,1)/=lb) stop 17
|
||||
if(ubound(a,1)/=ub) stop 18
|
||||
if(any(shape(a)/=[ex])) stop 19
|
||||
if(.not.checkb_o_as(a, 0, ex-1))stop 20
|
||||
if(lbound(a,1)/=lb) stop 21
|
||||
if(ubound(a,1)/=ub) stop 22
|
||||
if(any(shape(a)/=[ex])) stop 23
|
||||
if(any(a/=u)) stop 24
|
||||
!
|
||||
a = u
|
||||
if(lbound(a,1)/=lb) stop 25
|
||||
if(ubound(a,1)/=ub) stop 26
|
||||
if(any(shape(a)/=[ex])) stop 27
|
||||
if(.not.checkb_o_ar(a, 0, ex-1))stop 28
|
||||
if(lbound(a,1)/=lb) stop 29
|
||||
if(ubound(a,1)/=ub) stop 30
|
||||
if(any(shape(a)/=[ex])) stop 31
|
||||
if(any(a/=u)) stop 32
|
||||
!
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 33
|
||||
if(ubound(b,1)/=ub) stop 34
|
||||
if(any(shape(b)/=[ex])) stop 35
|
||||
if(.not.checkb_p_as(b, lb, ub)) stop 36
|
||||
if(.not.allocated(b)) stop 37
|
||||
if(lbound(b,1)/=lb) stop 38
|
||||
if(ubound(b,1)/=ub) stop 39
|
||||
if(any(shape(b)/=[ex])) stop 40
|
||||
if(any(b/=u)) stop 41
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 42
|
||||
if(ubound(b,1)/=ub) stop 43
|
||||
if(any(shape(b)/=[ex])) stop 44
|
||||
if(.not.checkb_p_ar(b, lb, ub)) stop 45
|
||||
if(.not.allocated(b)) stop 46
|
||||
if(lbound(b,1)/=lb) stop 47
|
||||
if(ubound(b,1)/=ub) stop 48
|
||||
if(any(shape(b)/=[ex])) stop 49
|
||||
if(any(b/=u)) stop 50
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 51
|
||||
if(ubound(b,1)/=ub) stop 52
|
||||
if(any(shape(b)/=[ex])) stop 53
|
||||
if(.not.checkb_a_as(b, lb, ub)) stop 54
|
||||
if(.not.allocated(b)) stop 55
|
||||
if(lbound(b,1)/=lb) stop 56
|
||||
if(ubound(b,1)/=ub) stop 57
|
||||
if(any(shape(b)/=[ex])) stop 58
|
||||
if(any(b/=u)) stop 59
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 60
|
||||
if(ubound(b,1)/=ub) stop 61
|
||||
if(any(shape(b)/=[ex])) stop 62
|
||||
if(.not.checkb_a_ar(b, lb, ub)) stop 63
|
||||
if(.not.allocated(b)) stop 64
|
||||
if(lbound(b,1)/=lb) stop 65
|
||||
if(ubound(b,1)/=ub) stop 66
|
||||
if(any(shape(b)/=[ex])) stop 67
|
||||
if(any(b/=u)) stop 68
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 69
|
||||
if(ubound(b,1)/=ub) stop 70
|
||||
if(any(shape(b)/=[ex])) stop 71
|
||||
if(.not.checkb_o_as(b, 0, ex-1))stop 72
|
||||
if(.not.allocated(b)) stop 73
|
||||
if(lbound(b,1)/=lb) stop 74
|
||||
if(ubound(b,1)/=ub) stop 75
|
||||
if(any(shape(b)/=[ex])) stop 76
|
||||
if(any(b/=u)) stop 77
|
||||
!
|
||||
deallocate(b)
|
||||
allocate(b(lb:ub), source=u)
|
||||
if(lbound(b,1)/=lb) stop 78
|
||||
if(ubound(b,1)/=ub) stop 79
|
||||
if(any(shape(b)/=[ex])) stop 80
|
||||
if(.not.checkb_o_ar(b, 0, ex-1))stop 81
|
||||
if(.not.allocated(b)) stop 82
|
||||
if(lbound(b,1)/=lb) stop 83
|
||||
if(ubound(b,1)/=ub) stop 84
|
||||
if(any(shape(b)/=[ex])) stop 85
|
||||
if(any(b/=u)) stop 86
|
||||
deallocate(b)
|
||||
!
|
||||
p(lb:ub) => a
|
||||
if(lbound(p,1)/=lb) stop 87
|
||||
if(ubound(p,1)/=ub) stop 88
|
||||
if(any(shape(p)/=[ex])) stop 89
|
||||
if(.not.checkb_p_as(p, lb, ub)) stop 90
|
||||
if(.not.associated(p)) stop 91
|
||||
if(.not.associated(p, a)) stop 92
|
||||
if(lbound(p,1)/=lb) stop 93
|
||||
if(ubound(p,1)/=ub) stop 94
|
||||
if(any(shape(p)/=[ex])) stop 95
|
||||
if(any(p/=u)) stop 96
|
||||
!
|
||||
nullify(p)
|
||||
p(lb:ub) => a
|
||||
if(lbound(p,1)/=lb) stop 97
|
||||
if(ubound(p,1)/=ub) stop 98
|
||||
if(any(shape(p)/=[ex])) stop 99
|
||||
if(.not.checkb_p_ar(p, lb, ub)) stop 100
|
||||
if(.not.associated(p)) stop 101
|
||||
if(.not.associated(p, a)) stop 102
|
||||
if(lbound(p,1)/=lb) stop 103
|
||||
if(ubound(p,1)/=ub) stop 104
|
||||
if(any(shape(p)/=[ex])) stop 105
|
||||
if(any(p/=u)) stop 106
|
||||
!
|
||||
nullify(p)
|
||||
p(lb:ub) => a
|
||||
if(lbound(p,1)/=lb) stop 107
|
||||
if(ubound(p,1)/=ub) stop 108
|
||||
if(any(shape(p)/=[ex])) stop 109
|
||||
if(.not.checkb_o_as(p, 0, ex-1))stop 110
|
||||
if(.not.associated(p)) stop 111
|
||||
if(.not.associated(p, a)) stop 112
|
||||
if(lbound(p,1)/=lb) stop 113
|
||||
if(ubound(p,1)/=ub) stop 114
|
||||
if(any(shape(p)/=[ex])) stop 115
|
||||
if(any(p/=u)) stop 116
|
||||
!
|
||||
nullify(p)
|
||||
p(lb:ub) => a
|
||||
if(lbound(p,1)/=lb) stop 117
|
||||
if(ubound(p,1)/=ub) stop 118
|
||||
if(any(shape(p)/=[ex])) stop 119
|
||||
if(.not.checkb_o_ar(p, 0, ex-1))stop 120
|
||||
if(.not.associated(p)) stop 121
|
||||
if(.not.associated(p, a)) stop 122
|
||||
if(lbound(p,1)/=lb) stop 123
|
||||
if(ubound(p,1)/=ub) stop 124
|
||||
if(any(shape(p)/=[ex])) stop 125
|
||||
if(any(p/=u)) stop 126
|
||||
nullify(p)
|
||||
stop
|
||||
|
||||
end program main_p
|
||||
58
gcc/testsuite/gfortran.dg/PR97046.f90
Normal file
58
gcc/testsuite/gfortran.dg/PR97046.f90
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR94331
|
||||
!
|
||||
! Contributed by Igor Gayday <igor.gayday@mu.edu>
|
||||
!
|
||||
|
||||
MODULE FOO
|
||||
|
||||
implicit none
|
||||
|
||||
INTEGER, parameter :: n = 11
|
||||
|
||||
contains
|
||||
|
||||
SUBROUTINE dummyc(x0) BIND(C)
|
||||
type(*), dimension(..) :: x0
|
||||
if(LBOUND(x0,1)/=1) stop 5
|
||||
if(UBOUND(x0,1)/=n) stop 6
|
||||
if(rank(x0)/=1) stop 7
|
||||
END SUBROUTINE dummyc
|
||||
|
||||
SUBROUTINE dummy(x0)
|
||||
type(*), dimension(..) :: x0
|
||||
call dummyc(x0)
|
||||
END SUBROUTINE dummy
|
||||
|
||||
END MODULE
|
||||
|
||||
PROGRAM main
|
||||
USE FOO
|
||||
IMPLICIT NONE
|
||||
integer :: before(2), after(2)
|
||||
|
||||
DOUBLE PRECISION, ALLOCATABLE :: buf(:)
|
||||
DOUBLE PRECISION :: buf2(n)
|
||||
|
||||
ALLOCATE(buf(n))
|
||||
before(1) = LBOUND(buf,1)
|
||||
before(2) = UBOUND(buf,1)
|
||||
CALL dummy (buf)
|
||||
after(1) = LBOUND(buf,1)
|
||||
after(2) = UBOUND(buf,1)
|
||||
deallocate(buf)
|
||||
|
||||
if (before(1) .NE. after(1)) stop 1
|
||||
if (before(2) .NE. after(2)) stop 2
|
||||
|
||||
before(1) = LBOUND(buf2,1)
|
||||
before(2) = UBOUND(buf2,1)
|
||||
CALL dummy (buf2)
|
||||
after(1) = LBOUND(buf2,1)
|
||||
after(2) = UBOUND(buf2,1)
|
||||
|
||||
if (before(1) .NE. after(1)) stop 3
|
||||
if (before(2) .NE. after(2)) stop 4
|
||||
|
||||
END PROGRAM
|
||||
|
|
@ -22,4 +22,4 @@ end
|
|||
! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
|
||||
! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } }
|
||||
! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } }
|
||||
! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } }
|
||||
|
|
|
|||
|
|
@ -43,6 +43,24 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
|
|||
if (!s)
|
||||
return;
|
||||
|
||||
/* Verify descriptor. */
|
||||
switch(s->attribute)
|
||||
{
|
||||
case CFI_attribute_pointer:
|
||||
case CFI_attribute_allocatable:
|
||||
break;
|
||||
case CFI_attribute_other:
|
||||
if (s->base_addr)
|
||||
break;
|
||||
runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
|
||||
"dummy argument where the effective argument is either "
|
||||
"not allocated or not associated");
|
||||
break;
|
||||
default:
|
||||
runtime_error ("Invalid attribute type %d in CFI_cdesc_t descriptor",
|
||||
(int) s->attribute);
|
||||
break;
|
||||
}
|
||||
GFC_DESCRIPTOR_DATA (d) = s->base_addr;
|
||||
GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
|
||||
kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
|
||||
|
|
@ -74,14 +92,19 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
|
|||
}
|
||||
|
||||
d->offset = 0;
|
||||
for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
|
||||
{
|
||||
GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
|
||||
GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
|
||||
+ s->dim[n].lower_bound - 1);
|
||||
GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
|
||||
d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
|
||||
}
|
||||
if (GFC_DESCRIPTOR_DATA (d))
|
||||
for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
|
||||
{
|
||||
CFI_index_t lb = 1;
|
||||
|
||||
if (s->attribute != CFI_attribute_other)
|
||||
lb = s->dim[n].lower_bound;
|
||||
|
||||
GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)lb;
|
||||
GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent + lb - 1);
|
||||
GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
|
||||
d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
|
||||
}
|
||||
}
|
||||
|
||||
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
|
||||
|
|
@ -102,6 +125,23 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
|
|||
else
|
||||
d = *d_ptr;
|
||||
|
||||
/* Verify descriptor. */
|
||||
switch (s->dtype.attribute)
|
||||
{
|
||||
case CFI_attribute_pointer:
|
||||
case CFI_attribute_allocatable:
|
||||
break;
|
||||
case CFI_attribute_other:
|
||||
if (s->base_addr)
|
||||
break;
|
||||
runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
|
||||
"dummy argument where the effective argument is either "
|
||||
"not allocated or not associated");
|
||||
break;
|
||||
default:
|
||||
internal_error (NULL, "Invalid attribute in gfc_array descriptor");
|
||||
break;
|
||||
}
|
||||
d->base_addr = GFC_DESCRIPTOR_DATA (s);
|
||||
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
|
||||
d->version = CFI_VERSION;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue