https://gcc.gnu.org/g:9d8888650e97cb76e4ea3b5d060e4a4cef38fc58
commit r15-2193-g9d8888650e97cb76e4ea3b5d060e4a4cef38fc58
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Thu Jul 11 10:07:12 2024 +0200
Fix Rejects allocatable coarray passed as a dummy argument [88624]
Coarray parameters of procedures/functions need to be dereffed, because
they are references to the descriptor but the routine expected the
descriptor directly.
PR fortran/88624
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_conv_procedure_call): Treat
pointers/references (e.g. from parameters) correctly by derefing
them.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/dummy_1.f90: Add calling function trough
function.
* gfortran.dg/pr88624.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 35 +++++++++++++++++++--------
gcc/testsuite/gfortran.dg/coarray/dummy_1.f90 | 2 ++
gcc/testsuite/gfortran.dg/pr88624.f90 | 21 ++++++++++++++++
3 files changed, 48 insertions(+), 10 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d9eb333abcb1..feb43fdec746 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7773,16 +7773,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& CLASS_DATA (fsym)->attr.codimension
&& !CLASS_DATA (fsym)->attr.allocatable)))
{
- tree caf_decl, caf_type;
+ tree caf_decl, caf_type, caf_desc = NULL_TREE;
tree offset, tmp2;
caf_decl = gfc_get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
-
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
- || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
- tmp = gfc_conv_descriptor_token (caf_decl);
+ if (POINTER_TYPE_P (caf_type)
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
+ caf_desc = TREE_TYPE (caf_type);
+ else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ caf_desc = caf_type;
+
+ if (caf_desc
+ && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
+ {
+ tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
+ ? build_fold_indirect_ref (caf_decl)
+ : caf_decl;
+ tmp = gfc_conv_descriptor_token (tmp);
+ }
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
tmp = GFC_DECL_TOKEN (caf_decl);
@@ -7795,8 +7805,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
vec_safe_push (stringargs, tmp);
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ if (caf_desc
+ && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
offset = build_int_cst (gfc_array_index_type, 0);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
@@ -7806,8 +7816,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
offset = build_int_cst (gfc_array_index_type, 0);
- if (GFC_DESCRIPTOR_TYPE_P (caf_type))
- tmp = gfc_conv_descriptor_data_get (caf_decl);
+ if (caf_desc)
+ {
+ tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
+ ? build_fold_indirect_ref (caf_decl)
+ : caf_decl;
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ }
else
{
gcc_assert (POINTER_TYPE_P (caf_type));
diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_1.f90
b/gcc/testsuite/gfortran.dg/coarray/dummy_1.f90
index 33e95853ad4a..c437b2a10fc4 100644
--- a/gcc/testsuite/gfortran.dg/coarray/dummy_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/dummy_1.f90
@@ -66,5 +66,7 @@
if (lcobound(A, dim=1) /= 2) STOP 13
if (ucobound(A, dim=1) /= 3) STOP 14
if (lcobound(A, dim=2) /= 5) STOP 15
+
+ call sub4(A) ! Check PR88624 is fixed.
end subroutine sub5
end
diff --git a/gcc/testsuite/gfortran.dg/pr88624.f90
b/gcc/testsuite/gfortran.dg/pr88624.f90
new file mode 100644
index 000000000000..e88ac907c6fc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr88624.f90
@@ -0,0 +1,21 @@
+!{ dg-do compile }
+!{ dg-options "-fcoarray=lib" }
+
+! Check that PR fortran/88624 is fixed.
+! Contributed by Modrzejewski <m.modrzejew...@student.uw.edu.pl>
+! Reduced to the essence of the issue.
+
+program test
+ implicit none
+ integer, dimension(:), allocatable :: x[:]
+ call g(x)
+contains
+ subroutine g(x)
+ integer, dimension(:), allocatable :: x[:]
+ call g2(x)
+ end subroutine g
+ subroutine g2(x)
+ integer, dimension(:) :: x[*]
+ end subroutine g2
+end program test
+
