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