| ! { 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 |
| |