Skip to content

Commit

Permalink
Fortran: Fix "str" to scalar descriptor conversion [PR92482]
Browse files Browse the repository at this point in the history
	PR fortran/92482
gcc/fortran/ChangeLog:

	* trans-expr.c (gfc_conv_procedure_call): Use TREE_OPERAND not
	build_fold_indirect_ref_loc to undo an ADDR_EXPR.

gcc/testsuite/ChangeLog:

	* gfortran.dg/bind-c-char-descr.f90: Remove xfail; extend a bit.
  • Loading branch information
tob2 committed Oct 19, 2021
1 parent e3ef92e commit 6920d5a
Show file tree
Hide file tree
Showing 2 changed files with 39 additions and 20 deletions.
2 changes: 1 addition & 1 deletion gcc/fortran/trans-expr.c
Original file line number Diff line number Diff line change
Expand Up @@ -6640,7 +6640,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = parmse.expr;
if (TREE_CODE (tmp) == ADDR_EXPR)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = TREE_OPERAND (tmp, 0);
parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
fsym->attr);
parmse.expr = gfc_build_addr_expr (NULL_TREE,
Expand Down
57 changes: 38 additions & 19 deletions gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@
!
! Contributed by José Rui Faustino de Sousa
!
! Note the xfail issue below for 'strg_print_2("abc")

program strp_p

Expand All @@ -24,13 +23,18 @@ program strp_p
if (len(str) /= 3 .or. str /= "abc") stop 1
if (len(strp_1) /= 3 .or. strp_1 /= "abc") stop 2
if (len(strp_2) /= 3 .or. strp_2 /= "abc") stop 3
call strg_print_0("abc") ! Error (10.0.0) or segmentation fault (9.1.0)
call strg_print_0(str) ! Error (10.0.0) or segmentation fault (9.1.0)
call strg_print_0(strp_1) ! Error (10.0.0) or segmentation fault (9.1.0)
call strg_print_0(strp_2) ! Error (10.0.0) or segmentation fault (9.1.0)
call strg_print_1(strp_1) ! Not yet supported
call strg_print_0("abc")
call strg_print_0(str)
call strg_print_0(strp_1)
call strg_print_0(strp_2)
call strg_print_0_c("abc")
call strg_print_0_c(str)
call strg_print_0_c(strp_1)
call strg_print_0_c(strp_2)
call strg_print_1(strp_1)
call strg_print_1_c(strp_1)

call strg_print_2("abc", xfail=.true.)
call strg_print_2("abc")
call strg_print_2(str)
call strg_print_2(strp_1)
call strg_print_2(strp_2)
Expand All @@ -42,14 +46,21 @@ program strp_p

contains

subroutine strg_print_0(this) bind(c) ! Error (10.0.0 20191106) or warning (9.1.0) issued with bind(c)
subroutine strg_print_0 (this)
character(len=*, kind=c_char), target, intent(in) :: this

if (len (this) /= 3) stop 10
if (this /= "abc") stop 11
end subroutine strg_print_0

subroutine strg_print_0_c (this) bind(c)
character(len=*, kind=c_char), target, intent(in) :: this

if (len (this) /= 3) stop 10
if (this /= "abc") stop 11
end subroutine strg_print_0_c

subroutine strg_print_1(this) bind(c) ! Not yet supported with bind(c)
subroutine strg_print_1 (this) bind(c)
character(len=:, kind=c_char), pointer, intent(in) :: this
character(len=:), pointer :: strn

Expand All @@ -63,26 +74,34 @@ subroutine strg_print_1(this) bind(c) ! Not yet supported with bind(c)
if (this /= "abc") stop 25
end if
end subroutine strg_print_1

subroutine strg_print_1_c (this) bind(c)
character(len=:, kind=c_char), pointer, intent(in) :: this
character(len=:), pointer :: strn

if (.not. associated (this)) stop 20
if (len (this) /= 3) stop 21
if (this /= "abc") stop 22
strn => this
if (.not. associated (strn)) stop 23
if(associated(strn))then
if (len (this) /= 3) stop 24
if (this /= "abc") stop 25
end if
end subroutine strg_print_1_c

subroutine strg_print_2(this, xfail)
subroutine strg_print_2(this)
use, intrinsic :: iso_c_binding, only: &
c_loc, c_f_pointer

type(*), target, intent(in) :: this(..)
logical, optional, value :: xfail
character(len=l), pointer :: strn

call c_f_pointer(c_loc(this), strn)
if (.not. associated (strn)) stop 30
if(associated(strn))then
if (associated(strn)) then
if (len (strn) /= 3) stop 31
if (strn /= "abc") then
if (present (xfail)) then
print *, 'INVALID STRING - EXPECTED "abc" / PR47225'
else
stop 32
end if
end if
if (strn /= "abc") stop 32
end if
end subroutine strg_print_2

Expand Down

0 comments on commit 6920d5a

Please sign in to comment.