From b4db79e9f573c4784c9017dbb486e88edc803236 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 19 Mar 2015 20:12:29 +0000 Subject: [PATCH] re PR fortran/59198 (ICE on cyclically dependent polymorphic types) 2014-03-19 Paul Thomas PR fortran/59198 * trans-types.c (gfc_get_derived_type): If an abstract derived type with procedure pointer components has no other type of component, return the backend_decl. Otherwise build the components if any of the non-procedure pointer components have no backend_decl. 2014-03-19 Paul Thomas PR fortran/59198 * gfortran.dg/proc_ptr_comp_44.f90 : New test * gfortran.dg/proc_ptr_comp_45.f90 : New test From-SVN: r221523 --- gcc/fortran/ChangeLog | 10 +++ gcc/fortran/trans-types.c | 19 ++++- gcc/testsuite/ChangeLog | 7 ++ .../gfortran.dg/proc_ptr_comp_44.f90 | 71 +++++++++++++++++++ .../gfortran.dg/proc_ptr_comp_45.f90 | 49 +++++++++++++ 5 files changed, 154 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_44.f90 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_45.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 51e5b8ccaf26..f762bb93cacf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2014-03-19 Paul Thomas + + Backport from mainline + PR fortran/59198 + * trans-types.c (gfc_get_derived_type): If an abstract derived + type with procedure pointer components has no other type of + component, return the backend_decl. Otherwise build the + components if any of the non-procedure pointer components have + no backend_decl. + 2015-03-12 Mikael Morin PR fortran/60898 diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 22f456e02838..20069e239ccc 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2415,9 +2415,24 @@ gfc_get_derived_type (gfc_symbol * derived) /* Its components' backend_decl have been built or we are seeing recursion through the formal arglist of a procedure pointer component. */ - if (TYPE_FIELDS (derived->backend_decl) - || derived->attr.proc_pointer_comp) + if (TYPE_FIELDS (derived->backend_decl)) return derived->backend_decl; + else if (derived->attr.abstract + && derived->attr.proc_pointer_comp) + { + /* If an abstract derived type with procedure pointer + components has no other type of component, return the + backend_decl. Otherwise build the components if any of the + non-procedure pointer components have no backend_decl. */ + for (c = derived->components; c; c = c->next) + { + if (!c->attr.proc_pointer && c->backend_decl == NULL) + break; + else if (c->next == NULL) + return derived->backend_decl; + } + typenode = derived->backend_decl; + } else typenode = derived->backend_decl; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7f79d7dc4b3a..31de6375b9c9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2014-03-19 Paul Thomas + + Backport from mainline + PR fortran/59198 + * gfortran.dg/proc_ptr_comp_44.f90 : New test + * gfortran.dg/proc_ptr_comp_45.f90 : New test + 2015-03-19 Kyrylo Tkachov Backport from mainline diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_44.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_44.f90 new file mode 100644 index 000000000000..15795c2d0faa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_44.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! Test the fix for PR59198, where the field for the component 'term' in +! the derived type 'decay_gen_t' was not being built. +! +! Contributed by Juergen Reuter +! +module decays + abstract interface + function obs_unary_int () + end function obs_unary_int + end interface + + type, abstract :: any_config_t + contains + procedure (any_config_final), deferred :: final + end type any_config_t + + type :: decay_term_t + type(unstable_t), dimension(:), pointer :: unstable_product => null () + end type decay_term_t + + type, abstract :: decay_gen_t + type(decay_term_t), dimension(:), allocatable :: term + procedure(obs_unary_int), nopass, pointer :: obs1_int => null () + end type decay_gen_t + + type, extends (decay_gen_t) :: decay_root_t + contains + procedure :: final => decay_root_final + end type decay_root_t + + type, abstract :: rng_t + end type rng_t + + type, extends (decay_gen_t) :: decay_t + class(rng_t), allocatable :: rng + contains + procedure :: final => decay_final + end type decay_t + + type, extends (any_config_t) :: unstable_config_t + contains + procedure :: final => unstable_config_final + end type unstable_config_t + + type :: unstable_t + type(unstable_config_t), pointer :: config => null () + type(decay_t), dimension(:), allocatable :: decay + end type unstable_t + + interface + subroutine any_config_final (object) + import + class(any_config_t), intent(inout) :: object + end subroutine any_config_final + end interface + +contains + subroutine decay_root_final (object) + class(decay_root_t), intent(inout) :: object + end subroutine decay_root_final + + recursive subroutine decay_final (object) + class(decay_t), intent(inout) :: object + end subroutine decay_final + + recursive subroutine unstable_config_final (object) + class(unstable_config_t), intent(inout) :: object + end subroutine unstable_config_final + +end module decays diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_45.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_45.f90 new file mode 100644 index 000000000000..31803453c541 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_45.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Test the fix for PR59198, where the field for the component 'term' in +! the derived type 'decay_gen_t' was not being built. +! +! Contributed by Paul Thomas and based on the original testcase by +! Juergen Reuter +! +module decays + + implicit none + + interface + real elemental function iface (arg) + real, intent(in) :: arg + end function + end interface + + type :: decay_term_t + type(decay_t), pointer :: unstable_product + integer :: i + end type + + type :: decay_gen_t + procedure(iface), nopass, pointer :: obs1_int + type(decay_term_t), allocatable :: term + end type + + type :: rng_t + integer :: i + end type + + type, extends (decay_gen_t) :: decay_t + class(rng_t), allocatable :: rng + end type + + class(decay_t), allocatable :: object + +end + + use decays + type(decay_t), pointer :: template + real, parameter :: arg = 1.570796327 + allocate (template) + allocate (template%rng) + template%obs1_int => cos + if (abs (template%obs1_int (arg) - cos (arg)) .gt. 1e-4) call abort + allocate (object, source = template) + if (abs (object%obs1_int (arg) - cos (arg)) .gt. 1e-4) call abort +end -- 2.47.2