gcc/testsuite/gfortran.dg/block_13.f08

   1 ! { dg-do run }
   2 ! Checks the fix for PR57959. The first assignment to a was proceeding
   3 ! without a deep copy. Since the anum field of 'uKnot' was being pointed
   4 ! to twice, the frees in the finally block, following the BLOCK caused
   5 ! a double free.
   6 !
   7 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   8 !
   9 program main
  10   implicit none
  11   type :: type1
  12     real, allocatable :: anum
  13     character(len = :), allocatable :: chr
  14   end type type1
  15   real, parameter :: five = 5.0
  16   real, parameter :: point_one = 0.1
  17
  18   type :: type2
  19     type(type1) :: temp
  20   end type type2
  21   block
  22     type(type1) :: uKnot
  23     type(type2) :: a
  24
  25     uKnot = type1 (five, "hello")
  26     call check (uKnot%anum, five)
  27     call check_chr (uKnot%chr, "hello")
  28
  29     a = type2 (uKnot) ! Deep copy needed here
  30     call check (a%temp%anum, five)
  31     call check_chr (a%temp%chr, "hello")
  32
  33     a = type2 (type1(point_one, "goodbye")) ! Not here
  34     call check (a%temp%anum, point_one)
  35     call check_chr (a%temp%chr, "goodbye")
  36
  37     a = type2 (foo (five)) ! Not here
  38     call check (a%temp%anum, five)
  39     call check_chr (a%temp%chr, "foo set me")
  40   end block
  41 contains
  42   subroutine check (arg1, arg2)
  43     real :: arg1, arg2
  44     if (arg1 .ne. arg2) STOP 1
  45   end subroutine
  46
  47   subroutine check_chr (arg1, arg2)
  48     character(*) :: arg1, arg2
  49     if (len (arg1) .ne. len (arg2)) STOP 1
  50     if (arg1 .ne. arg2) STOP 2
  51   end subroutine
  52
  53   type(type1) function foo (arg)
  54     real :: arg
  55     foo = type1 (arg, "foo set me")
  56   end function
  57 end
  58