From d4330ff9bc9a2995e79d88b09a2ee76673167661 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 12 Dec 2024 17:50:56 +0000 Subject: [PATCH] Fortran: Fix testsuite regressions after r15-5083 [PR117797] 2024-12-12 Paul Thomas 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. --- gcc/fortran/trans-array.cc | 61 +++++++++++--------------- gcc/testsuite/gfortran.dg/pr117797.f90 | 55 +++++++++++++++++++++++ 2 files changed, 81 insertions(+), 35 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr117797.f90 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 +! +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