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