Hi all, and here is already the follow-up. In the initial patch a safe wasn't commenced before pulling the patch, which lead to a refactoring of the new functions node to be partial only. Sorry for the noise.
- Andre Am Sun, 27 Mar 2016 18:49:18 +0200 schrieb Andre Vehreschild <ve...@gmx.de>: > Hi all, > > attached is a patch to fix an ICE on allocating an unlimited polymorphic > entity from a non-poly class or type without an length component. The routine > gfc_copy_class_to_class() assumed that both the source and destination > object's type is unlimited polymorphic, but in this case it is true for the > destination only, which made gfortran look for a non-existent _len component > in the source object and therefore ICE. This is fixed by the patch by adding > a function to return either the _len component, when it exists, or a constant > zero node to init the destination object's _len component with. > > Bootstrapped and regtested ok on x86_64-linux-gnu/F23. (Might have some > line deltas, because my git is a bit older. Sorry, only have limited/slow > net-access currently.) > > The same patch should be adaptable to trunk. To come... > > Ok for 5-trunk? > > Regards, > Andre -- Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen Email: ve...@gmx.de * Tel: +49 241 9291018
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1681d14..642ce26 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -173,6 +173,24 @@ gfc_class_len_get (tree decl) } +/* Try to get the _len component of a class. When the class is not unlimited + poly, i.e. no _len field exists, then return a zero node. */ + +tree +gfc_class_len_or_zero_get (tree decl) +{ + tree len; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), + CLASS_LEN_FIELD); + return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), decl, len, + NULL_TREE) + : integer_zero_node; +} + + /* Get the specified FIELD from the VPTR. */ static tree @@ -250,6 +268,7 @@ gfc_vptr_size_get (tree vptr) #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD +#undef CLASS_LEN_FIELD #undef VTABLE_HASH_FIELD #undef VTABLE_SIZE_FIELD #undef VTABLE_EXTENDS_FIELD @@ -1070,7 +1089,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) if (unlimited) { if (from_class_base != NULL_TREE) - from_len = gfc_class_len_get (from_class_base); + from_len = gfc_class_len_or_zero_get (from_class_base); else from_len = integer_zero_node; } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e6544f9..9a181be 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -356,6 +356,7 @@ tree gfc_class_set_static_fields (tree, tree, tree); tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); +tree gfc_class_len_or_zero_get (tree); gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 new file mode 100644 index 0000000..d0b2a2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Test contributed by Valery Weber <valerywe...@hotmail.com> + +module mod + + TYPE, PUBLIC :: base_type + END TYPE base_type + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(base_type), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + type(base_type) :: a, b + call dict_put(t, a, b) + + if (.NOT. allocated(t%key)) call abort() + select type (x => t%key) + type is (base_type) + class default + call abort() + end select + deallocate(t%key) +end + diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 new file mode 100644 index 0000000..1300069 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Test contributed by Valery Weber <valerywe...@hotmail.com> + +module mod + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + ALLOCATE( this%val, SOURCE=val, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + call dict_put(t, "foo", 42) + + if (.NOT. allocated(t%key)) call abort() + select type (x => t%key) + type is (CHARACTER(*)) + if (x /= "foo") call abort() + class default + call abort() + end select + deallocate(t%key) + + if (.NOT. allocated(t%val)) call abort() + select type (x => t%val) + type is (INTEGER) + if (x /= 42) call abort() + class default + call abort() + end select + deallocate(t%val) +end +