gcc/testsuite/gfortran.dg/typebound_proc_27.f03

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! PR fortran/47586
   5 ! Missing deep copy for data pointer returning functions when the type
   6 ! has allocatable components
   7 !
   8 ! Original testcase by Thomas Henlich  <thenlich@users.sourceforge.net>
   9 ! Reduced by Tobias Burnus  <burnus@net-b.de>
  10 !
  11
  12 module m
  13   type :: tx
  14     integer, dimension(:), allocatable :: i
  15   end type tx
  16   type proc_t
  17     procedure(find_x), nopass, pointer :: ppc => null()
  18    contains
  19     procedure, nopass :: tbp => find_x
  20   end type proc_t
  21
  22 contains
  23
  24   function find_x(that)
  25     type(tx), target  :: that
  26     type(tx), pointer :: find_x
  27     find_x => that
  28   end function find_x
  29
  30 end module m
  31
  32 program prog
  33
  34   use m
  35
  36  block ! Start new scoping unit as PROGRAM implies SAVE
  37   type(tx) :: this
  38   type(tx), target :: that
  39   type(tx), pointer :: p
  40
  41   type(proc_t) :: tab
  42
  43   allocate(that%i(2))
  44   that%i = [3, 7]
  45   p => that
  46   this = that  ! (1) direct assignment: works (deep copy)
  47   that%i = [2, -5]
  48   !print *,this%i
  49   if(any (this%i /= [3, 7])) call abort()
  50   this = p     ! (2) using a pointer works as well
  51   that%i = [10, 1]
  52   !print *,this%i
  53   if(any (this%i /= [2, -5])) call abort()
  54   this = find_x(that)  ! (3) pointer function: used to fail (deep copy missing)
  55   that%i = [4, 6]
  56   !print *,this%i
  57   if(any (this%i /= [10, 1])) call abort()
  58   this = tab%tbp(that)  ! other case: typebound procedure
  59   that%i = [8, 9]
  60   !print *,this%i
  61   if(any (this%i /= [4, 6])) call abort()
  62   tab%ppc => find_x
  63   this = tab%ppc(that)  ! other case: procedure pointer component
  64   that%i = [-1, 2]
  65   !print *,this%i
  66   if(any (this%i /= [8, 9])) call abort()
  67
  68  end block
  69 end program prog
  70
  71 !
  72 ! We add another check for deep copy by looking at the dump.
  73 ! We use realloc on assignment here: if we do a deep copy  for the assignment
  74 ! to `this', we have a reallocation of `this%i'.
  75 ! Thus, the total number of malloc calls should be the number of assignment to
  76 ! `that%i' + the number of assignments to `this' + the number of allocate
  77 ! statements.
  78 ! It is assumed that if the number of allocate is right, the number of
  79 ! deep copies is right too.
  80 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
  81
  82 !
  83 ! Realloc are only used for assignments to `that%i'.  Don't know why.
  84 ! { dg-final { scan-tree-dump-times "__builtin_realloc" 6 "original" } }
  85 !
  86
  87 ! No leak: Only assignments to `this' use malloc.  Assignments to `that%i'
  88 ! take the realloc path after the first assignment, so don't count as a malloc.
  89 ! { dg-final { scan-tree-dump-times "__builtin_free" 10 "original" } }
  90 !
  91