Hi All, This was yet another regression that I caused, which was backported and so I am rather anxious to fix it promptly.
The modifications that I made to gfc_get_array_span caused unlimited polymorphic array components to be missed, when contained in a dummy. Instead, the dummy was taken to be the class container, which then caused the segfault I took the opportunity to refactor gfc_get_array_span such that it is now improved over its original form. Class data descriptors now cannot be missed for any declared type. The new helper function 'class_array_element_size' extracts the vptr from both the class object and from class dummies. The vptr size is then returned, except in the case of unlimited polymorphic expressions, where the vptr size must be corrected with the _len value. The class container is unambiguously obtainable from the vptr. Regression tests - OK for mainline and then, after a short while, backported to the affected branches? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9a8477650f4..82a2ae1f747 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -955,6 +955,26 @@ get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
}
+/* A helper function for gfc_get_array_span that returns the array element size
+ of a class entity. */
+static tree
+class_array_element_size (tree decl, bool unlimited)
+{
+ /* Class dummys usually require extraction from the saved descriptor,
+ which gfc_class_vptr_get does for us if necessary. This, of course,
+ will be a component of the class object. */
+ tree vptr = gfc_class_vptr_get (decl);
+ /* If this is an unlimited polymorphic entity with a character payload,
+ the element size will be corrected for the string length. */
+ if (unlimited)
+ return gfc_resize_class_size_with_len (NULL,
+ TREE_OPERAND (vptr, 0),
+ gfc_vptr_size_get (vptr));
+ else
+ return gfc_vptr_size_get (vptr);
+}
+
+
/* Return the span of an array. */
tree
@@ -984,49 +1004,20 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
desc = build_fold_indirect_ref_loc (input_location, desc);
tmp = gfc_conv_descriptor_span_get (desc);
}
- else if (UNLIMITED_POLY (expr)
- || (sym && UNLIMITED_POLY (sym)))
- {
- /* Treat unlimited polymorphic expressions separately because
- the element size need not be the same as the span. Obtain
- the class container, which is simplified here by there being
- no component references. */
- if (sym && sym->attr.dummy)
- {
- tmp = gfc_get_symbol_decl (sym);
- tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
- if (INDIRECT_REF_P (tmp))
- tmp = TREE_OPERAND (tmp, 0);
- }
- else
- {
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
- tmp = TREE_OPERAND (desc, 0);
- }
- tmp = gfc_class_data_get (tmp);
- tmp = gfc_conv_descriptor_span_get (tmp);
- }
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
- {
- /* The descriptor is a class _data field. Use the vtable size
- since it is guaranteed to have been set and is always OK for
- class array descriptors that are not unlimited. */
- tmp = gfc_get_vptr_from_expr (desc);
- tmp = gfc_vptr_size_get (tmp);
- }
+ /* The descriptor is the _data field of a class object. */
+ tmp = class_array_element_size (TREE_OPERAND (desc, 0),
+ UNLIMITED_POLY (expr));
else if (sym && sym->ts.type == BT_CLASS
&& expr->ref->type == REF_COMPONENT
&& expr->ref->next->type == REF_ARRAY
&& expr->ref->next->next == NULL
&& CLASS_DATA (sym)->attr.dimension)
- {
- /* Class dummys usually require extraction from the saved
- descriptor, which gfc_class_vptr_get does for us. */
- tmp = gfc_class_vptr_get (sym->backend_decl);
- tmp = gfc_vptr_size_get (tmp);
- }
+ /* Having escaped the above, this can only be a class array dummy. */
+ tmp = class_array_element_size (sym->backend_decl,
+ UNLIMITED_POLY (sym));
else
{
/* If none of the fancy stuff works, the span is the element
diff --git a/gcc/testsuite/gfortran.dg/pr117797.f90 b/gcc/testsuite/gfortran.dg/pr117797.f90
new file mode 100644
index 00000000000..25c0c04e6c3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117797.f90
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! Test the fix for the regression caused by r15-5083.
+!
+! Contributed by Neil Carlson <neil.n.carl...@gmail.com>
+!
+module foo
+
+ type, public :: any_matrix
+ private
+ class(*), allocatable :: value(:,:)
+ end type
+
+contains
+
+ function bar(this) result(uptr)
+ class(any_matrix), target, intent(in) :: this
+ class(*), pointer :: uptr(:,:)
+ uptr => this%value ! Seg. fault in trans-array.cc(gfc_get_array_span) here
+ end function
+
+ function build(this) result (res)
+ class(*) :: this(:,:)
+ type(any_matrix) :: res
+ res%value = this
+ end function
+
+ function evaluate (this) result (res)
+ class(*) :: this(:,:)
+ character(len = 2, kind = 1), allocatable :: res(:)
+ select type (ans => this)
+ type is (character(*))
+ res = reshape (ans, [4])
+ type is (integer)
+ allocate (res (8))
+ write (res, '(i2)') ans
+ class default
+ res = ['no','t ','OK','!!']
+ end select
+ end
+
+end module
+
+ use foo
+ class(*), allocatable :: up (:, :)
+ character(len = 2, kind = 1) :: chr(2,2) = reshape (['ab','cd','ef','gh'], [2,2])
+ integer :: i(2,2) = reshape ([1,2,3,4], [2,2])
+ up = bar (build (chr))
+ if (any (evaluate (up) /= reshape (chr, [4]))) stop 1
+
+ up = bar (build (i))
+ if (any (evaluate (up) /= [' 1',' 2',' 3',' 4'])) stop 2
+
+ deallocate (up)
+end
