gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08

   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
   9 program 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."
  52 end program