gcc/testsuite/gfortran.dg/allocate_with_source_24.f90

! { dg-do run }
!
! Test that the temporary in a sourced-ALLOCATE is not freeed.
! PR fortran/79344
! Contributed by Juergen Reuter

module iso_varying_string
  implicit none

  type, public :: varying_string
     private
     character(LEN=1), dimension(:), allocatable :: chars
  end type varying_string

  interface assignment(=)
     module procedure op_assign_VS_CH
  end interface assignment(=)

  interface operator(/=)
     module procedure op_not_equal_VS_CA
  end interface operator(/=)

  interface len
     module procedure len_
  end interface len

  interface var_str
     module procedure var_str_
  end interface var_str

  public :: assignment(=)
  public :: operator(/=)
  public :: len

  private :: op_assign_VS_CH
  private :: op_not_equal_VS_CA
  private :: char_auto
  private :: len_
  private :: var_str_

contains

  elemental function len_ (string) result (length)
    type(varying_string), intent(in) :: string
    integer                          :: length
    if(ALLOCATED(string%chars)) then
       length = SIZE(string%chars)
    else
       length = 0
    endif
  end function len_

  elemental subroutine op_assign_VS_CH (var, exp)
    type(varying_string), intent(out) :: var
    character(LEN=*), intent(in)      :: exp
    var = var_str(exp)
  end subroutine op_assign_VS_CH

  pure function op_not_equal_VS_CA (var, exp) result(res)
    type(varying_string), intent(in) :: var
    character(LEN=*), intent(in)     :: exp
    logical :: res
    integer :: i
    res = .true.
    if (len(exp) /= size(var%chars)) return
    do i = 1, size(var%chars)
      if (var%chars(i) /= exp(i:i)) return
    end do
    res = .false.
  end function op_not_equal_VS_CA

  pure function char_auto (string) result (char_string)
    type(varying_string), intent(in) :: string
    character(LEN=len(string))       :: char_string
    integer                          :: i_char
    forall(i_char = 1:len(string))
       char_string(i_char:i_char) = string%chars(i_char)
    end forall
  end function char_auto

  elemental function var_str_ (char) result (string)
    character(LEN=*), intent(in) :: char
    type(varying_string)         :: string
    integer                      :: length
    integer                      :: i_char
    length = LEN(char)
    ALLOCATE(string%chars(length))
    forall(i_char = 1:length)
       string%chars(i_char) = char(i_char:i_char)
    end forall
  end function var_str_

end module iso_varying_string

!!!!!
 
program test_pr79344

  use iso_varying_string, string_t => varying_string

  implicit none

  type :: field_data_t
     type(string_t), dimension(:), allocatable :: name
  end type field_data_t

  type(field_data_t) :: model, model2
  allocate(model%name(2))
  model%name(1) = "foo"
  model%name(2) = "bar"
  call copy(model, model2)
contains

  subroutine copy(prt, prt_src)
    implicit none
    type(field_data_t), intent(inout) :: prt
    type(field_data_t), intent(in) :: prt_src
    integer :: i
    if (allocated (prt_src%name)) then
       if (prt_src%name(1) /= "foo") STOP 1
       if (prt_src%name(2) /= "bar") STOP 2

       if (allocated (prt%name))  deallocate (prt%name)
       allocate (prt%name (size (prt_src%name)), source = prt_src%name)
       ! The issue was, that prt_src was empty after sourced-allocate.
       if (prt_src%name(1) /= "foo") STOP 3
       if (prt_src%name(2) /= "bar") STOP 4
       if (prt%name(1) /= "foo") STOP 5
       if (prt%name(2) /= "bar") STOP 6
    end if
  end subroutine copy

end program test_pr79344