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.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0513495..795ce14 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -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)

diff --git a/gcc/testsuite/gfortran.dg/PR100103.f90 b/gcc/testsuite/gfortran.dg/PR100103.f90
new file mode 100644 (file)
index 0000000..2140561
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100103.f90
@@ -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