https://gcc.gnu.org/bugzilla/show_bug.cgi?id=79344
--- Comment #3 from Jürgen Reuter <juergen.reuter at desy dot de> ---
Finally reduced this to something like 260 lines. Problem is the allocate
source construct, i.e. copying of allocatable derived type components.
module iso_varying_string
implicit none
integer, parameter, private :: GET_BUFFER_LEN = 1
type, public :: varying_string
private
character(LEN=1), dimension(:), allocatable :: chars
end type varying_string
interface assignment(=)
module procedure op_assign_CH_VS
module procedure op_assign_VS_CH
end interface assignment(=)
interface char
module procedure char_auto
module procedure char_fixed
end interface char
interface len
module procedure len_
end interface len
interface var_str
module procedure var_str_
end interface var_str
public :: assignment(=)
public :: char
public :: len
public :: var_str
private :: op_assign_CH_VS
private :: op_assign_VS_CH
private :: char_auto
private :: char_fixed
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_CH_VS (var, exp)
character(LEN=*), intent(out) :: var
type(varying_string), intent(in) :: exp
var = char(exp)
end subroutine op_assign_CH_VS
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 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
pure function char_fixed (string, length) result (char_string)
type(varying_string), intent(in) :: string
integer, intent(in) :: length
character(LEN=length) :: char_string
char_string = char(string)
return
end function char_fixed
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
!!!!!
module models
use iso_varying_string, string_t => varying_string
implicit none
private
public :: field_data_t
public :: model_data_t
type :: field_data_t
private
type(string_t) :: longname
integer :: pdg = 0
type(string_t), dimension(:), allocatable :: name, anti
contains
procedure :: init => field_data_init
procedure :: copy_from => field_data_copy_from
procedure :: set => field_data_set
end type field_data_t
type :: field_data_p
type(field_data_t), pointer :: p => null ()
end type field_data_p
type :: model_data_t
private
type(string_t) :: name
type(field_data_t), dimension(:), allocatable :: field
contains
procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
end type model_data_t
public :: model_t
type, extends (model_data_t) :: model_t
contains
generic :: init => model_init
procedure, private :: model_init
procedure :: read => model_read
end type model_t
contains
subroutine field_data_init (prt, longname, pdg)
class(field_data_t), intent(out) :: prt
type(string_t), intent(in) :: longname
integer, intent(in) :: pdg
prt%longname = longname
prt%pdg = pdg
end subroutine field_data_init
subroutine field_data_copy_from (prt, prt_src)
class(field_data_t), intent(inout) :: prt
class(field_data_t), intent(in) :: prt_src
integer :: i
print *, "##############################################################"
print *, "inside copy_from"
if (allocated (prt_src%name)) then
print *, "foo"
do i = 1, size (prt_src%name)
print *, "name = ", char (prt_src%name(i))
end do
if (allocated (prt%name)) deallocate (prt%name)
allocate (prt%name (size (prt_src%name)), source = prt_src%name)
print *, "THESE SHOULD NOT BE EMPTY"
do i = 1, size (prt_src%name)
print *, "name = ", char (prt_src%name(i))
end do
end if
if (allocated (prt_src%anti)) then
if (allocated (prt%anti)) deallocate (prt%anti)
allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti)
end if
end subroutine field_data_copy_from
subroutine field_data_set (prt, name, anti)
class(field_data_t), intent(inout) :: prt
type(string_t), dimension(:), intent(in), optional :: name, anti
if (present (name)) then
if (allocated (prt%name)) deallocate (prt%name)
allocate (prt%name (size (name)), source = name)
end if
end subroutine field_data_set
function model_data_get_field_ptr_index (model, i) result (ptr)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: i
type(field_data_t), pointer :: ptr
ptr => model%field(i)
end function model_data_get_field_ptr_index
subroutine model_init &
(model, name, n_par, n_prt)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: name
integer, intent(in) :: n_par, n_prt
model%name = name
allocate (model%field (n_prt))
end subroutine model_init
subroutine model_read (model)
class(model_t), intent(out), target :: model
type(field_data_t), pointer :: field, field_src
call model%init (var_str ("foo"), 0, 2)
field_src => model%get_field_ptr_by_index (1)
call field_src%init (var_str ("E_LEPTON"), 11)
call field_src%set &
(name = [var_str ("e-"), var_str ("e1")])
field => model%get_field_ptr_by_index (2)
call field%init (var_str ("MU_LEPTON"), 13)
call field%copy_from (field_src)
end subroutine model_read
end module models
!!!!!
program main_ut
use iso_varying_string, string_t => varying_string
use models
implicit none
class(model_data_t), pointer :: model
allocate (model_t :: model)
select type (model)
type is (model_t)
call model%read ()
end select
end program main_ut
