Hi Mikael,
Am 08.12.21 um 10:32 schrieb Mikael Morin:
On 07/12/2021 21:46, Harald Anlauf wrote:
Hi Mikael,
Am 07.12.21 um 21:17 schrieb Mikael Morin:
The existing code looks dubious to me (or at least difficult to
understand), and your patch doesn’t make that any better.
I would rather try to remove the whole block, and fix the fallout on
move_alloc by adding calls to gfc_check_vardef_context in
gfc_check_move_alloc.
Can you try that instead?
I hadn't thought that far but will think about a possibly better
solution.
Hello,
I thought about it some more over night, and it is probably a poor
suggestion to restrict the check to move_alloc only. The existing code
was added for move_alloc, but it has a broader scope. Still,
gfc_check_vardef_context has the correct checks and is the one to be used.
I have played a little, and it took some time to understand the fallout.
Your suggestion to rely on gfc_check_vardef_context actually helped to
uncover another bug: a bad check for CLASS pointer.
See attached for an updated patch and the extended testcase.
Regtested again. OK now?
Thanks,
Harald
From dec60c90d47211d55048e7034e95f3e6fb10a2d4 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Thu, 9 Dec 2021 22:57:13 +0100
Subject: [PATCH] Fortran: fix check for pointer dummy arguments with
INTENT(IN)
gcc/fortran/ChangeLog:
PR fortran/103418
* check.c (variable_check): Replace previous check of procedure
dummy arguments with INTENT(IN) attribute when passed to intrinsic
procedures by gfc_check_vardef_context.
* expr.c (gfc_check_vardef_context): Correct check of INTENT(IN)
dummy arguments for the case of sub-components of a CLASS pointer.
gcc/testsuite/ChangeLog:
PR fortran/103418
* gfortran.dg/move_alloc_8.f90: Adjust error messages.
* gfortran.dg/pointer_intent_9.f90: New test.
---
gcc/fortran/check.c | 32 ++++--------------
gcc/fortran/expr.c | 9 +++--
gcc/testsuite/gfortran.dg/move_alloc_8.f90 | 4 +--
.../gfortran.dg/pointer_intent_9.f90 | 33 +++++++++++++++++++
4 files changed, 47 insertions(+), 31 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/pointer_intent_9.f90
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ee3a51ee253..3934336df2e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1011,33 +1011,13 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.intent == INTENT_IN
&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
- || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
+ || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)
+ && !gfc_check_vardef_context (e, false, true, false, NULL))
{
- gfc_ref *ref;
- bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
- && CLASS_DATA (e->symtree->n.sym)
- ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
- : e->symtree->n.sym->attr.pointer;
-
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (pointer && ref->type == REF_COMPONENT)
- break;
- if (ref->type == REF_COMPONENT
- && ((ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
- || (ref->u.c.component->ts.type != BT_CLASS
- && ref->u.c.component->attr.pointer)))
- break;
- }
-
- if (!ref)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
- "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
- gfc_current_intrinsic, &e->where);
- return false;
- }
+ gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
+ gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return false;
}
if (e->expr_type == EXPR_VARIABLE
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 87089321a3b..b874607db1d 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -6254,10 +6254,13 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
{
if (ptr_component && ref->type == REF_COMPONENT)
check_intentin = false;
- if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+ if (ref->type == REF_COMPONENT)
{
- ptr_component = true;
- if (!pointer)
+ gfc_component *comp = ref->u.c.component;
+ ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok)
+ ? CLASS_DATA (comp)->attr.class_pointer
+ : comp->attr.pointer;
+ if (ptr_component && !pointer)
check_intentin = false;
}
if (ref->type == REF_INQUIRY
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_8.f90 b/gcc/testsuite/gfortran.dg/move_alloc_8.f90
index f624b703cc9..d968ea0e5cd 100644
--- a/gcc/testsuite/gfortran.dg/move_alloc_8.f90
+++ b/gcc/testsuite/gfortran.dg/move_alloc_8.f90
@@ -60,7 +60,7 @@ subroutine test2 (x, px)
integer, allocatable :: a
type(t2), pointer :: ta
- call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" }
call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." }
call move_alloc (x%ptr%a, a) ! OK (3)
call move_alloc (px%a, a) ! OK (4)
@@ -84,7 +84,7 @@ subroutine test3 (x, px)
integer, allocatable :: a
class(t2), pointer :: ta
- call move_alloc (px, ta) ! { dg-error "cannot be INTENT.IN." }
+ call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" }
call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." }
call move_alloc (x%ptr%a, a) ! OK (6)
call move_alloc (px%a, a) ! OK (7)
diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_9.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_9.f90
new file mode 100644
index 00000000000..30ddd028359
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_intent_9.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! PR fortran/103418
+! Validate checks for dummy arguments with INTENT(IN), pointer attribute
+
+module m
+ type t
+ real, pointer :: a, b(:)
+ end type t
+contains
+ subroutine s1 (a, b, c, d, e)
+ real, pointer, intent(in) :: a, b(:)
+ type(t), intent(in) :: c
+ class(t), intent(in) :: d
+ type(t), pointer, intent(in) :: e
+ real, pointer :: pa, pb(:)
+ call random_number (a) ! legal
+ call random_number (b)
+ call cpu_time (a)
+ call system_clock (count_rate=a)
+ call random_number (c% a)
+ call random_number (c% b)
+ call random_number (d% a)
+ call random_number (d% b)
+ call random_number (e% a)
+ call random_number (e% b)
+ call move_alloc (a, pa) ! { dg-error "must be ALLOCATABLE" }
+ call move_alloc (b, pb) ! { dg-error "must be ALLOCATABLE" }
+ allocate (a) ! { dg-error "pointer association context" }
+ allocate (b(10)) ! { dg-error "pointer association context" }
+ allocate (c% a) ! { dg-error "pointer association context" }
+ allocate (c% b(10)) ! { dg-error "pointer association context" }
+ end subroutine s1
+end module
--
2.26.2
