https://gcc.gnu.org/g:e22d80d4f0f8d33f538c1a4bad07b2c819a6d55c
commit r15-5083-ge22d80d4f0f8d33f538c1a4bad07b2c819a6d55c
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Mon Nov 11 12:21:57 2024 +0000
Fortran: Fix elemental array refs in SELECT TYPE [PR109345]
2024-11-10 Paul Thomas <pa...@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.
Diff:
---
gcc/fortran/trans-array.cc | 44 +++++++++----
gcc/testsuite/gfortran.dg/character_workout_1.f90 | 8 +--
gcc/testsuite/gfortran.dg/pr109345.f90 | 77 +++++++++++++++++++++++
3 files changed, 113 insertions(+), 16 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a52bde90bd2c..e888b737bec3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/character_workout_1.f90
b/gcc/testsuite/gfortran.dg/character_workout_1.f90
index 98133b48960a..8f8bdbf00690 100644
--- a/gcc/testsuite/gfortran.dg/character_workout_1.f90
+++ b/gcc/testsuite/gfortran.dg/character_workout_1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/pr109345.f90
b/gcc/testsuite/gfortran.dg/pr109345.f90
new file mode 100644
index 000000000000..cff9aaa987a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109345.f90
@@ -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 <lchilu...@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
+
