From ebd63afa68237d05f4f5dfeb847d341a76239b68 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 17 Mar 2015 05:20:08 +0000 Subject: [PATCH] re PR fortran/59198 (ICE on cyclically dependent polymorphic types) 2014-03-17 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-17 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: r221474 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/trans-types.c | 19 ++++- gcc/testsuite/ChangeLog | 6 ++ .../gfortran.dg/proc_ptr_comp_44.f90 | 71 +++++++++++++++++++ .../gfortran.dg/proc_ptr_comp_45.f90 | 49 +++++++++++++ 5 files changed, 152 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 b638835c9be..21a3b35e9a8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2014-03-17 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. + 2015-03-16 Jerry DeLisle PR fortran/64432 diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 53da053fc4d..708289f064f 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2448,9 +2448,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 3e6beb2c7e2..12324f0e494 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2014-03-17 Paul Thomas + + PR fortran/59198 + * gfortran.dg/proc_ptr_comp_44.f90 : New test + * gfortran.dg/proc_ptr_comp_45.f90 : New test + 2015-03-16 Jerry DeLisle PR fortran/64432 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 00000000000..15795c2d0fa --- /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 00000000000..8f8a8fee241 --- /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 (template%obs1_int (arg) .ne. cos (arg)) call abort + allocate (object, source = template) + if (object%obs1_int (arg) .ne. cos (arg)) call abort +end -- 2.30.2