Skip to content

Commit 03b66ef

Browse files
krystophnykrystophny
committed
refactor(standardizer): split declarations core (fixes #1917)
1 parent d596d90 commit 03b66ef

8 files changed

+1964
-1921
lines changed

‎src/standardizers/standardizer_declarations_array.f90‎

Lines changed: 296 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,296 @@
1+
module standardizer_declarations_array
2+
use ast_arena_modern, only: ast_arena_t
3+
use ast_nodes_bounds, only: range_expression_node
4+
use ast_nodes_core, only: identifier_node, literal_node
5+
use ast_nodes_data, only: declaration_node
6+
use ast_base, only: LITERAL_INTEGER
7+
use type_system_unified, only: mono_type_t, TARRAY
8+
use uid_generator, only: generate_uid
9+
implicit none
10+
private
11+
12+
public :: parse_dimension_attribute
13+
public :: set_array_properties_from_type
14+
15+
contains
16+
17+
subroutine parse_dimension_attribute(arena, prog_index, var_type, &
18+
dim_pos, decl_node)
19+
type(ast_arena_t), intent(inout) :: arena
20+
integer, intent(in) :: prog_index, dim_pos
21+
character(len=*), intent(in) :: var_type
22+
type(declaration_node), intent(inout) :: decl_node
23+
integer :: paren_pos, iostat, dim_size, i, comma_count, ndims
24+
integer :: start_pos, end_pos, comma_pos
25+
character(len=20) :: dim_str
26+
type(literal_node) :: size_literal
27+
character(len=20) :: size_str
28+
integer, allocatable :: dimensions(:)
29+
character(len=100) :: dims_str
30+
logical :: has_explicit_bounds
31+
integer :: dim_idx
32+
33+
has_explicit_bounds = .false.
34+
if (allocated(decl_node%dimension_indices)) then
35+
if (size(decl_node%dimension_indices) > 0) then
36+
has_explicit_bounds = .true.
37+
do i = 1, size(decl_node%dimension_indices)
38+
dim_idx = decl_node%dimension_indices(i)
39+
if (dim_idx <= 0) then
40+
has_explicit_bounds = .false.
41+
exit
42+
else if (dim_idx > arena%size) then
43+
cycle
44+
else if (.not. allocated(arena%entries(dim_idx)%node)) then
45+
has_explicit_bounds = .false.
46+
exit
47+
else
48+
select type (dim_node => arena%entries(dim_idx)%node)
49+
type is (range_expression_node)
50+
if (dim_node%start_index <= 0 .or. &
51+
dim_node%end_index <= 0) then
52+
has_explicit_bounds = .false.
53+
exit
54+
end if
55+
class default
56+
cycle
57+
end select
58+
end if
59+
end do
60+
end if
61+
end if
62+
63+
if (decl_node%is_parameter) then
64+
decl_node%is_array = .true.
65+
return
66+
end if
67+
68+
paren_pos = index(var_type(dim_pos:), ')')
69+
if (paren_pos > 10) then
70+
dims_str = var_type(dim_pos + 10:dim_pos + paren_pos - 2)
71+
else
72+
if (has_explicit_bounds) then
73+
decl_node%is_array = .true.
74+
decl_node%is_allocatable = .false.
75+
end if
76+
return
77+
end if
78+
79+
if (trim(dims_str) == ':') then
80+
if (has_explicit_bounds) then
81+
decl_node%is_array = .true.
82+
decl_node%is_allocatable = .false.
83+
return
84+
end if
85+
decl_node%is_array = .true.
86+
decl_node%is_allocatable = .true.
87+
if (allocated(decl_node%dimension_indices)) &
88+
deallocate (decl_node%dimension_indices)
89+
allocate (decl_node%dimension_indices(1))
90+
decl_node%dimension_indices(1) = 0
91+
return
92+
end if
93+
94+
comma_count = 0
95+
do i = 1, len_trim(dims_str)
96+
if (dims_str(i:i) == ',') comma_count = comma_count + 1
97+
end do
98+
ndims = comma_count + 1
99+
100+
allocate (dimensions(ndims))
101+
102+
start_pos = 1
103+
do i = 1, ndims
104+
if (i < ndims) then
105+
comma_pos = index(dims_str(start_pos:), ',')
106+
if (comma_pos > 0) then
107+
end_pos = start_pos + comma_pos - 2
108+
else
109+
end_pos = len_trim(dims_str)
110+
end if
111+
else
112+
end_pos = len_trim(dims_str)
113+
end if
114+
115+
dim_str = dims_str(start_pos:end_pos)
116+
read (dim_str, *, iostat=iostat) dim_size
117+
if (iostat == 0) then
118+
dimensions(i) = dim_size
119+
else
120+
dimensions(i) = 0
121+
end if
122+
123+
start_pos = end_pos + 2
124+
end do
125+
126+
if (has_explicit_bounds) then
127+
if (size(decl_node%dimension_indices) == ndims) then
128+
block
129+
logical :: dimensions_match, dimensions_known
130+
integer :: existing_dim, dim_idx_local
131+
132+
dimensions_match = .true.
133+
dimensions_known = .true.
134+
do i = 1, ndims
135+
dim_idx_local = decl_node%dimension_indices(i)
136+
if (dim_idx_local <= 0 .or. dim_idx_local > arena%size) cycle
137+
if (.not. allocated(arena%entries(dim_idx_local)%node)) then
138+
dimensions_known = .false.
139+
exit
140+
end if
141+
select type (dim_node_local => &
142+
arena%entries(dim_idx_local)%node)
143+
type is (literal_node)
144+
read (dim_node_local%value, *, iostat=iostat) &
145+
existing_dim
146+
if (iostat /= 0) then
147+
dimensions_known = .false.
148+
exit
149+
end if
150+
if (existing_dim /= dimensions(i)) then
151+
dimensions_match = .false.
152+
exit
153+
end if
154+
class default
155+
dimensions_known = .false.
156+
exit
157+
end select
158+
end do
159+
if (.not. dimensions_known) then
160+
deallocate (dimensions)
161+
return
162+
end if
163+
if (dimensions_match) then
164+
deallocate (dimensions)
165+
return
166+
end if
167+
end block
168+
end if
169+
end if
170+
171+
decl_node%is_array = .true.
172+
if (allocated(decl_node%dimension_indices)) &
173+
deallocate (decl_node%dimension_indices)
174+
allocate (decl_node%dimension_indices(ndims))
175+
176+
do i = 1, ndims
177+
if (dimensions(i) > 0) then
178+
write (size_str, '(i0)') dimensions(i)
179+
size_literal%uid = generate_uid()
180+
size_literal%value = trim(size_str)
181+
size_literal%literal_kind = LITERAL_INTEGER
182+
size_literal%line = 1
183+
size_literal%column = 1
184+
call arena%push(size_literal, "literal", prog_index)
185+
decl_node%dimension_indices(i) = arena%size
186+
else
187+
decl_node%dimension_indices(i) = 0
188+
end if
189+
end do
190+
191+
deallocate (dimensions)
192+
end subroutine parse_dimension_attribute
193+
194+
subroutine set_array_properties_from_type(arena, var_name, prog_index, &
195+
decl_node)
196+
type(ast_arena_t), intent(inout) :: arena
197+
character(len=*), intent(in) :: var_name
198+
integer, intent(in) :: prog_index
199+
type(declaration_node), intent(inout) :: decl_node
200+
integer :: j, i
201+
type(literal_node) :: size_literal
202+
character(len=20) :: size_str
203+
type(mono_type_t) :: current_type
204+
integer :: ndims, dim_idx
205+
integer, allocatable :: dim_sizes(:)
206+
207+
if (decl_node%is_parameter) then
208+
return
209+
end if
210+
211+
do j = 1, arena%size
212+
if (allocated(arena%entries(j)%node)) then
213+
select type (node => arena%entries(j)%node)
214+
type is (identifier_node)
215+
if (trim(node%name) == trim(var_name)) then
216+
if (node%inferred_type%kind > 0) then
217+
if (node%inferred_type%kind == TARRAY) then
218+
decl_node%is_array = .true.
219+
220+
current_type = node%inferred_type
221+
ndims = 0
222+
223+
do while (current_type%kind == TARRAY)
224+
ndims = ndims + 1
225+
if (.not. current_type%has_args() .or. &
226+
current_type%get_args_count() < 1) exit
227+
current_type = current_type%get_arg(1)
228+
end do
229+
230+
if (ndims > 1) then
231+
ndims = 2
232+
end if
233+
234+
if (allocated(decl_node%dimension_indices)) &
235+
deallocate (decl_node%dimension_indices)
236+
allocate (decl_node%dimension_indices(ndims))
237+
allocate (dim_sizes(ndims))
238+
239+
if (ndims == 2) then
240+
dim_sizes(1) = node%inferred_type%size
241+
if (node%inferred_type%has_args() .and. &
242+
node%inferred_type%get_args_count() > 0) then
243+
current_type = node%inferred_type%get_arg(1)
244+
if (current_type%kind == TARRAY) then
245+
dim_sizes(2) = current_type%size
246+
else
247+
dim_sizes(2) = 0
248+
end if
249+
else
250+
dim_sizes(2) = 0
251+
end if
252+
else
253+
current_type = node%inferred_type
254+
dim_idx = 1
255+
do while (current_type%kind == TARRAY .and. &
256+
dim_idx <= ndims)
257+
dim_sizes(dim_idx) = current_type%size
258+
if (.not. current_type%has_args() .or. &
259+
current_type%get_args_count() < 1) exit
260+
current_type = current_type%get_arg(1)
261+
dim_idx = dim_idx + 1
262+
end do
263+
end if
264+
265+
do i = 1, ndims
266+
if (dim_sizes(i) > 0) then
267+
if (.not. node%inferred_type%alloc_info% &
268+
is_allocatable) then
269+
write (size_str, '(i0)') dim_sizes(i)
270+
size_literal%uid = generate_uid()
271+
size_literal%value = trim(size_str)
272+
size_literal%literal_kind = LITERAL_INTEGER
273+
size_literal%line = 1
274+
size_literal%column = 1
275+
call arena%push(size_literal, "literal", &
276+
prog_index)
277+
decl_node%dimension_indices(i) = arena%size
278+
else
279+
decl_node%dimension_indices(i) = 0
280+
end if
281+
else
282+
decl_node%dimension_indices(i) = 0
283+
end if
284+
end do
285+
286+
deallocate (dim_sizes)
287+
exit
288+
end if
289+
end if
290+
end if
291+
end select
292+
end if
293+
end do
294+
end subroutine set_array_properties_from_type
295+
296+
end module standardizer_declarations_array

0 commit comments

Comments
 (0)