[gcc r10-10364] Fortran: fix check for pointer dummy arguments with INTENT(IN)

[gcc r10-10364] Fortran: fix check for pointer dummy arguments with INTENT(IN)

[Harald Anlauf]

https://gcc.gnu.org/g:f8486c9fd71c08f30273e1a98b86e35a679ca229

commit r10-10364-gf8486c9fd71c08f30273e1a98b86e35a679ca229
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Thu Dec 9 22:57:13 2021 +0100

    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.
    
    (cherry picked from commit bb6a1ebb8585b85879735d0d6df9535885fad165)

Diff:
---
 gcc/fortran/check.c                            | 32 +++++--------------------
 gcc/fortran/expr.c                             |  9 ++++---
 gcc/testsuite/gfortran.dg/move_alloc_8.f90     |  4 ++--
 gcc/testsuite/gfortran.dg/pointer_intent_9.f90 | 33 ++++++++++++++++++++++++++
 4 files changed, 47 insertions(+), 31 deletions(-)

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index eab12e93887..392786ac48e 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 9f5e84cbb1c..95b35153941 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -6229,10 +6229,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;
 	}
     }
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