Fortran: fix variable definition context checks for SELECT TYPE [PR123253]

Commit r16-6300 introduced a regression when checking the variable
definition context of SELECT TYPE variables where the selector was not a
dummy argument as the scan for the association target was too shallow.
Scan through association lists for the ultimate selector.

	PR fortran/123253

gcc/fortran/ChangeLog:

	* expr.cc (gfc_check_vardef_context): Replace simple check by a
	scan through the association targets for a dummy argument.

gcc/testsuite/ChangeLog:

	* gfortran.dg/associate_76.f90: Extended testcase.
	* gfortran.dg/associate_77.f90: New test.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index d8d9009dc42618aa4f70c3a8845c1de66e4ea9e9..87587ee2010cb68e9cdd4e3b78a5596736b764a7 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6784,14 +6784,31 @@ 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->assoc && sym->assoc->target)
+    {
+      gfc_expr *target;
+      gfc_symbol *tsym;
+
+      check_intentin = false;
+
+      /* Walk through associate target chain to find a dummy argument.  */
+      for (target = sym->assoc->target; target; target = tsym->assoc->target)
+       {
+         tsym = target->symtree ? target->symtree->n.sym : NULL;
+
+         if (tsym == NULL)
+           break;
+
+         if (tsym->attr.dummy)
+           {
+             check_intentin = (tsym->attr.intent == INTENT_IN);
+             break;
+           }
+
+         if (tsym->assoc == NULL)
+           break;
+       }
+    }
 
   if (check_intentin
       && (sym->attr.intent == INTENT_IN

diff --git a/gcc/testsuite/gfortran.dg/associate_76.f90 b/gcc/testsuite/gfortran.dg/associate_76.f90
index d76c052703e85f5f4f73092838deb4e8a63e16d5..7f1023fd19f8dcf3f47b5db39919fece70050510 100644 (file)
--- a/gcc/testsuite/gfortran.dg/associate_76.f90
+++ b/gcc/testsuite/gfortran.dg/associate_76.f90
@@ -22,6 +22,14 @@ contains
        var%i = 3
        var%i => NULL()      ! { dg-error "pointer association context" }
     end select
+
+    associate (avar => var)
+      select type(avar)     ! { dg-error "variable definition context" }
+      class is(t_b)
+         avar%i = 3
+         avar%i => NULL()   ! { dg-error "variable definition context" }
+      end select
+    end associate
   end subroutine s1
 
   subroutine s1a(var)
@@ -31,8 +39,27 @@ contains
        tmp%i = 3
        tmp%i => NULL()      ! { dg-error "variable definition context" }
     end select
+
+    associate (avar => var)
+      select type(tmp => avar) ! { dg-error "variable definition context" }
+      class is(t_b)
+         tmp%i = 3
+         tmp%i => NULL()       ! { dg-error "variable definition context" }
+      end select
+    end associate
   end subroutine s1a
 
+  subroutine s1b(var)
+    class(t_a), intent(in) :: var
+    associate (avar => var)
+      select type(tmp => avar) ! { dg-error "variable definition context" }
+      class is(t_b)
+         tmp%i = 3
+         tmp%i => NULL()       ! { dg-error "variable definition context" }
+      end select
+    end associate
+  end subroutine s1b
+
   subroutine s2(var)
     class(t_b), intent(in) :: var
     var%i = 3
@@ -58,10 +85,19 @@ contains
   subroutine s3(var)
     class(t_a), intent(in) :: var
     integer, pointer :: tmp
-    select type(var); class is(t_b)
+    select type(var)
+    class is(t_b)
        tmp => var%i
        tmp =  3
     end select
+
+    associate (avar => var)
+      select type(avar)
+      class is(t_b)
+         tmp => avar%i
+         tmp =  3
+      end select
+    end associate
   end subroutine s3
 
 end module m

diff --git a/gcc/testsuite/gfortran.dg/associate_77.f90 b/gcc/testsuite/gfortran.dg/associate_77.f90
new file mode 100644 (file)
index 0000000..6e80595
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_77.f90
@@ -0,0 +1,65 @@
+! { dg-do compile }
+! PR fortran/123253 - pointer assignment checks in SELECT TYPE
+!
+! Contributed by Jürgen Reuter
+
+module vamp
+  implicit none
+  private
+  type, public :: vamp_data_t
+  end type vamp_data_t
+end module vamp
+
+module mci_vamp
+  use vamp !NODEP!
+  implicit none
+  private
+
+  type, abstract :: mci_sampler_t
+  end type mci_sampler_t
+
+  type :: mci_vamp_t
+   contains
+     procedure :: generate_weighted_event => mci_vamp_generate_weighted_event
+  end type mci_vamp_t
+
+  type, extends (vamp_data_t) :: mci_workspace_t
+     class(mci_sampler_t), pointer :: sampler => null ()
+     class(mci_vamp_instance_t), pointer :: instance => null ()
+  end type mci_workspace_t
+
+  type :: mci_vamp_instance_t
+     type(mci_vamp_t), pointer :: mci => null ()
+  end type mci_vamp_instance_t
+
+contains
+
+  subroutine mci_vamp_generate_weighted_event (mci, instance, sampler)
+    class(mci_vamp_t), intent(inout) :: mci
+    class(mci_vamp_instance_t), intent(inout), target :: instance
+    class(mci_sampler_t), intent(inout), target :: sampler
+    class(vamp_data_t), allocatable :: data
+
+    select type (instance)
+    type is (mci_vamp_instance_t)
+       allocate (mci_workspace_t :: data)
+       select type (data)
+       type is (mci_workspace_t)
+          data%sampler => sampler
+          data%instance => instance
+       end select
+    end select
+
+    select type (foo_instance => instance)
+    type is (mci_vamp_instance_t)
+       allocate (mci_workspace_t :: data)
+       select type (tmp => data)
+       type is (mci_workspace_t)
+          tmp%sampler => sampler
+          tmp%instance => foo_instance
+       end select
+    end select
+
+  end subroutine mci_vamp_generate_weighted_event
+
+end module mci_vamp