https://gcc.gnu.org/bugzilla/show_bug.cgi?id=117763
--- Comment #2 from Jürgen Reuter <juergen.reuter at desy dot de> ---
This is a shorter reproducer:
1 module iso_varying_string
2 implicit none
3 integer, parameter, private :: GET_BUFFER_LEN = 1
4
5 type, public :: varying_string
6 private
7 character(LEN=1), dimension(:), allocatable :: chars
8 end type varying_string
9
10 interface assignment(=)
11 module procedure op_assign_CH_VS
12 module procedure op_assign_VS_CH
13 end interface assignment(=)
14
15 interface char
16 module procedure char_auto
17 module procedure char_fixed
18 end interface char
19
20 interface len
21 module procedure len_
22 end interface len
23
24 interface var_str
25 module procedure var_str_
26 end interface var_str
27
28 public :: assignment(=)
29 public :: char
30 public :: len
31 public :: var_str
32
33 private :: op_assign_CH_VS
34 private :: op_assign_VS_CH
35 private :: char_auto
36 private :: char_fixed
37 private :: len_
38 private :: var_str_
39
40 contains
41
42 elemental function len_ (string) result (length)
43 type(varying_string), intent(in) :: string
44 integer :: length
45 if(ALLOCATED(string%chars)) then
46 length = SIZE(string%chars)
47 else
48 length = 0
49 endif
50 end function len_
51
52 elemental subroutine op_assign_CH_VS (var, exp)
53 character(LEN=*), intent(out) :: var
54 type(varying_string), intent(in) :: exp
55 var = char(exp)
56 end subroutine op_assign_CH_VS
57
58 elemental subroutine op_assign_VS_CH (var, exp)
59 type(varying_string), intent(out) :: var
60 character(LEN=*), intent(in) :: exp
61 var = var_str(exp)
62 end subroutine op_assign_VS_CH
63
64 pure function char_auto (string) result (char_string)
65 type(varying_string), intent(in) :: string
66 character(LEN=len(string)) :: char_string
67 integer :: i_char
68 forall(i_char = 1:len(string))
69 char_string(i_char:i_char) = string%chars(i_char)
70 end forall
71 end function char_auto
72
73 pure function char_fixed (string, length) result (char_string)
74 type(varying_string), intent(in) :: string
75 integer, intent(in) :: length
76 character(LEN=length) :: char_string
77 char_string = char(string)
78 end function char_fixed
79
80 elemental function var_str_ (char) result (string)
81 character(LEN=*), intent(in) :: char
82 type(varying_string) :: string
83 integer :: length
84 integer :: i_char
85 length = LEN(char)
86 ALLOCATE(string%chars(length))
87 forall(i_char = 1:length)
88 string%chars(i_char) = char(i_char:i_char)
89 end forall
90 end function var_str_
91
92 end module iso_varying_string
93
94 module model_data
95 use, intrinsic :: iso_c_binding !NODEP!
96 use iso_varying_string, string_t => varying_string
97
98 implicit none
99 private
100
101 public :: field_data_t
102 public :: model_data_t
103
104 type :: field_data_t
105 private
106 type(string_t) :: longname
107 integer :: pdg = 0
108 logical :: has_anti = .false.
109 type(string_t), dimension(:), allocatable :: name, anti
110 type(string_t) :: tex_name
111 integer :: multiplicity = 1
112 contains
113 procedure :: init => field_data_init
114 procedure :: set => field_data_set
115 procedure :: get_longname => field_data_get_longname
116 procedure :: get_name_array => field_data_get_name_array
117 end type field_data_t
118
119 type :: model_data_t
120 private
121 type(field_data_t), dimension(:), allocatable :: field
122 contains
123 generic :: init => model_data_init
124 procedure, private :: model_data_init
125 procedure :: get_field_array_ptr => model_data_get_field_array_ptr
126 procedure :: get_field_ptr_by_index =>
model_data_get_field_ptr_index
127 procedure :: init_sm_test => model_data_init_sm_test
128 end type model_data_t
129
130
131 contains
132
133 subroutine field_data_init (prt, longname, pdg)
134 class(field_data_t), intent(out) :: prt
135 type(string_t), intent(in) :: longname
136 integer, intent(in) :: pdg
137 prt%longname = longname
138 prt%pdg = pdg
139 prt%tex_name = ""
140 end subroutine field_data_init
141
142 subroutine field_data_set (prt, &
143 name, anti, tex_name)
144 class(field_data_t), intent(inout) :: prt
145 type(string_t), dimension(:), intent(in), optional :: name, anti
146 type(string_t), intent(in), optional :: tex_name
147 if (present (name)) then
148 if (allocated (prt%name)) deallocate (prt%name)
149 allocate (prt%name (size (name)), source = name)
150 end if
151 if (present (anti)) then
152 if (allocated (prt%anti)) deallocate (prt%anti)
153 allocate (prt%anti (size (anti)), source = anti)
154 prt%has_anti = .true.
155 end if
156 if (present (tex_name)) prt%tex_name = tex_name
157 end subroutine field_data_set
158
159 pure function field_data_get_longname (prt) result (name)
160 type(string_t) :: name
161 class(field_data_t), intent(in) :: prt
162 name = prt%longname
163 end function field_data_get_longname
164
165 subroutine field_data_get_name_array (prt, is_antiparticle, name)
166 class(field_data_t), intent(in) :: prt
167 logical, intent(in) :: is_antiparticle
168 type(string_t), dimension(:), allocatable, intent(inout) :: name
169 if (allocated (name)) deallocate (name)
170 if (is_antiparticle) then
171 if (prt%has_anti) then
172 allocate (name (size (prt%anti)))
173 name = prt%anti
174 else
175 allocate (name (0))
176 end if
177 else
178 allocate (name (size (prt%name)))
179 name = prt%name
180 end if
181 end subroutine field_data_get_name_array
182
183 subroutine model_data_init (model, n_field)
184 class(model_data_t), intent(out) :: model
185 integer, intent(in) :: n_field
186 allocate (model%field (n_field))
187 end subroutine model_data_init
188
189 function model_data_get_field_array_ptr (model) result (ptr)
190 class(model_data_t), intent(in), target :: model
191 type(field_data_t), dimension(:), pointer :: ptr
192 ptr => model%field
193 end function model_data_get_field_array_ptr
194
195 function model_data_get_field_ptr_index (model, i) result (ptr)
196 class(model_data_t), intent(in), target :: model
197 integer, intent(in) :: i
198 type(field_data_t), pointer :: ptr
199 ptr => model%field(i)
200 end function model_data_get_field_ptr_index
201
202 subroutine model_data_init_sm_test (model)
203 class(model_data_t), intent(out) :: model
204 type(field_data_t), pointer :: field
205 integer :: i
206 call model%init (2)
207 i = 0
208 i = i + 1
209 field => model%get_field_ptr_by_index (i)
210 call field%init (var_str ("W_BOSON"), 24)
211 call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
212 i = i + 1
213 field => model%get_field_ptr_by_index (i)
214 call field%init (var_str ("HIGGS"), 25)
215 call field%set (name = [var_str ("H")])
216 end subroutine model_data_init_sm_test
217
218 end module model_data
219
220
221 module models
222 use, intrinsic :: iso_c_binding !NODEP!
223 use iso_varying_string, string_t => varying_string
224 use model_data
225 use parser
226 use variables
227 implicit none
228 private
229 public :: model_t
230
231 type, extends (model_data_t) :: model_t
232 private
233 contains
234 procedure :: append_field_vars => model_append_field_vars
235 end type model_t
236
237 contains
238
239 subroutine model_append_field_vars (model)
240 class(model_t), intent(inout) :: model
241 type(field_data_t), dimension(:), pointer :: field_array
242 type(field_data_t), pointer :: field
243 type(string_t) :: name
244 type(string_t), dimension(:), allocatable :: name_array
245 integer :: i, j
246 field_array => model%get_field_array_ptr ()
247 do i = 1, size (field_array)
248 name = field_array(i)%get_longname ()
249 call field_array(i)%get_name_array (.false., name_array)
250 end do
251 end subroutine model_append_field_vars
252
253 end module models
254
255
256 program main_ut
257 use iso_varying_string, string_t => varying_string
258 use model_data
259 use models
260 implicit none
261
262 class(model_data_t), pointer :: model
263 model => null ()
264 allocate (model_t :: model)
265 select type (model)
266 type is (model_t)
267 call model%init_sm_test ()
268 call model%append_field_vars ()
269 end select
270 end program main_ut
