1! { dg-do run } 2! { dg-options "-fcoarray=lib -lcaf_single" } 3! { dg-additional-options "-latomic" { target libatomic_available } } 4! 5! Contributed by Andre Vehreschild 6! Check that manually freeing components does not lead to a runtime crash, 7! when the auto-deallocation is taking care. 8 9program coarray_alloc_comp_3 10 implicit none 11 12 type dt 13 integer, allocatable :: i 14 end type dt 15 16 type linktype 17 type(dt), allocatable :: link 18 end type linktype 19 20 type(linktype), allocatable :: obj[:] 21 22 allocate(obj[*]) 23 allocate(obj%link) 24 25 if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." 26 if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." 27 if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." 28 29 allocate(obj%link%i, source = 42) 30 31 if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." 32 if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." 33 if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." 34 if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." 35 36 deallocate(obj%link%i) 37 38 if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." 39 if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." 40 if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." 41 42 ! Freeing this object, lead to crash with older gfortran... 43 deallocate(obj%link) 44 45 if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." 46 if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." 47 48 ! ... when auto-deallocating the allocated components. 49 deallocate(obj) 50 51 if (allocated(obj)) error stop "Test failed. 'obj' still allocated." 52end program 53