gcc/testsuite/gfortran.dg/structure_constructor_11.f90

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/54603
!
! Contributed by Kacper Kowalik
!
module foo
   implicit none

   interface
      subroutine cg_ext
         implicit none
      end subroutine cg_ext
   end interface

   type :: ext_ptr
      procedure(cg_ext), nopass, pointer :: init
      procedure(cg_ext), nopass, pointer :: cleanup
   end type ext_ptr

   type :: ext_ptr_array
      type(ext_ptr) :: a
      contains
         procedure :: epa_init
   end type ext_ptr_array

   type(ext_ptr_array) :: bar

contains
   subroutine epa_init(this, init, cleanup)
      implicit none
      class(ext_ptr_array), intent(inout) :: this
      procedure(cg_ext), pointer, intent(in)    :: init
      procedure(cg_ext), pointer, intent(in)    :: cleanup

      this%a = ext_ptr(null(), null())  ! Wrong code
      this%a = ext_ptr(init, cleanup)  ! Wrong code

      this%a%init => init              ! OK
      this%a%cleanup => cleanup        ! OK

      this%a = ext_ptr(this%a%init,this%a%cleanup) ! ICE in fold_convert_loc
   end subroutine epa_init

end module foo

program ala
   use foo, only: bar
   implicit none
   integer :: count1, count2
   count1 = 0
   count2 = 0

   call setme
   call bar%a%cleanup()
   call bar%a%init()

   ! They should be called once
   if (count1 /= 23 .or. count2 /= 42) STOP 1

contains

   subroutine dummy1
      implicit none
      !print *, 'dummy1'
      count1 = 23 
   end subroutine dummy1

   subroutine dummy2
      implicit none
      !print *, 'dummy2'
      count2 = 42
   end subroutine dummy2
   
   subroutine setme
      use foo, only: bar, cg_ext
      implicit none
      procedure(cg_ext), pointer :: a_init, a_clean

      a_init => dummy1
      a_clean => dummy2
      call bar%epa_init(a_init, a_clean)
   end subroutine setme

end program ala

! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_ptr.1.init = \\*init;" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_ptr.1.cleanup = \\*cleanup;" 1 "original" } }
! { dg-final { scan-tree-dump-times "this->_data->a.init = \\*init;" 1 "original" } }
! { dg-final { scan-tree-dump-times "this->_data->a.cleanup = \\*cleanup;" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = this->_data->a.init;" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = this->_data->a.cleanup;" 1 "original" } }