https://gcc.gnu.org/g:d1710c420a0fcea40c983eff2427fe72072099da
commit r14-11109-gd1710c420a0fcea40c983eff2427fe72072099da
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Thu Dec 12 17:50:56 2024 +0000
Fortran: Fix testsuite regressions after r15-5083 [PR117797]
2024-12-12 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/117797
* trans-array.cc (class_array_element_size): New function.
(gfc_get_array_span): Refactor, using class_array_element_size
to return the span for descriptors that are the _data component
of a class expression and then class dummy references. Revert
the conditions to those before r15-5083 tidying up using 'sym'.
gcc/testsuite/
PR fortran/117797
* gfortran.dg/pr117797.f90: New test.
(cherry picked from commit d4330ff9bc9a2995e79d88b09a2ee76673167661)
Diff:
---
gcc/fortran/trans-array.cc | 61 +++++++++++++++-------------------
gcc/testsuite/gfortran.dg/pr117797.f90 | 55 ++++++++++++++++++++++++++++++
2 files changed, 81 insertions(+), 35 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index fe69b694e0da..d9aaa9bceae4 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 000000000000..25c0c04e6c3d
--- /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
