1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--                 ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2004-2018, 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
30with Ada.Unchecked_Deallocation;
31
32with Ada.Containers.Helpers; use Ada.Containers.Helpers;
33
34with Ada.Containers.Red_Black_Trees.Generic_Operations;
35pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
36
37with Ada.Containers.Red_Black_Trees.Generic_Keys;
38pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
39
40with System; use type System.Address;
41
42package 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
1686end Ada.Containers.Indefinite_Ordered_Maps;
1687