From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 9 Dec 2021 21:57:13 +0000 (+0100)
Subject: Fortran: fix check for pointer dummy arguments with INTENT(IN)
X-Git-Tag: basepoints/gcc-13~2413
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=bb6a1ebb8585b85879735d0d6df9535885fad165;p=thirdparty%2Fgcc.git

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.
---

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ee3a51ee253b..3934336df2e8 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 87089321a3b7..b874607db1d2 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 f624b703cc95..d968ea0e5cd0 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 000000000000..30ddd0283597
--- /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