File : a-cforma.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-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
28 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
29 pragma Elaborate_All
30 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
31
32 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
34
35 with System; use type System.Address;
36
37 package body Ada.Containers.Formal_Ordered_Maps with
38 SPARK_Mode => Off
39 is
40
41 -----------------------------
42 -- Node Access Subprograms --
43 -----------------------------
44
45 -- These subprograms provide a functional interface to access fields
46 -- of a node, and a procedural interface for modifying these values.
47
48 function Color
49 (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
50 pragma Inline (Color);
51
52 function Left_Son (Node : Node_Type) return Count_Type;
53 pragma Inline (Left_Son);
54
55 function Parent (Node : Node_Type) return Count_Type;
56 pragma Inline (Parent);
57
58 function Right_Son (Node : Node_Type) return Count_Type;
59 pragma Inline (Right_Son);
60
61 procedure Set_Color
62 (Node : in out Node_Type;
63 Color : Ada.Containers.Red_Black_Trees.Color_Type);
64 pragma Inline (Set_Color);
65
66 procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
67 pragma Inline (Set_Left);
68
69 procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
70 pragma Inline (Set_Right);
71
72 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
73 pragma Inline (Set_Parent);
74
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
78
79 -- All need comments ???
80
81 generic
82 with procedure Set_Element (Node : in out Node_Type);
83 procedure Generic_Allocate
84 (Tree : in out Tree_Types.Tree_Type'Class;
85 Node : out Count_Type);
86
87 procedure Free (Tree : in out Map; X : Count_Type);
88
89 function Is_Greater_Key_Node
90 (Left : Key_Type;
91 Right : Node_Type) return Boolean;
92 pragma Inline (Is_Greater_Key_Node);
93
94 function Is_Less_Key_Node
95 (Left : Key_Type;
96 Right : Node_Type) return Boolean;
97 pragma Inline (Is_Less_Key_Node);
98
99 --------------------------
100 -- Local Instantiations --
101 --------------------------
102
103 package Tree_Operations is
104 new Red_Black_Trees.Generic_Bounded_Operations
105 (Tree_Types => Tree_Types,
106 Left => Left_Son,
107 Right => Right_Son);
108
109 use Tree_Operations;
110
111 package Key_Ops is
112 new Red_Black_Trees.Generic_Bounded_Keys
113 (Tree_Operations => Tree_Operations,
114 Key_Type => Key_Type,
115 Is_Less_Key_Node => Is_Less_Key_Node,
116 Is_Greater_Key_Node => Is_Greater_Key_Node);
117
118 ---------
119 -- "=" --
120 ---------
121
122 function "=" (Left, Right : Map) return Boolean is
123 Lst : Count_Type;
124 Node : Count_Type;
125 ENode : Count_Type;
126
127 begin
128 if Length (Left) /= Length (Right) then
129 return False;
130 end if;
131
132 if Is_Empty (Left) then
133 return True;
134 end if;
135
136 Lst := Next (Left, Last (Left).Node);
137
138 Node := First (Left).Node;
139 while Node /= Lst loop
140 ENode := Find (Right, Left.Nodes (Node).Key).Node;
141
142 if ENode = 0 or else
143 Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
144 then
145 return False;
146 end if;
147
148 Node := Next (Left, Node);
149 end loop;
150
151 return True;
152 end "=";
153
154 ------------
155 -- Assign --
156 ------------
157
158 procedure Assign (Target : in out Map; Source : Map) is
159 procedure Append_Element (Source_Node : Count_Type);
160
161 procedure Append_Elements is
162 new Tree_Operations.Generic_Iteration (Append_Element);
163
164 --------------------
165 -- Append_Element --
166 --------------------
167
168 procedure Append_Element (Source_Node : Count_Type) is
169 SN : Node_Type renames Source.Nodes (Source_Node);
170
171 procedure Set_Element (Node : in out Node_Type);
172 pragma Inline (Set_Element);
173
174 function New_Node return Count_Type;
175 pragma Inline (New_Node);
176
177 procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
178
179 procedure Unconditional_Insert_Sans_Hint is
180 new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
181
182 procedure Unconditional_Insert_Avec_Hint is
183 new Key_Ops.Generic_Unconditional_Insert_With_Hint
184 (Insert_Post,
185 Unconditional_Insert_Sans_Hint);
186
187 procedure Allocate is new Generic_Allocate (Set_Element);
188
189 --------------
190 -- New_Node --
191 --------------
192
193 function New_Node return Count_Type is
194 Result : Count_Type;
195 begin
196 Allocate (Target, Result);
197 return Result;
198 end New_Node;
199
200 -----------------
201 -- Set_Element --
202 -----------------
203
204 procedure Set_Element (Node : in out Node_Type) is
205 begin
206 Node.Key := SN.Key;
207 Node.Element := SN.Element;
208 end Set_Element;
209
210 Target_Node : Count_Type;
211
212 -- Start of processing for Append_Element
213
214 begin
215 Unconditional_Insert_Avec_Hint
216 (Tree => Target,
217 Hint => 0,
218 Key => SN.Key,
219 Node => Target_Node);
220 end Append_Element;
221
222 -- Start of processing for Assign
223
224 begin
225 if Target'Address = Source'Address then
226 return;
227 end if;
228
229 if Target.Capacity < Length (Source) then
230 raise Storage_Error with "not enough capacity"; -- SE or CE? ???
231 end if;
232
233 Tree_Operations.Clear_Tree (Target);
234 Append_Elements (Source);
235 end Assign;
236
237 -------------
238 -- Ceiling --
239 -------------
240
241 function Ceiling (Container : Map; Key : Key_Type) return Cursor is
242 Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
243
244 begin
245 if Node = 0 then
246 return No_Element;
247 end if;
248
249 return (Node => Node);
250 end Ceiling;
251
252 -----------
253 -- Clear --
254 -----------
255
256 procedure Clear (Container : in out Map) is
257 begin
258 Tree_Operations.Clear_Tree (Container);
259 end Clear;
260
261 -----------
262 -- Color --
263 -----------
264
265 function Color (Node : Node_Type) return Color_Type is
266 begin
267 return Node.Color;
268 end Color;
269
270 --------------
271 -- Contains --
272 --------------
273
274 function Contains (Container : Map; Key : Key_Type) return Boolean is
275 begin
276 return Find (Container, Key) /= No_Element;
277 end Contains;
278
279 ----------
280 -- Copy --
281 ----------
282
283 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
284 Node : Count_Type := 1;
285 N : Count_Type;
286
287 begin
288 if 0 < Capacity and then Capacity < Source.Capacity then
289 raise Capacity_Error;
290 end if;
291
292 return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
293 if Length (Source) > 0 then
294 Target.Length := Source.Length;
295 Target.Root := Source.Root;
296 Target.First := Source.First;
297 Target.Last := Source.Last;
298 Target.Free := Source.Free;
299
300 while Node <= Source.Capacity loop
301 Target.Nodes (Node).Element :=
302 Source.Nodes (Node).Element;
303 Target.Nodes (Node).Key :=
304 Source.Nodes (Node).Key;
305 Target.Nodes (Node).Parent :=
306 Source.Nodes (Node).Parent;
307 Target.Nodes (Node).Left :=
308 Source.Nodes (Node).Left;
309 Target.Nodes (Node).Right :=
310 Source.Nodes (Node).Right;
311 Target.Nodes (Node).Color :=
312 Source.Nodes (Node).Color;
313 Target.Nodes (Node).Has_Element :=
314 Source.Nodes (Node).Has_Element;
315 Node := Node + 1;
316 end loop;
317
318 while Node <= Target.Capacity loop
319 N := Node;
320 Formal_Ordered_Maps.Free (Tree => Target, X => N);
321 Node := Node + 1;
322 end loop;
323 end if;
324 end return;
325 end Copy;
326
327 ---------------------
328 -- Current_To_Last --
329 ---------------------
330
331 function Current_To_Last (Container : Map; Current : Cursor) return Map is
332 Curs : Cursor := First (Container);
333 C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
334 Node : Count_Type;
335
336 begin
337 if Curs = No_Element then
338 Clear (C);
339 return C;
340
341 elsif Current /= No_Element and not Has_Element (Container, Current) then
342 raise Constraint_Error;
343
344 else
345 while Curs.Node /= Current.Node loop
346 Node := Curs.Node;
347 Delete (C, Curs);
348 Curs := Next (Container, (Node => Node));
349 end loop;
350
351 return C;
352 end if;
353 end Current_To_Last;
354
355 ------------
356 -- Delete --
357 ------------
358
359 procedure Delete (Container : in out Map; Position : in out Cursor) is
360 begin
361 if not Has_Element (Container, Position) then
362 raise Constraint_Error with
363 "Position cursor of Delete has no element";
364 end if;
365
366 pragma Assert (Vet (Container, Position.Node),
367 "Position cursor of Delete is bad");
368
369 Tree_Operations.Delete_Node_Sans_Free (Container,
370 Position.Node);
371 Formal_Ordered_Maps.Free (Container, Position.Node);
372 end Delete;
373
374 procedure Delete (Container : in out Map; Key : Key_Type) is
375 X : constant Node_Access := Key_Ops.Find (Container, Key);
376
377 begin
378 if X = 0 then
379 raise Constraint_Error with "key not in map";
380 end if;
381
382 Tree_Operations.Delete_Node_Sans_Free (Container, X);
383 Formal_Ordered_Maps.Free (Container, X);
384 end Delete;
385
386 ------------------
387 -- Delete_First --
388 ------------------
389
390 procedure Delete_First (Container : in out Map) is
391 X : constant Node_Access := First (Container).Node;
392 begin
393 if X /= 0 then
394 Tree_Operations.Delete_Node_Sans_Free (Container, X);
395 Formal_Ordered_Maps.Free (Container, X);
396 end if;
397 end Delete_First;
398
399 -----------------
400 -- Delete_Last --
401 -----------------
402
403 procedure Delete_Last (Container : in out Map) is
404 X : constant Node_Access := Last (Container).Node;
405 begin
406 if X /= 0 then
407 Tree_Operations.Delete_Node_Sans_Free (Container, X);
408 Formal_Ordered_Maps.Free (Container, X);
409 end if;
410 end Delete_Last;
411
412 -------------
413 -- Element --
414 -------------
415
416 function Element (Container : Map; Position : Cursor) return Element_Type is
417 begin
418 if not Has_Element (Container, Position) then
419 raise Constraint_Error with
420 "Position cursor of function Element has no element";
421 end if;
422
423 pragma Assert (Vet (Container, Position.Node),
424 "Position cursor of function Element is bad");
425
426 return Container.Nodes (Position.Node).Element;
427
428 end Element;
429
430 function Element (Container : Map; Key : Key_Type) return Element_Type is
431 Node : constant Node_Access := Find (Container, Key).Node;
432
433 begin
434 if Node = 0 then
435 raise Constraint_Error with "key not in map";
436 end if;
437
438 return Container.Nodes (Node).Element;
439 end Element;
440
441 ---------------------
442 -- Equivalent_Keys --
443 ---------------------
444
445 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
446 begin
447 if Left < Right
448 or else Right < Left
449 then
450 return False;
451 else
452 return True;
453 end if;
454 end Equivalent_Keys;
455
456 -------------
457 -- Exclude --
458 -------------
459
460 procedure Exclude (Container : in out Map; Key : Key_Type) is
461 X : constant Node_Access := Key_Ops.Find (Container, Key);
462 begin
463 if X /= 0 then
464 Tree_Operations.Delete_Node_Sans_Free (Container, X);
465 Formal_Ordered_Maps.Free (Container, X);
466 end if;
467 end Exclude;
468
469 ----------
470 -- Find --
471 ----------
472
473 function Find (Container : Map; Key : Key_Type) return Cursor is
474 Node : constant Count_Type := Key_Ops.Find (Container, Key);
475
476 begin
477 if Node = 0 then
478 return No_Element;
479 end if;
480
481 return (Node => Node);
482 end Find;
483
484 -----------
485 -- First --
486 -----------
487
488 function First (Container : Map) return Cursor is
489 begin
490 if Length (Container) = 0 then
491 return No_Element;
492 end if;
493
494 return (Node => Container.First);
495 end First;
496
497 -------------------
498 -- First_Element --
499 -------------------
500
501 function First_Element (Container : Map) return Element_Type is
502 begin
503 if Is_Empty (Container) then
504 raise Constraint_Error with "map is empty";
505 end if;
506
507 return Container.Nodes (First (Container).Node).Element;
508 end First_Element;
509
510 ---------------
511 -- First_Key --
512 ---------------
513
514 function First_Key (Container : Map) return Key_Type is
515 begin
516 if Is_Empty (Container) then
517 raise Constraint_Error with "map is empty";
518 end if;
519
520 return Container.Nodes (First (Container).Node).Key;
521 end First_Key;
522
523 -----------------------
524 -- First_To_Previous --
525 -----------------------
526
527 function First_To_Previous
528 (Container : Map;
529 Current : Cursor) return Map
530 is
531 Curs : Cursor := Current;
532 C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
533 Node : Count_Type;
534
535 begin
536 if Curs = No_Element then
537 return C;
538
539 elsif not Has_Element (Container, Curs) then
540 raise Constraint_Error;
541
542 else
543 while Curs.Node /= 0 loop
544 Node := Curs.Node;
545 Delete (C, Curs);
546 Curs := Next (Container, (Node => Node));
547 end loop;
548
549 return C;
550 end if;
551 end First_To_Previous;
552
553 -----------
554 -- Floor --
555 -----------
556
557 function Floor (Container : Map; Key : Key_Type) return Cursor is
558 Node : constant Count_Type := Key_Ops.Floor (Container, Key);
559
560 begin
561 if Node = 0 then
562 return No_Element;
563 end if;
564
565 return (Node => Node);
566 end Floor;
567
568 ----------
569 -- Free --
570 ----------
571
572 procedure Free
573 (Tree : in out Map;
574 X : Count_Type)
575 is
576 begin
577 Tree.Nodes (X).Has_Element := False;
578 Tree_Operations.Free (Tree, X);
579 end Free;
580
581 ----------------------
582 -- Generic_Allocate --
583 ----------------------
584
585 procedure Generic_Allocate
586 (Tree : in out Tree_Types.Tree_Type'Class;
587 Node : out Count_Type)
588 is
589 procedure Allocate is
590 new Tree_Operations.Generic_Allocate (Set_Element);
591 begin
592 Allocate (Tree, Node);
593 Tree.Nodes (Node).Has_Element := True;
594 end Generic_Allocate;
595
596 -----------------
597 -- Has_Element --
598 -----------------
599
600 function Has_Element (Container : Map; Position : Cursor) return Boolean is
601 begin
602 if Position.Node = 0 then
603 return False;
604 end if;
605
606 return Container.Nodes (Position.Node).Has_Element;
607 end Has_Element;
608
609 -------------
610 -- Include --
611 -------------
612
613 procedure Include
614 (Container : in out Map;
615 Key : Key_Type;
616 New_Item : Element_Type)
617 is
618 Position : Cursor;
619 Inserted : Boolean;
620
621 begin
622 Insert (Container, Key, New_Item, Position, Inserted);
623
624 if not Inserted then
625 declare
626 N : Node_Type renames Container.Nodes (Position.Node);
627 begin
628 N.Key := Key;
629 N.Element := New_Item;
630 end;
631 end if;
632 end Include;
633
634 procedure Insert
635 (Container : in out Map;
636 Key : Key_Type;
637 New_Item : Element_Type;
638 Position : out Cursor;
639 Inserted : out Boolean)
640 is
641 function New_Node return Node_Access;
642 -- Comment ???
643
644 procedure Insert_Post is
645 new Key_Ops.Generic_Insert_Post (New_Node);
646
647 procedure Insert_Sans_Hint is
648 new Key_Ops.Generic_Conditional_Insert (Insert_Post);
649
650 --------------
651 -- New_Node --
652 --------------
653
654 function New_Node return Node_Access is
655 procedure Initialize (Node : in out Node_Type);
656 procedure Allocate_Node is new Generic_Allocate (Initialize);
657
658 procedure Initialize (Node : in out Node_Type) is
659 begin
660 Node.Key := Key;
661 Node.Element := New_Item;
662 end Initialize;
663
664 X : Node_Access;
665
666 begin
667 Allocate_Node (Container, X);
668 return X;
669 end New_Node;
670
671 -- Start of processing for Insert
672
673 begin
674 Insert_Sans_Hint
675 (Container,
676 Key,
677 Position.Node,
678 Inserted);
679 end Insert;
680
681 procedure Insert
682 (Container : in out Map;
683 Key : Key_Type;
684 New_Item : Element_Type)
685 is
686 Position : Cursor;
687 Inserted : Boolean;
688
689 begin
690 Insert (Container, Key, New_Item, Position, Inserted);
691
692 if not Inserted then
693 raise Constraint_Error with "key already in map";
694 end if;
695 end Insert;
696
697 --------------
698 -- Is_Empty --
699 --------------
700
701 function Is_Empty (Container : Map) return Boolean is
702 begin
703 return Length (Container) = 0;
704 end Is_Empty;
705
706 -------------------------
707 -- Is_Greater_Key_Node --
708 -------------------------
709
710 function Is_Greater_Key_Node
711 (Left : Key_Type;
712 Right : Node_Type) return Boolean
713 is
714 begin
715 -- k > node same as node < k
716
717 return Right.Key < Left;
718 end Is_Greater_Key_Node;
719
720 ----------------------
721 -- Is_Less_Key_Node --
722 ----------------------
723
724 function Is_Less_Key_Node
725 (Left : Key_Type;
726 Right : Node_Type) return Boolean
727 is
728 begin
729 return Left < Right.Key;
730 end Is_Less_Key_Node;
731
732 ---------
733 -- Key --
734 ---------
735
736 function Key (Container : Map; Position : Cursor) return Key_Type is
737 begin
738 if not Has_Element (Container, Position) then
739 raise Constraint_Error with
740 "Position cursor of function Key has no element";
741 end if;
742
743 pragma Assert (Vet (Container, Position.Node),
744 "Position cursor of function Key is bad");
745
746 return Container.Nodes (Position.Node).Key;
747 end Key;
748
749 ----------
750 -- Last --
751 ----------
752
753 function Last (Container : Map) return Cursor is
754 begin
755 if Length (Container) = 0 then
756 return No_Element;
757 end if;
758
759 return (Node => Container.Last);
760 end Last;
761
762 ------------------
763 -- Last_Element --
764 ------------------
765
766 function Last_Element (Container : Map) return Element_Type is
767 begin
768 if Is_Empty (Container) then
769 raise Constraint_Error with "map is empty";
770 end if;
771
772 return Container.Nodes (Last (Container).Node).Element;
773 end Last_Element;
774
775 --------------
776 -- Last_Key --
777 --------------
778
779 function Last_Key (Container : Map) return Key_Type is
780 begin
781 if Is_Empty (Container) then
782 raise Constraint_Error with "map is empty";
783 end if;
784
785 return Container.Nodes (Last (Container).Node).Key;
786 end Last_Key;
787
788 --------------
789 -- Left_Son --
790 --------------
791
792 function Left_Son (Node : Node_Type) return Count_Type is
793 begin
794 return Node.Left;
795 end Left_Son;
796
797 ------------
798 -- Length --
799 ------------
800
801 function Length (Container : Map) return Count_Type is
802 begin
803 return Container.Length;
804 end Length;
805
806 ----------
807 -- Move --
808 ----------
809
810 procedure Move (Target : in out Map; Source : in out Map) is
811 NN : Tree_Types.Nodes_Type renames Source.Nodes;
812 X : Node_Access;
813
814 begin
815 if Target'Address = Source'Address then
816 return;
817 end if;
818
819 if Target.Capacity < Length (Source) then
820 raise Constraint_Error with -- ???
821 "Source length exceeds Target capacity";
822 end if;
823
824 Clear (Target);
825
826 loop
827 X := First (Source).Node;
828 exit when X = 0;
829
830 -- Here we insert a copy of the source element into the target, and
831 -- then delete the element from the source. Another possibility is
832 -- that delete it first (and hang onto its index), then insert it.
833 -- ???
834
835 Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
836
837 Tree_Operations.Delete_Node_Sans_Free (Source, X);
838 Formal_Ordered_Maps.Free (Source, X);
839 end loop;
840 end Move;
841
842 ----------
843 -- Next --
844 ----------
845
846 procedure Next (Container : Map; Position : in out Cursor) is
847 begin
848 Position := Next (Container, Position);
849 end Next;
850
851 function Next (Container : Map; Position : Cursor) return Cursor is
852 begin
853 if Position = No_Element then
854 return No_Element;
855 end if;
856
857 if not Has_Element (Container, Position) then
858 raise Constraint_Error;
859 end if;
860
861 pragma Assert (Vet (Container, Position.Node),
862 "bad cursor in Next");
863
864 return (Node => Tree_Operations.Next (Container, Position.Node));
865 end Next;
866
867 -------------
868 -- Overlap --
869 -------------
870
871 function Overlap (Left, Right : Map) return Boolean is
872 begin
873 if Length (Left) = 0 or Length (Right) = 0 then
874 return False;
875 end if;
876
877 declare
878 L_Node : Count_Type := First (Left).Node;
879 R_Node : Count_Type := First (Right).Node;
880 L_Last : constant Count_Type := Next (Left, Last (Left).Node);
881 R_Last : constant Count_Type := Next (Right, Last (Right).Node);
882
883 begin
884 if Left'Address = Right'Address then
885 return True;
886 end if;
887
888 loop
889 if L_Node = L_Last
890 or else R_Node = R_Last
891 then
892 return False;
893 end if;
894
895 if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then
896 L_Node := Next (Left, L_Node);
897
898 elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then
899 R_Node := Next (Right, R_Node);
900
901 else
902 return True;
903 end if;
904 end loop;
905 end;
906 end Overlap;
907
908 ------------
909 -- Parent --
910 ------------
911
912 function Parent (Node : Node_Type) return Count_Type is
913 begin
914 return Node.Parent;
915 end Parent;
916
917 --------------
918 -- Previous --
919 --------------
920
921 procedure Previous (Container : Map; Position : in out Cursor) is
922 begin
923 Position := Previous (Container, Position);
924 end Previous;
925
926 function Previous (Container : Map; Position : Cursor) return Cursor is
927 begin
928 if Position = No_Element then
929 return No_Element;
930 end if;
931
932 if not Has_Element (Container, Position) then
933 raise Constraint_Error;
934 end if;
935
936 pragma Assert (Vet (Container, Position.Node),
937 "bad cursor in Previous");
938
939 declare
940 Node : constant Count_Type :=
941 Tree_Operations.Previous (Container, Position.Node);
942
943 begin
944 if Node = 0 then
945 return No_Element;
946 end if;
947
948 return (Node => Node);
949 end;
950 end Previous;
951
952 -------------
953 -- Replace --
954 -------------
955
956 procedure Replace
957 (Container : in out Map;
958 Key : Key_Type;
959 New_Item : Element_Type)
960 is
961 begin
962 declare
963 Node : constant Node_Access := Key_Ops.Find (Container, Key);
964
965 begin
966 if Node = 0 then
967 raise Constraint_Error with "key not in map";
968 end if;
969
970 declare
971 N : Node_Type renames Container.Nodes (Node);
972 begin
973 N.Key := Key;
974 N.Element := New_Item;
975 end;
976 end;
977 end Replace;
978
979 ---------------------
980 -- Replace_Element --
981 ---------------------
982
983 procedure Replace_Element
984 (Container : in out Map;
985 Position : Cursor;
986 New_Item : Element_Type)
987 is
988 begin
989 if not Has_Element (Container, Position) then
990 raise Constraint_Error with
991 "Position cursor of Replace_Element has no element";
992 end if;
993
994 pragma Assert (Vet (Container, Position.Node),
995 "Position cursor of Replace_Element is bad");
996
997 Container.Nodes (Position.Node).Element := New_Item;
998 end Replace_Element;
999
1000 ---------------
1001 -- Right_Son --
1002 ---------------
1003
1004 function Right_Son (Node : Node_Type) return Count_Type is
1005 begin
1006 return Node.Right;
1007 end Right_Son;
1008
1009 ---------------
1010 -- Set_Color --
1011 ---------------
1012
1013 procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is
1014 begin
1015 Node.Color := Color;
1016 end Set_Color;
1017
1018 --------------
1019 -- Set_Left --
1020 --------------
1021
1022 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1023 begin
1024 Node.Left := Left;
1025 end Set_Left;
1026
1027 ----------------
1028 -- Set_Parent --
1029 ----------------
1030
1031 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1032 begin
1033 Node.Parent := Parent;
1034 end Set_Parent;
1035
1036 ---------------
1037 -- Set_Right --
1038 ---------------
1039
1040 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1041 begin
1042 Node.Right := Right;
1043 end Set_Right;
1044
1045 ------------------
1046 -- Strict_Equal --
1047 ------------------
1048
1049 function Strict_Equal (Left, Right : Map) return Boolean is
1050 LNode : Count_Type := First (Left).Node;
1051 RNode : Count_Type := First (Right).Node;
1052
1053 begin
1054 if Length (Left) /= Length (Right) then
1055 return False;
1056 end if;
1057
1058 while LNode = RNode loop
1059 if LNode = 0 then
1060 return True;
1061 end if;
1062
1063 if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element
1064 or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key
1065 then
1066 exit;
1067 end if;
1068
1069 LNode := Next (Left, LNode);
1070 RNode := Next (Right, RNode);
1071 end loop;
1072
1073 return False;
1074 end Strict_Equal;
1075
1076 end Ada.Containers.Formal_Ordered_Maps;