Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-coorma.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M A P S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
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 Ada.Containers.Helpers; use Ada.Containers.Helpers;
33
34 with Ada.Containers.Red_Black_Trees.Generic_Operations;
35 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
36
37 with Ada.Containers.Red_Black_Trees.Generic_Keys;
38 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
39
40 with System; use type System.Address;
41
42 package body Ada.Containers.Ordered_Maps is
43
44 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
45 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
46 -- See comment in Ada.Containers.Helpers
47
48 -----------------------------
49 -- Node Access Subprograms --
50 -----------------------------
51
52 -- These subprograms provide a functional interface to access fields
53 -- of a node, and a procedural interface for modifying these values.
54
55 function Color (Node : Node_Access) return Color_Type;
56 pragma Inline (Color);
57
58 function Left (Node : Node_Access) return Node_Access;
59 pragma Inline (Left);
60
61 function Parent (Node : Node_Access) return Node_Access;
62 pragma Inline (Parent);
63
64 function Right (Node : Node_Access) return Node_Access;
65 pragma Inline (Right);
66
67 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
68 pragma Inline (Set_Parent);
69
70 procedure Set_Left (Node : Node_Access; Left : Node_Access);
71 pragma Inline (Set_Left);
72
73 procedure Set_Right (Node : Node_Access; Right : Node_Access);
74 pragma Inline (Set_Right);
75
76 procedure Set_Color (Node : Node_Access; Color : Color_Type);
77 pragma Inline (Set_Color);
78
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
82
83 function Copy_Node (Source : Node_Access) return Node_Access;
84 pragma Inline (Copy_Node);
85
86 procedure Free (X : in out Node_Access);
87
88 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
89 pragma Inline (Is_Equal_Node_Node);
90
91 function Is_Greater_Key_Node
92 (Left : Key_Type;
93 Right : Node_Access) return Boolean;
94 pragma Inline (Is_Greater_Key_Node);
95
96 function Is_Less_Key_Node
97 (Left : Key_Type;
98 Right : Node_Access) return Boolean;
99 pragma Inline (Is_Less_Key_Node);
100
101 --------------------------
102 -- Local Instantiations --
103 --------------------------
104
105 package Tree_Operations is
106 new Red_Black_Trees.Generic_Operations (Tree_Types);
107
108 procedure Delete_Tree is
109 new Tree_Operations.Generic_Delete_Tree (Free);
110
111 function Copy_Tree is
112 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
113
114 use Tree_Operations;
115
116 package Key_Ops is
117 new Red_Black_Trees.Generic_Keys
118 (Tree_Operations => Tree_Operations,
119 Key_Type => Key_Type,
120 Is_Less_Key_Node => Is_Less_Key_Node,
121 Is_Greater_Key_Node => Is_Greater_Key_Node);
122
123 function Is_Equal is
124 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
125
126 ---------
127 -- "<" --
128 ---------
129
130 function "<" (Left, Right : Cursor) return Boolean is
131 begin
132 if Checks and then Left.Node = null then
133 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
134 end if;
135
136 if Checks and then Right.Node = null then
137 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
138 end if;
139
140 pragma Assert (Vet (Left.Container.Tree, Left.Node),
141 "Left cursor of ""<"" is bad");
142
143 pragma Assert (Vet (Right.Container.Tree, Right.Node),
144 "Right cursor of ""<"" is bad");
145
146 return Left.Node.Key < Right.Node.Key;
147 end "<";
148
149 function "<" (Left : Cursor; Right : Key_Type) return Boolean is
150 begin
151 if Checks and then Left.Node = null then
152 raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
153 end if;
154
155 pragma Assert (Vet (Left.Container.Tree, Left.Node),
156 "Left cursor of ""<"" is bad");
157
158 return Left.Node.Key < Right;
159 end "<";
160
161 function "<" (Left : Key_Type; Right : Cursor) return Boolean is
162 begin
163 if Checks and then Right.Node = null then
164 raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
165 end if;
166
167 pragma Assert (Vet (Right.Container.Tree, Right.Node),
168 "Right cursor of ""<"" is bad");
169
170 return Left < Right.Node.Key;
171 end "<";
172
173 ---------
174 -- "=" --
175 ---------
176
177 function "=" (Left, Right : Map) return Boolean is
178 begin
179 return Is_Equal (Left.Tree, Right.Tree);
180 end "=";
181
182 ---------
183 -- ">" --
184 ---------
185
186 function ">" (Left, Right : Cursor) return Boolean is
187 begin
188 if Checks and then Left.Node = null then
189 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
190 end if;
191
192 if Checks and then Right.Node = null then
193 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
194 end if;
195
196 pragma Assert (Vet (Left.Container.Tree, Left.Node),
197 "Left cursor of "">"" is bad");
198
199 pragma Assert (Vet (Right.Container.Tree, Right.Node),
200 "Right cursor of "">"" is bad");
201
202 return Right.Node.Key < Left.Node.Key;
203 end ">";
204
205 function ">" (Left : Cursor; Right : Key_Type) return Boolean is
206 begin
207 if Checks and then Left.Node = null then
208 raise Constraint_Error with "Left cursor of "">"" equals No_Element";
209 end if;
210
211 pragma Assert (Vet (Left.Container.Tree, Left.Node),
212 "Left cursor of "">"" is bad");
213
214 return Right < Left.Node.Key;
215 end ">";
216
217 function ">" (Left : Key_Type; Right : Cursor) return Boolean is
218 begin
219 if Checks and then Right.Node = null then
220 raise Constraint_Error with "Right cursor of "">"" equals No_Element";
221 end if;
222
223 pragma Assert (Vet (Right.Container.Tree, Right.Node),
224 "Right cursor of "">"" is bad");
225
226 return Right.Node.Key < Left;
227 end ">";
228
229 ------------
230 -- Adjust --
231 ------------
232
233 procedure Adjust is
234 new Tree_Operations.Generic_Adjust (Copy_Tree);
235
236 procedure Adjust (Container : in out Map) is
237 begin
238 Adjust (Container.Tree);
239 end Adjust;
240
241 ------------
242 -- Assign --
243 ------------
244
245 procedure Assign (Target : in out Map; Source : Map) is
246 procedure Insert_Item (Node : Node_Access);
247 pragma Inline (Insert_Item);
248
249 procedure Insert_Items is
250 new Tree_Operations.Generic_Iteration (Insert_Item);
251
252 -----------------
253 -- Insert_Item --
254 -----------------
255
256 procedure Insert_Item (Node : Node_Access) is
257 begin
258 Target.Insert (Key => Node.Key, New_Item => Node.Element);
259 end Insert_Item;
260
261 -- Start of processing for Assign
262
263 begin
264 if Target'Address = Source'Address then
265 return;
266 end if;
267
268 Target.Clear;
269 Insert_Items (Source.Tree);
270 end Assign;
271
272 -------------
273 -- Ceiling --
274 -------------
275
276 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
277 Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
278
279 begin
280 if Node = null then
281 return No_Element;
282 end if;
283
284 return Cursor'(Container'Unrestricted_Access, Node);
285 end Ceiling;
286
287 -----------
288 -- Clear --
289 -----------
290
291 procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
292
293 procedure Clear (Container : in out Map) is
294 begin
295 Clear (Container.Tree);
296 end Clear;
297
298 -----------
299 -- Color --
300 -----------
301
302 function Color (Node : Node_Access) return Color_Type is
303 begin
304 return Node.Color;
305 end Color;
306
307 ------------------------
308 -- Constant_Reference --
309 ------------------------
310
311 function Constant_Reference
312 (Container : aliased Map;
313 Position : Cursor) return Constant_Reference_Type
314 is
315 begin
316 if Checks and then Position.Container = null then
317 raise Constraint_Error with
318 "Position cursor has no element";
319 end if;
320
321 if Checks and then Position.Container /= Container'Unrestricted_Access
322 then
323 raise Program_Error with
324 "Position cursor designates wrong map";
325 end if;
326
327 pragma Assert (Vet (Container.Tree, Position.Node),
328 "Position cursor in Constant_Reference is bad");
329
330 declare
331 T : Tree_Type renames Position.Container.all.Tree;
332 TC : constant Tamper_Counts_Access :=
333 T.TC'Unrestricted_Access;
334 begin
335 return R : constant Constant_Reference_Type :=
336 (Element => Position.Node.Element'Access,
337 Control => (Controlled with TC))
338 do
339 Lock (TC.all);
340 end return;
341 end;
342 end Constant_Reference;
343
344 function Constant_Reference
345 (Container : aliased Map;
346 Key : Key_Type) return Constant_Reference_Type
347 is
348 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
349
350 begin
351 if Checks and then Node = null then
352 raise Constraint_Error with "key not in map";
353 end if;
354
355 declare
356 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
357 TC : constant Tamper_Counts_Access :=
358 T.TC'Unrestricted_Access;
359 begin
360 return R : constant Constant_Reference_Type :=
361 (Element => Node.Element'Access,
362 Control => (Controlled with TC))
363 do
364 Lock (TC.all);
365 end return;
366 end;
367 end Constant_Reference;
368
369 --------------
370 -- Contains --
371 --------------
372
373 function Contains (Container : Map; Key : Key_Type) return Boolean is
374 begin
375 return Find (Container, Key) /= No_Element;
376 end Contains;
377
378 ----------
379 -- Copy --
380 ----------
381
382 function Copy (Source : Map) return Map is
383 begin
384 return Target : Map do
385 Target.Assign (Source);
386 end return;
387 end Copy;
388
389 ---------------
390 -- Copy_Node --
391 ---------------
392
393 function Copy_Node (Source : Node_Access) return Node_Access is
394 Target : constant Node_Access :=
395 new Node_Type'(Color => Source.Color,
396 Key => Source.Key,
397 Element => Source.Element,
398 Parent => null,
399 Left => null,
400 Right => null);
401 begin
402 return Target;
403 end Copy_Node;
404
405 ------------
406 -- Delete --
407 ------------
408
409 procedure Delete (Container : in out Map; Position : in out Cursor) is
410 Tree : Tree_Type renames Container.Tree;
411
412 begin
413 if Checks and then Position.Node = null then
414 raise Constraint_Error with
415 "Position cursor of Delete equals No_Element";
416 end if;
417
418 if Checks and then Position.Container /= Container'Unrestricted_Access
419 then
420 raise Program_Error with
421 "Position cursor of Delete designates wrong map";
422 end if;
423
424 pragma Assert (Vet (Tree, Position.Node),
425 "Position cursor of Delete is bad");
426
427 Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
428 Free (Position.Node);
429
430 Position.Container := null;
431 end Delete;
432
433 procedure Delete (Container : in out Map; Key : Key_Type) is
434 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
435
436 begin
437 if Checks and then X = null then
438 raise Constraint_Error with "key not in map";
439 end if;
440
441 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
442 Free (X);
443 end Delete;
444
445 ------------------
446 -- Delete_First --
447 ------------------
448
449 procedure Delete_First (Container : in out Map) is
450 X : Node_Access := Container.Tree.First;
451
452 begin
453 if X /= null then
454 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
455 Free (X);
456 end if;
457 end Delete_First;
458
459 -----------------
460 -- Delete_Last --
461 -----------------
462
463 procedure Delete_Last (Container : in out Map) is
464 X : Node_Access := Container.Tree.Last;
465
466 begin
467 if X /= null then
468 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
469 Free (X);
470 end if;
471 end Delete_Last;
472
473 -------------
474 -- Element --
475 -------------
476
477 function Element (Position : Cursor) return Element_Type is
478 begin
479 if Checks and then Position.Node = null then
480 raise Constraint_Error with
481 "Position cursor of function Element equals No_Element";
482 end if;
483
484 pragma Assert (Vet (Position.Container.Tree, Position.Node),
485 "Position cursor of function Element is bad");
486
487 return Position.Node.Element;
488 end Element;
489
490 function Element (Container : Map; Key : Key_Type) return Element_Type is
491 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
492
493 begin
494 if Checks and then Node = null then
495 raise Constraint_Error with "key not in map";
496 end if;
497
498 return Node.Element;
499 end Element;
500
501 ---------------------
502 -- Equivalent_Keys --
503 ---------------------
504
505 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
506 begin
507 if Left < Right
508 or else Right < Left
509 then
510 return False;
511 else
512 return True;
513 end if;
514 end Equivalent_Keys;
515
516 -------------
517 -- Exclude --
518 -------------
519
520 procedure Exclude (Container : in out Map; Key : Key_Type) is
521 X : Node_Access := Key_Ops.Find (Container.Tree, Key);
522
523 begin
524 if X /= null then
525 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
526 Free (X);
527 end if;
528 end Exclude;
529
530 --------------
531 -- Finalize --
532 --------------
533
534 procedure Finalize (Object : in out Iterator) is
535 begin
536 if Object.Container /= null then
537 Unbusy (Object.Container.Tree.TC);
538 end if;
539 end Finalize;
540
541 ----------
542 -- Find --
543 ----------
544
545 function Find (Container : Map; Key : Key_Type) return Cursor is
546 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
547 begin
548 return (if Node = null then No_Element
549 else Cursor'(Container'Unrestricted_Access, Node));
550 end Find;
551
552 -----------
553 -- First --
554 -----------
555
556 function First (Container : Map) return Cursor is
557 T : Tree_Type renames Container.Tree;
558 begin
559 if T.First = null then
560 return No_Element;
561 else
562 return Cursor'(Container'Unrestricted_Access, T.First);
563 end if;
564 end First;
565
566 function First (Object : Iterator) return Cursor is
567 begin
568 -- The value of the iterator object's Node component influences the
569 -- behavior of the First (and Last) selector function.
570
571 -- When the Node component is null, this means the iterator object was
572 -- constructed without a start expression, in which case the (forward)
573 -- iteration starts from the (logical) beginning of the entire sequence
574 -- of items (corresponding to Container.First, for a forward iterator).
575
576 -- Otherwise, this is iteration over a partial sequence of items. When
577 -- the Node component is non-null, the iterator object was constructed
578 -- with a start expression, that specifies the position from which the
579 -- (forward) partial iteration begins.
580
581 if Object.Node = null then
582 return Object.Container.First;
583 else
584 return Cursor'(Object.Container, Object.Node);
585 end if;
586 end First;
587
588 -------------------
589 -- First_Element --
590 -------------------
591
592 function First_Element (Container : Map) return Element_Type is
593 T : Tree_Type renames Container.Tree;
594 begin
595 if Checks and then T.First = null then
596 raise Constraint_Error with "map is empty";
597 end if;
598
599 return T.First.Element;
600 end First_Element;
601
602 ---------------
603 -- First_Key --
604 ---------------
605
606 function First_Key (Container : Map) return Key_Type is
607 T : Tree_Type renames Container.Tree;
608 begin
609 if Checks and then T.First = null then
610 raise Constraint_Error with "map is empty";
611 end if;
612
613 return T.First.Key;
614 end First_Key;
615
616 -----------
617 -- Floor --
618 -----------
619
620 function Floor (Container : Map; Key : Key_Type) return Cursor is
621 Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
622 begin
623 if Node = null then
624 return No_Element;
625 else
626 return Cursor'(Container'Unrestricted_Access, Node);
627 end if;
628 end Floor;
629
630 ----------
631 -- Free --
632 ----------
633
634 procedure Free (X : in out Node_Access) is
635 procedure Deallocate is
636 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
637
638 begin
639 if X = null then
640 return;
641 end if;
642
643 X.Parent := X;
644 X.Left := X;
645 X.Right := X;
646
647 Deallocate (X);
648 end Free;
649
650 ------------------------
651 -- Get_Element_Access --
652 ------------------------
653
654 function Get_Element_Access
655 (Position : Cursor) return not null Element_Access is
656 begin
657 return Position.Node.Element'Access;
658 end Get_Element_Access;
659
660 -----------------
661 -- Has_Element --
662 -----------------
663
664 function Has_Element (Position : Cursor) return Boolean is
665 begin
666 return Position /= No_Element;
667 end Has_Element;
668
669 -------------
670 -- Include --
671 -------------
672
673 procedure Include
674 (Container : in out Map;
675 Key : Key_Type;
676 New_Item : Element_Type)
677 is
678 Position : Cursor;
679 Inserted : Boolean;
680
681 begin
682 Insert (Container, Key, New_Item, Position, Inserted);
683
684 if not Inserted then
685 TE_Check (Container.Tree.TC);
686
687 Position.Node.Key := Key;
688 Position.Node.Element := New_Item;
689 end if;
690 end Include;
691
692 ------------
693 -- Insert --
694 ------------
695
696 procedure Insert
697 (Container : in out Map;
698 Key : Key_Type;
699 New_Item : Element_Type;
700 Position : out Cursor;
701 Inserted : out Boolean)
702 is
703 function New_Node return Node_Access;
704 pragma Inline (New_Node);
705
706 procedure Insert_Post is
707 new Key_Ops.Generic_Insert_Post (New_Node);
708
709 procedure Insert_Sans_Hint is
710 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
711
712 --------------
713 -- New_Node --
714 --------------
715
716 function New_Node return Node_Access is
717 begin
718 return new Node_Type'(Key => Key,
719 Element => New_Item,
720 Color => Red_Black_Trees.Red,
721 Parent => null,
722 Left => null,
723 Right => null);
724 end New_Node;
725
726 -- Start of processing for Insert
727
728 begin
729 Insert_Sans_Hint
730 (Container.Tree,
731 Key,
732 Position.Node,
733 Inserted);
734
735 Position.Container := Container'Unrestricted_Access;
736 end Insert;
737
738 procedure Insert
739 (Container : in out Map;
740 Key : Key_Type;
741 New_Item : Element_Type)
742 is
743 Position : Cursor;
744 pragma Unreferenced (Position);
745
746 Inserted : Boolean;
747
748 begin
749 Insert (Container, Key, New_Item, Position, Inserted);
750
751 if Checks and then not Inserted then
752 raise Constraint_Error with "key already in map";
753 end if;
754 end Insert;
755
756 procedure Insert
757 (Container : in out Map;
758 Key : Key_Type;
759 Position : out Cursor;
760 Inserted : out Boolean)
761 is
762 function New_Node return Node_Access;
763 pragma Inline (New_Node);
764
765 procedure Insert_Post is
766 new Key_Ops.Generic_Insert_Post (New_Node);
767
768 procedure Insert_Sans_Hint is
769 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
770
771 --------------
772 -- New_Node --
773 --------------
774
775 function New_Node return Node_Access is
776 begin
777 return new Node_Type'(Key => Key,
778 Element => <>,
779 Color => Red_Black_Trees.Red,
780 Parent => null,
781 Left => null,
782 Right => null);
783 end New_Node;
784
785 -- Start of processing for Insert
786
787 begin
788 Insert_Sans_Hint
789 (Container.Tree,
790 Key,
791 Position.Node,
792 Inserted);
793
794 Position.Container := Container'Unrestricted_Access;
795 end Insert;
796
797 --------------
798 -- Is_Empty --
799 --------------
800
801 function Is_Empty (Container : Map) return Boolean is
802 begin
803 return Container.Tree.Length = 0;
804 end Is_Empty;
805
806 ------------------------
807 -- Is_Equal_Node_Node --
808 ------------------------
809
810 function Is_Equal_Node_Node
811 (L, R : Node_Access) return Boolean
812 is
813 begin
814 if L.Key < R.Key then
815 return False;
816 elsif R.Key < L.Key then
817 return False;
818 else
819 return L.Element = R.Element;
820 end if;
821 end Is_Equal_Node_Node;
822
823 -------------------------
824 -- Is_Greater_Key_Node --
825 -------------------------
826
827 function Is_Greater_Key_Node
828 (Left : Key_Type;
829 Right : Node_Access) return Boolean
830 is
831 begin
832 -- Left > Right same as Right < Left
833
834 return Right.Key < Left;
835 end Is_Greater_Key_Node;
836
837 ----------------------
838 -- Is_Less_Key_Node --
839 ----------------------
840
841 function Is_Less_Key_Node
842 (Left : Key_Type;
843 Right : Node_Access) return Boolean
844 is
845 begin
846 return Left < Right.Key;
847 end Is_Less_Key_Node;
848
849 -------------
850 -- Iterate --
851 -------------
852
853 procedure Iterate
854 (Container : Map;
855 Process : not null access procedure (Position : Cursor))
856 is
857 procedure Process_Node (Node : Node_Access);
858 pragma Inline (Process_Node);
859
860 procedure Local_Iterate is
861 new Tree_Operations.Generic_Iteration (Process_Node);
862
863 ------------------
864 -- Process_Node --
865 ------------------
866
867 procedure Process_Node (Node : Node_Access) is
868 begin
869 Process (Cursor'(Container'Unrestricted_Access, Node));
870 end Process_Node;
871
872 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
873
874 -- Start of processing for Iterate
875
876 begin
877 Local_Iterate (Container.Tree);
878 end Iterate;
879
880 function Iterate
881 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
882 is
883 begin
884 -- The value of the Node component influences the behavior of the First
885 -- and Last selector functions of the iterator object. When the Node
886 -- component is null (as is the case here), this means the iterator
887 -- object was constructed without a start expression. This is a
888 -- complete iterator, meaning that the iteration starts from the
889 -- (logical) beginning of the sequence of items.
890
891 -- Note: For a forward iterator, Container.First is the beginning, and
892 -- for a reverse iterator, Container.Last is the beginning.
893
894 return It : constant Iterator :=
895 (Limited_Controlled with
896 Container => Container'Unrestricted_Access,
897 Node => null)
898 do
899 Busy (Container.Tree.TC'Unrestricted_Access.all);
900 end return;
901 end Iterate;
902
903 function Iterate (Container : Map; Start : Cursor)
904 return Map_Iterator_Interfaces.Reversible_Iterator'Class
905 is
906 begin
907 -- It was formerly the case that when Start = No_Element, the partial
908 -- iterator was defined to behave the same as for a complete iterator,
909 -- and iterate over the entire sequence of items. However, those
910 -- semantics were unintuitive and arguably error-prone (it is too easy
911 -- to accidentally create an endless loop), and so they were changed,
912 -- per the ARG meeting in Denver on 2011/11. However, there was no
913 -- consensus about what positive meaning this corner case should have,
914 -- and so it was decided to simply raise an exception. This does imply,
915 -- however, that it is not possible to use a partial iterator to specify
916 -- an empty sequence of items.
917
918 if Checks and then Start = No_Element then
919 raise Constraint_Error with
920 "Start position for iterator equals No_Element";
921 end if;
922
923 if Checks and then Start.Container /= Container'Unrestricted_Access then
924 raise Program_Error with
925 "Start cursor of Iterate designates wrong map";
926 end if;
927
928 pragma Assert (Vet (Container.Tree, Start.Node),
929 "Start cursor of Iterate is bad");
930
931 -- The value of the Node component influences the behavior of the First
932 -- and Last selector functions of the iterator object. When the Node
933 -- component is non-null (as is the case here), it means that this
934 -- is a partial iteration, over a subset of the complete sequence of
935 -- items. The iterator object was constructed with a start expression,
936 -- indicating the position from which the iteration begins. Note that
937 -- the start position has the same value irrespective of whether this
938 -- is a forward or reverse iteration.
939
940 return It : constant Iterator :=
941 (Limited_Controlled with
942 Container => Container'Unrestricted_Access,
943 Node => Start.Node)
944 do
945 Busy (Container.Tree.TC'Unrestricted_Access.all);
946 end return;
947 end Iterate;
948
949 ---------
950 -- Key --
951 ---------
952
953 function Key (Position : Cursor) return Key_Type is
954 begin
955 if Checks and then Position.Node = null then
956 raise Constraint_Error with
957 "Position cursor of function Key equals No_Element";
958 end if;
959
960 pragma Assert (Vet (Position.Container.Tree, Position.Node),
961 "Position cursor of function Key is bad");
962
963 return Position.Node.Key;
964 end Key;
965
966 ----------
967 -- Last --
968 ----------
969
970 function Last (Container : Map) return Cursor is
971 T : Tree_Type renames Container.Tree;
972 begin
973 if T.Last = null then
974 return No_Element;
975 else
976 return Cursor'(Container'Unrestricted_Access, T.Last);
977 end if;
978 end Last;
979
980 function Last (Object : Iterator) return Cursor is
981 begin
982 -- The value of the iterator object's Node component influences the
983 -- behavior of the Last (and First) selector function.
984
985 -- When the Node component is null, this means the iterator object was
986 -- constructed without a start expression, in which case the (reverse)
987 -- iteration starts from the (logical) beginning of the entire sequence
988 -- (corresponding to Container.Last, for a reverse iterator).
989
990 -- Otherwise, this is iteration over a partial sequence of items. When
991 -- the Node component is non-null, the iterator object was constructed
992 -- with a start expression, that specifies the position from which the
993 -- (reverse) partial iteration begins.
994
995 if Object.Node = null then
996 return Object.Container.Last;
997 else
998 return Cursor'(Object.Container, Object.Node);
999 end if;
1000 end Last;
1001
1002 ------------------
1003 -- Last_Element --
1004 ------------------
1005
1006 function Last_Element (Container : Map) return Element_Type is
1007 T : Tree_Type renames Container.Tree;
1008 begin
1009 if Checks and then T.Last = null then
1010 raise Constraint_Error with "map is empty";
1011 end if;
1012
1013 return T.Last.Element;
1014 end Last_Element;
1015
1016 --------------
1017 -- Last_Key --
1018 --------------
1019
1020 function Last_Key (Container : Map) return Key_Type is
1021 T : Tree_Type renames Container.Tree;
1022 begin
1023 if Checks and then T.Last = null then
1024 raise Constraint_Error with "map is empty";
1025 end if;
1026
1027 return T.Last.Key;
1028 end Last_Key;
1029
1030 ----------
1031 -- Left --
1032 ----------
1033
1034 function Left (Node : Node_Access) return Node_Access is
1035 begin
1036 return Node.Left;
1037 end Left;
1038
1039 ------------
1040 -- Length --
1041 ------------
1042
1043 function Length (Container : Map) return Count_Type is
1044 begin
1045 return Container.Tree.Length;
1046 end Length;
1047
1048 ----------
1049 -- Move --
1050 ----------
1051
1052 procedure Move is
1053 new Tree_Operations.Generic_Move (Clear);
1054
1055 procedure Move (Target : in out Map; Source : in out Map) is
1056 begin
1057 Move (Target => Target.Tree, Source => Source.Tree);
1058 end Move;
1059
1060 ----------
1061 -- Next --
1062 ----------
1063
1064 procedure Next (Position : in out Cursor) is
1065 begin
1066 Position := Next (Position);
1067 end Next;
1068
1069 function Next (Position : Cursor) return Cursor is
1070 begin
1071 if Position = No_Element then
1072 return No_Element;
1073 end if;
1074
1075 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1076 "Position cursor of Next is bad");
1077
1078 declare
1079 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1080
1081 begin
1082 if Node = null then
1083 return No_Element;
1084 end if;
1085
1086 return Cursor'(Position.Container, Node);
1087 end;
1088 end Next;
1089
1090 function Next
1091 (Object : Iterator;
1092 Position : Cursor) return Cursor
1093 is
1094 begin
1095 if Position.Container = null then
1096 return No_Element;
1097 end if;
1098
1099 if Checks and then Position.Container /= Object.Container then
1100 raise Program_Error with
1101 "Position cursor of Next designates wrong map";
1102 end if;
1103
1104 return Next (Position);
1105 end Next;
1106
1107 ------------
1108 -- Parent --
1109 ------------
1110
1111 function Parent (Node : Node_Access) return Node_Access is
1112 begin
1113 return Node.Parent;
1114 end Parent;
1115
1116 --------------
1117 -- Previous --
1118 --------------
1119
1120 procedure Previous (Position : in out Cursor) is
1121 begin
1122 Position := Previous (Position);
1123 end Previous;
1124
1125 function Previous (Position : Cursor) return Cursor is
1126 begin
1127 if Position = No_Element then
1128 return No_Element;
1129 end if;
1130
1131 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1132 "Position cursor of Previous is bad");
1133
1134 declare
1135 Node : constant Node_Access :=
1136 Tree_Operations.Previous (Position.Node);
1137
1138 begin
1139 if Node = null then
1140 return No_Element;
1141 end if;
1142
1143 return Cursor'(Position.Container, Node);
1144 end;
1145 end Previous;
1146
1147 function Previous
1148 (Object : Iterator;
1149 Position : Cursor) return Cursor
1150 is
1151 begin
1152 if Position.Container = null then
1153 return No_Element;
1154 end if;
1155
1156 if Checks and then Position.Container /= Object.Container then
1157 raise Program_Error with
1158 "Position cursor of Previous designates wrong map";
1159 end if;
1160
1161 return Previous (Position);
1162 end Previous;
1163
1164 ----------------------
1165 -- Pseudo_Reference --
1166 ----------------------
1167
1168 function Pseudo_Reference
1169 (Container : aliased Map'Class) return Reference_Control_Type
1170 is
1171 TC : constant Tamper_Counts_Access :=
1172 Container.Tree.TC'Unrestricted_Access;
1173 begin
1174 return R : constant Reference_Control_Type := (Controlled with TC) do
1175 Lock (TC.all);
1176 end return;
1177 end Pseudo_Reference;
1178
1179 -------------------
1180 -- Query_Element --
1181 -------------------
1182
1183 procedure Query_Element
1184 (Position : Cursor;
1185 Process : not null access procedure (Key : Key_Type;
1186 Element : Element_Type))
1187 is
1188 begin
1189 if Checks and then Position.Node = null then
1190 raise Constraint_Error with
1191 "Position cursor of Query_Element equals No_Element";
1192 end if;
1193
1194 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1195 "Position cursor of Query_Element is bad");
1196
1197 declare
1198 T : Tree_Type renames Position.Container.Tree;
1199 Lock : With_Lock (T.TC'Unrestricted_Access);
1200 K : Key_Type renames Position.Node.Key;
1201 E : Element_Type renames Position.Node.Element;
1202 begin
1203 Process (K, E);
1204 end;
1205 end Query_Element;
1206
1207 ----------
1208 -- Read --
1209 ----------
1210
1211 procedure Read
1212 (Stream : not null access Root_Stream_Type'Class;
1213 Container : out Map)
1214 is
1215 function Read_Node
1216 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1217 pragma Inline (Read_Node);
1218
1219 procedure Read is
1220 new Tree_Operations.Generic_Read (Clear, Read_Node);
1221
1222 ---------------
1223 -- Read_Node --
1224 ---------------
1225
1226 function Read_Node
1227 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1228 is
1229 Node : Node_Access := new Node_Type;
1230 begin
1231 Key_Type'Read (Stream, Node.Key);
1232 Element_Type'Read (Stream, Node.Element);
1233 return Node;
1234 exception
1235 when others =>
1236 Free (Node);
1237 raise;
1238 end Read_Node;
1239
1240 -- Start of processing for Read
1241
1242 begin
1243 Read (Stream, Container.Tree);
1244 end Read;
1245
1246 procedure Read
1247 (Stream : not null access Root_Stream_Type'Class;
1248 Item : out Cursor)
1249 is
1250 begin
1251 raise Program_Error with "attempt to stream map cursor";
1252 end Read;
1253
1254 procedure Read
1255 (Stream : not null access Root_Stream_Type'Class;
1256 Item : out Reference_Type)
1257 is
1258 begin
1259 raise Program_Error with "attempt to stream reference";
1260 end Read;
1261
1262 procedure Read
1263 (Stream : not null access Root_Stream_Type'Class;
1264 Item : out Constant_Reference_Type)
1265 is
1266 begin
1267 raise Program_Error with "attempt to stream reference";
1268 end Read;
1269
1270 ---------------
1271 -- Reference --
1272 ---------------
1273
1274 function Reference
1275 (Container : aliased in out Map;
1276 Position : Cursor) return Reference_Type
1277 is
1278 begin
1279 if Checks and then Position.Container = null then
1280 raise Constraint_Error with
1281 "Position cursor has no element";
1282 end if;
1283
1284 if Checks and then Position.Container /= Container'Unrestricted_Access
1285 then
1286 raise Program_Error with
1287 "Position cursor designates wrong map";
1288 end if;
1289
1290 pragma Assert (Vet (Container.Tree, Position.Node),
1291 "Position cursor in function Reference is bad");
1292
1293 declare
1294 T : Tree_Type renames Position.Container.all.Tree;
1295 TC : constant Tamper_Counts_Access :=
1296 T.TC'Unrestricted_Access;
1297 begin
1298 return R : constant Reference_Type :=
1299 (Element => Position.Node.Element'Access,
1300 Control => (Controlled with TC))
1301 do
1302 Lock (TC.all);
1303 end return;
1304 end;
1305 end Reference;
1306
1307 function Reference
1308 (Container : aliased in out Map;
1309 Key : Key_Type) return Reference_Type
1310 is
1311 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1312
1313 begin
1314 if Checks and then Node = null then
1315 raise Constraint_Error with "key not in map";
1316 end if;
1317
1318 declare
1319 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1320 TC : constant Tamper_Counts_Access :=
1321 T.TC'Unrestricted_Access;
1322 begin
1323 return R : constant Reference_Type :=
1324 (Element => Node.Element'Access,
1325 Control => (Controlled with TC))
1326 do
1327 Lock (TC.all);
1328 end return;
1329 end;
1330 end Reference;
1331
1332 -------------
1333 -- Replace --
1334 -------------
1335
1336 procedure Replace
1337 (Container : in out Map;
1338 Key : Key_Type;
1339 New_Item : Element_Type)
1340 is
1341 Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1342
1343 begin
1344 if Checks and then Node = null then
1345 raise Constraint_Error with "key not in map";
1346 end if;
1347
1348 TE_Check (Container.Tree.TC);
1349
1350 Node.Key := Key;
1351 Node.Element := New_Item;
1352 end Replace;
1353
1354 ---------------------
1355 -- Replace_Element --
1356 ---------------------
1357
1358 procedure Replace_Element
1359 (Container : in out Map;
1360 Position : Cursor;
1361 New_Item : Element_Type)
1362 is
1363 begin
1364 if Checks and then Position.Node = null then
1365 raise Constraint_Error with
1366 "Position cursor of Replace_Element equals No_Element";
1367 end if;
1368
1369 if Checks and then Position.Container /= Container'Unrestricted_Access
1370 then
1371 raise Program_Error with
1372 "Position cursor of Replace_Element designates wrong map";
1373 end if;
1374
1375 TE_Check (Container.Tree.TC);
1376
1377 pragma Assert (Vet (Container.Tree, Position.Node),
1378 "Position cursor of Replace_Element is bad");
1379
1380 Position.Node.Element := New_Item;
1381 end Replace_Element;
1382
1383 ---------------------
1384 -- Reverse_Iterate --
1385 ---------------------
1386
1387 procedure Reverse_Iterate
1388 (Container : Map;
1389 Process : not null access procedure (Position : Cursor))
1390 is
1391 procedure Process_Node (Node : Node_Access);
1392 pragma Inline (Process_Node);
1393
1394 procedure Local_Reverse_Iterate is
1395 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1396
1397 ------------------
1398 -- Process_Node --
1399 ------------------
1400
1401 procedure Process_Node (Node : Node_Access) is
1402 begin
1403 Process (Cursor'(Container'Unrestricted_Access, Node));
1404 end Process_Node;
1405
1406 Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
1407
1408 -- Start of processing for Reverse_Iterate
1409
1410 begin
1411 Local_Reverse_Iterate (Container.Tree);
1412 end Reverse_Iterate;
1413
1414 -----------
1415 -- Right --
1416 -----------
1417
1418 function Right (Node : Node_Access) return Node_Access is
1419 begin
1420 return Node.Right;
1421 end Right;
1422
1423 ---------------
1424 -- Set_Color --
1425 ---------------
1426
1427 procedure Set_Color
1428 (Node : Node_Access;
1429 Color : Color_Type)
1430 is
1431 begin
1432 Node.Color := Color;
1433 end Set_Color;
1434
1435 --------------
1436 -- Set_Left --
1437 --------------
1438
1439 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1440 begin
1441 Node.Left := Left;
1442 end Set_Left;
1443
1444 ----------------
1445 -- Set_Parent --
1446 ----------------
1447
1448 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1449 begin
1450 Node.Parent := Parent;
1451 end Set_Parent;
1452
1453 ---------------
1454 -- Set_Right --
1455 ---------------
1456
1457 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1458 begin
1459 Node.Right := Right;
1460 end Set_Right;
1461
1462 --------------------
1463 -- Update_Element --
1464 --------------------
1465
1466 procedure Update_Element
1467 (Container : in out Map;
1468 Position : Cursor;
1469 Process : not null access procedure (Key : Key_Type;
1470 Element : in out Element_Type))
1471 is
1472 begin
1473 if Checks and then Position.Node = null then
1474 raise Constraint_Error with
1475 "Position cursor of Update_Element equals No_Element";
1476 end if;
1477
1478 if Checks and then Position.Container /= Container'Unrestricted_Access
1479 then
1480 raise Program_Error with
1481 "Position cursor of Update_Element designates wrong map";
1482 end if;
1483
1484 pragma Assert (Vet (Container.Tree, Position.Node),
1485 "Position cursor of Update_Element is bad");
1486
1487 declare
1488 T : Tree_Type renames Container.Tree;
1489 Lock : With_Lock (T.TC'Unrestricted_Access);
1490 K : Key_Type renames Position.Node.Key;
1491 E : Element_Type renames Position.Node.Element;
1492 begin
1493 Process (K, E);
1494 end;
1495 end Update_Element;
1496
1497 -----------
1498 -- Write --
1499 -----------
1500
1501 procedure Write
1502 (Stream : not null access Root_Stream_Type'Class;
1503 Container : Map)
1504 is
1505 procedure Write_Node
1506 (Stream : not null access Root_Stream_Type'Class;
1507 Node : Node_Access);
1508 pragma Inline (Write_Node);
1509
1510 procedure Write is
1511 new Tree_Operations.Generic_Write (Write_Node);
1512
1513 ----------------
1514 -- Write_Node --
1515 ----------------
1516
1517 procedure Write_Node
1518 (Stream : not null access Root_Stream_Type'Class;
1519 Node : Node_Access)
1520 is
1521 begin
1522 Key_Type'Write (Stream, Node.Key);
1523 Element_Type'Write (Stream, Node.Element);
1524 end Write_Node;
1525
1526 -- Start of processing for Write
1527
1528 begin
1529 Write (Stream, Container.Tree);
1530 end Write;
1531
1532 procedure Write
1533 (Stream : not null access Root_Stream_Type'Class;
1534 Item : Cursor)
1535 is
1536 begin
1537 raise Program_Error with "attempt to stream map cursor";
1538 end Write;
1539
1540 procedure Write
1541 (Stream : not null access Root_Stream_Type'Class;
1542 Item : Reference_Type)
1543 is
1544 begin
1545 raise Program_Error with "attempt to stream reference";
1546 end Write;
1547
1548 procedure Write
1549 (Stream : not null access Root_Stream_Type'Class;
1550 Item : Constant_Reference_Type)
1551 is
1552 begin
1553 raise Program_Error with "attempt to stream reference";
1554 end Write;
1555
1556 end Ada.Containers.Ordered_Maps;