From: Mikael Morin <[email protected]>
This fixes the span set by array pointer assignments, which is part of
PR127448.
The testcase is a variant of the original testcase from the PR, with the
dummy argument of the checking function having the target attribute, so that
arguments are passed to the function without any temporary array. This
avoids problems relating to array copy that remain unfixed despite this
patch in the original testcase.
Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline?
-- >8 --
Mark the _data field of array pointer class containers with the
GFC_DECL_PTR_ARRAY_P flag, so that in pointer assignments, the span assigned
to the array descriptor is copied from the target descriptor span instead of
the class container size.
Before this change, it was assumed that the size taken from the class
container was the correct span value. This was supposing all polymorphic
arrays to be contiguous, which is not the case for a polymorphic pointer
whose target is a parent object of an extended derived type object.
The change tries to keep the current behaviour if possible, that is use
the size from the class container if the array is known to be contiguous.
I doubt the information is properly propagated everywhere, but it should
be conservatively correct.
The is_pointer_array hunk removes a condition that is redundant: the
type of the operand 1 of a component ref is the type of the field, which
is also the type of the component ref itself, which has already been
checked before. I suspect the condition to be a typo and should check
operand 0 of the component ref. If that was the case, this patch would
remove it anyway.
PR fortran/127448
gcc/fortran/ChangeLog:
* trans-array.cc (is_pointer_array): Remove redundant condition.
(is_span_addressed_array): For polymorphic arrays, return false if
the array is known to be contiguous.
* trans-types.cc (gfc_get_derived_type): Also set the
GFC_DECL_PTR_ARRAY_P flag for _data fields of class containers
corresponding to polymorphic array pointers.
gcc/testsuite/ChangeLog:
* gfortran.dg/pointer_assign_17.f90: New test.
---
gcc/fortran/trans-array.cc | 28 +++++++-
gcc/fortran/trans-types.cc | 5 +-
.../gfortran.dg/pointer_assign_17.f90 | 65 +++++++++++++++++++
3 files changed, 93 insertions(+), 5 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/pointer_assign_17.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index abf6f907f05..abc606dc627 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -484,8 +484,7 @@ is_pointer_array (tree expr)
/* The field declaration is marked as a pointer array. */
if (TREE_CODE (expr) == COMPONENT_REF
- && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
- && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
+ && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)))
return true;
return false;
@@ -501,7 +500,30 @@ static bool
is_span_addressed_array (tree expr)
{
if (is_pointer_array (expr))
- return true;
+ {
+ /* For classes, index arrays using the size from the virtual pointer if
+ the array is contiguous. Otherwise use the span. */
+ if (TREE_CODE (expr) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
+ && TYPE_LANG_SPECIFIC (TREE_TYPE (expr)))
+ {
+ switch (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (expr)))
+ {
+ case GFC_ARRAY_ASSUMED_SHAPE_CONT:
+ case GFC_ARRAY_ASSUMED_RANK_CONT:
+ case GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE:
+ case GFC_ARRAY_ASSUMED_RANK_POINTER_CONT:
+ case GFC_ARRAY_ALLOCATABLE:
+ case GFC_ARRAY_POINTER_CONT:
+ return false;
+
+ default:
+ break;
+ }
+ }
+
+ return true;
+ }
if (VAR_P (expr)
&& GFC_DECL_PTR_ARRAY_P (expr)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index ef80cd8feab..3675f093253 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -3167,8 +3167,9 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
c->backend_decl = field;
- if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
- && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
+ if ((c->attr.dimension || c->attr.codimension)
+ && ((derived->attr.is_class && c->attr.class_pointer)
+ || (!derived->attr.is_class && c->attr.pointer)))
GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
}
diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_17.f90
b/gcc/testsuite/gfortran.dg/pointer_assign_17.f90
new file mode 100644
index 00000000000..a3fc3e2ff47
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_assign_17.f90
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! PR fortran/127448
+! Check the span set in array pointer assignments.
+! For class pointers, the size from the class container was always
+! used as span, which caused problems when the pointer was pointing
+! to a parent subobject of an extended derived type entity.
+
+program prog
+ implicit none
+ integer, parameter :: k = 2
+ integer, parameter :: n = 5
+ type :: t1
+ integer(kind=k) :: c1, c2
+ end type
+ type, extends(t1) :: t2
+ integer(kind=k) :: c3
+ end type
+ type(t2), target :: x(n)
+ class(t1), pointer :: y1(:), z1(:)
+ class(t2), pointer :: y2(:)
+ type(t1), pointer :: p1(:), q1(:)
+ integer :: i
+ x = [ (t2(i*i, 2*i*i+1, i), i=1,n) ]
+ y2 => x
+ y1 => x
+ call check_t1(y1, 12)
+ z1 => y2
+ call check_t1(z1, 13)
+ z1 => y1
+ call check_t1(z1, 14)
+ call check_t1(x%t1, 21)
+ call check_t1(y2%t1, 22)
+ y1 => x%t1
+ call check_t1(y1, 23)
+ z1 => y2%t1
+ call check_t1(z1, 24)
+ z1 => y1
+ call check_t1(z1, 25)
+ p1 => x%t1
+ call check_t1(p1, 41)
+ p1 => y2%t1
+ call check_t1(p1, 42)
+ p1 => y1
+ call check_t1(p1, 43)
+ q1 => p1
+ call check_t1(q1, 44)
+contains
+ subroutine check_t1(arg, f)
+ type(t1), target, intent(in) :: arg(:)
+ integer, intent(in) :: f
+ call check_int(arg%c1, [1, 4, 9, 16, 25], f*10+1)
+ call check_int(arg%c2, [3, 9, 19, 33, 51], f*10+2)
+ end subroutine
+ subroutine check_int(arg, e, f)
+ integer(kind=k), intent(in) :: arg(:)
+ integer, intent(in) :: e(:), f
+ integer :: i
+ if (size(arg, 1) /= size(e, 1)) error stop f*10+1
+ !do i=1,size(arg)
+ ! print *, f*10+i, (arg(i) == e(i) ? "PASS" : "FAIL"), arg(i), e(i)
+ !end do
+ if (any(arg /= e)) error stop f*10+2
+ end subroutine
+end program
--
2.53.0
