gcc/testsuite/gfortran.dg/allocate_with_source_24.f90

   1 ! { dg-do run }
   2 !
   3 ! Test that the temporary in a sourced-ALLOCATE is not freeed.
   4 ! PR fortran/79344
   5 ! Contributed by Juergen Reuter
   6
   7 module iso_varying_string
   8   implicit none
   9
  10   type, public :: varying_string
  11      private
  12      character(LEN=1), dimension(:), allocatable :: chars
  13   end type varying_string
  14
  15   interface assignment(=)
  16      module procedure op_assign_VS_CH
  17   end interface assignment(=)
  18
  19   interface operator(/=)
  20      module procedure op_not_equal_VS_CA
  21   end interface operator(/=)
  22
  23   interface len
  24      module procedure len_
  25   end interface len
  26
  27   interface var_str
  28      module procedure var_str_
  29   end interface var_str
  30
  31   public :: assignment(=)
  32   public :: operator(/=)
  33   public :: len
  34
  35   private :: op_assign_VS_CH
  36   private :: op_not_equal_VS_CA
  37   private :: char_auto
  38   private :: len_
  39   private :: var_str_
  40
  41 contains
  42
  43   elemental function len_ (string) result (length)
  44     type(varying_string), intent(in) :: string
  45     integer                          :: length
  46     if(ALLOCATED(string%chars)) then
  47        length = SIZE(string%chars)
  48     else
  49        length = 0
  50     endif
  51   end function len_
  52
  53   elemental subroutine op_assign_VS_CH (var, exp)
  54     type(varying_string), intent(out) :: var
  55     character(LEN=*), intent(in)      :: exp
  56     var = var_str(exp)
  57   end subroutine op_assign_VS_CH
  58
  59   pure function op_not_equal_VS_CA (var, exp) result(res)
  60     type(varying_string), intent(in) :: var
  61     character(LEN=*), intent(in)     :: exp
  62     logical :: res
  63     integer :: i
  64     res = .true.
  65     if (len(exp) /= size(var%chars)) return
  66     do i = 1, size(var%chars)
  67       if (var%chars(i) /= exp(i:i)) return
  68     end do
  69     res = .false.
  70   end function op_not_equal_VS_CA
  71
  72   pure function char_auto (string) result (char_string)
  73     type(varying_string), intent(in) :: string
  74     character(LEN=len(string))       :: char_string
  75     integer                          :: i_char
  76     forall(i_char = 1:len(string))
  77        char_string(i_char:i_char) = string%chars(i_char)
  78     end forall
  79   end function char_auto
  80
  81   elemental function var_str_ (char) result (string)
  82     character(LEN=*), intent(in) :: char
  83     type(varying_string)         :: string
  84     integer                      :: length
  85     integer                      :: i_char
  86     length = LEN(char)
  87     ALLOCATE(string%chars(length))
  88     forall(i_char = 1:length)
  89        string%chars(i_char) = char(i_char:i_char)
  90     end forall
  91   end function var_str_
  92
  93 end module iso_varying_string
  94
  95 !!!!!
  96
  97 program test_pr79344
  98
  99   use iso_varying_string, string_t => varying_string
 100
 101   implicit none
 102
 103   type :: field_data_t
 104      type(string_t), dimension(:), allocatable :: name
 105   end type field_data_t
 106
 107   type(field_data_t) :: model, model2
 108   allocate(model%name(2))
 109   model%name(1) = "foo"
 110   model%name(2) = "bar"
 111   call copy(model, model2)
 112 contains
 113
 114   subroutine copy(prt, prt_src)
 115     implicit none
 116     type(field_data_t), intent(inout) :: prt
 117     type(field_data_t), intent(in) :: prt_src
 118     integer :: i
 119     if (allocated (prt_src%name)) then
 120        if (prt_src%name(1) /= "foo") STOP 1
 121        if (prt_src%name(2) /= "bar") STOP 2
 122
 123        if (allocated (prt%name))  deallocate (prt%name)
 124        allocate (prt%name (size (prt_src%name)), source = prt_src%name)
 125        ! The issue was, that prt_src was empty after sourced-allocate.
 126        if (prt_src%name(1) /= "foo") STOP 3
 127        if (prt_src%name(2) /= "bar") STOP 4
 128        if (prt%name(1) /= "foo") STOP 5
 129        if (prt%name(2) /= "bar") STOP 6
 130     end if
 131   end subroutine copy
 132
 133 end program test_pr79344
 134