diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index c32bd05..97aafe3 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4526,22 +4526,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); - - 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 = 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); - 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); + 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); + } /* Add the lot to the procedure init and finally blocks. */ gfc_add_init_cleanup (block, incoming, outgoing); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index de406ad..52e243b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5501,13 +5501,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) { @@ -5615,10 +5614,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 + && !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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 102bc60..0cf3b2c 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/PR93308.f90 b/gcc/testsuite/gfortran.dg/PR93308.f90 new file mode 100644 index 0000000..ee116f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93308.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Robin Hogan +! + +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 diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90 new file mode 100644 index 0000000..4e1b06f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93963.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/PR94327.c b/gcc/testsuite/gfortran.dg/PR94327.c new file mode 100644 index 0000000..6791c37 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.c @@ -0,0 +1,70 @@ +/* Test the fix for PR94327. */ + +#include +#include +#include + +#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; ielem_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; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90 new file mode 100644 index 0000000..3cb3ac3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/PR94331.c b/gcc/testsuite/gfortran.dg/PR94331.c new file mode 100644 index 0000000..4e13051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.c @@ -0,0 +1,73 @@ +/* Test the fix for PR94331. */ + +#include +#include +#include + +#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; ielem_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; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90 new file mode 100644 index 0000000..6185031 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/PR97046.f90 b/gcc/testsuite/gfortran.dg/PR97046.f90 new file mode 100644 index 0000000..7d133a5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR97046.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Igor Gayday +! + +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 diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 00628c1..ede6eff 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -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" } } diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 20833ad..db9b32b 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -43,6 +43,20 @@ 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; + /* FALL THROUGH */ + default: + internal_error (NULL, "INVALID CFI DESCRIPTOR"); + 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 +88,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 +121,20 @@ 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; + /* FALL THROUGH */ + default: + internal_error (NULL, "INVALID GFC DESCRIPTOR"); + break; + } d->base_addr = GFC_DESCRIPTOR_DATA (s); d->elem_len = GFC_DESCRIPTOR_SIZE (s); d->version = s->dtype.version;