diff mbox series

Patch, fortran] PR fortran/100103 - Automatic reallocation fails inside select rank

Message ID 5ac8daf2-dafb-8f0b-7eef-5d1d9df7dcb3@gmail.com
State New
Headers show
Series Patch, fortran] PR fortran/100103 - Automatic reallocation fails inside select rank | expand

Commit Message

José Rui Faustino de Sousa April 15, 2021, 6:15 p.m. UTC 
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 mbox series

Patch

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