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