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