Dear all,
while preparing the testcase null_actual_7.f90 for commit r15-6408,
I overlooked a corner case, leading to a regression (PR118179).
The obvious solution is to extend the suppression of copying back
the pointer also for NULL actual arguments to pointer dummies
with no specified intent.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 49754a5acc6ca4c0927d54c3c00cc3f93f1ce4dd Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Mon, 23 Dec 2024 17:56:46 +0100
Subject: [PATCH] Fortran: fix NULL without MOLD argument to scalar DT pointer
dummy [PR118179]
Commit r15-6408 overlooked the case of passing NULL without MOLD argument
to a derived type pointer dummy argument without specified intent. Since
it is prohibited to modify the dummy argument, we treat it as if intent(in)
were specified and suppress copying back of the pointer address.
PR fortran/118179
gcc/fortran/ChangeLog:
* trans-expr.cc (conv_null_actual): Suppress copying back of
pointer address for unspecified intent.
gcc/testsuite/ChangeLog:
* gfortran.dg/null_actual_7.f90: Extend testcase to also cover
scalar variants with pointer or allocatable dummy with or without
specified intent.
---
gcc/fortran/trans-expr.cc | 3 +-
gcc/testsuite/gfortran.dg/null_actual_7.f90 | 77 +++++++++++++++++++++
2 files changed, 79 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9aedecb9780..4b022989e6f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6488,7 +6488,8 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
int dummy_rank;
tree tmp = parmse->expr;
- if (fsym->attr.allocatable && fsym->attr.intent == INTENT_UNKNOWN)
+ if ((fsym->attr.allocatable || fsym->attr.pointer)
+ && fsym->attr.intent == INTENT_UNKNOWN)
fsym->attr.intent = INTENT_IN;
tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
dummy_rank = fsym->as ? fsym->as->rank : 0;
diff --git a/gcc/testsuite/gfortran.dg/null_actual_7.f90 b/gcc/testsuite/gfortran.dg/null_actual_7.f90
index ba3cd10f21b..8891a3620ce 100644
--- a/gcc/testsuite/gfortran.dg/null_actual_7.f90
+++ b/gcc/testsuite/gfortran.dg/null_actual_7.f90
@@ -10,6 +10,8 @@ program null_actual
end type t
type(t), pointer :: p2(:,:) => NULL()
type(t), allocatable :: a2(:,:)
+ type(t), pointer :: p0 => NULL ()
+ type(t), allocatable :: a0
! Basic tests passing unallocated allocatable / disassociated pointer
stop_base = 0
@@ -27,6 +29,16 @@ program null_actual
call chk2_t_p (p2)
call opt2_t_a (a2)
call opt2_t_p (p2)
+ ! ... to rank-0 dummy:
+ stop_base = 60
+ call chk0_t_a (a0)
+ call chk0_t_p (p0)
+ call opt0_t_a (a0)
+ call opt0_t_p (p0)
+ call chk0_t_a_i (a0)
+ call chk0_t_p_i (p0)
+ call opt0_t_a_i (a0)
+ call opt0_t_p_i (p0)
! Test NULL with MOLD argument
stop_base = 20
@@ -43,6 +55,16 @@ program null_actual
call opt2_t_a (null(a2))
call opt2_t_p (null(p2))
+ stop_base = 80
+ call chk0_t_a (null(a0))
+ call chk0_t_p (null(p0))
+ call opt0_t_a (null(a0))
+ call opt0_t_p (null(p0))
+ call chk0_t_a_i (null(a0))
+ call chk0_t_p_i (null(p0))
+ call opt0_t_a_i (null(a0))
+ call opt0_t_p_i (null(p0))
+
! Test NULL without MOLD argument
stop_base = 40
call chk2_t_a (null())
@@ -50,6 +72,16 @@ program null_actual
call opt2_t_a (null())
call opt2_t_p (null())
+ stop_base = 100
+ call chk0_t_a (null())
+ call chk0_t_p (null())
+ call opt0_t_a (null())
+ call opt0_t_p (null())
+ call chk0_t_a_i (null())
+ call chk0_t_p_i (null())
+ call opt0_t_a_i (null())
+ call opt0_t_p_i (null())
+
contains
! Check assumed-rank dummy:
subroutine chk_t_a (x)
@@ -120,4 +152,49 @@ contains
if (.not. present (x)) stop stop_base + 19
if (associated (x)) stop stop_base + 20
end subroutine opt2_t_p
+
+ ! Checks for rank-0 dummy:
+ subroutine chk0_t_p (x)
+ type(t), pointer :: x
+ if (associated (x)) stop stop_base + 1
+ end subroutine chk0_t_p
+
+ subroutine chk0_t_p_i (x)
+ type(t), pointer, intent(in) :: x
+ if (associated (x)) stop stop_base + 2
+ end subroutine chk0_t_p_i
+
+ subroutine opt0_t_p (x)
+ type(t), pointer, optional :: x
+ if (.not. present (x)) stop stop_base + 3
+ if (associated (x)) stop stop_base + 4
+ end subroutine opt0_t_p
+
+ subroutine opt0_t_p_i (x)
+ type(t), pointer, optional, intent(in) :: x
+ if (.not. present (x)) stop stop_base + 5
+ if (associated (x)) stop stop_base + 6
+ end subroutine opt0_t_p_i
+
+ subroutine chk0_t_a (x)
+ type(t), allocatable :: x
+ if (allocated (x)) stop stop_base + 7
+ end subroutine chk0_t_a
+
+ subroutine chk0_t_a_i (x)
+ type(t), allocatable, intent(in) :: x
+ if (allocated (x)) stop stop_base + 8
+ end subroutine chk0_t_a_i
+
+ subroutine opt0_t_a (x)
+ type(t), allocatable, optional :: x
+ if (.not. present (x)) stop stop_base + 9
+ if (allocated (x)) stop stop_base + 10
+ end subroutine opt0_t_a
+
+ subroutine opt0_t_a_i (x)
+ type(t), allocatable, optional, intent(in) :: x
+ if (.not. present (x)) stop stop_base + 11
+ if (allocated (x)) stop stop_base + 12
+ end subroutine opt0_t_a_i
end
--
2.35.3
