Line data Source code
1 : !> Table and iterator operations for HSD types
2 : !>
3 : !> This submodule implements all type-bound procedures for table
4 : !> and iterator operations on hsd_node_t. See hsd_types.f90 for type
5 : !> definitions and interface declarations.
6 : submodule (hsd_types) hsd_table_ops
7 : implicit none (type, external)
8 :
9 : contains
10 :
11 : !> Add a child node to the table
12 : !>
13 : !> Creates a deep copy of the child node and adds it to the table.
14 : !> The table takes ownership of the copy and will deallocate it when
15 : !> the table is destroyed or the child is removed.
16 3045 : module procedure table_add_child
17 :
18 3045 : type(hsd_node_ptr_t), allocatable :: tmp(:)
19 3045 : integer :: new_size, ii
20 :
21 : ! Initialize if table was never set up via new_table
22 3045 : if (.not. allocated(self%children)) then
23 10 : allocate(self%children(4))
24 2 : self%num_children = 0
25 : end if
26 :
27 : ! Grow array if needed
28 3045 : if (self%num_children >= size(self%children)) then
29 61 : new_size = size(self%children) * 2
30 3277 : allocate(tmp(new_size))
31 : ! Move pointers (shallow copy) — node objects stay at same address
32 1669 : do ii = 1, self%num_children
33 1608 : tmp(ii)%node => self%children(ii)%node
34 1669 : self%children(ii)%node => null()
35 : end do
36 61 : deallocate(self%children)
37 61 : call move_alloc(tmp, self%children)
38 : end if
39 :
40 : ! Add child (allocate a copy on the heap, store pointer)
41 3045 : self%num_children = self%num_children + 1
42 3045 : allocate(self%children(self%num_children)%node, source=child)
43 :
44 3045 : end procedure table_add_child
45 :
46 : !> Get child by index
47 : !>
48 : !> Returns a pointer to the child at the given index. The pointer is
49 : !> owned by the table - do NOT deallocate it. The pointer becomes
50 : !> invalid if the child is removed or the table is destroyed.
51 2662 : module procedure table_get_child
52 :
53 2662 : child => null()
54 2662 : if (index >= 1 .and. index <= self%num_children) then
55 2661 : if (associated(self%children(index)%node)) then
56 2661 : child => self%children(index)%node
57 : end if
58 : end if
59 :
60 3045 : end procedure table_get_child
61 :
62 : !> Get child by name (linear search, returns last match)
63 2398 : module procedure table_get_child_by_name
64 :
65 2398 : integer :: idx
66 2398 : character(len=:), allocatable :: lower_name
67 :
68 2398 : child => null()
69 2398 : lower_name = to_lower(name)
70 :
71 : ! Search from end to return last occurrence (override semantics)
72 542373 : do idx = self%num_children, 1, -1
73 540965 : if (.not. associated(self%children(idx)%node)) cycle
74 540965 : if (.not. allocated(self%children(idx)%node%name)) cycle
75 1083338 : if (to_lower(self%children(idx)%node%name) == lower_name) then
76 990 : child => self%children(idx)%node
77 541955 : return
78 : end if
79 : end do
80 :
81 5060 : end procedure table_get_child_by_name
82 :
83 : !> Check if table has a child with given name
84 27 : module procedure table_has_child
85 :
86 : type(hsd_node_t), pointer :: child
87 :
88 27 : call self%get_child_by_name(name, child)
89 27 : has = associated(child)
90 :
91 2425 : end procedure table_has_child
92 :
93 : !> Get number of children
94 0 : module procedure table_num_children
95 0 : n = self%num_children
96 27 : end procedure table_num_children
97 :
98 : !> Get list of all child names
99 7 : module procedure table_get_keys
100 :
101 7 : integer :: i, max_len
102 :
103 : ! Find maximum key length
104 7 : max_len = 0
105 17 : do i = 1, self%num_children
106 17 : if (associated(self%children(i)%node)) then
107 10 : if (allocated(self%children(i)%node%name)) then
108 : max_len = max(max_len, &
109 8 : & len(self%children(i)%node%name))
110 : end if
111 : end if
112 : end do
113 :
114 : ! Allocate and fill keys
115 7 : if (max_len > 0) then
116 : allocate(character(len=max_len) :: &
117 4 : & keys(self%num_children))
118 13 : do i = 1, self%num_children
119 13 : if (associated(self%children(i)%node)) then
120 9 : if (allocated(self%children(i)%node%name)) then
121 8 : keys(i) = self%children(i)%node%name
122 : else
123 1 : keys(i) = ""
124 : end if
125 : end if
126 : end do
127 : else
128 3 : allocate(character(len=1) :: keys(0))
129 : end if
130 :
131 0 : end procedure table_get_keys
132 :
133 : !> Remove child at given index
134 : !>
135 : !> Removes and deallocates the child at the given index. Children
136 : !> after the removed one are shifted to fill the gap. Any pointers
137 : !> to the removed child become invalid after this call.
138 7 : module procedure table_remove_child
139 :
140 7 : integer :: i
141 :
142 7 : if (index < 1 .or. index > self%num_children) then
143 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
144 2 : return
145 : end if
146 :
147 : ! Destroy the child node
148 5 : if (associated(self%children(index)%node)) then
149 5 : call self%children(index)%node%destroy()
150 5 : deallocate(self%children(index)%node)
151 : end if
152 :
153 : ! Shift remaining children down (move pointers)
154 12 : do i = index, self%num_children - 1
155 12 : self%children(i)%node => self%children(i + 1)%node
156 : end do
157 5 : self%children(self%num_children)%node => null()
158 :
159 5 : self%num_children = self%num_children - 1
160 :
161 5 : if (present(stat)) stat = HSD_STAT_OK
162 :
163 14 : end procedure table_remove_child
164 :
165 : !> Remove child by name (linear search, removes last match)
166 7 : module procedure table_remove_child_by_name
167 :
168 7 : integer :: idx
169 7 : character(len=:), allocatable :: lower_name
170 :
171 7 : lower_name = to_lower(name)
172 :
173 : ! Search from end to match last occurrence (override semantics)
174 17 : do idx = self%num_children, 1, -1
175 15 : if (.not. associated(self%children(idx)%node)) cycle
176 15 : if (.not. allocated(self%children(idx)%node%name)) cycle
177 30 : if (to_lower(self%children(idx)%node%name) == &
178 2 : & lower_name) then
179 5 : call self%remove_child(idx, stat)
180 20 : return
181 : end if
182 : end do
183 :
184 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
185 :
186 14 : end procedure table_remove_child_by_name
187 :
188 : !> Destroy node and all children
189 : !>
190 : !> Recursively deallocates all child nodes and frees all allocated
191 : !> memory. Must be called explicitly to avoid memory leaks.
192 3472 : module procedure node_destroy
193 :
194 3472 : integer :: i
195 :
196 : ! Destroy children if this is a table node
197 3472 : if (self%node_type == NODE_TYPE_TABLE) then
198 3959 : do i = 1, self%num_children
199 3959 : if (associated(self%children(i)%node)) then
200 2954 : call self%children(i)%node%destroy()
201 2954 : deallocate(self%children(i)%node)
202 : end if
203 : end do
204 1005 : if (allocated(self%children)) deallocate(self%children)
205 1005 : self%num_children = 0
206 : end if
207 :
208 : ! Clean up value fields
209 3472 : if (allocated(self%string_value)) &
210 2460 : & deallocate(self%string_value)
211 3472 : self%value_type = VALUE_TYPE_NONE
212 :
213 : ! Clean up common fields
214 3472 : if (allocated(self%name)) deallocate(self%name)
215 3472 : if (allocated(self%attrib)) deallocate(self%attrib)
216 :
217 7 : end procedure node_destroy
218 :
219 : !> Initialize iterator for a table
220 5 : module procedure iterator_init
221 :
222 5 : self%table => table
223 5 : self%pos = 0
224 :
225 5 : end procedure iterator_init
226 :
227 : !> Advance to next child and return it
228 : !> Returns .false. if no more children
229 21 : module procedure iterator_next
230 :
231 21 : child => null()
232 21 : has_more = .false.
233 :
234 1 : if (.not. associated(self%table)) return
235 :
236 20 : self%pos = self%pos + 1
237 20 : if (self%pos <= self%table%num_children) then
238 16 : if (associated( &
239 16 : & self%table%children(self%pos)%node)) then
240 16 : child => self%table%children(self%pos)%node
241 16 : has_more = .true.
242 : end if
243 : end if
244 :
245 21 : end procedure iterator_next
246 :
247 : !> Reset iterator to beginning
248 2 : module procedure iterator_reset
249 2 : self%pos = 0
250 21 : end procedure iterator_reset
251 :
252 : !> Check if there are more children without advancing
253 13 : module procedure iterator_has_next
254 :
255 13 : has_more = .false.
256 13 : if (associated(self%table)) then
257 13 : has_more = self%pos < self%table%num_children
258 : end if
259 :
260 13 : end procedure iterator_has_next
261 :
262 : end submodule hsd_table_ops
|
