This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran, pr70397, gcc-5, v1] [5/6 Regression] ice while allocating ultimate polymorphic


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 * vehre at gcc dot gnu.org

Attachment: pr70391_1.clog
Description: Binary data

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..38cffa4 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_get_try (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  <valeryweber@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  <valeryweber@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
+

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]