From: Tobias Burnus <burnus@net-b.de>
Date: Wed, 17 Oct 2018 19:58:58 +0000 (+0200)
Subject: Fix select-type regression
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=91f9b2e0f7054c64e56053993de41b14c5e02226;p=gcc.git

Fix select-type regression

        PR fortran/87632
        * resolve.c (resolve_select_type): Use correct variable.

        PR fortran/87632
        * gfortran.dg/select_type_47.f90: New.

From-SVN: r265248
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 962f7fb6028..4f216d94cae 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2018-10-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/87632
+	* resolve.c (resolve_select_type): Use correct variable.
+
 2018-10-17  David Malcolm  <dmalcolm@redhat.com>
 
 	* Make-lang.in (selftest-fortran): New.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7c0381698cb..7ec9e969c71 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8914,7 +8914,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       if (ref2)
 	{
 	  if (code->expr1->symtree->n.sym->attr.untyped)
-	    code->expr1->symtree->n.sym->ts = ref->u.c.component->ts;
+	    code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
 	  selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
 	}
       else
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1e622066da5..9cb109ef034 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-10-17  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/87632
+	* gfortran.dg/select_type_47.f90: New.
+
 2018-10-17  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc.c-torture/execute/pr87623.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/select_type_47.f90 b/gcc/testsuite/gfortran.dg/select_type_47.f90
new file mode 100644
index 00000000000..c7a750e35ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_47.f90
@@ -0,0 +1,59 @@
+! { dg-do compile }
+!
+! PR fortran/87632
+!
+! Contributed by Jürgen Reuter
+!
+module m
+type t
+  integer :: i
+end type t
+type t2
+  type(t) :: phs_config
+end type t2
+end module m
+
+module m2
+use m
+implicit none
+type t3
+end type t3
+
+type process_t
+  private
+  type(t2), allocatable :: component(:)
+contains
+  procedure :: get_phs_config => process_get_phs_config
+end type process_t
+
+contains
+  subroutine process_extract_resonance_history_set &
+       (process, include_trivial, i_component)
+    class(process_t), intent(in), target :: process
+    logical, intent(in), optional :: include_trivial
+    integer, intent(in), optional :: i_component
+    integer :: i
+    i = 1;  if (present (i_component))  i = i_component
+    select type (phs_config => process%get_phs_config (i))
+    class is (t)
+       call foo()
+    class default
+       call bar()
+    end select
+  end subroutine process_extract_resonance_history_set
+
+  function process_get_phs_config (process, i_component) result (phs_config)
+    class(t), pointer :: phs_config
+    class(process_t), intent(in), target :: process
+    integer, intent(in) :: i_component
+    if (allocated (process%component)) then
+       phs_config => process%component(i_component)%phs_config
+    else
+       phs_config => null ()
+    end if
+  end function process_get_phs_config
+end module m2
+
+program main
+  use m2
+end program main