mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: Fix elemental array refs in SELECT TYPE [PR109345]

Browse Source 
2024-11-10  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/109345
	* trans-array.cc (gfc_get_array_span): Unlimited polymorphic
	expressions are now treated separately since the span need not
	be the same as the element size.

gcc/testsuite/
	PR fortran/109345
	* gfortran.dg/character_workout_1.f90: Cut trailing whitespace.
	* gfortran.dg/pr109345.f90: New test.
This commit is contained in:
Paul Thomas 2024-11-11 12:21:57 +00:00
parent da64698159
commit e22d80d4f0
3 changed files with 113 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gcc/fortran/trans-array.cc
View File

@ -962,6 +962,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
? expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@ -983,25 +985,43 @@ 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 their 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 and so use the vtable
size for the receiving span field. */
tmp = gfc_get_vptr_from_expr (desc);
/* 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_class_vptr_get (TREE_OPERAND (desc, 0));
tmp = gfc_vptr_size_get (tmp);
}
else if (expr && expr->expr_type == EXPR_VARIABLE
&& expr->symtree->n.sym->ts.type == BT_CLASS
&& expr->ref->type == REF_COMPONENT
&& expr->ref->next->type == REF_ARRAY
&& expr->ref->next->next == NULL
&& CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
{
/* Dummys come in sometimes with the descriptor detached from
the class field or declaration. */
tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
/* Class dummys usually requires 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);
}
else

8
gcc/testsuite/gfortran.dg/character_workout_1.f90
View File

@ -1,7 +1,7 @@
! { dg-do run }
!
! Tests fix for PR100120/100816/100818/100819/100821
!
!
program main_p
@ -27,10 +27,10 @@ program main_p
character(len=m, kind=k), pointer :: pm(:)
character(len=e, kind=k), pointer :: pe(:)
character(len=:, kind=k), pointer :: pd(:)
class(*), pointer :: su
class(*), pointer :: pu(:)
integer :: i, j
nullify(s1, sm, se, sd, su)
@ -41,7 +41,7 @@ program main_p
cm(i)(j:j) = char(i*m+j+c-m, kind=k)
end do
end do
s1 => c1(n)
if(.not.associated(s1)) stop 1
if(.not.associated(s1, c1(n))) stop 2

77
gcc/testsuite/gfortran.dg/pr109345.f90 Normal file
View File

@ -0,0 +1,77 @@
! { dg-do run }
!
! Test the fix for PR109345 in which array references in the SELECT TYPE
! block below failed because the descriptor span was not set correctly.
!
! Contributed by Lauren Chilutti <lchilutti@gmail.com>
!
program test
implicit none
type :: t
character(len=12, kind=4) :: str_array(4)
integer :: i
end type
character(len=12, kind=1), target :: str_array(4)
character(len=12, kind=4), target :: str_array4(4)
type(t) :: str_t (4)
integer :: i
str_array(:) = ""
str_array(1) = "12345678"
str_array(2) = "@ABCDEFG"
! Original failing test
call foo (str_array)
str_array4(:) = ""
str_array4(1) = "12345678"
str_array4(2) = "@ABCDEFG"
str_t = [(t(str_array4, i), i = 1, 4)]
! Test character(kind=4)
call foo (str_t(2)%str_array)
! Test component references
call foo (str_t%str_array(1), .true.)
! Test component references and that array offset is correct.
call foo (str_t(2:3)%i)
contains
subroutine foo (var, flag)
class(*), intent(in) :: var(:)
integer(kind=4) :: i
logical, optional :: flag
select type (var)
type is (character(len=*, kind=1))
if (len (var) /= 12) stop 1
! Scalarised array references worked.
if (any (var /= str_array)) stop 2
do i = 1, size(var)
! Elemental array references did not work.
if (trim (var(i)) /= trim (str_array(i))) stop 3
enddo
type is (character(len=*, kind=4))
if (len (var) /= 12) stop 4
! Scalarised array references worked.
if (any (var /= var(1))) then
if (any (var /= str_array4)) stop 5
else
if (any (var /= str_array4(1))) stop 6
end if
do i = 1, size(var)
! Elemental array references did not work.
if (var(i) /= var(1)) then
if (present (flag)) stop 7
if (trim (var(i)) /= trim (str_array4(i))) stop 8
else
if (trim (var(i)) /= trim (str_array4(1))) stop 9
end if
enddo
type is (integer(kind=4))
if (any(var /= [2,3])) stop 10
do i = 1, size (var)
if (var(i) /= i+1) stop 11
end do
end select
end
end