gcc/testsuite/gfortran.dg/structure_constructor_11.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! PR fortran/54603
   5 !
   6 ! Contributed by Kacper Kowalik
   7 !
   8 module foo
   9    implicit none
  10
  11    interface
  12       subroutine cg_ext
  13          implicit none
  14       end subroutine cg_ext
  15    end interface
  16
  17    type :: ext_ptr
  18       procedure(cg_ext), nopass, pointer :: init
  19       procedure(cg_ext), nopass, pointer :: cleanup
  20    end type ext_ptr
  21
  22    type :: ext_ptr_array
  23       type(ext_ptr) :: a
  24       contains
  25          procedure :: epa_init
  26    end type ext_ptr_array
  27
  28    type(ext_ptr_array) :: bar
  29
  30 contains
  31    subroutine epa_init(this, init, cleanup)
  32       implicit none
  33       class(ext_ptr_array), intent(inout) :: this
  34       procedure(cg_ext), pointer, intent(in)    :: init
  35       procedure(cg_ext), pointer, intent(in)    :: cleanup
  36
  37       this%a = ext_ptr(null(), null())  ! Wrong code
  38       this%a = ext_ptr(init, cleanup)  ! Wrong code
  39
  40       this%a%init => init              ! OK
  41       this%a%cleanup => cleanup        ! OK
  42
  43       this%a = ext_ptr(this%a%init,this%a%cleanup) ! ICE in fold_convert_loc
  44    end subroutine epa_init
  45
  46 end module foo
  47
  48 program ala
  49    use foo, only: bar
  50    implicit none
  51    integer :: count1, count2
  52    count1 = 0
  53    count2 = 0
  54
  55    call setme
  56    call bar%a%cleanup()
  57    call bar%a%init()
  58
  59    ! They should be called once
  60    if (count1 /= 23 .or. count2 /= 42) call abort ()
  61
  62 contains
  63
  64    subroutine dummy1
  65       implicit none
  66       !print *, 'dummy1'
  67       count1 = 23
  68    end subroutine dummy1
  69
  70    subroutine dummy2
  71       implicit none
  72       !print *, 'dummy2'
  73       count2 = 42
  74    end subroutine dummy2
  75
  76    subroutine setme
  77       use foo, only: bar, cg_ext
  78       implicit none
  79       procedure(cg_ext), pointer :: a_init, a_clean
  80
  81       a_init => dummy1
  82       a_clean => dummy2
  83       call bar%epa_init(a_init, a_clean)
  84    end subroutine setme
  85
  86 end program ala
  87
  88 ! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = 0B;" 1 "original" } }
  89 ! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = 0B;" 1 "original" } }
  90 ! { dg-final { scan-tree-dump-times "ext_ptr.1.init = \\*init;" 1 "original" } }
  91 ! { dg-final { scan-tree-dump-times "ext_ptr.1.cleanup = \\*cleanup;" 1 "original" } }
  92 ! { dg-final { scan-tree-dump-times "this->_data->a.init = \\*init;" 1 "original" } }
  93 ! { dg-final { scan-tree-dump-times "this->_data->a.cleanup = \\*cleanup;" 1 "original" } }
  94 ! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = this->_data->a.init;" 1 "original" } }
  95 ! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = this->_data->a.cleanup;" 1 "original" } }