diff mbox series

[v2] PR fortran/103418 - random_number() does not accept pointer, intent(in) array argument

Message ID bfc2e0ce-de7a-108a-e457-3791ad53f179@gmx.de
State New
Headers show
Series [v2] PR fortran/103418 - random_number() does not accept pointer, intent(in) array argument | expand

Commit Message

Harald Anlauf Dec. 9, 2021, 10:05 p.m. UTC
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

Comments

Mikael Morin Dec. 10, 2021, 12:28 p.m. UTC | #1
On 09/12/2021 23:05, Harald Anlauf wrote:
> 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.
> 
Reading gfc_check_vardef_context, I have undersood what the existing 
code was doing, and why.  It was not that dubious after all.  Still, I 
prefer the v2 much.

> See attached for an updated patch and the extended testcase.
> 
> Regtested again.  OK now?
> 
Yes, thanks.
diff mbox series

Patch

From dec60c90d47211d55048e7034e95f3e6fb10a2d4 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@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