]>
Commit | Line | Data |
---|---|---|
143eac12 MH |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT LIBRARY COMPONENTS -- | |
4 | -- -- | |
5 | -- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2004-2020, Free Software Foundation, Inc. -- |
143eac12 MH |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- | |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
22 | -- You should have received a copy of the GNU General Public License and -- | |
23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 | -- <http://www.gnu.org/licenses/>. -- | |
26 | -- -- | |
27 | -- This unit was originally developed by Matthew J Heaney. -- | |
28 | ------------------------------------------------------------------------------ | |
29 | ||
ef992452 | 30 | with System; use type System.Address; |
143eac12 MH |
31 | |
32 | package body Ada.Containers.Bounded_Doubly_Linked_Lists is | |
595a055f | 33 | |
14f73211 BD |
34 | pragma Warnings (Off, "variable ""Busy*"" is not referenced"); |
35 | pragma Warnings (Off, "variable ""Lock*"" is not referenced"); | |
36 | -- See comment in Ada.Containers.Helpers | |
37 | ||
143eac12 MH |
38 | ----------------------- |
39 | -- Local Subprograms -- | |
40 | ----------------------- | |
41 | ||
42 | procedure Allocate | |
43 | (Container : in out List; | |
44 | New_Item : Element_Type; | |
45 | New_Node : out Count_Type); | |
46 | ||
143eac12 MH |
47 | procedure Allocate |
48 | (Container : in out List; | |
49 | Stream : not null access Root_Stream_Type'Class; | |
50 | New_Node : out Count_Type); | |
51 | ||
52 | procedure Free | |
53 | (Container : in out List; | |
54 | X : Count_Type); | |
55 | ||
56 | procedure Insert_Internal | |
57 | (Container : in out List; | |
58 | Before : Count_Type; | |
59 | New_Node : Count_Type); | |
60 | ||
6c2e4047 AC |
61 | procedure Splice_Internal |
62 | (Target : in out List; | |
63 | Before : Count_Type; | |
64 | Source : in out List); | |
65 | ||
66 | procedure Splice_Internal | |
67 | (Target : in out List; | |
68 | Before : Count_Type; | |
69 | Source : in out List; | |
70 | Src_Pos : Count_Type; | |
71 | Tgt_Pos : out Count_Type); | |
72 | ||
143eac12 | 73 | function Vet (Position : Cursor) return Boolean; |
dd91386d AC |
74 | -- Checks invariants of the cursor and its designated container, as a |
75 | -- simple way of detecting dangling references (see operation Free for a | |
76 | -- description of the detection mechanism), returning True if all checks | |
77 | -- pass. Invocations of Vet are used here as the argument of pragma Assert, | |
78 | -- so the checks are performed only when assertions are enabled. | |
143eac12 MH |
79 | |
80 | --------- | |
81 | -- "=" -- | |
82 | --------- | |
83 | ||
84 | function "=" (Left, Right : List) return Boolean is | |
143eac12 | 85 | begin |
143eac12 MH |
86 | if Left.Length /= Right.Length then |
87 | return False; | |
88 | end if; | |
89 | ||
a015ef67 AC |
90 | if Left.Length = 0 then |
91 | return True; | |
92 | end if; | |
93 | ||
94 | declare | |
95 | -- Per AI05-0022, the container implementation is required to detect | |
96 | -- element tampering by a generic actual subprogram. | |
97 | ||
98 | Lock_Left : With_Lock (Left.TC'Unrestricted_Access); | |
99 | Lock_Right : With_Lock (Right.TC'Unrestricted_Access); | |
100 | ||
101 | LN : Node_Array renames Left.Nodes; | |
102 | RN : Node_Array renames Right.Nodes; | |
103 | ||
104 | LI : Count_Type := Left.First; | |
105 | RI : Count_Type := Right.First; | |
106 | begin | |
107 | for J in 1 .. Left.Length loop | |
108 | if LN (LI).Element /= RN (RI).Element then | |
109 | return False; | |
110 | end if; | |
143eac12 | 111 | |
a015ef67 AC |
112 | LI := LN (LI).Next; |
113 | RI := RN (RI).Next; | |
114 | end loop; | |
115 | end; | |
143eac12 | 116 | |
14f73211 | 117 | return True; |
143eac12 MH |
118 | end "="; |
119 | ||
120 | -------------- | |
121 | -- Allocate -- | |
122 | -------------- | |
123 | ||
124 | procedure Allocate | |
125 | (Container : in out List; | |
126 | New_Item : Element_Type; | |
127 | New_Node : out Count_Type) | |
128 | is | |
129 | N : Node_Array renames Container.Nodes; | |
130 | ||
131 | begin | |
132 | if Container.Free >= 0 then | |
133 | New_Node := Container.Free; | |
134 | ||
e47e21c1 AC |
135 | -- We always perform the assignment first, before we change container |
136 | -- state, in order to defend against exceptions duration assignment. | |
143eac12 MH |
137 | |
138 | N (New_Node).Element := New_Item; | |
139 | Container.Free := N (New_Node).Next; | |
140 | ||
141 | else | |
e47e21c1 AC |
142 | -- A negative free store value means that the links of the nodes in |
143 | -- the free store have not been initialized. In this case, the nodes | |
144 | -- are physically contiguous in the array, starting at the index that | |
145 | -- is the absolute value of the Container.Free, and continuing until | |
146 | -- the end of the array (Nodes'Last). | |
143eac12 MH |
147 | |
148 | New_Node := abs Container.Free; | |
149 | ||
e47e21c1 AC |
150 | -- As above, we perform this assignment first, before modifying any |
151 | -- container state. | |
143eac12 MH |
152 | |
153 | N (New_Node).Element := New_Item; | |
154 | Container.Free := Container.Free - 1; | |
155 | end if; | |
156 | end Allocate; | |
157 | ||
158 | procedure Allocate | |
159 | (Container : in out List; | |
160 | Stream : not null access Root_Stream_Type'Class; | |
161 | New_Node : out Count_Type) | |
162 | is | |
163 | N : Node_Array renames Container.Nodes; | |
164 | ||
165 | begin | |
166 | if Container.Free >= 0 then | |
167 | New_Node := Container.Free; | |
168 | ||
e47e21c1 AC |
169 | -- We always perform the assignment first, before we change container |
170 | -- state, in order to defend against exceptions duration assignment. | |
143eac12 MH |
171 | |
172 | Element_Type'Read (Stream, N (New_Node).Element); | |
173 | Container.Free := N (New_Node).Next; | |
174 | ||
175 | else | |
e47e21c1 AC |
176 | -- A negative free store value means that the links of the nodes in |
177 | -- the free store have not been initialized. In this case, the nodes | |
178 | -- are physically contiguous in the array, starting at the index that | |
179 | -- is the absolute value of the Container.Free, and continuing until | |
180 | -- the end of the array (Nodes'Last). | |
143eac12 MH |
181 | |
182 | New_Node := abs Container.Free; | |
183 | ||
e47e21c1 AC |
184 | -- As above, we perform this assignment first, before modifying any |
185 | -- container state. | |
143eac12 MH |
186 | |
187 | Element_Type'Read (Stream, N (New_Node).Element); | |
188 | Container.Free := Container.Free - 1; | |
189 | end if; | |
190 | end Allocate; | |
191 | ||
143eac12 MH |
192 | ------------ |
193 | -- Append -- | |
194 | ------------ | |
195 | ||
196 | procedure Append | |
197 | (Container : in out List; | |
198 | New_Item : Element_Type; | |
199 | Count : Count_Type := 1) | |
200 | is | |
201 | begin | |
202 | Insert (Container, No_Element, New_Item, Count); | |
203 | end Append; | |
204 | ||
205 | ------------ | |
206 | -- Assign -- | |
207 | ------------ | |
208 | ||
209 | procedure Assign (Target : in out List; Source : List) is | |
210 | SN : Node_Array renames Source.Nodes; | |
211 | J : Count_Type; | |
212 | ||
213 | begin | |
214 | if Target'Address = Source'Address then | |
215 | return; | |
216 | end if; | |
217 | ||
14f73211 | 218 | if Checks and then Target.Capacity < Source.Length then |
143eac12 MH |
219 | raise Capacity_Error -- ??? |
220 | with "Target capacity is less than Source length"; | |
221 | end if; | |
222 | ||
223 | Target.Clear; | |
224 | ||
225 | J := Source.First; | |
226 | while J /= 0 loop | |
227 | Target.Append (SN (J).Element); | |
228 | J := SN (J).Next; | |
229 | end loop; | |
230 | end Assign; | |
231 | ||
232 | ----------- | |
233 | -- Clear -- | |
234 | ----------- | |
235 | ||
236 | procedure Clear (Container : in out List) is | |
237 | N : Node_Array renames Container.Nodes; | |
238 | X : Count_Type; | |
239 | ||
240 | begin | |
241 | if Container.Length = 0 then | |
242 | pragma Assert (Container.First = 0); | |
243 | pragma Assert (Container.Last = 0); | |
14f73211 | 244 | pragma Assert (Container.TC = (Busy => 0, Lock => 0)); |
143eac12 MH |
245 | return; |
246 | end if; | |
247 | ||
248 | pragma Assert (Container.First >= 1); | |
249 | pragma Assert (Container.Last >= 1); | |
250 | pragma Assert (N (Container.First).Prev = 0); | |
251 | pragma Assert (N (Container.Last).Next = 0); | |
252 | ||
14f73211 | 253 | TC_Check (Container.TC); |
143eac12 MH |
254 | |
255 | while Container.Length > 1 loop | |
256 | X := Container.First; | |
257 | pragma Assert (N (N (X).Next).Prev = Container.First); | |
258 | ||
259 | Container.First := N (X).Next; | |
260 | N (Container.First).Prev := 0; | |
261 | ||
262 | Container.Length := Container.Length - 1; | |
263 | ||
264 | Free (Container, X); | |
265 | end loop; | |
266 | ||
267 | X := Container.First; | |
268 | pragma Assert (X = Container.Last); | |
269 | ||
270 | Container.First := 0; | |
271 | Container.Last := 0; | |
272 | Container.Length := 0; | |
273 | ||
274 | Free (Container, X); | |
275 | end Clear; | |
276 | ||
c9423ca3 AC |
277 | ------------------------ |
278 | -- Constant_Reference -- | |
279 | ------------------------ | |
280 | ||
281 | function Constant_Reference | |
282 | (Container : aliased List; | |
283 | Position : Cursor) return Constant_Reference_Type | |
284 | is | |
285 | begin | |
14f73211 | 286 | if Checks and then Position.Container = null then |
c9423ca3 | 287 | raise Constraint_Error with "Position cursor has no element"; |
14f73211 | 288 | end if; |
c9423ca3 | 289 | |
14f73211 BD |
290 | if Checks and then Position.Container /= Container'Unrestricted_Access |
291 | then | |
c9423ca3 AC |
292 | raise Program_Error with |
293 | "Position cursor designates wrong container"; | |
14f73211 | 294 | end if; |
c9423ca3 | 295 | |
14f73211 | 296 | pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); |
c9423ca3 | 297 | |
14f73211 BD |
298 | declare |
299 | N : Node_Type renames Container.Nodes (Position.Node); | |
300 | TC : constant Tamper_Counts_Access := | |
301 | Container.TC'Unrestricted_Access; | |
302 | begin | |
303 | return R : constant Constant_Reference_Type := | |
304 | (Element => N.Element'Access, | |
305 | Control => (Controlled with TC)) | |
306 | do | |
2f26abcc | 307 | Busy (TC.all); |
14f73211 BD |
308 | end return; |
309 | end; | |
c9423ca3 AC |
310 | end Constant_Reference; |
311 | ||
143eac12 MH |
312 | -------------- |
313 | -- Contains -- | |
314 | -------------- | |
315 | ||
316 | function Contains | |
317 | (Container : List; | |
318 | Item : Element_Type) return Boolean | |
319 | is | |
320 | begin | |
321 | return Find (Container, Item) /= No_Element; | |
322 | end Contains; | |
323 | ||
324 | ---------- | |
325 | -- Copy -- | |
326 | ---------- | |
327 | ||
328 | function Copy (Source : List; Capacity : Count_Type := 0) return List is | |
329 | C : Count_Type; | |
330 | ||
331 | begin | |
3815f967 AC |
332 | if Capacity < Source.Length then |
333 | if Checks and then Capacity /= 0 then | |
334 | raise Capacity_Error | |
335 | with "Requested capacity is less than Source length"; | |
336 | end if; | |
337 | ||
143eac12 | 338 | C := Source.Length; |
3815f967 | 339 | else |
143eac12 | 340 | C := Capacity; |
143eac12 MH |
341 | end if; |
342 | ||
343 | return Target : List (Capacity => C) do | |
344 | Assign (Target => Target, Source => Source); | |
345 | end return; | |
346 | end Copy; | |
347 | ||
348 | ------------ | |
349 | -- Delete -- | |
350 | ------------ | |
351 | ||
352 | procedure Delete | |
353 | (Container : in out List; | |
354 | Position : in out Cursor; | |
355 | Count : Count_Type := 1) | |
356 | is | |
357 | N : Node_Array renames Container.Nodes; | |
358 | X : Count_Type; | |
359 | ||
360 | begin | |
14f73211 | 361 | if Checks and then Position.Node = 0 then |
143eac12 MH |
362 | raise Constraint_Error with |
363 | "Position cursor has no element"; | |
364 | end if; | |
365 | ||
14f73211 BD |
366 | if Checks and then Position.Container /= Container'Unrestricted_Access |
367 | then | |
143eac12 MH |
368 | raise Program_Error with |
369 | "Position cursor designates wrong container"; | |
370 | end if; | |
371 | ||
372 | pragma Assert (Vet (Position), "bad cursor in Delete"); | |
373 | pragma Assert (Container.First >= 1); | |
374 | pragma Assert (Container.Last >= 1); | |
375 | pragma Assert (N (Container.First).Prev = 0); | |
376 | pragma Assert (N (Container.Last).Next = 0); | |
377 | ||
378 | if Position.Node = Container.First then | |
379 | Delete_First (Container, Count); | |
380 | Position := No_Element; | |
381 | return; | |
382 | end if; | |
383 | ||
384 | if Count = 0 then | |
385 | Position := No_Element; | |
386 | return; | |
387 | end if; | |
388 | ||
14f73211 | 389 | TC_Check (Container.TC); |
143eac12 MH |
390 | |
391 | for Index in 1 .. Count loop | |
392 | pragma Assert (Container.Length >= 2); | |
393 | ||
394 | X := Position.Node; | |
395 | Container.Length := Container.Length - 1; | |
396 | ||
397 | if X = Container.Last then | |
398 | Position := No_Element; | |
399 | ||
400 | Container.Last := N (X).Prev; | |
401 | N (Container.Last).Next := 0; | |
402 | ||
403 | Free (Container, X); | |
404 | return; | |
405 | end if; | |
406 | ||
407 | Position.Node := N (X).Next; | |
408 | ||
409 | N (N (X).Next).Prev := N (X).Prev; | |
410 | N (N (X).Prev).Next := N (X).Next; | |
411 | ||
412 | Free (Container, X); | |
413 | end loop; | |
414 | ||
415 | Position := No_Element; | |
416 | end Delete; | |
417 | ||
418 | ------------------ | |
419 | -- Delete_First -- | |
420 | ------------------ | |
421 | ||
422 | procedure Delete_First | |
423 | (Container : in out List; | |
424 | Count : Count_Type := 1) | |
425 | is | |
426 | N : Node_Array renames Container.Nodes; | |
427 | X : Count_Type; | |
428 | ||
429 | begin | |
430 | if Count >= Container.Length then | |
431 | Clear (Container); | |
432 | return; | |
433 | end if; | |
434 | ||
435 | if Count = 0 then | |
436 | return; | |
437 | end if; | |
438 | ||
14f73211 | 439 | TC_Check (Container.TC); |
143eac12 | 440 | |
8bfbd380 | 441 | for J in 1 .. Count loop |
143eac12 MH |
442 | X := Container.First; |
443 | pragma Assert (N (N (X).Next).Prev = Container.First); | |
444 | ||
445 | Container.First := N (X).Next; | |
446 | N (Container.First).Prev := 0; | |
447 | ||
448 | Container.Length := Container.Length - 1; | |
449 | ||
450 | Free (Container, X); | |
451 | end loop; | |
452 | end Delete_First; | |
453 | ||
454 | ----------------- | |
455 | -- Delete_Last -- | |
456 | ----------------- | |
457 | ||
458 | procedure Delete_Last | |
459 | (Container : in out List; | |
460 | Count : Count_Type := 1) | |
461 | is | |
462 | N : Node_Array renames Container.Nodes; | |
463 | X : Count_Type; | |
464 | ||
465 | begin | |
466 | if Count >= Container.Length then | |
467 | Clear (Container); | |
468 | return; | |
469 | end if; | |
470 | ||
471 | if Count = 0 then | |
472 | return; | |
473 | end if; | |
474 | ||
14f73211 | 475 | TC_Check (Container.TC); |
143eac12 | 476 | |
8bfbd380 | 477 | for J in 1 .. Count loop |
143eac12 MH |
478 | X := Container.Last; |
479 | pragma Assert (N (N (X).Prev).Next = Container.Last); | |
480 | ||
481 | Container.Last := N (X).Prev; | |
482 | N (Container.Last).Next := 0; | |
483 | ||
484 | Container.Length := Container.Length - 1; | |
485 | ||
486 | Free (Container, X); | |
487 | end loop; | |
488 | end Delete_Last; | |
489 | ||
490 | ------------- | |
491 | -- Element -- | |
492 | ------------- | |
493 | ||
494 | function Element (Position : Cursor) return Element_Type is | |
495 | begin | |
14f73211 | 496 | if Checks and then Position.Node = 0 then |
143eac12 MH |
497 | raise Constraint_Error with |
498 | "Position cursor has no element"; | |
14f73211 | 499 | end if; |
143eac12 | 500 | |
14f73211 | 501 | pragma Assert (Vet (Position), "bad cursor in Element"); |
143eac12 | 502 | |
14f73211 | 503 | return Position.Container.Nodes (Position.Node).Element; |
143eac12 MH |
504 | end Element; |
505 | ||
ef992452 AC |
506 | -------------- |
507 | -- Finalize -- | |
508 | -------------- | |
509 | ||
510 | procedure Finalize (Object : in out Iterator) is | |
511 | begin | |
512 | if Object.Container /= null then | |
14f73211 | 513 | Unbusy (Object.Container.TC); |
3bd783ec AC |
514 | end if; |
515 | end Finalize; | |
516 | ||
143eac12 MH |
517 | ---------- |
518 | -- Find -- | |
519 | ---------- | |
520 | ||
521 | function Find | |
522 | (Container : List; | |
523 | Item : Element_Type; | |
524 | Position : Cursor := No_Element) return Cursor | |
525 | is | |
526 | Nodes : Node_Array renames Container.Nodes; | |
527 | Node : Count_Type := Position.Node; | |
528 | ||
529 | begin | |
530 | if Node = 0 then | |
531 | Node := Container.First; | |
532 | ||
533 | else | |
14f73211 BD |
534 | if Checks and then Position.Container /= Container'Unrestricted_Access |
535 | then | |
143eac12 MH |
536 | raise Program_Error with |
537 | "Position cursor designates wrong container"; | |
538 | end if; | |
539 | ||
540 | pragma Assert (Vet (Position), "bad cursor in Find"); | |
541 | end if; | |
542 | ||
6c2e4047 AC |
543 | -- Per AI05-0022, the container implementation is required to detect |
544 | -- element tampering by a generic actual subprogram. | |
143eac12 | 545 | |
6c2e4047 | 546 | declare |
14f73211 | 547 | Lock : With_Lock (Container.TC'Unrestricted_Access); |
6c2e4047 | 548 | begin |
6c2e4047 AC |
549 | while Node /= 0 loop |
550 | if Nodes (Node).Element = Item then | |
14f73211 | 551 | return Cursor'(Container'Unrestricted_Access, Node); |
6c2e4047 AC |
552 | end if; |
553 | ||
554 | Node := Nodes (Node).Next; | |
555 | end loop; | |
143eac12 | 556 | |
14f73211 | 557 | return No_Element; |
6c2e4047 | 558 | end; |
143eac12 MH |
559 | end Find; |
560 | ||
561 | ----------- | |
562 | -- First -- | |
563 | ----------- | |
564 | ||
565 | function First (Container : List) return Cursor is | |
566 | begin | |
567 | if Container.First = 0 then | |
568 | return No_Element; | |
8bfbd380 AC |
569 | else |
570 | return Cursor'(Container'Unrestricted_Access, Container.First); | |
143eac12 | 571 | end if; |
143eac12 MH |
572 | end First; |
573 | ||
8cf23b91 AC |
574 | function First (Object : Iterator) return Cursor is |
575 | begin | |
595a055f MH |
576 | -- The value of the iterator object's Node component influences the |
577 | -- behavior of the First (and Last) selector function. | |
578 | ||
579 | -- When the Node component is 0, this means the iterator object was | |
580 | -- constructed without a start expression, in which case the (forward) | |
581 | -- iteration starts from the (logical) beginning of the entire sequence | |
582 | -- of items (corresponding to Container.First, for a forward iterator). | |
583 | ||
584 | -- Otherwise, this is iteration over a partial sequence of items. When | |
585 | -- the Node component is positive, the iterator object was constructed | |
586 | -- with a start expression, that specifies the position from which the | |
587 | -- (forward) partial iteration begins. | |
588 | ||
589 | if Object.Node = 0 then | |
590 | return Bounded_Doubly_Linked_Lists.First (Object.Container.all); | |
8cf23b91 | 591 | else |
595a055f | 592 | return Cursor'(Object.Container, Object.Node); |
8cf23b91 AC |
593 | end if; |
594 | end First; | |
595 | ||
143eac12 MH |
596 | ------------------- |
597 | -- First_Element -- | |
598 | ------------------- | |
599 | ||
600 | function First_Element (Container : List) return Element_Type is | |
601 | begin | |
14f73211 | 602 | if Checks and then Container.First = 0 then |
143eac12 MH |
603 | raise Constraint_Error with "list is empty"; |
604 | end if; | |
14f73211 BD |
605 | |
606 | return Container.Nodes (Container.First).Element; | |
143eac12 MH |
607 | end First_Element; |
608 | ||
609 | ---------- | |
610 | -- Free -- | |
611 | ---------- | |
612 | ||
613 | procedure Free | |
614 | (Container : in out List; | |
615 | X : Count_Type) | |
616 | is | |
617 | pragma Assert (X > 0); | |
618 | pragma Assert (X <= Container.Capacity); | |
619 | ||
620 | N : Node_Array renames Container.Nodes; | |
621 | pragma Assert (N (X).Prev >= 0); -- node is active | |
622 | ||
623 | begin | |
624 | -- The list container actually contains two lists: one for the "active" | |
625 | -- nodes that contain elements that have been inserted onto the list, | |
626 | -- and another for the "inactive" nodes for the free store. | |
0b5b2bbc | 627 | |
143eac12 MH |
628 | -- We desire that merely declaring an object should have only minimal |
629 | -- cost; specially, we want to avoid having to initialize the free | |
630 | -- store (to fill in the links), especially if the capacity is large. | |
0b5b2bbc | 631 | |
143eac12 | 632 | -- The head of the free list is indicated by Container.Free. If its |
0b5b2bbc AC |
633 | -- value is non-negative, then the free store has been initialized in |
634 | -- the "normal" way: Container.Free points to the head of the list of | |
635 | -- free (inactive) nodes, and the value 0 means the free list is empty. | |
636 | -- Each node on the free list has been initialized to point to the next | |
637 | -- free node (via its Next component), and the value 0 means that this | |
638 | -- is the last free node. | |
639 | ||
640 | -- If Container.Free is negative, then the links on the free store have | |
641 | -- not been initialized. In this case the link values are implied: the | |
642 | -- free store comprises the components of the node array started with | |
643 | -- the absolute value of Container.Free, and continuing until the end of | |
644 | -- the array (Nodes'Last). | |
645 | ||
646 | -- If the list container is manipulated on one end only (for example if | |
647 | -- the container were being used as a stack), then there is no need to | |
648 | -- initialize the free store, since the inactive nodes are physically | |
649 | -- contiguous (in fact, they lie immediately beyond the logical end | |
650 | -- being manipulated). The only time we need to actually initialize the | |
651 | -- nodes in the free store is if the node that becomes inactive is not | |
652 | -- at the end of the list. The free store would then be discontiguous | |
653 | -- and so its nodes would need to be linked in the traditional way. | |
654 | ||
143eac12 MH |
655 | -- ??? |
656 | -- It might be possible to perform an optimization here. Suppose that | |
0b5b2bbc AC |
657 | -- the free store can be represented as having two parts: one comprising |
658 | -- the non-contiguous inactive nodes linked together in the normal way, | |
659 | -- and the other comprising the contiguous inactive nodes (that are not | |
660 | -- linked together, at the end of the nodes array). This would allow us | |
661 | -- to never have to initialize the free store, except in a lazy way as | |
662 | -- nodes become inactive. | |
663 | ||
664 | -- When an element is deleted from the list container, its node becomes | |
665 | -- inactive, and so we set its Prev component to a negative value, to | |
666 | -- indicate that it is now inactive. This provides a useful way to | |
dd91386d | 667 | -- detect a dangling cursor reference (and which is used in Vet). |
143eac12 MH |
668 | |
669 | N (X).Prev := -1; -- Node is deallocated (not on active list) | |
670 | ||
671 | if Container.Free >= 0 then | |
0b5b2bbc | 672 | |
143eac12 MH |
673 | -- The free store has previously been initialized. All we need to |
674 | -- do here is link the newly-free'd node onto the free list. | |
675 | ||
676 | N (X).Next := Container.Free; | |
677 | Container.Free := X; | |
678 | ||
679 | elsif X + 1 = abs Container.Free then | |
0b5b2bbc | 680 | |
143eac12 MH |
681 | -- The free store has not been initialized, and the node becoming |
682 | -- inactive immediately precedes the start of the free store. All | |
683 | -- we need to do is move the start of the free store back by one. | |
684 | ||
e47e21c1 AC |
685 | -- Note: initializing Next to zero is not strictly necessary but |
686 | -- seems cleaner and marginally safer. | |
687 | ||
688 | N (X).Next := 0; | |
143eac12 MH |
689 | Container.Free := Container.Free + 1; |
690 | ||
691 | else | |
692 | -- The free store has not been initialized, and the node becoming | |
693 | -- inactive does not immediately precede the free store. Here we | |
694 | -- first initialize the free store (meaning the links are given | |
695 | -- values in the traditional way), and then link the newly-free'd | |
696 | -- node onto the head of the free store. | |
697 | ||
698 | -- ??? | |
0b5b2bbc AC |
699 | -- See the comments above for an optimization opportunity. If the |
700 | -- next link for a node on the free store is negative, then this | |
701 | -- means the remaining nodes on the free store are physically | |
702 | -- contiguous, starting as the absolute value of that index value. | |
143eac12 MH |
703 | |
704 | Container.Free := abs Container.Free; | |
705 | ||
706 | if Container.Free > Container.Capacity then | |
707 | Container.Free := 0; | |
708 | ||
709 | else | |
710 | for I in Container.Free .. Container.Capacity - 1 loop | |
711 | N (I).Next := I + 1; | |
712 | end loop; | |
713 | ||
714 | N (Container.Capacity).Next := 0; | |
715 | end if; | |
716 | ||
717 | N (X).Next := Container.Free; | |
718 | Container.Free := X; | |
719 | end if; | |
720 | end Free; | |
721 | ||
722 | --------------------- | |
723 | -- Generic_Sorting -- | |
724 | --------------------- | |
725 | ||
726 | package body Generic_Sorting is | |
727 | ||
728 | --------------- | |
729 | -- Is_Sorted -- | |
730 | --------------- | |
731 | ||
732 | function Is_Sorted (Container : List) return Boolean is | |
6c2e4047 AC |
733 | -- Per AI05-0022, the container implementation is required to detect |
734 | -- element tampering by a generic actual subprogram. | |
735 | ||
14f73211 | 736 | Lock : With_Lock (Container.TC'Unrestricted_Access); |
6c2e4047 | 737 | |
14f73211 BD |
738 | Nodes : Node_Array renames Container.Nodes; |
739 | Node : Count_Type; | |
740 | begin | |
6c2e4047 | 741 | Node := Container.First; |
0b5b2bbc | 742 | for J in 2 .. Container.Length loop |
143eac12 | 743 | if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then |
14f73211 | 744 | return False; |
143eac12 MH |
745 | end if; |
746 | ||
747 | Node := Nodes (Node).Next; | |
748 | end loop; | |
749 | ||
14f73211 | 750 | return True; |
143eac12 MH |
751 | end Is_Sorted; |
752 | ||
753 | ----------- | |
754 | -- Merge -- | |
755 | ----------- | |
756 | ||
757 | procedure Merge | |
758 | (Target : in out List; | |
759 | Source : in out List) | |
760 | is | |
143eac12 | 761 | begin |
4c9fe6c7 AC |
762 | -- The semantics of Merge changed slightly per AI05-0021. It was |
763 | -- originally the case that if Target and Source denoted the same | |
764 | -- container object, then the GNAT implementation of Merge did | |
765 | -- nothing. However, it was argued that RM05 did not precisely | |
766 | -- specify the semantics for this corner case. The decision of the | |
767 | -- ARG was that if Target and Source denote the same non-empty | |
768 | -- container object, then Program_Error is raised. | |
769 | ||
770 | if Source.Is_Empty then | |
143eac12 MH |
771 | return; |
772 | end if; | |
773 | ||
14f73211 | 774 | if Checks and then Target'Address = Source'Address then |
4c9fe6c7 AC |
775 | raise Program_Error with |
776 | "Target and Source denote same non-empty container"; | |
777 | end if; | |
778 | ||
14f73211 BD |
779 | if Checks and then Target.Length > Count_Type'Last - Source.Length |
780 | then | |
6c2e4047 AC |
781 | raise Constraint_Error with "new length exceeds maximum"; |
782 | end if; | |
783 | ||
14f73211 BD |
784 | if Checks and then Target.Length + Source.Length > Target.Capacity |
785 | then | |
6c2e4047 AC |
786 | raise Capacity_Error with "new length exceeds target capacity"; |
787 | end if; | |
788 | ||
14f73211 BD |
789 | TC_Check (Target.TC); |
790 | TC_Check (Source.TC); | |
143eac12 | 791 | |
6c2e4047 AC |
792 | -- Per AI05-0022, the container implementation is required to detect |
793 | -- element tampering by a generic actual subprogram. | |
143eac12 | 794 | |
6c2e4047 | 795 | declare |
14f73211 BD |
796 | Lock_Target : With_Lock (Target.TC'Unchecked_Access); |
797 | Lock_Source : With_Lock (Source.TC'Unchecked_Access); | |
143eac12 | 798 | |
6c2e4047 AC |
799 | LN : Node_Array renames Target.Nodes; |
800 | RN : Node_Array renames Source.Nodes; | |
143eac12 | 801 | |
6c2e4047 AC |
802 | LI, LJ, RI, RJ : Count_Type; |
803 | ||
804 | begin | |
6c2e4047 AC |
805 | LI := Target.First; |
806 | RI := Source.First; | |
807 | while RI /= 0 loop | |
808 | pragma Assert (RN (RI).Next = 0 | |
809 | or else not (RN (RN (RI).Next).Element < | |
810 | RN (RI).Element)); | |
811 | ||
812 | if LI = 0 then | |
813 | Splice_Internal (Target, 0, Source); | |
814 | exit; | |
815 | end if; | |
816 | ||
817 | pragma Assert (LN (LI).Next = 0 | |
818 | or else not (LN (LN (LI).Next).Element < | |
819 | LN (LI).Element)); | |
820 | ||
821 | if RN (RI).Element < LN (LI).Element then | |
822 | RJ := RI; | |
823 | RI := RN (RI).Next; | |
824 | Splice_Internal (Target, LI, Source, RJ, LJ); | |
825 | ||
826 | else | |
827 | LI := LN (LI).Next; | |
828 | end if; | |
829 | end loop; | |
6c2e4047 | 830 | end; |
143eac12 MH |
831 | end Merge; |
832 | ||
833 | ---------- | |
834 | -- Sort -- | |
835 | ---------- | |
836 | ||
837 | procedure Sort (Container : in out List) is | |
838 | N : Node_Array renames Container.Nodes; | |
839 | ||
840 | procedure Partition (Pivot, Back : Count_Type); | |
0b5b2bbc | 841 | -- What does this do ??? |
143eac12 MH |
842 | |
843 | procedure Sort (Front, Back : Count_Type); | |
0b5b2bbc | 844 | -- Internal procedure, what does it do??? rename it??? |
143eac12 MH |
845 | |
846 | --------------- | |
847 | -- Partition -- | |
848 | --------------- | |
849 | ||
850 | procedure Partition (Pivot, Back : Count_Type) is | |
0b5b2bbc | 851 | Node : Count_Type; |
143eac12 MH |
852 | |
853 | begin | |
0b5b2bbc | 854 | Node := N (Pivot).Next; |
143eac12 MH |
855 | while Node /= Back loop |
856 | if N (Node).Element < N (Pivot).Element then | |
857 | declare | |
858 | Prev : constant Count_Type := N (Node).Prev; | |
859 | Next : constant Count_Type := N (Node).Next; | |
860 | ||
861 | begin | |
862 | N (Prev).Next := Next; | |
863 | ||
864 | if Next = 0 then | |
865 | Container.Last := Prev; | |
866 | else | |
867 | N (Next).Prev := Prev; | |
868 | end if; | |
869 | ||
870 | N (Node).Next := Pivot; | |
871 | N (Node).Prev := N (Pivot).Prev; | |
872 | ||
873 | N (Pivot).Prev := Node; | |
874 | ||
875 | if N (Node).Prev = 0 then | |
876 | Container.First := Node; | |
877 | else | |
878 | N (N (Node).Prev).Next := Node; | |
879 | end if; | |
880 | ||
881 | Node := Next; | |
882 | end; | |
883 | ||
884 | else | |
885 | Node := N (Node).Next; | |
886 | end if; | |
887 | end loop; | |
888 | end Partition; | |
889 | ||
890 | ---------- | |
891 | -- Sort -- | |
892 | ---------- | |
893 | ||
894 | procedure Sort (Front, Back : Count_Type) is | |
895 | Pivot : constant Count_Type := | |
15f0f591 | 896 | (if Front = 0 then Container.First else N (Front).Next); |
143eac12 MH |
897 | begin |
898 | if Pivot /= Back then | |
899 | Partition (Pivot, Back); | |
900 | Sort (Front, Pivot); | |
901 | Sort (Pivot, Back); | |
902 | end if; | |
903 | end Sort; | |
904 | ||
905 | -- Start of processing for Sort | |
906 | ||
907 | begin | |
908 | if Container.Length <= 1 then | |
909 | return; | |
910 | end if; | |
911 | ||
912 | pragma Assert (N (Container.First).Prev = 0); | |
913 | pragma Assert (N (Container.Last).Next = 0); | |
914 | ||
14f73211 | 915 | TC_Check (Container.TC); |
143eac12 | 916 | |
6c2e4047 AC |
917 | -- Per AI05-0022, the container implementation is required to detect |
918 | -- element tampering by a generic actual subprogram. | |
919 | ||
920 | declare | |
14f73211 | 921 | Lock : With_Lock (Container.TC'Unchecked_Access); |
6c2e4047 | 922 | begin |
6c2e4047 | 923 | Sort (Front => 0, Back => 0); |
6c2e4047 | 924 | end; |
143eac12 MH |
925 | |
926 | pragma Assert (N (Container.First).Prev = 0); | |
927 | pragma Assert (N (Container.Last).Next = 0); | |
928 | end Sort; | |
929 | ||
930 | end Generic_Sorting; | |
931 | ||
14f73211 BD |
932 | ------------------------ |
933 | -- Get_Element_Access -- | |
934 | ------------------------ | |
935 | ||
936 | function Get_Element_Access | |
937 | (Position : Cursor) return not null Element_Access is | |
938 | begin | |
939 | return Position.Container.Nodes (Position.Node).Element'Access; | |
940 | end Get_Element_Access; | |
941 | ||
143eac12 MH |
942 | ----------------- |
943 | -- Has_Element -- | |
944 | ----------------- | |
945 | ||
946 | function Has_Element (Position : Cursor) return Boolean is | |
947 | begin | |
948 | pragma Assert (Vet (Position), "bad cursor in Has_Element"); | |
949 | return Position.Node /= 0; | |
950 | end Has_Element; | |
951 | ||
952 | ------------ | |
953 | -- Insert -- | |
954 | ------------ | |
955 | ||
956 | procedure Insert | |
957 | (Container : in out List; | |
958 | Before : Cursor; | |
959 | New_Item : Element_Type; | |
960 | Position : out Cursor; | |
961 | Count : Count_Type := 1) | |
962 | is | |
f8c59c05 AC |
963 | First_Node : Count_Type; |
964 | New_Node : Count_Type; | |
143eac12 MH |
965 | |
966 | begin | |
967 | if Before.Container /= null then | |
14f73211 BD |
968 | if Checks and then Before.Container /= Container'Unrestricted_Access |
969 | then | |
143eac12 MH |
970 | raise Program_Error with |
971 | "Before cursor designates wrong list"; | |
972 | end if; | |
973 | ||
974 | pragma Assert (Vet (Before), "bad cursor in Insert"); | |
975 | end if; | |
976 | ||
977 | if Count = 0 then | |
978 | Position := Before; | |
979 | return; | |
980 | end if; | |
981 | ||
14f73211 | 982 | if Checks and then Container.Length > Container.Capacity - Count then |
350b83cc | 983 | raise Capacity_Error with "capacity exceeded"; |
143eac12 MH |
984 | end if; |
985 | ||
14f73211 | 986 | TC_Check (Container.TC); |
143eac12 MH |
987 | |
988 | Allocate (Container, New_Item, New_Node); | |
f8c59c05 AC |
989 | First_Node := New_Node; |
990 | Insert_Internal (Container, Before.Node, New_Node); | |
143eac12 MH |
991 | |
992 | for Index in Count_Type'(2) .. Count loop | |
f8c59c05 AC |
993 | Allocate (Container, New_Item, New_Node); |
994 | Insert_Internal (Container, Before.Node, New_Node); | |
143eac12 | 995 | end loop; |
f8c59c05 AC |
996 | |
997 | Position := Cursor'(Container'Unchecked_Access, First_Node); | |
143eac12 MH |
998 | end Insert; |
999 | ||
1000 | procedure Insert | |
1001 | (Container : in out List; | |
1002 | Before : Cursor; | |
1003 | New_Item : Element_Type; | |
1004 | Count : Count_Type := 1) | |
1005 | is | |
1006 | Position : Cursor; | |
1007 | pragma Unreferenced (Position); | |
1008 | begin | |
1009 | Insert (Container, Before, New_Item, Position, Count); | |
1010 | end Insert; | |
1011 | ||
1012 | procedure Insert | |
1013 | (Container : in out List; | |
1014 | Before : Cursor; | |
1015 | Position : out Cursor; | |
1016 | Count : Count_Type := 1) | |
1017 | is | |
63a5b3dc | 1018 | pragma Warnings (Off); |
b7051481 AC |
1019 | Default_Initialized_Item : Element_Type; |
1020 | pragma Unmodified (Default_Initialized_Item); | |
63a5b3dc | 1021 | -- OK to reference, see below. Note that we need to suppress both the |
b7051481 AC |
1022 | -- front end warning and the back end warning. In addition, pragma |
1023 | -- Unmodified is needed to suppress the warning ``actual type for | |
1024 | -- "Element_Type" should be fully initialized type'' on certain | |
1025 | -- instantiations. | |
143eac12 MH |
1026 | |
1027 | begin | |
3e586e10 AC |
1028 | -- There is no explicit element provided, but in an instance the element |
1029 | -- type may be a scalar with a Default_Value aspect, or a composite | |
1030 | -- type with such a scalar component, or components with default | |
1031 | -- initialization, so insert the specified number of possibly | |
1032 | -- initialized elements at the given position. | |
143eac12 | 1033 | |
b7051481 | 1034 | Insert (Container, Before, Default_Initialized_Item, Position, Count); |
3815f967 | 1035 | pragma Warnings (On); |
143eac12 MH |
1036 | end Insert; |
1037 | ||
1038 | --------------------- | |
1039 | -- Insert_Internal -- | |
1040 | --------------------- | |
1041 | ||
1042 | procedure Insert_Internal | |
1043 | (Container : in out List; | |
1044 | Before : Count_Type; | |
1045 | New_Node : Count_Type) | |
1046 | is | |
1047 | N : Node_Array renames Container.Nodes; | |
1048 | ||
1049 | begin | |
1050 | if Container.Length = 0 then | |
1051 | pragma Assert (Before = 0); | |
1052 | pragma Assert (Container.First = 0); | |
1053 | pragma Assert (Container.Last = 0); | |
1054 | ||
1055 | Container.First := New_Node; | |
1056 | N (Container.First).Prev := 0; | |
1057 | ||
1058 | Container.Last := New_Node; | |
1059 | N (Container.Last).Next := 0; | |
1060 | ||
e47e21c1 AC |
1061 | -- Before = zero means append |
1062 | ||
1063 | elsif Before = 0 then | |
143eac12 MH |
1064 | pragma Assert (N (Container.Last).Next = 0); |
1065 | ||
1066 | N (Container.Last).Next := New_Node; | |
1067 | N (New_Node).Prev := Container.Last; | |
1068 | ||
1069 | Container.Last := New_Node; | |
1070 | N (Container.Last).Next := 0; | |
1071 | ||
e47e21c1 AC |
1072 | -- Before = Container.First means prepend |
1073 | ||
1074 | elsif Before = Container.First then | |
143eac12 MH |
1075 | pragma Assert (N (Container.First).Prev = 0); |
1076 | ||
1077 | N (Container.First).Prev := New_Node; | |
1078 | N (New_Node).Next := Container.First; | |
1079 | ||
1080 | Container.First := New_Node; | |
1081 | N (Container.First).Prev := 0; | |
1082 | ||
1083 | else | |
1084 | pragma Assert (N (Container.First).Prev = 0); | |
1085 | pragma Assert (N (Container.Last).Next = 0); | |
1086 | ||
1087 | N (New_Node).Next := Before; | |
1088 | N (New_Node).Prev := N (Before).Prev; | |
1089 | ||
1090 | N (N (Before).Prev).Next := New_Node; | |
1091 | N (Before).Prev := New_Node; | |
1092 | end if; | |
1093 | ||
1094 | Container.Length := Container.Length + 1; | |
1095 | end Insert_Internal; | |
1096 | ||
1097 | -------------- | |
1098 | -- Is_Empty -- | |
1099 | -------------- | |
1100 | ||
1101 | function Is_Empty (Container : List) return Boolean is | |
1102 | begin | |
1103 | return Container.Length = 0; | |
1104 | end Is_Empty; | |
1105 | ||
1106 | ------------- | |
1107 | -- Iterate -- | |
1108 | ------------- | |
1109 | ||
1110 | procedure Iterate | |
1111 | (Container : List; | |
1112 | Process : not null access procedure (Position : Cursor)) | |
1113 | is | |
14f73211 | 1114 | Busy : With_Busy (Container.TC'Unrestricted_Access); |
143eac12 MH |
1115 | Node : Count_Type := Container.First; |
1116 | ||
1117 | begin | |
14f73211 BD |
1118 | while Node /= 0 loop |
1119 | Process (Cursor'(Container'Unrestricted_Access, Node)); | |
1120 | Node := Container.Nodes (Node).Next; | |
1121 | end loop; | |
143eac12 MH |
1122 | end Iterate; |
1123 | ||
e0c32166 AC |
1124 | function Iterate |
1125 | (Container : List) | |
595a055f | 1126 | return List_Iterator_Interfaces.Reversible_Iterator'Class |
8cf23b91 AC |
1127 | is |
1128 | begin | |
595a055f MH |
1129 | -- The value of the Node component influences the behavior of the First |
1130 | -- and Last selector functions of the iterator object. When the Node | |
1131 | -- component is 0 (as is the case here), this means the iterator | |
1132 | -- object was constructed without a start expression. This is a | |
1133 | -- complete iterator, meaning that the iteration starts from the | |
1134 | -- (logical) beginning of the sequence of items. | |
1135 | ||
1136 | -- Note: For a forward iterator, Container.First is the beginning, and | |
1137 | -- for a reverse iterator, Container.Last is the beginning. | |
1138 | ||
ef992452 | 1139 | return It : constant Iterator := |
8bfbd380 AC |
1140 | Iterator'(Limited_Controlled with |
1141 | Container => Container'Unrestricted_Access, | |
1142 | Node => 0) | |
ef992452 | 1143 | do |
14f73211 | 1144 | Busy (Container.TC'Unrestricted_Access.all); |
ef992452 | 1145 | end return; |
8cf23b91 AC |
1146 | end Iterate; |
1147 | ||
e0c32166 AC |
1148 | function Iterate |
1149 | (Container : List; | |
1150 | Start : Cursor) | |
1151 | return List_Iterator_Interfaces.Reversible_Iterator'class | |
8cf23b91 | 1152 | is |
8cf23b91 | 1153 | begin |
595a055f MH |
1154 | -- It was formerly the case that when Start = No_Element, the partial |
1155 | -- iterator was defined to behave the same as for a complete iterator, | |
1156 | -- and iterate over the entire sequence of items. However, those | |
1157 | -- semantics were unintuitive and arguably error-prone (it is too easy | |
1158 | -- to accidentally create an endless loop), and so they were changed, | |
1159 | -- per the ARG meeting in Denver on 2011/11. However, there was no | |
1160 | -- consensus about what positive meaning this corner case should have, | |
1161 | -- and so it was decided to simply raise an exception. This does imply, | |
1162 | -- however, that it is not possible to use a partial iterator to specify | |
1163 | -- an empty sequence of items. | |
1164 | ||
14f73211 | 1165 | if Checks and then Start = No_Element then |
595a055f MH |
1166 | raise Constraint_Error with |
1167 | "Start position for iterator equals No_Element"; | |
1168 | end if; | |
1169 | ||
14f73211 | 1170 | if Checks and then Start.Container /= Container'Unrestricted_Access then |
595a055f MH |
1171 | raise Program_Error with |
1172 | "Start cursor of Iterate designates wrong list"; | |
1173 | end if; | |
1174 | ||
1175 | pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); | |
1176 | ||
1177 | -- The value of the Node component influences the behavior of the First | |
1178 | -- and Last selector functions of the iterator object. When the Node | |
1179 | -- component is positive (as is the case here), it means that this | |
1180 | -- is a partial iteration, over a subset of the complete sequence of | |
1181 | -- items. The iterator object was constructed with a start expression, | |
1182 | -- indicating the position from which the iteration begins. Note that | |
1183 | -- the start position has the same value irrespective of whether this | |
1184 | -- is a forward or reverse iteration. | |
1185 | ||
ef992452 | 1186 | return It : constant Iterator := |
15f0f591 AC |
1187 | Iterator'(Limited_Controlled with |
1188 | Container => Container'Unrestricted_Access, | |
1189 | Node => Start.Node) | |
ef992452 | 1190 | do |
14f73211 | 1191 | Busy (Container.TC'Unrestricted_Access.all); |
ef992452 | 1192 | end return; |
8cf23b91 AC |
1193 | end Iterate; |
1194 | ||
143eac12 MH |
1195 | ---------- |
1196 | -- Last -- | |
1197 | ---------- | |
1198 | ||
1199 | function Last (Container : List) return Cursor is | |
1200 | begin | |
1201 | if Container.Last = 0 then | |
1202 | return No_Element; | |
8bfbd380 AC |
1203 | else |
1204 | return Cursor'(Container'Unrestricted_Access, Container.Last); | |
143eac12 | 1205 | end if; |
143eac12 MH |
1206 | end Last; |
1207 | ||
8cf23b91 AC |
1208 | function Last (Object : Iterator) return Cursor is |
1209 | begin | |
595a055f MH |
1210 | -- The value of the iterator object's Node component influences the |
1211 | -- behavior of the Last (and First) selector function. | |
1212 | ||
1213 | -- When the Node component is 0, this means the iterator object was | |
1214 | -- constructed without a start expression, in which case the (reverse) | |
1215 | -- iteration starts from the (logical) beginning of the entire sequence | |
1216 | -- (corresponding to Container.Last, for a reverse iterator). | |
1217 | ||
1218 | -- Otherwise, this is iteration over a partial sequence of items. When | |
1219 | -- the Node component is positive, the iterator object was constructed | |
1220 | -- with a start expression, that specifies the position from which the | |
1221 | -- (reverse) partial iteration begins. | |
1222 | ||
1223 | if Object.Node = 0 then | |
1224 | return Bounded_Doubly_Linked_Lists.Last (Object.Container.all); | |
8cf23b91 | 1225 | else |
595a055f | 1226 | return Cursor'(Object.Container, Object.Node); |
8cf23b91 AC |
1227 | end if; |
1228 | end Last; | |
1229 | ||
143eac12 MH |
1230 | ------------------ |
1231 | -- Last_Element -- | |
1232 | ------------------ | |
1233 | ||
1234 | function Last_Element (Container : List) return Element_Type is | |
1235 | begin | |
14f73211 | 1236 | if Checks and then Container.Last = 0 then |
143eac12 MH |
1237 | raise Constraint_Error with "list is empty"; |
1238 | end if; | |
14f73211 BD |
1239 | |
1240 | return Container.Nodes (Container.Last).Element; | |
143eac12 MH |
1241 | end Last_Element; |
1242 | ||
1243 | ------------ | |
1244 | -- Length -- | |
1245 | ------------ | |
1246 | ||
1247 | function Length (Container : List) return Count_Type is | |
1248 | begin | |
1249 | return Container.Length; | |
1250 | end Length; | |
1251 | ||
1252 | ---------- | |
1253 | -- Move -- | |
1254 | ---------- | |
1255 | ||
1256 | procedure Move | |
1257 | (Target : in out List; | |
1258 | Source : in out List) | |
1259 | is | |
1260 | N : Node_Array renames Source.Nodes; | |
1261 | X : Count_Type; | |
1262 | ||
1263 | begin | |
1264 | if Target'Address = Source'Address then | |
1265 | return; | |
1266 | end if; | |
1267 | ||
14f73211 | 1268 | if Checks and then Target.Capacity < Source.Length then |
143eac12 MH |
1269 | raise Capacity_Error with "Source length exceeds Target capacity"; |
1270 | end if; | |
1271 | ||
14f73211 | 1272 | TC_Check (Source.TC); |
143eac12 | 1273 | |
bdf69d33 | 1274 | -- Clear target, note that this checks busy bits of Target |
03e1048e | 1275 | |
bdf69d33 | 1276 | Clear (Target); |
03e1048e | 1277 | |
bdf69d33 | 1278 | while Source.Length > 1 loop |
03e1048e AC |
1279 | pragma Assert (Source.First in 1 .. Source.Capacity); |
1280 | pragma Assert (Source.Last /= Source.First); | |
1281 | pragma Assert (N (Source.First).Prev = 0); | |
1282 | pragma Assert (N (Source.Last).Next = 0); | |
1283 | ||
1284 | -- Copy first element from Source to Target | |
143eac12 | 1285 | |
143eac12 MH |
1286 | X := Source.First; |
1287 | Append (Target, N (X).Element); | |
1288 | ||
03e1048e AC |
1289 | -- Unlink first node of Source |
1290 | ||
143eac12 MH |
1291 | Source.First := N (X).Next; |
1292 | N (Source.First).Prev := 0; | |
1293 | ||
1294 | Source.Length := Source.Length - 1; | |
03e1048e AC |
1295 | |
1296 | -- The representation invariants for Source have been restored. It is | |
1297 | -- now safe to free the unlinked node, without fear of corrupting the | |
1298 | -- active links of Source. | |
1299 | ||
1300 | -- Note that the algorithm we use here models similar algorithms used | |
1301 | -- in the unbounded form of the doubly-linked list container. In that | |
1302 | -- case, Free is an instantation of Unchecked_Deallocation, which can | |
1303 | -- fail (because PE will be raised if controlled Finalize fails), so | |
bdf69d33 AC |
1304 | -- we must defer the call until the last step. Here in the bounded |
1305 | -- form, Free merely links the node we have just "deallocated" onto a | |
1306 | -- list of inactive nodes, so technically Free cannot fail. However, | |
1307 | -- for consistency, we handle Free the same way here as we do for the | |
1308 | -- unbounded form, with the pessimistic assumption that it can fail. | |
03e1048e | 1309 | |
143eac12 MH |
1310 | Free (Source, X); |
1311 | end loop; | |
03e1048e AC |
1312 | |
1313 | if Source.Length = 1 then | |
03e1048e AC |
1314 | pragma Assert (Source.First in 1 .. Source.Capacity); |
1315 | pragma Assert (Source.Last = Source.First); | |
1316 | pragma Assert (N (Source.First).Prev = 0); | |
1317 | pragma Assert (N (Source.Last).Next = 0); | |
1318 | ||
1319 | -- Copy element from Source to Target | |
1320 | ||
1321 | X := Source.First; | |
1322 | Append (Target, N (X).Element); | |
1323 | ||
1324 | -- Unlink node of Source | |
1325 | ||
1326 | Source.First := 0; | |
1327 | Source.Last := 0; | |
1328 | Source.Length := 0; | |
1329 | ||
1330 | -- Return the unlinked node to the free store | |
1331 | ||
1332 | Free (Source, X); | |
1333 | end if; | |
143eac12 MH |
1334 | end Move; |
1335 | ||
1336 | ---------- | |
1337 | -- Next -- | |
1338 | ---------- | |
1339 | ||
1340 | procedure Next (Position : in out Cursor) is | |
1341 | begin | |
1342 | Position := Next (Position); | |
1343 | end Next; | |
1344 | ||
1345 | function Next (Position : Cursor) return Cursor is | |
1346 | begin | |
1347 | if Position.Node = 0 then | |
1348 | return No_Element; | |
1349 | end if; | |
1350 | ||
1351 | pragma Assert (Vet (Position), "bad cursor in Next"); | |
1352 | ||
1353 | declare | |
1354 | Nodes : Node_Array renames Position.Container.Nodes; | |
1355 | Node : constant Count_Type := Nodes (Position.Node).Next; | |
1356 | begin | |
1357 | if Node = 0 then | |
1358 | return No_Element; | |
8bfbd380 AC |
1359 | else |
1360 | return Cursor'(Position.Container, Node); | |
143eac12 | 1361 | end if; |
143eac12 MH |
1362 | end; |
1363 | end Next; | |
1364 | ||
8cf23b91 AC |
1365 | function Next |
1366 | (Object : Iterator; | |
1367 | Position : Cursor) return Cursor | |
1368 | is | |
8cf23b91 | 1369 | begin |
595a055f | 1370 | if Position.Container = null then |
8cf23b91 | 1371 | return No_Element; |
14f73211 BD |
1372 | end if; |
1373 | ||
1374 | if Checks and then Position.Container /= Object.Container then | |
595a055f MH |
1375 | raise Program_Error with |
1376 | "Position cursor of Next designates wrong list"; | |
1377 | end if; | |
14f73211 BD |
1378 | |
1379 | return Next (Position); | |
8cf23b91 AC |
1380 | end Next; |
1381 | ||
143eac12 MH |
1382 | ------------- |
1383 | -- Prepend -- | |
1384 | ------------- | |
1385 | ||
1386 | procedure Prepend | |
1387 | (Container : in out List; | |
1388 | New_Item : Element_Type; | |
1389 | Count : Count_Type := 1) | |
1390 | is | |
1391 | begin | |
1392 | Insert (Container, First (Container), New_Item, Count); | |
1393 | end Prepend; | |
1394 | ||
1395 | -------------- | |
1396 | -- Previous -- | |
1397 | -------------- | |
1398 | ||
1399 | procedure Previous (Position : in out Cursor) is | |
1400 | begin | |
1401 | Position := Previous (Position); | |
1402 | end Previous; | |
1403 | ||
1404 | function Previous (Position : Cursor) return Cursor is | |
1405 | begin | |
1406 | if Position.Node = 0 then | |
1407 | return No_Element; | |
1408 | end if; | |
1409 | ||
1410 | pragma Assert (Vet (Position), "bad cursor in Previous"); | |
1411 | ||
1412 | declare | |
1413 | Nodes : Node_Array renames Position.Container.Nodes; | |
1414 | Node : constant Count_Type := Nodes (Position.Node).Prev; | |
1415 | begin | |
1416 | if Node = 0 then | |
1417 | return No_Element; | |
8bfbd380 AC |
1418 | else |
1419 | return Cursor'(Position.Container, Node); | |
143eac12 | 1420 | end if; |
143eac12 MH |
1421 | end; |
1422 | end Previous; | |
1423 | ||
8cf23b91 AC |
1424 | function Previous |
1425 | (Object : Iterator; | |
1426 | Position : Cursor) return Cursor | |
1427 | is | |
8cf23b91 | 1428 | begin |
595a055f | 1429 | if Position.Container = null then |
8cf23b91 | 1430 | return No_Element; |
14f73211 BD |
1431 | end if; |
1432 | ||
1433 | if Checks and then Position.Container /= Object.Container then | |
595a055f MH |
1434 | raise Program_Error with |
1435 | "Position cursor of Previous designates wrong list"; | |
1436 | end if; | |
14f73211 BD |
1437 | |
1438 | return Previous (Position); | |
8cf23b91 AC |
1439 | end Previous; |
1440 | ||
14f73211 BD |
1441 | ---------------------- |
1442 | -- Pseudo_Reference -- | |
1443 | ---------------------- | |
1444 | ||
1445 | function Pseudo_Reference | |
1446 | (Container : aliased List'Class) return Reference_Control_Type | |
1447 | is | |
1448 | TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; | |
1449 | begin | |
1450 | return R : constant Reference_Control_Type := (Controlled with TC) do | |
2f26abcc | 1451 | Busy (TC.all); |
14f73211 BD |
1452 | end return; |
1453 | end Pseudo_Reference; | |
1454 | ||
143eac12 MH |
1455 | ------------------- |
1456 | -- Query_Element -- | |
1457 | ------------------- | |
1458 | ||
1459 | procedure Query_Element | |
1460 | (Position : Cursor; | |
1461 | Process : not null access procedure (Element : Element_Type)) | |
1462 | is | |
1463 | begin | |
14f73211 | 1464 | if Checks and then Position.Node = 0 then |
143eac12 MH |
1465 | raise Constraint_Error with |
1466 | "Position cursor has no element"; | |
1467 | end if; | |
1468 | ||
1469 | pragma Assert (Vet (Position), "bad cursor in Query_Element"); | |
1470 | ||
1471 | declare | |
14f73211 | 1472 | Lock : With_Lock (Position.Container.TC'Unrestricted_Access); |
143eac12 | 1473 | C : List renames Position.Container.all'Unrestricted_Access.all; |
14f73211 | 1474 | N : Node_Type renames C.Nodes (Position.Node); |
143eac12 | 1475 | begin |
14f73211 | 1476 | Process (N.Element); |
143eac12 MH |
1477 | end; |
1478 | end Query_Element; | |
1479 | ||
1480 | ---------- | |
1481 | -- Read -- | |
1482 | ---------- | |
1483 | ||
1484 | procedure Read | |
1485 | (Stream : not null access Root_Stream_Type'Class; | |
1486 | Item : out List) | |
1487 | is | |
1488 | N : Count_Type'Base; | |
1489 | X : Count_Type; | |
1490 | ||
1491 | begin | |
1492 | Clear (Item); | |
1493 | Count_Type'Base'Read (Stream, N); | |
1494 | ||
14f73211 | 1495 | if Checks and then N < 0 then |
143eac12 | 1496 | raise Program_Error with "bad list length (corrupt stream)"; |
14f73211 | 1497 | end if; |
143eac12 | 1498 | |
14f73211 | 1499 | if N = 0 then |
143eac12 | 1500 | return; |
14f73211 | 1501 | end if; |
143eac12 | 1502 | |
14f73211 | 1503 | if Checks and then N > Item.Capacity then |
143eac12 | 1504 | raise Constraint_Error with "length exceeds capacity"; |
8bfbd380 | 1505 | end if; |
14f73211 BD |
1506 | |
1507 | for Idx in 1 .. N loop | |
1508 | Allocate (Item, Stream, New_Node => X); | |
1509 | Insert_Internal (Item, Before => 0, New_Node => X); | |
1510 | end loop; | |
143eac12 MH |
1511 | end Read; |
1512 | ||
1513 | procedure Read | |
1514 | (Stream : not null access Root_Stream_Type'Class; | |
1515 | Item : out Cursor) | |
1516 | is | |
1517 | begin | |
1518 | raise Program_Error with "attempt to stream list cursor"; | |
1519 | end Read; | |
1520 | ||
8cf23b91 AC |
1521 | procedure Read |
1522 | (Stream : not null access Root_Stream_Type'Class; | |
1523 | Item : out Reference_Type) | |
1524 | is | |
1525 | begin | |
1526 | raise Program_Error with "attempt to stream reference"; | |
1527 | end Read; | |
1528 | ||
1529 | procedure Read | |
1530 | (Stream : not null access Root_Stream_Type'Class; | |
1531 | Item : out Constant_Reference_Type) | |
1532 | is | |
1533 | begin | |
1534 | raise Program_Error with "attempt to stream reference"; | |
1535 | end Read; | |
1536 | ||
1537 | --------------- | |
1538 | -- Reference -- | |
1539 | --------------- | |
1540 | ||
d781a615 | 1541 | function Reference |
c9423ca3 | 1542 | (Container : aliased in out List; |
d781a615 AC |
1543 | Position : Cursor) return Reference_Type |
1544 | is | |
8cf23b91 | 1545 | begin |
14f73211 | 1546 | if Checks and then Position.Container = null then |
8cf23b91 | 1547 | raise Constraint_Error with "Position cursor has no element"; |
14f73211 | 1548 | end if; |
8cf23b91 | 1549 | |
14f73211 BD |
1550 | if Checks and then Position.Container /= Container'Unrestricted_Access |
1551 | then | |
c9423ca3 AC |
1552 | raise Program_Error with |
1553 | "Position cursor designates wrong container"; | |
14f73211 | 1554 | end if; |
c9423ca3 | 1555 | |
14f73211 | 1556 | pragma Assert (Vet (Position), "bad cursor in function Reference"); |
c9423ca3 | 1557 | |
14f73211 BD |
1558 | declare |
1559 | N : Node_Type renames Container.Nodes (Position.Node); | |
1560 | TC : constant Tamper_Counts_Access := | |
1561 | Container.TC'Unrestricted_Access; | |
1562 | begin | |
1563 | return R : constant Reference_Type := | |
1564 | (Element => N.Element'Access, | |
1565 | Control => (Controlled with TC)) | |
1566 | do | |
2f26abcc | 1567 | Busy (TC.all); |
14f73211 BD |
1568 | end return; |
1569 | end; | |
8cf23b91 AC |
1570 | end Reference; |
1571 | ||
143eac12 MH |
1572 | --------------------- |
1573 | -- Replace_Element -- | |
1574 | --------------------- | |
1575 | ||
1576 | procedure Replace_Element | |
1577 | (Container : in out List; | |
1578 | Position : Cursor; | |
1579 | New_Item : Element_Type) | |
1580 | is | |
1581 | begin | |
14f73211 | 1582 | if Checks and then Position.Container = null then |
143eac12 | 1583 | raise Constraint_Error with "Position cursor has no element"; |
14f73211 | 1584 | end if; |
143eac12 | 1585 | |
14f73211 | 1586 | if Checks and then Position.Container /= Container'Unchecked_Access then |
143eac12 MH |
1587 | raise Program_Error with |
1588 | "Position cursor designates wrong container"; | |
14f73211 | 1589 | end if; |
143eac12 | 1590 | |
14f73211 | 1591 | TE_Check (Container.TC); |
143eac12 | 1592 | |
14f73211 | 1593 | pragma Assert (Vet (Position), "bad cursor in Replace_Element"); |
143eac12 | 1594 | |
14f73211 | 1595 | Container.Nodes (Position.Node).Element := New_Item; |
143eac12 MH |
1596 | end Replace_Element; |
1597 | ||
1598 | ---------------------- | |
1599 | -- Reverse_Elements -- | |
1600 | ---------------------- | |
1601 | ||
1602 | procedure Reverse_Elements (Container : in out List) is | |
1603 | N : Node_Array renames Container.Nodes; | |
1604 | I : Count_Type := Container.First; | |
1605 | J : Count_Type := Container.Last; | |
1606 | ||
1607 | procedure Swap (L, R : Count_Type); | |
1608 | ||
1609 | ---------- | |
1610 | -- Swap -- | |
1611 | ---------- | |
1612 | ||
1613 | procedure Swap (L, R : Count_Type) is | |
1614 | LN : constant Count_Type := N (L).Next; | |
1615 | LP : constant Count_Type := N (L).Prev; | |
1616 | ||
1617 | RN : constant Count_Type := N (R).Next; | |
1618 | RP : constant Count_Type := N (R).Prev; | |
1619 | ||
1620 | begin | |
1621 | if LP /= 0 then | |
1622 | N (LP).Next := R; | |
1623 | end if; | |
1624 | ||
1625 | if RN /= 0 then | |
1626 | N (RN).Prev := L; | |
1627 | end if; | |
1628 | ||
1629 | N (L).Next := RN; | |
1630 | N (R).Prev := LP; | |
1631 | ||
1632 | if LN = R then | |
1633 | pragma Assert (RP = L); | |
1634 | ||
1635 | N (L).Prev := R; | |
1636 | N (R).Next := L; | |
1637 | ||
1638 | else | |
1639 | N (L).Prev := RP; | |
1640 | N (RP).Next := L; | |
1641 | ||
1642 | N (R).Next := LN; | |
1643 | N (LN).Prev := R; | |
1644 | end if; | |
1645 | end Swap; | |
1646 | ||
1647 | -- Start of processing for Reverse_Elements | |
1648 | ||
1649 | begin | |
1650 | if Container.Length <= 1 then | |
1651 | return; | |
1652 | end if; | |
1653 | ||
1654 | pragma Assert (N (Container.First).Prev = 0); | |
1655 | pragma Assert (N (Container.Last).Next = 0); | |
1656 | ||
14f73211 | 1657 | TC_Check (Container.TC); |
143eac12 MH |
1658 | |
1659 | Container.First := J; | |
1660 | Container.Last := I; | |
1661 | loop | |
1662 | Swap (L => I, R => J); | |
1663 | ||
1664 | J := N (J).Next; | |
1665 | exit when I = J; | |
1666 | ||
1667 | I := N (I).Prev; | |
1668 | exit when I = J; | |
1669 | ||
1670 | Swap (L => J, R => I); | |
1671 | ||
1672 | I := N (I).Next; | |
1673 | exit when I = J; | |
1674 | ||
1675 | J := N (J).Prev; | |
1676 | exit when I = J; | |
1677 | end loop; | |
1678 | ||
1679 | pragma Assert (N (Container.First).Prev = 0); | |
1680 | pragma Assert (N (Container.Last).Next = 0); | |
1681 | end Reverse_Elements; | |
1682 | ||
1683 | ------------------ | |
1684 | -- Reverse_Find -- | |
1685 | ------------------ | |
1686 | ||
1687 | function Reverse_Find | |
1688 | (Container : List; | |
1689 | Item : Element_Type; | |
1690 | Position : Cursor := No_Element) return Cursor | |
1691 | is | |
1692 | Node : Count_Type := Position.Node; | |
1693 | ||
1694 | begin | |
1695 | if Node = 0 then | |
1696 | Node := Container.Last; | |
1697 | ||
1698 | else | |
14f73211 BD |
1699 | if Checks and then Position.Container /= Container'Unrestricted_Access |
1700 | then | |
143eac12 MH |
1701 | raise Program_Error with |
1702 | "Position cursor designates wrong container"; | |
1703 | end if; | |
1704 | ||
1705 | pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); | |
1706 | end if; | |
1707 | ||
6c2e4047 AC |
1708 | -- Per AI05-0022, the container implementation is required to detect |
1709 | -- element tampering by a generic actual subprogram. | |
143eac12 | 1710 | |
6c2e4047 | 1711 | declare |
14f73211 | 1712 | Lock : With_Lock (Container.TC'Unrestricted_Access); |
6c2e4047 | 1713 | begin |
6c2e4047 AC |
1714 | while Node /= 0 loop |
1715 | if Container.Nodes (Node).Element = Item then | |
14f73211 | 1716 | return Cursor'(Container'Unrestricted_Access, Node); |
6c2e4047 AC |
1717 | end if; |
1718 | ||
1719 | Node := Container.Nodes (Node).Prev; | |
1720 | end loop; | |
1721 | ||
14f73211 | 1722 | return No_Element; |
6c2e4047 | 1723 | end; |
143eac12 MH |
1724 | end Reverse_Find; |
1725 | ||
1726 | --------------------- | |
1727 | -- Reverse_Iterate -- | |
1728 | --------------------- | |
1729 | ||
1730 | procedure Reverse_Iterate | |
1731 | (Container : List; | |
1732 | Process : not null access procedure (Position : Cursor)) | |
1733 | is | |
14f73211 | 1734 | Busy : With_Busy (Container.TC'Unrestricted_Access); |
143eac12 MH |
1735 | Node : Count_Type := Container.Last; |
1736 | ||
1737 | begin | |
14f73211 BD |
1738 | while Node /= 0 loop |
1739 | Process (Cursor'(Container'Unrestricted_Access, Node)); | |
1740 | Node := Container.Nodes (Node).Prev; | |
1741 | end loop; | |
143eac12 MH |
1742 | end Reverse_Iterate; |
1743 | ||
1744 | ------------ | |
1745 | -- Splice -- | |
1746 | ------------ | |
1747 | ||
1748 | procedure Splice | |
1749 | (Target : in out List; | |
1750 | Before : Cursor; | |
1751 | Source : in out List) | |
1752 | is | |
1753 | begin | |
1754 | if Before.Container /= null then | |
14f73211 | 1755 | if Checks and then Before.Container /= Target'Unrestricted_Access then |
143eac12 MH |
1756 | raise Program_Error with |
1757 | "Before cursor designates wrong container"; | |
1758 | end if; | |
1759 | ||
1760 | pragma Assert (Vet (Before), "bad cursor in Splice"); | |
1761 | end if; | |
1762 | ||
8bfbd380 | 1763 | if Target'Address = Source'Address or else Source.Length = 0 then |
143eac12 | 1764 | return; |
14f73211 | 1765 | end if; |
143eac12 | 1766 | |
14f73211 | 1767 | if Checks and then Target.Length > Count_Type'Last - Source.Length then |
143eac12 | 1768 | raise Constraint_Error with "new length exceeds maximum"; |
14f73211 | 1769 | end if; |
143eac12 | 1770 | |
14f73211 | 1771 | if Checks and then Target.Length + Source.Length > Target.Capacity then |
143eac12 | 1772 | raise Capacity_Error with "new length exceeds target capacity"; |
14f73211 | 1773 | end if; |
143eac12 | 1774 | |
14f73211 BD |
1775 | TC_Check (Target.TC); |
1776 | TC_Check (Source.TC); | |
143eac12 | 1777 | |
14f73211 | 1778 | Splice_Internal (Target, Before.Node, Source); |
143eac12 MH |
1779 | end Splice; |
1780 | ||
1781 | procedure Splice | |
1782 | (Container : in out List; | |
1783 | Before : Cursor; | |
1784 | Position : Cursor) | |
1785 | is | |
1786 | N : Node_Array renames Container.Nodes; | |
1787 | ||
1788 | begin | |
1789 | if Before.Container /= null then | |
14f73211 | 1790 | if Checks and then Before.Container /= Container'Unchecked_Access then |
143eac12 MH |
1791 | raise Program_Error with |
1792 | "Before cursor designates wrong container"; | |
1793 | end if; | |
1794 | ||
1795 | pragma Assert (Vet (Before), "bad Before cursor in Splice"); | |
1796 | end if; | |
1797 | ||
14f73211 | 1798 | if Checks and then Position.Node = 0 then |
143eac12 MH |
1799 | raise Constraint_Error with "Position cursor has no element"; |
1800 | end if; | |
1801 | ||
14f73211 BD |
1802 | if Checks and then Position.Container /= Container'Unrestricted_Access |
1803 | then | |
143eac12 MH |
1804 | raise Program_Error with |
1805 | "Position cursor designates wrong container"; | |
1806 | end if; | |
1807 | ||
1808 | pragma Assert (Vet (Position), "bad Position cursor in Splice"); | |
1809 | ||
1810 | if Position.Node = Before.Node | |
1811 | or else N (Position.Node).Next = Before.Node | |
1812 | then | |
1813 | return; | |
1814 | end if; | |
1815 | ||
1816 | pragma Assert (Container.Length >= 2); | |
1817 | ||
14f73211 | 1818 | TC_Check (Container.TC); |
143eac12 MH |
1819 | |
1820 | if Before.Node = 0 then | |
1821 | pragma Assert (Position.Node /= Container.Last); | |
1822 | ||
1823 | if Position.Node = Container.First then | |
1824 | Container.First := N (Position.Node).Next; | |
1825 | N (Container.First).Prev := 0; | |
1826 | else | |
1827 | N (N (Position.Node).Prev).Next := N (Position.Node).Next; | |
1828 | N (N (Position.Node).Next).Prev := N (Position.Node).Prev; | |
1829 | end if; | |
1830 | ||
1831 | N (Container.Last).Next := Position.Node; | |
1832 | N (Position.Node).Prev := Container.Last; | |
1833 | ||
1834 | Container.Last := Position.Node; | |
1835 | N (Container.Last).Next := 0; | |
1836 | ||
1837 | return; | |
1838 | end if; | |
1839 | ||
1840 | if Before.Node = Container.First then | |
1841 | pragma Assert (Position.Node /= Container.First); | |
1842 | ||
1843 | if Position.Node = Container.Last then | |
1844 | Container.Last := N (Position.Node).Prev; | |
1845 | N (Container.Last).Next := 0; | |
1846 | else | |
1847 | N (N (Position.Node).Prev).Next := N (Position.Node).Next; | |
1848 | N (N (Position.Node).Next).Prev := N (Position.Node).Prev; | |
1849 | end if; | |
1850 | ||
1851 | N (Container.First).Prev := Position.Node; | |
1852 | N (Position.Node).Next := Container.First; | |
1853 | ||
1854 | Container.First := Position.Node; | |
1855 | N (Container.First).Prev := 0; | |
1856 | ||
1857 | return; | |
1858 | end if; | |
1859 | ||
1860 | if Position.Node = Container.First then | |
1861 | Container.First := N (Position.Node).Next; | |
1862 | N (Container.First).Prev := 0; | |
1863 | ||
1864 | elsif Position.Node = Container.Last then | |
1865 | Container.Last := N (Position.Node).Prev; | |
1866 | N (Container.Last).Next := 0; | |
1867 | ||
1868 | else | |
1869 | N (N (Position.Node).Prev).Next := N (Position.Node).Next; | |
1870 | N (N (Position.Node).Next).Prev := N (Position.Node).Prev; | |
1871 | end if; | |
1872 | ||
1873 | N (N (Before.Node).Prev).Next := Position.Node; | |
1874 | N (Position.Node).Prev := N (Before.Node).Prev; | |
1875 | ||
1876 | N (Before.Node).Prev := Position.Node; | |
1877 | N (Position.Node).Next := Before.Node; | |
1878 | ||
1879 | pragma Assert (N (Container.First).Prev = 0); | |
1880 | pragma Assert (N (Container.Last).Next = 0); | |
1881 | end Splice; | |
1882 | ||
1883 | procedure Splice | |
1884 | (Target : in out List; | |
1885 | Before : Cursor; | |
1886 | Source : in out List; | |
1887 | Position : in out Cursor) | |
1888 | is | |
6c2e4047 | 1889 | Target_Position : Count_Type; |
143eac12 MH |
1890 | |
1891 | begin | |
1892 | if Target'Address = Source'Address then | |
1893 | Splice (Target, Before, Position); | |
1894 | return; | |
1895 | end if; | |
1896 | ||
1897 | if Before.Container /= null then | |
14f73211 | 1898 | if Checks and then Before.Container /= Target'Unrestricted_Access then |
143eac12 MH |
1899 | raise Program_Error with |
1900 | "Before cursor designates wrong container"; | |
1901 | end if; | |
1902 | ||
1903 | pragma Assert (Vet (Before), "bad Before cursor in Splice"); | |
1904 | end if; | |
1905 | ||
14f73211 | 1906 | if Checks and then Position.Node = 0 then |
143eac12 MH |
1907 | raise Constraint_Error with "Position cursor has no element"; |
1908 | end if; | |
1909 | ||
14f73211 | 1910 | if Checks and then Position.Container /= Source'Unrestricted_Access then |
143eac12 MH |
1911 | raise Program_Error with |
1912 | "Position cursor designates wrong container"; | |
1913 | end if; | |
1914 | ||
1915 | pragma Assert (Vet (Position), "bad Position cursor in Splice"); | |
1916 | ||
14f73211 | 1917 | if Checks and then Target.Length >= Target.Capacity then |
143eac12 MH |
1918 | raise Capacity_Error with "Target is full"; |
1919 | end if; | |
1920 | ||
14f73211 BD |
1921 | TC_Check (Target.TC); |
1922 | TC_Check (Source.TC); | |
143eac12 | 1923 | |
6c2e4047 AC |
1924 | Splice_Internal |
1925 | (Target => Target, | |
1926 | Before => Before.Node, | |
1927 | Source => Source, | |
1928 | Src_Pos => Position.Node, | |
1929 | Tgt_Pos => Target_Position); | |
143eac12 | 1930 | |
6c2e4047 | 1931 | Position := Cursor'(Target'Unrestricted_Access, Target_Position); |
143eac12 MH |
1932 | end Splice; |
1933 | ||
6c2e4047 AC |
1934 | --------------------- |
1935 | -- Splice_Internal -- | |
1936 | --------------------- | |
1937 | ||
1938 | procedure Splice_Internal | |
1939 | (Target : in out List; | |
1940 | Before : Count_Type; | |
1941 | Source : in out List) | |
1942 | is | |
1943 | N : Node_Array renames Source.Nodes; | |
1944 | X : Count_Type; | |
1945 | ||
1946 | begin | |
1947 | -- This implements the corresponding Splice operation, after the | |
1948 | -- parameters have been vetted, and corner-cases disposed of. | |
1949 | ||
1950 | pragma Assert (Target'Address /= Source'Address); | |
1951 | pragma Assert (Source.Length > 0); | |
1952 | pragma Assert (Source.First /= 0); | |
1953 | pragma Assert (N (Source.First).Prev = 0); | |
1954 | pragma Assert (Source.Last /= 0); | |
1955 | pragma Assert (N (Source.Last).Next = 0); | |
1956 | pragma Assert (Target.Length <= Count_Type'Last - Source.Length); | |
1957 | pragma Assert (Target.Length + Source.Length <= Target.Capacity); | |
1958 | ||
1959 | while Source.Length > 1 loop | |
1960 | -- Copy first element of Source onto Target | |
1961 | ||
1962 | Allocate (Target, N (Source.First).Element, New_Node => X); | |
1963 | Insert_Internal (Target, Before => Before, New_Node => X); | |
1964 | ||
1965 | -- Unlink the first node from Source | |
1966 | ||
1967 | X := Source.First; | |
1968 | pragma Assert (N (N (X).Next).Prev = X); | |
1969 | ||
1970 | Source.First := N (X).Next; | |
1971 | N (Source.First).Prev := 0; | |
1972 | ||
1973 | Source.Length := Source.Length - 1; | |
1974 | ||
1975 | -- Return the Source node to its free store | |
1976 | ||
1977 | Free (Source, X); | |
1978 | end loop; | |
1979 | ||
1980 | -- Copy first (and only remaining) element of Source onto Target | |
1981 | ||
1982 | Allocate (Target, N (Source.First).Element, New_Node => X); | |
1983 | Insert_Internal (Target, Before => Before, New_Node => X); | |
1984 | ||
1985 | -- Unlink the node from Source | |
1986 | ||
1987 | X := Source.First; | |
1988 | pragma Assert (X = Source.Last); | |
1989 | ||
1990 | Source.First := 0; | |
1991 | Source.Last := 0; | |
1992 | ||
1993 | Source.Length := 0; | |
1994 | ||
1995 | -- Return the Source node to its free store | |
1996 | ||
1997 | Free (Source, X); | |
1998 | end Splice_Internal; | |
1999 | ||
2000 | procedure Splice_Internal | |
2001 | (Target : in out List; | |
2002 | Before : Count_Type; -- node of Target | |
2003 | Source : in out List; | |
2004 | Src_Pos : Count_Type; -- node of Source | |
2005 | Tgt_Pos : out Count_Type) | |
2006 | is | |
2007 | N : Node_Array renames Source.Nodes; | |
2008 | ||
2009 | begin | |
2010 | -- This implements the corresponding Splice operation, after the | |
2011 | -- parameters have been vetted, and corner-cases handled. | |
2012 | ||
2013 | pragma Assert (Target'Address /= Source'Address); | |
2014 | pragma Assert (Target.Length < Target.Capacity); | |
2015 | pragma Assert (Source.Length > 0); | |
2016 | pragma Assert (Source.First /= 0); | |
2017 | pragma Assert (N (Source.First).Prev = 0); | |
2018 | pragma Assert (Source.Last /= 0); | |
2019 | pragma Assert (N (Source.Last).Next = 0); | |
2020 | pragma Assert (Src_Pos /= 0); | |
2021 | ||
2022 | Allocate (Target, N (Src_Pos).Element, New_Node => Tgt_Pos); | |
2023 | Insert_Internal (Target, Before => Before, New_Node => Tgt_Pos); | |
2024 | ||
2025 | if Source.Length = 1 then | |
2026 | pragma Assert (Source.First = Source.Last); | |
2027 | pragma Assert (Src_Pos = Source.First); | |
2028 | ||
2029 | Source.First := 0; | |
2030 | Source.Last := 0; | |
2031 | ||
2032 | elsif Src_Pos = Source.First then | |
2033 | pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); | |
2034 | ||
2035 | Source.First := N (Src_Pos).Next; | |
2036 | N (Source.First).Prev := 0; | |
2037 | ||
2038 | elsif Src_Pos = Source.Last then | |
2039 | pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); | |
2040 | ||
2041 | Source.Last := N (Src_Pos).Prev; | |
2042 | N (Source.Last).Next := 0; | |
2043 | ||
2044 | else | |
2045 | pragma Assert (Source.Length >= 3); | |
2046 | pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); | |
2047 | pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); | |
2048 | ||
2049 | N (N (Src_Pos).Next).Prev := N (Src_Pos).Prev; | |
2050 | N (N (Src_Pos).Prev).Next := N (Src_Pos).Next; | |
2051 | end if; | |
2052 | ||
2053 | Source.Length := Source.Length - 1; | |
2054 | Free (Source, Src_Pos); | |
2055 | end Splice_Internal; | |
2056 | ||
143eac12 MH |
2057 | ---------- |
2058 | -- Swap -- | |
2059 | ---------- | |
2060 | ||
2061 | procedure Swap | |
2062 | (Container : in out List; | |
2063 | I, J : Cursor) | |
2064 | is | |
2065 | begin | |
14f73211 | 2066 | if Checks and then I.Node = 0 then |
143eac12 MH |
2067 | raise Constraint_Error with "I cursor has no element"; |
2068 | end if; | |
2069 | ||
14f73211 | 2070 | if Checks and then J.Node = 0 then |
143eac12 MH |
2071 | raise Constraint_Error with "J cursor has no element"; |
2072 | end if; | |
2073 | ||
14f73211 | 2074 | if Checks and then I.Container /= Container'Unchecked_Access then |
143eac12 MH |
2075 | raise Program_Error with "I cursor designates wrong container"; |
2076 | end if; | |
2077 | ||
14f73211 | 2078 | if Checks and then J.Container /= Container'Unchecked_Access then |
143eac12 MH |
2079 | raise Program_Error with "J cursor designates wrong container"; |
2080 | end if; | |
2081 | ||
2082 | if I.Node = J.Node then | |
2083 | return; | |
2084 | end if; | |
2085 | ||
14f73211 | 2086 | TE_Check (Container.TC); |
143eac12 MH |
2087 | |
2088 | pragma Assert (Vet (I), "bad I cursor in Swap"); | |
2089 | pragma Assert (Vet (J), "bad J cursor in Swap"); | |
2090 | ||
2091 | declare | |
2092 | EI : Element_Type renames Container.Nodes (I.Node).Element; | |
2093 | EJ : Element_Type renames Container.Nodes (J.Node).Element; | |
2094 | ||
2095 | EI_Copy : constant Element_Type := EI; | |
2096 | ||
2097 | begin | |
2098 | EI := EJ; | |
2099 | EJ := EI_Copy; | |
2100 | end; | |
2101 | end Swap; | |
2102 | ||
2103 | ---------------- | |
2104 | -- Swap_Links -- | |
2105 | ---------------- | |
2106 | ||
2107 | procedure Swap_Links | |
2108 | (Container : in out List; | |
2109 | I, J : Cursor) | |
2110 | is | |
2111 | begin | |
14f73211 | 2112 | if Checks and then I.Node = 0 then |
143eac12 MH |
2113 | raise Constraint_Error with "I cursor has no element"; |
2114 | end if; | |
2115 | ||
14f73211 | 2116 | if Checks and then J.Node = 0 then |
143eac12 MH |
2117 | raise Constraint_Error with "J cursor has no element"; |
2118 | end if; | |
2119 | ||
14f73211 | 2120 | if Checks and then I.Container /= Container'Unrestricted_Access then |
143eac12 MH |
2121 | raise Program_Error with "I cursor designates wrong container"; |
2122 | end if; | |
2123 | ||
14f73211 | 2124 | if Checks and then J.Container /= Container'Unrestricted_Access then |
143eac12 MH |
2125 | raise Program_Error with "J cursor designates wrong container"; |
2126 | end if; | |
2127 | ||
2128 | if I.Node = J.Node then | |
2129 | return; | |
2130 | end if; | |
2131 | ||
14f73211 | 2132 | TC_Check (Container.TC); |
143eac12 MH |
2133 | |
2134 | pragma Assert (Vet (I), "bad I cursor in Swap_Links"); | |
2135 | pragma Assert (Vet (J), "bad J cursor in Swap_Links"); | |
2136 | ||
2137 | declare | |
2138 | I_Next : constant Cursor := Next (I); | |
2139 | ||
2140 | begin | |
2141 | if I_Next = J then | |
2142 | Splice (Container, Before => I, Position => J); | |
2143 | ||
2144 | else | |
2145 | declare | |
2146 | J_Next : constant Cursor := Next (J); | |
2147 | ||
2148 | begin | |
2149 | if J_Next = I then | |
2150 | Splice (Container, Before => J, Position => I); | |
2151 | ||
2152 | else | |
2153 | pragma Assert (Container.Length >= 3); | |
2154 | ||
2155 | Splice (Container, Before => I_Next, Position => J); | |
2156 | Splice (Container, Before => J_Next, Position => I); | |
2157 | end if; | |
2158 | end; | |
2159 | end if; | |
2160 | end; | |
2161 | end Swap_Links; | |
2162 | ||
2163 | -------------------- | |
2164 | -- Update_Element -- | |
2165 | -------------------- | |
2166 | ||
2167 | procedure Update_Element | |
2168 | (Container : in out List; | |
2169 | Position : Cursor; | |
2170 | Process : not null access procedure (Element : in out Element_Type)) | |
2171 | is | |
2172 | begin | |
14f73211 | 2173 | if Checks and then Position.Node = 0 then |
143eac12 MH |
2174 | raise Constraint_Error with "Position cursor has no element"; |
2175 | end if; | |
2176 | ||
14f73211 | 2177 | if Checks and then Position.Container /= Container'Unchecked_Access then |
143eac12 MH |
2178 | raise Program_Error with |
2179 | "Position cursor designates wrong container"; | |
2180 | end if; | |
2181 | ||
2182 | pragma Assert (Vet (Position), "bad cursor in Update_Element"); | |
2183 | ||
2184 | declare | |
14f73211 BD |
2185 | Lock : With_Lock (Container.TC'Unchecked_Access); |
2186 | N : Node_Type renames Container.Nodes (Position.Node); | |
143eac12 | 2187 | begin |
14f73211 | 2188 | Process (N.Element); |
143eac12 MH |
2189 | end; |
2190 | end Update_Element; | |
2191 | ||
2192 | --------- | |
2193 | -- Vet -- | |
2194 | --------- | |
2195 | ||
2196 | function Vet (Position : Cursor) return Boolean is | |
2197 | begin | |
2198 | if Position.Node = 0 then | |
2199 | return Position.Container = null; | |
2200 | end if; | |
2201 | ||
2202 | if Position.Container = null then | |
2203 | return False; | |
2204 | end if; | |
2205 | ||
2206 | declare | |
2207 | L : List renames Position.Container.all; | |
2208 | N : Node_Array renames L.Nodes; | |
e47e21c1 | 2209 | |
143eac12 MH |
2210 | begin |
2211 | if L.Length = 0 then | |
2212 | return False; | |
2213 | end if; | |
2214 | ||
e47e21c1 | 2215 | if L.First = 0 or L.First > L.Capacity then |
143eac12 MH |
2216 | return False; |
2217 | end if; | |
2218 | ||
e47e21c1 | 2219 | if L.Last = 0 or L.Last > L.Capacity then |
143eac12 MH |
2220 | return False; |
2221 | end if; | |
2222 | ||
2223 | if N (L.First).Prev /= 0 then | |
2224 | return False; | |
2225 | end if; | |
2226 | ||
2227 | if N (L.Last).Next /= 0 then | |
2228 | return False; | |
2229 | end if; | |
2230 | ||
2231 | if Position.Node > L.Capacity then | |
2232 | return False; | |
2233 | end if; | |
2234 | ||
dd91386d AC |
2235 | -- An invariant of an active node is that its Previous and Next |
2236 | -- components are non-negative. Operation Free sets the Previous | |
2237 | -- component of the node to the value -1 before actually deallocating | |
2238 | -- the node, to mark the node as inactive. (By "dellocating" we mean | |
2239 | -- only that the node is linked onto a list of inactive nodes used | |
2240 | -- for storage.) This marker gives us a simple way to detect a | |
2241 | -- dangling reference to a node. | |
2242 | ||
143eac12 MH |
2243 | if N (Position.Node).Prev < 0 then -- see Free |
2244 | return False; | |
2245 | end if; | |
2246 | ||
2247 | if N (Position.Node).Prev > L.Capacity then | |
2248 | return False; | |
2249 | end if; | |
2250 | ||
2251 | if N (Position.Node).Next = Position.Node then | |
2252 | return False; | |
2253 | end if; | |
2254 | ||
2255 | if N (Position.Node).Prev = Position.Node then | |
2256 | return False; | |
2257 | end if; | |
2258 | ||
2259 | if N (Position.Node).Prev = 0 | |
2260 | and then Position.Node /= L.First | |
2261 | then | |
2262 | return False; | |
2263 | end if; | |
2264 | ||
dd91386d AC |
2265 | pragma Assert (N (Position.Node).Prev /= 0 |
2266 | or else Position.Node = L.First); | |
143eac12 MH |
2267 | |
2268 | if N (Position.Node).Next = 0 | |
2269 | and then Position.Node /= L.Last | |
2270 | then | |
2271 | return False; | |
2272 | end if; | |
2273 | ||
dd91386d AC |
2274 | pragma Assert (N (Position.Node).Next /= 0 |
2275 | or else Position.Node = L.Last); | |
143eac12 MH |
2276 | |
2277 | if L.Length = 1 then | |
2278 | return L.First = L.Last; | |
2279 | end if; | |
2280 | ||
2281 | if L.First = L.Last then | |
2282 | return False; | |
2283 | end if; | |
2284 | ||
2285 | if N (L.First).Next = 0 then | |
2286 | return False; | |
2287 | end if; | |
2288 | ||
2289 | if N (L.Last).Prev = 0 then | |
2290 | return False; | |
2291 | end if; | |
2292 | ||
2293 | if N (N (L.First).Next).Prev /= L.First then | |
2294 | return False; | |
2295 | end if; | |
2296 | ||
2297 | if N (N (L.Last).Prev).Next /= L.Last then | |
2298 | return False; | |
2299 | end if; | |
2300 | ||
2301 | if L.Length = 2 then | |
2302 | if N (L.First).Next /= L.Last then | |
2303 | return False; | |
2304 | end if; | |
2305 | ||
2306 | if N (L.Last).Prev /= L.First then | |
2307 | return False; | |
2308 | end if; | |
2309 | ||
2310 | return True; | |
2311 | end if; | |
2312 | ||
2313 | if N (L.First).Next = L.Last then | |
2314 | return False; | |
2315 | end if; | |
2316 | ||
2317 | if N (L.Last).Prev = L.First then | |
2318 | return False; | |
2319 | end if; | |
2320 | ||
25081892 AC |
2321 | -- Eliminate earlier possibility |
2322 | ||
2323 | if Position.Node = L.First then | |
143eac12 MH |
2324 | return True; |
2325 | end if; | |
2326 | ||
dd91386d | 2327 | pragma Assert (N (Position.Node).Prev /= 0); |
143eac12 | 2328 | |
8bfbd380 | 2329 | -- Eliminate another possibility |
25081892 AC |
2330 | |
2331 | if Position.Node = L.Last then | |
143eac12 MH |
2332 | return True; |
2333 | end if; | |
2334 | ||
dd91386d | 2335 | pragma Assert (N (Position.Node).Next /= 0); |
143eac12 MH |
2336 | |
2337 | if N (N (Position.Node).Next).Prev /= Position.Node then | |
2338 | return False; | |
2339 | end if; | |
2340 | ||
2341 | if N (N (Position.Node).Prev).Next /= Position.Node then | |
2342 | return False; | |
2343 | end if; | |
2344 | ||
2345 | if L.Length = 3 then | |
2346 | if N (L.First).Next /= Position.Node then | |
2347 | return False; | |
2348 | end if; | |
2349 | ||
2350 | if N (L.Last).Prev /= Position.Node then | |
2351 | return False; | |
2352 | end if; | |
2353 | end if; | |
2354 | ||
2355 | return True; | |
2356 | end; | |
2357 | end Vet; | |
2358 | ||
2359 | ----------- | |
2360 | -- Write -- | |
2361 | ----------- | |
2362 | ||
2363 | procedure Write | |
2364 | (Stream : not null access Root_Stream_Type'Class; | |
2365 | Item : List) | |
2366 | is | |
2367 | Node : Count_Type; | |
2368 | ||
2369 | begin | |
2370 | Count_Type'Base'Write (Stream, Item.Length); | |
2371 | ||
2372 | Node := Item.First; | |
2373 | while Node /= 0 loop | |
2374 | Element_Type'Write (Stream, Item.Nodes (Node).Element); | |
2375 | Node := Item.Nodes (Node).Next; | |
2376 | end loop; | |
2377 | end Write; | |
2378 | ||
2379 | procedure Write | |
2380 | (Stream : not null access Root_Stream_Type'Class; | |
2381 | Item : Cursor) | |
2382 | is | |
2383 | begin | |
2384 | raise Program_Error with "attempt to stream list cursor"; | |
2385 | end Write; | |
2386 | ||
8cf23b91 AC |
2387 | procedure Write |
2388 | (Stream : not null access Root_Stream_Type'Class; | |
2389 | Item : Reference_Type) | |
2390 | is | |
2391 | begin | |
2392 | raise Program_Error with "attempt to stream reference"; | |
2393 | end Write; | |
2394 | ||
2395 | procedure Write | |
2396 | (Stream : not null access Root_Stream_Type'Class; | |
2397 | Item : Constant_Reference_Type) | |
2398 | is | |
2399 | begin | |
2400 | raise Program_Error with "attempt to stream reference"; | |
2401 | end Write; | |
2402 | ||
143eac12 | 2403 | end Ada.Containers.Bounded_Doubly_Linked_Lists; |