Fortran: INTENT(IN) polymorphic argument with pointer components [PR71565]

	PR fortran/71565

gcc/fortran/ChangeLog:

	* expr.cc (gfc_check_vardef_context): Fix treatment of INTENT(IN)
	checks for ASSOCIATE variables.  Correct checking of PROTECTED
	objects, as subobjects inherit the PROTECTED attribute.

gcc/testsuite/ChangeLog:

	* gfortran.dg/protected_8.f90: Adjust patterns.
	* gfortran.dg/associate_76.f90: New test.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 054276e86b1f5959f35a3a7538e0b273d4850f7e..d8d9009dc42618aa4f70c3a8845c1de66e4ea9e9 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6757,7 +6757,10 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
                  ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
   for (ref = e->ref; ref && check_intentin; ref = ref->next)
     {
-      if (ptr_component && ref->type == REF_COMPONENT)
+      /* Associate-targets need special handling.  Subobjects of an object with
+        the PROTECTED attribute inherit this attribute.  */
+      if (ptr_component && ref->type == REF_COMPONENT
+         && !sym->assoc && !sym->attr.is_protected)
        check_intentin = false;
       if (ref->type == REF_COMPONENT)
        {
@@ -6780,24 +6783,34 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
        }
     }
 
+  /* See if the INTENT(IN) check should apply to an ASSOCIATE target.  */
+  if (check_intentin
+      && sym->assoc
+      && sym->assoc->target
+      && sym->assoc->target->symtree
+      && sym->assoc->target->symtree->n.sym
+      && sym->assoc->target->symtree->n.sym->attr.dummy
+      && sym->assoc->target->symtree->n.sym->attr.intent != INTENT_IN)
+    check_intentin = false;
+
   if (check_intentin
       && (sym->attr.intent == INTENT_IN
          || (sym->attr.select_type_temporary && sym->assoc
              && sym->assoc->target && sym->assoc->target->symtree
              && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
     {
+      const char *name = (sym->attr.select_type_temporary
+                         ? sym->assoc->target->symtree->name : sym->name);
       if (pointer && is_pointer)
        {
          if (context)
            gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
                       " association context (%s) at %L",
-                      sym->name, context, &e->where);
+                      name, context, &e->where);
          return false;
        }
       if (!pointer && !is_pointer && !sym->attr.pointer)
        {
-         const char *name = sym->attr.select_type_temporary
-                          ? sym->assoc->target->symtree->name : sym->name;
          if (context)
            gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
                       " definition context (%s) at %L",
@@ -6810,7 +6823,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
   if (sym->attr.is_protected
       && (sym->attr.use_assoc
          || (sym->attr.used_in_submodule && !sym_is_from_ancestor (sym)))
-      && check_intentin)
+      && !own_scope
+      && (check_intentin || !pointer))
     {
       if (pointer && is_pointer)
        {
@@ -6863,7 +6877,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
        }
     }
   /* Check variable definition context for associate-names.  */
-  if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
+  if ((!pointer || check_intentin)
+      && sym->assoc && !sym->attr.select_rank_temporary)
     {
       const char* name;
       gfc_association_list* assoc;
@@ -6927,8 +6942,10 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
            }
        }
 
-      /* Target must be allowed to appear in a variable definition context.  */
-      if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
+      /* Target must be allowed to appear in a variable definition context.
+        Check valid assignment to pointers and invalid reassociations.  */
+      if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)
+         && (!ptr_component || pointer))
        {
          if (context)
            gfc_error ("Associate-name %qs cannot appear in a variable"

diff --git a/gcc/testsuite/gfortran.dg/associate_76.f90 b/gcc/testsuite/gfortran.dg/associate_76.f90
new file mode 100644 (file)
index 0000000..d76c052
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_76.f90
@@ -0,0 +1,67 @@
+! { dg-do compile }
+! PR fortran/71565 - INTENT(IN) polymorphic argument with pointer components
+!
+! Contributed by Marco Restelli.
+
+module m
+  implicit none
+
+  type, abstract :: t_a
+  end type t_a
+
+  type, extends(t_a), abstract :: t_b
+     integer, pointer :: i => null()
+  end type t_b
+
+contains
+
+  subroutine s1(var)
+    class(t_a), intent(in) :: var
+    select type(var)
+    class is(t_b)
+       var%i = 3
+       var%i => NULL()      ! { dg-error "pointer association context" }
+    end select
+  end subroutine s1
+
+  subroutine s1a(var)
+    class(t_a), intent(in) :: var
+    select type(tmp => var) ! { dg-error "variable definition context" }
+    class is(t_b)
+       tmp%i = 3
+       tmp%i => NULL()      ! { dg-error "variable definition context" }
+    end select
+  end subroutine s1a
+
+  subroutine s2(var)
+    class(t_b), intent(in) :: var
+    var%i = 3
+    var%i => NULL()        ! { dg-error "pointer association context" }
+  end subroutine s2
+
+  subroutine s2a(var)
+    class(t_b), intent(in) :: var
+    associate (tmp => var) ! { dg-error "variable definition context" }
+      print *, associated (tmp%i)
+      tmp%i = 3
+      tmp%i => NULL()      ! { dg-error "variable definition context" }
+    end associate
+  end subroutine s2a
+
+  subroutine s2b(var)
+    class(t_b), intent(in) :: var
+    associate (tmp => var%i)
+      tmp = 3
+    end associate
+  end subroutine s2b
+
+  subroutine s3(var)
+    class(t_a), intent(in) :: var
+    integer, pointer :: tmp
+    select type(var); class is(t_b)
+       tmp => var%i
+       tmp =  3
+    end select
+  end subroutine s3
+
+end module m

diff --git a/gcc/testsuite/gfortran.dg/protected_8.f90 b/gcc/testsuite/gfortran.dg/protected_8.f90
index 7e02044720de6f51415061ad3beafae7153cb46b..dfd0625bd408f5c2cc66b3a1302cfd217cd007d8 100644 (file)
--- a/gcc/testsuite/gfortran.dg/protected_8.f90
+++ b/gcc/testsuite/gfortran.dg/protected_8.f90
@@ -41,8 +41,8 @@ PROGRAM test
    a%j => k ! { dg-error "is PROTECTED" }
    a%j = 5  ! OK 2
    b => c   ! { dg-error "is PROTECTED" }
-   b%i = k  ! OK 3
-   b%j => k ! OK 4
-   b%j = 5  ! OK 5
+   b%i = k  ! { dg-error "is PROTECTED" }
+   b%j => k ! { dg-error "is PROTECTED" }
+   b%j = 5  ! OK 3
 
 END PROGRAM test