diff options
| author | Andre Vehreschild <vehre@gcc.gnu.org> | 2024-09-18 15:55:28 +0200 |
|---|---|---|
| committer | Andre Vehreschild <vehre@gcc.gnu.org> | 2024-09-24 14:28:03 +0200 |
| commit | 0c0d79c783f5c289651d76aa697b48d4505e169d (patch) | |
| tree | 1f7c6ebaa976d3cd42a005040cea68dc5eca46bc | |
| parent | 2249c3b459510f307b4f241ea4b14f6557035152 (diff) | |
| download | gcc-0c0d79c783f5c289651d76aa697b48d4505e169d.zip gcc-0c0d79c783f5c289651d76aa697b48d4505e169d.tar.gz gcc-0c0d79c783f5c289651d76aa697b48d4505e169d.tar.bz2 | |
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.
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/proc_pointer_assign_1.f90 | 29 |
2 files changed, 36 insertions, 1 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 01cf3f0..d0c7dfe 100644 --- 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 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 + |