Hi All, The failing testcase came about because the array reference in the TYPE IS block required the correct value of the span. The fix separates out unlimited polymorphic expressions in gfc_get_array_span and ensures that the value returned is the originating array span, rather than the element size. This is done by extracting the class container and then the class data.
The other tweak in gfc_get_array_span makes the logic rather clearer by identifying class dummy references as being the only cases where 'desc' is not a component of a class container. OK for mainline and backporting to the affected, active branches after a couple of weeks? Paul
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a52bde90bd2..e888b737bec 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 98133b48960..8f8bdbf0069 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/pr109435.f90 b/gcc/testsuite/gfortran.dg/pr109435.f90
new file mode 100644
index 00000000000..7326c2e71a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109435.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! Test the fix for PR109435 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
+
Change.Logs
Description: Binary data
