gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=lib -fdump-tree-original" }
   3 ! { dg-additional-options "-latomic" { target libatomic_available } }
   4 !
   5 ! Contributed by Andre Vehreschild
   6 ! Check that sub-components are caf_deregistered and not freed.
   7
   8 program coarray_alloc_comp_3
   9   implicit none
  10
  11   type dt
  12     integer, allocatable :: i
  13   end type dt
  14
  15   type linktype
  16     type(dt), allocatable :: link
  17   end type linktype
  18
  19   type(linktype) :: obj[*]
  20
  21   allocate(obj%link)
  22
  23   if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
  24   if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
  25
  26   allocate(obj%link%i, source = 42)
  27
  28   if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
  29   if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
  30   if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
  31
  32   deallocate(obj%link%i)
  33
  34   if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
  35   if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
  36
  37   ! Freeing this object, lead to crash with older gfortran...
  38   deallocate(obj%link)
  39
  40   if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
  41 end program
  42 ! Ensure, that three calls to deregister are present.
  43 ! { dg-final { scan-tree-dump-times "_caf_deregister" 3 "original" } }
  44 ! And ensure that no calls to builtin_free are made.
  45 ! { dg-final { scan-tree-dump-not "_builtin_free" "original" } }