mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-28 18:56:06 +00:00
120 lines
3.8 KiB
Fortran
120 lines
3.8 KiB
Fortran
! { dg-do run }
|
|
! { dg-options "-fdump-tree-original" }
|
|
!
|
|
! Tests the fix for PR87359 in which the finalization of
|
|
! 'source=process%component%extract_mci_template()' in the allocation
|
|
! of 'process%mci' caused invalid reads and freeing of already freed
|
|
! memory. This test is a greatly reduced version of the original code.
|
|
!
|
|
! Contributed by Juergen Reuter <juergen.reuter@desy.de>
|
|
!
|
|
module mci_base
|
|
implicit none
|
|
private
|
|
public :: mci_t
|
|
public :: mci_midpoint_t
|
|
public :: cnt
|
|
integer :: cnt = 0
|
|
type, abstract :: mci_t
|
|
integer, dimension(:), allocatable :: chain
|
|
end type mci_t
|
|
type, extends (mci_t) :: mci_midpoint_t
|
|
contains
|
|
final :: mci_midpoint_final
|
|
end type mci_midpoint_t
|
|
contains
|
|
IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg)
|
|
TYPE(mci_midpoint_t), INTENT(INOUT) :: arg
|
|
cnt = cnt + 1
|
|
END SUBROUTINE mci_midpoint_final
|
|
end module mci_base
|
|
|
|
!!!!!
|
|
|
|
module process_config
|
|
use mci_base
|
|
implicit none
|
|
private
|
|
public :: process_component_t
|
|
type :: process_component_t
|
|
class(mci_t), allocatable :: mci_template
|
|
contains
|
|
procedure :: init => process_component_init
|
|
procedure :: extract_mci_template => process_component_extract_mci_template
|
|
end type process_component_t
|
|
|
|
contains
|
|
|
|
subroutine process_component_init (component, mci_template)
|
|
class(process_component_t), intent(out) :: component
|
|
class(mci_t), intent(in), allocatable :: mci_template
|
|
if (allocated (mci_template)) &
|
|
allocate (component%mci_template, source = mci_template)
|
|
end subroutine process_component_init
|
|
|
|
function process_component_extract_mci_template (component) &
|
|
result (mci_template)
|
|
class(mci_t), allocatable :: mci_template
|
|
class(process_component_t), intent(in) :: component
|
|
if (allocated (component%mci_template)) &
|
|
allocate (mci_template, source = component%mci_template)
|
|
end function process_component_extract_mci_template
|
|
end module process_config
|
|
|
|
!!!!!
|
|
|
|
module process
|
|
use mci_base
|
|
use process_config
|
|
implicit none
|
|
private
|
|
public :: process_t
|
|
type :: process_t
|
|
private
|
|
type(process_component_t) :: component
|
|
class(mci_t), allocatable :: mci
|
|
contains
|
|
procedure :: init_component => process_init_component
|
|
procedure :: setup_mci => process_setup_mci
|
|
end type process_t
|
|
contains
|
|
subroutine process_init_component &
|
|
(process, mci_template)
|
|
class(process_t), intent(inout), target :: process
|
|
class(mci_t), intent(in), allocatable :: mci_template
|
|
call process%component%init (mci_template)
|
|
end subroutine process_init_component
|
|
|
|
subroutine process_setup_mci (process)
|
|
class(process_t), intent(inout) :: process
|
|
allocate (process%mci, source=process%component%extract_mci_template ())
|
|
end subroutine process_setup_mci
|
|
|
|
end module process
|
|
|
|
!!!!!
|
|
|
|
program main_ut
|
|
use mci_base
|
|
use process, only: process_t
|
|
implicit none
|
|
call event_transforms_1 ()
|
|
if (cnt .ne. 4) stop 2
|
|
contains
|
|
|
|
subroutine event_transforms_1 ()
|
|
class(mci_t), allocatable :: mci_template
|
|
type(process_t), allocatable, target :: process
|
|
allocate (process)
|
|
allocate (mci_midpoint_t :: mci_template)
|
|
call process%init_component (mci_template)
|
|
call process%setup_mci () ! generates 1 final call from call to extract_mci_template
|
|
if (cnt .ne. 1) stop 1
|
|
end subroutine event_transforms_1 ! generates 3 final calls to mci_midpoint_final:
|
|
! (i) process%component%mci_template
|
|
! (ii) process%mci
|
|
! (iii) mci_template
|
|
end program main_ut
|
|
! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } }
|
|
! { dg-final { scan-tree-dump-times "__builtin_free" 19 "original" } }
|