fortran: Add the preliminary code of MOVE_ALLOC arguments

Add the preliminary code produced for the evaluation of the FROM and TO
arguments of the MOVE_ALLOC intrinsic before using their values.
Before this change, the preliminary code was ignored and dropped,
limiting the validity of the implementation of MOVE_ALLOC to simple
cases without preliminary code.

This change also adds the cleanup code of the same arguments.  It
doesn't make any difference on the testcase though.  Because of the
limited set of arguments that are allowed (variables or components
without subreference), it is possible that the cleanup code is actually
guaranteed to be empty.  At least adding the cleanup code makes the
array case consistent with the scalar case.

gcc/fortran/ChangeLog:

	* trans-intrinsic.cc (conv_intrinsic_move_alloc): Add pre and
	post code for the FROM and TO arguments.

gcc/testsuite/ChangeLog:

	* gfortran.dg/move_alloc_20.f03: New test.

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index f1bfd3eee510d491a6bf76a1ecbad98a9814719f..be984271d6a8da49343cf000ffee5e2d42d2884f 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -13101,6 +13101,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
     }
   gfc_conv_expr_descriptor (&to_se, to_expr);
   gfc_conv_expr_descriptor (&from_se, from_expr);
+  gfc_add_block_to_block (&block, &to_se.pre);
+  gfc_add_block_to_block (&block, &from_se.pre);
 
   /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
      is an image control "statement", cf. IR F08/0040 in 12-006A.  */
@@ -13174,6 +13176,9 @@ conv_intrinsic_move_alloc (gfc_code *code)
   if (fin_label)
     gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
 
+  gfc_add_block_to_block (&block, &to_se.post);
+  gfc_add_block_to_block (&block, &from_se.post);
+
   return gfc_finish_block (&block);
 }
 

diff --git a/gcc/testsuite/gfortran.dg/move_alloc_20.f03 b/gcc/testsuite/gfortran.dg/move_alloc_20.f03
new file mode 100644 (file)
index 0000000..20403c3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_20.f03
@@ -0,0 +1,151 @@
+! { dg-do run }
+!
+! Check the presence of the pre and post code of the FROM and TO arguments
+! of the MOVE_ALLOC intrinsic subroutine.
+
+module m
+  implicit none
+  type :: t
+    integer, allocatable :: a(:)
+  end type
+end module 
+
+module pre
+  use m
+  implicit none
+  private
+  public :: check_pre
+
+contains
+
+  subroutine check_pre
+    integer, parameter :: n = 5
+    type(t) :: x(n)
+    integer, allocatable :: tmp(:)
+    integer :: array(4) = [ -1, 0, 1, 2 ]
+    integer :: i
+
+    if (allocated(tmp)) error stop 1
+
+    tmp = [17]
+
+    if (.not. allocated(tmp)) error stop 11
+    if (any(shape(tmp) /= [1])) error stop 12
+    if (any(tmp /= [17])) error stop 13
+    do i=1,n
+      if (allocated(x(i)%a)) error stop 14
+    end do
+
+    ! Check that the index of X is properly computed for the evaluation of TO.
+    call move_alloc(tmp, x(sum(array))%a)
+
+    do i=1,n
+      if (i == 2) cycle
+      if (allocated(x(i)%a)) error stop 21
+    end do
+    if (.not. allocated(x(2)%a)) error stop 22
+    if (any(shape(x(2)%a) /= [1])) error stop 23
+    if (any(x(2)%a /= [17])) error stop 24
+    if (allocated(tmp)) error stop 25
+
+    ! Check that the index of X is properly computed for the evaluation of FROM.
+    call move_alloc(x(sum(array))%a, tmp)
+
+    if (.not. allocated(tmp)) error stop 31
+    if (any(shape(tmp) /= [1])) error stop 32
+    if (any(tmp /= [17])) error stop 33
+    do i=1,n
+      if (allocated(x(i)%a)) error stop 34
+    end do
+  end subroutine
+
+end module
+
+module post
+  use m
+  implicit none
+  private
+  public :: check_post
+  integer, parameter :: n = 5
+  type(t), target :: x(n)
+  type :: u
+    integer :: a
+  contains
+    final :: finalize
+  end type
+  integer :: finalization_count = 0
+
+contains
+
+  function idx(arg)
+    type(u) :: arg
+    integer :: idx
+    idx = mod(arg%a, n)
+  end function
+
+  subroutine check_post
+    type(u) :: y
+    integer, allocatable :: tmp(:)
+    integer, target :: array(4) = [ -1, 0, 1, 2 ]
+    integer :: i
+
+    y%a = 12
+
+    if (allocated(tmp)) error stop 1
+
+    tmp = [37]
+
+    if (.not. allocated(tmp)) error stop 11
+    if (any(shape(tmp) /= [1])) error stop 12
+    if (any(tmp /= [37])) error stop 13
+    if (finalization_count /= 0) error stop 14
+    do i=1,n
+      if (allocated(x(i)%a)) error stop 15
+    end do
+
+    ! Check that the cleanup code for the evaluation of TO is properly
+    ! executed after MOVE_ALLOC: the result of GET_U should be finalized.
+    call move_alloc(tmp, x(idx(get_u(y)))%a)
+
+    do i=1,n
+      if (i == 2) cycle
+      if (allocated(x(i)%a)) error stop 21
+    end do
+    if (.not. allocated(x(2)%a)) error stop 22
+    if (any(shape(x(2)%a) /= [1])) error stop 23
+    if (any(x(2)%a /= [37])) error stop 24
+    if (allocated(tmp)) error stop 25
+    if (finalization_count /= 1) error stop 26
+
+    ! Check that the cleanup code for the evaluation of FROM is properly
+    ! executed after MOVE_ALLOC: the result of GET_U should be finalized.
+    call move_alloc(x(idx(get_u(y)))%a, tmp)
+
+    if (.not. allocated(tmp)) error stop 31
+    if (any(shape(tmp) /= [1])) error stop 32
+    if (any(tmp /= [37])) error stop 33
+    if (finalization_count /= 2) error stop 34
+    do i=1,n
+      if (allocated(x(i)%a)) error stop 35
+    end do
+  end subroutine
+
+  function get_u(arg)
+    type(u) :: arg, get_u
+    get_u = arg
+  end function get_u
+
+  subroutine finalize(obj)
+    type(u) :: obj
+    finalization_count = finalization_count + 1
+  end subroutine
+
+end module
+
+program p
+  use pre
+  use post
+  implicit none
+  call check_pre
+  call check_post
+end program