Fortran: Fix automatic reallocation inside select rank [PR100103]

gcc/fortran/ChangeLog:

	PR fortran/100103
	* trans-array.cc (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.
This commit is contained in:
José Rui Faustino de Sousa 2022-09-21 22:55:02 +02:00 committed by Harald Anlauf
parent bc71318a91
commit 12b537b9b7
2 changed files with 78 additions and 2 deletions

View file

@ -10378,7 +10378,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
@ -10393,7 +10393,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)

View file

@ -0,0 +1,76 @@
! { 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)
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
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
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
end subroutine foo_u
end program main_p