Hi all,
the attached patch fixes an ICE when compiling with -fcoarray=lib and using
(proc_-)pointer component in a coarray. The code was looking at the wrong
location for the caf-token.
Regtests ok on x86_64-pc-linux-gnu / Fedora 39. Ok for mainline?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From 5115201ea3eb9caf673adce89c49e953cb46c375 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Wed, 18 Sep 2024 15:55:28 +0200
Subject: [PATCH] Fortran: Allow to nullify caf token when not in ultimate
component. [PR101100]
gcc/fortran/ChangeLog:
PR fortran/101100
* trans-expr.cc (trans_caf_token_assign): Take caf-token from
decl for non ultimate coarray components.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/proc_pointer_assign_1.f90: New test.
---
gcc/fortran/trans-expr.cc | 8 ++++-
.../coarray/proc_pointer_assign_1.f90 | 29 +++++++++++++++++++
2 files changed, 36 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/proc_pointer_assign_1.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 54901c33139..18ef5e246ce 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10371,7 +10371,13 @@ trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
else if (lhs_attr.codimension)
{
lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
- lhs_tok = build_fold_indirect_ref (lhs_tok);
+ if (!lhs_tok)
+ {
+ lhs_tok = gfc_get_tree_for_caf_expr (expr1);
+ lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
+ }
+ else
+ lhs_tok = build_fold_indirect_ref (lhs_tok);
tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
lhs_tok, null_pointer_node);
gfc_prepend_expr_to_block (&lse->post, tmp);
diff --git a/gcc/testsuite/gfortran.dg/coarray/proc_pointer_assign_1.f90 b/gcc/testsuite/gfortran.dg/coarray/proc_pointer_assign_1.f90
new file mode 100644
index 00000000000..81f0c3b19cf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/proc_pointer_assign_1.f90
@@ -0,0 +1,29 @@
+!{ dg-do run }
+
+! Check that PR101100 is fixed.
+
+! Contributed by G. Steinmetz <gs...@t-online.de>
+
+program p
+ type t
+ procedure(), pointer, nopass :: f
+ end type
+
+ integer :: i = 0
+ type(t) :: x[*]
+
+ x%f => null()
+ if ( associated(x%f) ) stop 1
+
+ x%f => g
+ if (.not. associated(x%f) ) stop 2
+
+ call x%f()
+ if ( i /= 1 ) stop 3
+
+contains
+ subroutine g()
+ i = 1
+ end subroutine
+end
+
--
2.46.0
