Hi Paul,
thanks for the quick review. Committed to gcc-5-branch as r234507. The
patch for trunk needs more polishing than expected. I hope to present
it soon.
Regards,
Andre
On Sun, 27 Mar 2016 19:19:11 +0200
Paul Richard Thomas <paul.richard.tho...@gmail.com> wrote:
> Hi Andre,
>
> The patch looks to be fine to me for both trunk and 5-branch.
>
> Thanks for the patch.
>
> Paul
>
> On 27 March 2016 at 18:53, Andre Vehreschild <ve...@gmx.de> wrote:
> > 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 * Email: vehre ad gmx dot de
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 234506)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,12 @@
+2016-03-28 Andre Vehreschild <ve...@gcc.gnu.org>
+
+ PR fortran/70397
+ * trans-expr.c (gfc_class_len_or_zero_get): Add function to return a
+ constant zero tree, when the class to get the _len component from is
+ not unlimited polymorphic.
+ (gfc_copy_class_to_class): Use the new function.
+ * trans.h: Added interface of new function gfc_class_len_or_zero_get.
+
2016-03-28 Alessandro Fanfarillo <fanfarillo....@gmail.com>
Backport from trunk.
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 234506)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -173,6 +173,24 @@
}
+/* 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 @@
#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 @@
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;
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 234506)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -356,6 +356,7 @@
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. */
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 234506)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,9 @@
+2016-03-28 Andre Vehreschild <ve...@gcc.gnu.org>
+
+ PR fortran/70397
+ * gfortran.dg/unlimited_polymorphic_25.f90: New test.
+ * gfortran.dg/unlimited_polymorphic_26.f90: New test.
+
2016-03-28 Kirill Yukhin <kirill.yuk...@intel.com>
PR target/70406
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 (nicht existent)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 (Arbeitskopie)
@@ -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
+
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 (nicht existent)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 (Arbeitskopie)
@@ -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
+
