-- >8 --
Fix two problems relating to the source argument of ALLOCATE statements.
When the source is a pointer array, drop the forced temporary leading to a
bogus copy, and to avoid regressing when the source is an array
subreference, fix the retrieval of the array reference serving as source of
bounds.
To fix PR114024, r14-9160 introduced an automatic wrapping in parentheses of
the allocate source expression, forcing the generation of a temporary and
avoiding an internal error. That change causes a regression with
polymorphic pointers, because the reference generated for the temporary
array doesn't contain the class container as parent subreference, so the
array indexing ends up being generated by the non-polymorphic fall back. As
a consequence, indexing is off and the values copied are wrong.
This change reverts that PR114024 fix. It doesn't solve the underlying
problem in case the parentheses are explicitly present in the user code, but
it at least fixes the much more common case where they are absent.
Reverting means restoring the original problem which has to be fixed some
other way. The problem is an assertion failure expecting all intermediary
array references to be single element references in the walk to find the
last element of the data reference chain. The assertion makes sense in the
context of the allocated entity, but the same function is also used with the
source expression as input. In the latter case, there can be subreferences
coming after the main array reference, so it's not a surprise that the
assertion triggers. In the first place, we shouldn't be looking for the
last element in the reference chain, as there is no guarantee that is the
one holding the array information.
To fix this, we need to find the single non-element array reference in the
chain of the source expression. There is the existing gfc_find_array_ref
which does exactly that, except it returns a gfc_array_ref, not a gfc_ref.
So the type of the main array ref pointer is changed from gfc_ref to
gfc_array_ref, and all the accesses from the gfc_ref to the gfc_array_ref
beneath it are factored to set the new pointer.
PR fortran/114024
PR fortran/128033
gcc/fortran/ChangeLog:
* trans-stmt.cc (gfc_trans_allocate): Remove automatic wrapping of
array subreferences in a parentheses expression.
* trans-array.cc (gfc_array_allocate): Find the single non-element
array reference in the source expression instead of getting the last
reference in the chain. Use a gfc_array_ref pointer instead of a
gfc_ref pointer and simplify the references using it.
gcc/testsuite/ChangeLog:
* gfortran.dg/allocate_with_source_34.f90: New test.
---
gcc/fortran/trans-array.cc | 30 ++++++------
gcc/fortran/trans-stmt.cc | 9 +---
.../gfortran.dg/allocate_with_source_34.f90 | 48 +++++++++++++++++++
3 files changed, 65 insertions(+), 22 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_34.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index abc606dc627..54b69a6ff3d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6554,47 +6554,47 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
if (!dimension)
gcc_assert (coarray);
+ gfc_array_ref *ar;
if (ref->u.ar.type == AR_FULL && expr3 != NULL)
{
- gfc_ref *old_ref = ref;
/* F08:C633: Array shape from expr3. */
- ref = expr3->ref;
-
- /* Find the last reference in the chain. */
- if (!retrieve_last_ref (&ref, &prev_ref))
+ ar = gfc_find_array_ref (expr3, true);
+ if (!ar)
{
if (expr3->expr_type == EXPR_FUNCTION
&& gfc_expr_attr (expr3).dimension)
- ref = old_ref;
+ ar = &ref->u.ar;
else
return false;
}
alloc_w_e3_arr_spec = true;
}
+ else
+ ar = &ref->u.ar;
/* Figure out the size of the array. */
- switch (ref->u.ar.type)
+ switch (ar->type)
{
case AR_ELEMENT:
if (!coarray)
{
lower = NULL;
- upper = ref->u.ar.start;
+ upper = ar->start;
break;
}
/* Fall through. */
case AR_SECTION:
- lower = ref->u.ar.start;
- upper = ref->u.ar.end;
+ lower = ar->start;
+ upper = ar->end;
break;
case AR_FULL:
- gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+ gcc_assert (ar->as->type == AS_EXPLICIT
|| alloc_w_e3_arr_spec);
- lower = ref->u.ar.as->lower;
- upper = ref->u.ar.as->upper;
+ lower = ar->as->lower;
+ upper = ar->as->upper;
break;
default:
@@ -6617,8 +6617,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
later will mislead the generation of the array dimensions for
allocatable/
pointer components in derived types. */
size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
- : ref->u.ar.as->rank,
- coarray ? ref->u.ar.as->corank : 0,
+ : ar->as->rank,
+ coarray ? ar->as->corank : 0,
&offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
expr3_elem_size, expr3, e3_arr_desc,
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 2a87176ffa9..2a53bdaf9fc 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6727,14 +6727,9 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
vtab_needed = (al->expr->ts.type == BT_CLASS);
gfc_init_se (&se, NULL);
- /* When expr3 is a variable, i.e., a very simple expression, then
- convert it once here. If one has a source expression that has
- substring references, part-refs, or %re/%im inquiries, wrap the
- entity in parentheses to force evaluation of the expression. */
- if (code->expr3->expr_type == EXPR_VARIABLE
- && is_subref_array (code->expr3))
- code->expr3 = gfc_get_parentheses (code->expr3);
+ /* When expr3 is a variable, i.e., a very simple expression, then
+ convert it once here. */
if (code->expr3->expr_type == EXPR_VARIABLE
|| code->expr3->expr_type == EXPR_ARRAY
|| code->expr3->expr_type == EXPR_CONSTANT)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_34.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_34.f90
new file mode 100644
index 00000000000..38d958fbcca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_34.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! PR fortran/128033
+! Check that array allocation from polymorphic pointer source correctly
+! implements the array copy.
+
+program prog
+ implicit none
+ integer, parameter :: n = 5
+ type :: t1
+ integer :: c1, c2
+ end type
+ type, extends(t1) :: t2
+ integer :: c3
+ end type
+ type(t2), target :: a(n)
+ integer :: i
+ a = [ (t2(2*i*i+3, i*i+2, 3*i+5), i=1,n) ]
+ call sub(a)
+contains
+ subroutine sub(x)
+ class(t1), pointer, intent(in) :: x(:)
+ class(t1), allocatable :: a(:)
+ allocate(a, source=x)
+ call check_all(x, 1)
+ call check_all(a, 2)
+ end subroutine
+ subroutine check_all(x, e)
+ class(t1), target, intent(in) :: x(:)
+ integer, intent(in) :: e
+ select type(x)
+ type is (t2)
+ call check(x%c1, [ 5, 11, 21, 35, 53], e*10+1)
+ call check(x%c2, [ 3, 6, 11, 18, 27], e*10+2)
+ call check(x%c3, [ 8, 11, 14, 17, 20], e*10+3)
+ class default
+ error stop e*10+7
+ end select
+ end subroutine
+ subroutine check(x, y, e)
+ integer, target, dimension(:), intent(in) :: x, y
+ integer, intent(in) :: e
+ character(4) :: status
+ integer :: i
+ if (size(x) /= size(y)) error stop e*10+8
+ if (any(x /= y)) error stop e*10+9
+ end subroutine
+end program
