1! { dg-do run } 2! { dg-options "-fdump-tree-original" } 3! 4! Tests the fix for PR87359 in which the finalization of 5! 'source=process%component%extract_mci_template()' in the allocation 6! of 'process%mci' caused invalid reads and freeing of already freed 7! memory. This test is a greatly reduced version of the original code. 8! 9! Contributed by Juergen Reuter <juergen.reuter@desy.de> 10! 11module mci_base 12 implicit none 13 private 14 public :: mci_t 15 public :: mci_midpoint_t 16 public :: cnt 17 integer :: cnt = 0 18 type, abstract :: mci_t 19 integer, dimension(:), allocatable :: chain 20 end type mci_t 21 type, extends (mci_t) :: mci_midpoint_t 22 contains 23 final :: mci_midpoint_final 24 end type mci_midpoint_t 25contains 26 IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg) 27 TYPE(mci_midpoint_t), INTENT(INOUT) :: arg 28 cnt = cnt + 1 29 END SUBROUTINE mci_midpoint_final 30end module mci_base 31 32!!!!! 33 34module process_config 35 use mci_base 36 implicit none 37 private 38 public :: process_component_t 39 type :: process_component_t 40 class(mci_t), allocatable :: mci_template 41 contains 42 procedure :: init => process_component_init 43 procedure :: extract_mci_template => process_component_extract_mci_template 44 end type process_component_t 45 46contains 47 48 subroutine process_component_init (component, mci_template) 49 class(process_component_t), intent(out) :: component 50 class(mci_t), intent(in), allocatable :: mci_template 51 if (allocated (mci_template)) & 52 allocate (component%mci_template, source = mci_template) 53 end subroutine process_component_init 54 55 function process_component_extract_mci_template (component) & 56 result (mci_template) 57 class(mci_t), allocatable :: mci_template 58 class(process_component_t), intent(in) :: component 59 if (allocated (component%mci_template)) & 60 allocate (mci_template, source = component%mci_template) 61 end function process_component_extract_mci_template 62end module process_config 63 64!!!!! 65 66module process 67 use mci_base 68 use process_config 69 implicit none 70 private 71 public :: process_t 72 type :: process_t 73 private 74 type(process_component_t) :: component 75 class(mci_t), allocatable :: mci 76 contains 77 procedure :: init_component => process_init_component 78 procedure :: setup_mci => process_setup_mci 79 end type process_t 80contains 81 subroutine process_init_component & 82 (process, mci_template) 83 class(process_t), intent(inout), target :: process 84 class(mci_t), intent(in), allocatable :: mci_template 85 call process%component%init (mci_template) 86 end subroutine process_init_component 87 88 subroutine process_setup_mci (process) 89 class(process_t), intent(inout) :: process 90 allocate (process%mci, source=process%component%extract_mci_template ()) 91 end subroutine process_setup_mci 92 93end module process 94 95!!!!! 96 97program main_ut 98 use mci_base 99 use process, only: process_t 100 implicit none 101 call event_transforms_1 () 102 if (cnt .ne. 4) stop 2 103contains 104 105 subroutine event_transforms_1 () 106 class(mci_t), allocatable :: mci_template 107 type(process_t), allocatable, target :: process 108 allocate (process) 109 allocate (mci_midpoint_t :: mci_template) 110 call process%init_component (mci_template) 111 call process%setup_mci () ! generates 1 final call from call to extract_mci_template 112 if (cnt .ne. 1) stop 1 113 end subroutine event_transforms_1 ! generates 3 final calls to mci_midpoint_final: 114 ! (i) process%component%mci_template 115 ! (ii) process%mci 116 ! (iii) mci_template 117end program main_ut 118! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } } 119! { dg-final { scan-tree-dump-times "__builtin_free" 20 "original" } } 120