| ! { 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" } } |