procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix testsuite regressions after r15-5083 [PR117797]

Browse source 
2024-12-12  Paul Thomas  <pault@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.
This commit is contained in:
Paul Thomas 2024-12-12 17:50:56 +00:00
parent b563a3a00d
commit d4330ff9bc
2 changed files with 81 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
gcc/fortran/trans-array.cc
View file

@ -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

55
gcc/testsuite/gfortran.dg/pr117797.f90 Normal file
View file

@ -0,0 +1,55 @@
! { dg-do run }
!
! Test the fix for the regression caused by r15-5083.
!
! Contributed by Neil Carlson <neil.n.carlson@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