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.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 01cf3f0ff148c392ddd284768b3d8984f0d3522a..d0c7dfea903d8408051bd818831edee77fea257c 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10359,7 +10359,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 (file)
index 0000000..81f0c3b
--- /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  <gscfq@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
+