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 ee3a51e..3934336 100644 (file)
--- 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 8708932..b874607 100644 (file)
--- 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 f624b70..d968ea0 100644 (file)
--- 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 (file)
index 0000000..30ddd02
--- /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