From 91f9b2e0f7054c64e56053993de41b14c5e02226 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 17 Oct 2018 21:58:58 +0200 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 5 ++ gcc/fortran/resolve.c | 2 +- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/select_type_47.f90 | 59 ++++++++++++++++++++ 4 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_47.f90 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 + + PR fortran/87632 + * resolve.c (resolve_select_type): Use correct variable. + 2018-10-17 David Malcolm * 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 + + PR fortran/87632 + * gfortran.dg/select_type_47.f90: New. + 2018-10-17 Eric Botcazou * 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 -- 2.30.2