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