Hi All!
Proposed patch to:
PR100103 - Automatic reallocation fails inside select rank
Patch tested only on x86_64-pc-linux-gnu.
Add select rank temporary associated names as possible targets of
automatic reallocation.
The patch depends on PR100097 and PR100098.
Thank you very much.
Best regards,
José Rui
Fortran: Fix automatic reallocation inside select rank [PR100103]
gcc/fortran/ChangeLog:
PR fortran/100103
* trans-array.c (gfc_is_reallocatable_lhs): add select rank
temporary associate names as possible targets of automatic
reallocation.
gcc/testsuite/ChangeLog:
PR fortran/100103
* gfortran.dg/PR100103.f90: New test.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index be5eb89350f..99225e70d5d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10048,7 +10048,7 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
/* An allocatable class variable with no reference. */
if (sym->ts.type == BT_CLASS
- && !sym->attr.associate_var
+ && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
&& CLASS_DATA (sym)->attr.allocatable
&& expr->ref
&& ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
@@ -10063,7 +10063,7 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
/* An allocatable variable. */
if (sym->attr.allocatable
- && !sym->attr.associate_var
+ && (!sym->attr.associate_var || sym->attr.select_rank_temporary)
&& expr->ref
&& expr->ref->type == REF_ARRAY
&& expr->ref->u.ar.type == AR_FULL)
diff --git a/gcc/testsuite/gfortran.dg/PR100103.f90 b/gcc/testsuite/gfortran.dg/PR100103.f90
new file mode 100644
index 00000000000..756fd5824c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100103.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+!
+! Test the fix for PR100103
+!
+
+program main_p
+
+ implicit none
+
+ integer :: i
+ integer, parameter :: n = 11
+
+ type :: foo_t
+ integer :: i
+ end type foo_t
+
+ type(foo_t), parameter :: a(*) = [(foo_t(i), i=1,n)]
+
+ type(foo_t), allocatable :: bar_d(:)
+ class(foo_t), allocatable :: bar_p(:)
+ class(*), allocatable :: bar_u(:)
+
+
+ call foo_d(bar_d)
+ if(.not.allocated(bar_d)) stop 1
+ if(any(bar_d%i/=a%i)) stop 2
+ deallocate(bar_d)
+ call foo_p(bar_p)
+ if(.not.allocated(bar_p)) stop 3
+ if(any(bar_p%i/=a%i)) stop 4
+ deallocate(bar_p)
+ call foo_u(bar_u)
+ if(.not.allocated(bar_u)) stop 5
+ select type(bar_u)
+ type is(foo_t)
+ if(any(bar_u%i/=a%i)) stop 6
+ class default
+ stop 7
+ end select
+ deallocate(bar_u)
+ stop
+
+contains
+
+ subroutine foo_d(that)
+ type(foo_t), allocatable, intent(out) :: that(..)
+
+ select rank(that)
+ rank(1)
+ that = a
+ rank default
+ stop 8
+ end select
+ return
+ end subroutine foo_d
+
+ subroutine foo_p(that)
+ class(foo_t), allocatable, intent(out) :: that(..)
+
+ select rank(that)
+ rank(1)
+ that = a
+ rank default
+ stop 9
+ end select
+ return
+ end subroutine foo_p
+
+ subroutine foo_u(that)
+ class(*), allocatable, intent(out) :: that(..)
+
+ select rank(that)
+ rank(1)
+ that = a
+ rank default
+ stop 10
+ end select
+ return
+ end subroutine foo_u
+
+end program main_p
