Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1853 bytes --]

Hi Harald,

Thanks for giving the patch a whirl.


> the parent components as an array. I strongly suspect that, from reading
> > 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However,
> this
> > is another issue to come back to in the future.
>
> Could you specify which version of Intel you tried?
>

ifort (IFORT) 2021.1 Beta 20201112

>
> Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:
>
> 131
>

That's the point where the interpretation of the standard diverges. Ifort
uses the scalar finalization for the parent component, whereas gfortran
uses the rank 1. Thus the final count is different by one. I have a version
of the patch, where gfortran behaves in the same way as ifort.


> This test also fails with crayftn 11 & 12 and nagfor 7.0,
> but in a different place.
>



>
> (Also finalize_45.f90 fails with that version with something that
> looks like memory corruption, but that might be just a compiler bug.)
>

I take it 'that version' is of ifort? Mine does the same. I suspect that it
is one of the perils of using pointer components in such circumstances! You
will notice that I had to nullify pointer components when doing the copy.

>
> Thanks,
> Harald
>

Could you use the attached version of finalize_38.f90 with crayftn and NAG?
All the stop statements are replaced with prints. Ifort gives:
         131           3           2
         132           0           4
         133           5           6 |           0           0
         141           4           3
         151           7           5
         152           3           0
         153           0           0 |           1           3
         161          13           9
         162          20           0
         163           0           0 |          10          20
         171          14          11

Best regards

Paul

[-- Attachment #2: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 6068 bytes --]

! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
  implicit none

  type :: simple
    integer :: ind
  contains
    final :: destructor1, destructor2
  end type simple

  type, extends(simple) :: complicated
    real :: rind
  contains
    final :: destructor3, destructor4
  end type complicated

  integer :: check_scalar
  integer :: check_array(4)
  real :: check_real
  real :: check_rarray(4)
  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    check_scalar = self%ind
    check_array = 0
    final_count = final_count + 1
  end subroutine destructor1

  subroutine destructor2(self)
    type(simple), intent(inout) :: self(:)
    check_scalar = 0
    check_array(1:size(self, 1)) = self%ind
    final_count = final_count + 1
  end subroutine destructor2

  subroutine destructor3(self)
    type(complicated), intent(inout) :: self
    check_real = self%rind
    check_array = 0.0
    final_count = final_count + 1
  end subroutine destructor3

  subroutine destructor4(self)
    type(complicated), intent(inout) :: self(:)
    check_real = 0.0
    check_rarray(1:size(self, 1)) = self%rind
    final_count = final_count + 1
  end subroutine destructor4

  function constructor1(ind) result(res)
    type(simple), allocatable :: res
    integer, intent(in) :: ind
    allocate (res, source = simple (ind))
  end function constructor1

  function constructor2(ind, rind) result(res)
    class(simple), allocatable :: res(:)
    integer, intent(in) :: ind(:)
    real, intent(in), optional :: rind(:)
    type(complicated), allocatable :: src(:)
    integer :: sz
    integer :: i
    if (present (rind)) then
      sz = min (size (ind, 1), size (rind, 1))
      src  = [(complicated (ind(i), rind(i)), i = 1, sz)]
      allocate (res, source = src)
    else
      sz = size (ind, 1)
      allocate (res, source = [(simple (ind(i)), i = 1, sz)])
    end if
  end function constructor2

  subroutine test (cnt, scalar, array, off, rind, rarray)
    integer :: cnt
    integer :: scalar
    integer :: array(:)
    integer :: off
    real, optional :: rind
    real, optional :: rarray(:)
    if (final_count .ne. cnt)  print *, 1 + off, final_count, cnt
    if (check_scalar .ne. scalar) print *, 2 + off, check_scalar, scalar
    if (any (check_array(1:size (array, 1)) .ne. array)) print *,  3 + off, &
                                       check_array(1:size (array, 1)), "|", array
    if (present (rind)) then
      if (check_real .ne. rind)  print *,  4+off, check_real, rind
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) print *,  5 + off, &
                                       check_rarray(1:size (rarray, 1)), "|", rarray
    end if
  end subroutine test

end module testmode

program test_final
  use testmode
  implicit none

  type(simple), allocatable :: MyType, MyType2
  type(simple), allocatable :: MyTypeArray(:)
  type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
  class(simple), allocatable :: MyClass
  class(simple), allocatable :: MyClassArray(:)

! ************************
! Derived type assignments
! ************************

! The original PR - one finalization of 'var' before (re)allocation.
  MyType = ThyType
  call test(1, 0, [0,0], 0)

  if (.not. allocated(MyType)) allocate(MyType)
  allocate(MyType2)
  MyType%ind = 1
  MyType2%ind = 2

! This should result in a final call with self = simple(1).
  MyType = MyType2
  call test(2, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
  MyTypeArray = [ThyType, ThyType2]
  call test(3, 0, [42,43], 20)

! This should result in a final call with self = initialization = simple(22).
  ThyType2 = simple(99)
  call test(4, 22, [0,0], 30)

! This should result in a final call with self = simple(22).
  ThyType = ThyType2
  call test(5, 21, [0,0], 40)

! This should result in two final calls; the last is for self2 = simple(2).
  deallocate (MyType, MyType2)
  call test(7, 2, [0,0], 50)

! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
  deallocate (MyTypeArray)
  call test(8, 0, [21,22], 60)

! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(10, 99, [0,0], 70)

  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

  allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
  MyClass = simple (4)
  call test(1, 3, [0,0], 100)

! This should result in a final call with the assigned value.
  deallocate (MyClass)
  call test(2, 4, [0,0], 110)

  allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call.
  call test(2, 4, [0,0], 120)

  MyClassArray = [simple (7), simple (8)]
! The final call should return the value before the assignment.
  call test(2, 4, [0,0], 130)

! This should result in a final call with the assigned value.
  deallocate (MyClassArray)
  call test(3, 0, [7,8], 140)

! This should produce no final calls.
  allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])

! This should produce calls to destructor4 then destructor2.
  deallocate (MyClassArray)

! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
! finalizable, the parent component is finalized.
  call test(5, 0, [1, 3], 150, rarray = [2.0, 4.0])

! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(9, 0, [10,20], 160, rarray = [10.0,20.0])

  deallocate (MyClassArray)
  call test(11, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final