gcc/
[official-gcc.git] / gcc / ada / a-cfhama.adb
blob11dbc6fe66de338b9c45e501a9a555a4fb48df68
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 _ H A S H E D _ M A P S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2014, 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 ------------------------------------------------------------------------------
28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
36 with System; use type System.Address;
38 package body Ada.Containers.Formal_Hashed_Maps with
39 SPARK_Mode => Off
41 pragma Annotate (CodePeer, Skip_Analysis);
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
47 -- All local subprograms require comments ???
49 function Equivalent_Keys
50 (Key : Key_Type;
51 Node : Node_Type) return Boolean;
52 pragma Inline (Equivalent_Keys);
54 procedure Free
55 (HT : in out Map;
56 X : Count_Type);
58 generic
59 with procedure Set_Element (Node : in out Node_Type);
60 procedure Generic_Allocate
61 (HT : in out Map;
62 Node : out Count_Type);
64 function Hash_Node (Node : Node_Type) return Hash_Type;
65 pragma Inline (Hash_Node);
67 function Next (Node : Node_Type) return Count_Type;
68 pragma Inline (Next);
70 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
71 pragma Inline (Set_Next);
73 function Vet (Container : Map; Position : Cursor) return Boolean;
75 --------------------------
76 -- Local Instantiations --
77 --------------------------
79 package HT_Ops is
80 new Hash_Tables.Generic_Bounded_Operations
81 (HT_Types => HT_Types,
82 Hash_Node => Hash_Node,
83 Next => Next,
84 Set_Next => Set_Next);
86 package Key_Ops is
87 new Hash_Tables.Generic_Bounded_Keys
88 (HT_Types => HT_Types,
89 Next => Next,
90 Set_Next => Set_Next,
91 Key_Type => Key_Type,
92 Hash => Hash,
93 Equivalent_Keys => Equivalent_Keys);
95 ---------
96 -- "=" --
97 ---------
99 function "=" (Left, Right : Map) return Boolean is
100 begin
101 if Length (Left) /= Length (Right) then
102 return False;
103 end if;
105 if Length (Left) = 0 then
106 return True;
107 end if;
109 declare
110 Node : Count_Type;
111 ENode : Count_Type;
113 begin
114 Node := Left.First.Node;
115 while Node /= 0 loop
116 ENode := Find (Container => Right,
117 Key => Left.Nodes (Node).Key).Node;
119 if ENode = 0 or else
120 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
121 then
122 return False;
123 end if;
125 Node := HT_Ops.Next (Left, Node);
126 end loop;
128 return True;
129 end;
130 end "=";
132 ------------
133 -- Assign --
134 ------------
136 procedure Assign (Target : in out Map; Source : Map) is
137 procedure Insert_Element (Source_Node : Count_Type);
138 pragma Inline (Insert_Element);
140 procedure Insert_Elements is
141 new HT_Ops.Generic_Iteration (Insert_Element);
143 --------------------
144 -- Insert_Element --
145 --------------------
147 procedure Insert_Element (Source_Node : Count_Type) is
148 N : Node_Type renames Source.Nodes (Source_Node);
149 begin
150 Insert (Target, N.Key, N.Element);
151 end Insert_Element;
153 -- Start of processing for Assign
155 begin
156 if Target'Address = Source'Address then
157 return;
158 end if;
160 if Target.Capacity < Length (Source) then
161 raise Constraint_Error with -- correct exception ???
162 "Source length exceeds Target capacity";
163 end if;
165 Clear (Target);
167 Insert_Elements (Source);
168 end Assign;
170 --------------
171 -- Capacity --
172 --------------
174 function Capacity (Container : Map) return Count_Type is
175 begin
176 return Container.Nodes'Length;
177 end Capacity;
179 -----------
180 -- Clear --
181 -----------
183 procedure Clear (Container : in out Map) is
184 begin
185 HT_Ops.Clear (Container);
186 end Clear;
188 --------------
189 -- Contains --
190 --------------
192 function Contains (Container : Map; Key : Key_Type) return Boolean is
193 begin
194 return Find (Container, Key) /= No_Element;
195 end Contains;
197 ----------
198 -- Copy --
199 ----------
201 function Copy
202 (Source : Map;
203 Capacity : Count_Type := 0) return Map
205 C : constant Count_Type :=
206 Count_Type'Max (Capacity, Source.Capacity);
207 H : Hash_Type;
208 N : Count_Type;
209 Target : Map (C, Source.Modulus);
210 Cu : Cursor;
212 begin
213 if 0 < Capacity and then Capacity < Source.Capacity then
214 raise Capacity_Error;
215 end if;
217 Target.Length := Source.Length;
218 Target.Free := Source.Free;
220 H := 1;
221 while H <= Source.Modulus loop
222 Target.Buckets (H) := Source.Buckets (H);
223 H := H + 1;
224 end loop;
226 N := 1;
227 while N <= Source.Capacity loop
228 Target.Nodes (N) := Source.Nodes (N);
229 N := N + 1;
230 end loop;
232 while N <= C loop
233 Cu := (Node => N);
234 Free (Target, Cu.Node);
235 N := N + 1;
236 end loop;
238 return Target;
239 end Copy;
241 ---------------------
242 -- Current_To_Last --
243 ---------------------
245 function Current_To_Last (Container : Map; Current : Cursor) return Map is
246 Curs : Cursor := First (Container);
247 C : Map (Container.Capacity, Container.Modulus) :=
248 Copy (Container, Container.Capacity);
249 Node : Count_Type;
251 begin
252 if Curs = No_Element then
253 Clear (C);
254 return C;
256 elsif Current /= No_Element and not Has_Element (Container, Current) then
257 raise Constraint_Error;
259 else
260 while Curs.Node /= Current.Node loop
261 Node := Curs.Node;
262 Delete (C, Curs);
263 Curs := Next (Container, (Node => Node));
264 end loop;
266 return C;
267 end if;
268 end Current_To_Last;
270 ---------------------
271 -- Default_Modulus --
272 ---------------------
274 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
275 begin
276 return To_Prime (Capacity);
277 end Default_Modulus;
279 ------------
280 -- Delete --
281 ------------
283 procedure Delete (Container : in out Map; Key : Key_Type) is
284 X : Count_Type;
286 begin
287 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
289 if X = 0 then
290 raise Constraint_Error with "attempt to delete key not in map";
291 end if;
293 Free (Container, X);
294 end Delete;
296 procedure Delete (Container : in out Map; Position : in out Cursor) is
297 begin
298 if not Has_Element (Container, Position) then
299 raise Constraint_Error with
300 "Position cursor of Delete has no element";
301 end if;
303 pragma Assert (Vet (Container, Position), "bad cursor in Delete");
305 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
307 Free (Container, Position.Node);
308 end Delete;
310 -------------
311 -- Element --
312 -------------
314 function Element (Container : Map; Key : Key_Type) return Element_Type is
315 Node : constant Count_Type := Find (Container, Key).Node;
317 begin
318 if Node = 0 then
319 raise Constraint_Error with
320 "no element available because key not in map";
321 end if;
323 return Container.Nodes (Node).Element;
324 end Element;
326 function Element (Container : Map; Position : Cursor) return Element_Type is
327 begin
328 if not Has_Element (Container, Position) then
329 raise Constraint_Error with "Position cursor equals No_Element";
330 end if;
332 pragma Assert (Vet (Container, Position),
333 "bad cursor in function Element");
335 return Container.Nodes (Position.Node).Element;
336 end Element;
338 ---------------------
339 -- Equivalent_Keys --
340 ---------------------
342 function Equivalent_Keys
343 (Key : Key_Type;
344 Node : Node_Type) return Boolean
346 begin
347 return Equivalent_Keys (Key, Node.Key);
348 end Equivalent_Keys;
350 function Equivalent_Keys
351 (Left : Map;
352 CLeft : Cursor;
353 Right : Map;
354 CRight : Cursor) return Boolean
356 begin
357 if not Has_Element (Left, CLeft) then
358 raise Constraint_Error with
359 "Left cursor of Equivalent_Keys has no element";
360 end if;
362 if not Has_Element (Right, CRight) then
363 raise Constraint_Error with
364 "Right cursor of Equivalent_Keys has no element";
365 end if;
367 pragma Assert (Vet (Left, CLeft),
368 "Left cursor of Equivalent_Keys is bad");
369 pragma Assert (Vet (Right, CRight),
370 "Right cursor of Equivalent_Keys is bad");
372 declare
373 LN : Node_Type renames Left.Nodes (CLeft.Node);
374 RN : Node_Type renames Right.Nodes (CRight.Node);
375 begin
376 return Equivalent_Keys (LN.Key, RN.Key);
377 end;
378 end Equivalent_Keys;
380 function Equivalent_Keys
381 (Left : Map;
382 CLeft : Cursor;
383 Right : Key_Type) return Boolean
385 begin
386 if not Has_Element (Left, CLeft) then
387 raise Constraint_Error with
388 "Left cursor of Equivalent_Keys has no element";
389 end if;
391 pragma Assert (Vet (Left, CLeft),
392 "Left cursor in Equivalent_Keys is bad");
394 declare
395 LN : Node_Type renames Left.Nodes (CLeft.Node);
396 begin
397 return Equivalent_Keys (LN.Key, Right);
398 end;
399 end Equivalent_Keys;
401 function Equivalent_Keys
402 (Left : Key_Type;
403 Right : Map;
404 CRight : Cursor) return Boolean
406 begin
407 if Has_Element (Right, CRight) then
408 raise Constraint_Error with
409 "Right cursor of Equivalent_Keys has no element";
410 end if;
412 pragma Assert (Vet (Right, CRight),
413 "Right cursor of Equivalent_Keys is bad");
415 declare
416 RN : Node_Type renames Right.Nodes (CRight.Node);
418 begin
419 return Equivalent_Keys (Left, RN.Key);
420 end;
421 end Equivalent_Keys;
423 -------------
424 -- Exclude --
425 -------------
427 procedure Exclude (Container : in out Map; Key : Key_Type) is
428 X : Count_Type;
429 begin
430 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
431 Free (Container, X);
432 end Exclude;
434 ----------
435 -- Find --
436 ----------
438 function Find (Container : Map; Key : Key_Type) return Cursor is
439 Node : constant Count_Type := Key_Ops.Find (Container, Key);
441 begin
442 if Node = 0 then
443 return No_Element;
444 end if;
446 return (Node => Node);
447 end Find;
449 -----------
450 -- First --
451 -----------
453 function First (Container : Map) return Cursor is
454 Node : constant Count_Type := HT_Ops.First (Container);
456 begin
457 if Node = 0 then
458 return No_Element;
459 end if;
461 return (Node => Node);
462 end First;
464 -----------------------
465 -- First_To_Previous --
466 -----------------------
468 function First_To_Previous
469 (Container : Map;
470 Current : Cursor) return Map is
471 Curs : Cursor;
472 C : Map (Container.Capacity, Container.Modulus) :=
473 Copy (Container, Container.Capacity);
474 Node : Count_Type;
476 begin
477 Curs := Current;
479 if Curs = No_Element then
480 return C;
482 elsif not Has_Element (Container, Curs) then
483 raise Constraint_Error;
485 else
486 while Curs.Node /= 0 loop
487 Node := Curs.Node;
488 Delete (C, Curs);
489 Curs := Next (Container, (Node => Node));
490 end loop;
492 return C;
493 end if;
494 end First_To_Previous;
496 ----------
497 -- Free --
498 ----------
500 procedure Free (HT : in out Map; X : Count_Type) is
501 begin
502 HT.Nodes (X).Has_Element := False;
503 HT_Ops.Free (HT, X);
504 end Free;
506 ----------------------
507 -- Generic_Allocate --
508 ----------------------
510 procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
512 procedure Allocate is
513 new HT_Ops.Generic_Allocate (Set_Element);
515 begin
516 Allocate (HT, Node);
517 HT.Nodes (Node).Has_Element := True;
518 end Generic_Allocate;
520 -----------------
521 -- Has_Element --
522 -----------------
524 function Has_Element (Container : Map; Position : Cursor) return Boolean is
525 begin
526 if Position.Node = 0
527 or else not Container.Nodes (Position.Node).Has_Element
528 then
529 return False;
530 else
531 return True;
532 end if;
533 end Has_Element;
535 ---------------
536 -- Hash_Node --
537 ---------------
539 function Hash_Node (Node : Node_Type) return Hash_Type is
540 begin
541 return Hash (Node.Key);
542 end Hash_Node;
544 -------------
545 -- Include --
546 -------------
548 procedure Include
549 (Container : in out Map;
550 Key : Key_Type;
551 New_Item : Element_Type)
553 Position : Cursor;
554 Inserted : Boolean;
556 begin
557 Insert (Container, Key, New_Item, Position, Inserted);
559 if not Inserted then
560 declare
561 N : Node_Type renames Container.Nodes (Position.Node);
562 begin
563 N.Key := Key;
564 N.Element := New_Item;
565 end;
566 end if;
567 end Include;
569 ------------
570 -- Insert --
571 ------------
573 procedure Insert
574 (Container : in out Map;
575 Key : Key_Type;
576 New_Item : Element_Type;
577 Position : out Cursor;
578 Inserted : out Boolean)
580 procedure Assign_Key (Node : in out Node_Type);
581 pragma Inline (Assign_Key);
583 function New_Node return Count_Type;
584 pragma Inline (New_Node);
586 procedure Local_Insert is
587 new Key_Ops.Generic_Conditional_Insert (New_Node);
589 procedure Allocate is
590 new Generic_Allocate (Assign_Key);
592 -----------------
593 -- Assign_Key --
594 -----------------
596 procedure Assign_Key (Node : in out Node_Type) is
597 begin
598 Node.Key := Key;
599 Node.Element := New_Item;
600 end Assign_Key;
602 --------------
603 -- New_Node --
604 --------------
606 function New_Node return Count_Type is
607 Result : Count_Type;
608 begin
609 Allocate (Container, Result);
610 return Result;
611 end New_Node;
613 -- Start of processing for Insert
615 begin
616 Local_Insert (Container, Key, Position.Node, Inserted);
617 end Insert;
619 procedure Insert
620 (Container : in out Map;
621 Key : Key_Type;
622 New_Item : Element_Type)
624 Position : Cursor;
625 pragma Unreferenced (Position);
627 Inserted : Boolean;
629 begin
630 Insert (Container, Key, New_Item, Position, Inserted);
632 if not Inserted then
633 raise Constraint_Error with
634 "attempt to insert key already in map";
635 end if;
636 end Insert;
638 --------------
639 -- Is_Empty --
640 --------------
642 function Is_Empty (Container : Map) return Boolean is
643 begin
644 return Length (Container) = 0;
645 end Is_Empty;
647 ---------
648 -- Key --
649 ---------
651 function Key (Container : Map; Position : Cursor) return Key_Type is
652 begin
653 if not Has_Element (Container, Position) then
654 raise Constraint_Error with
655 "Position cursor of function Key has no element";
656 end if;
658 pragma Assert (Vet (Container, Position), "bad cursor in function Key");
660 return Container.Nodes (Position.Node).Key;
661 end Key;
663 ------------
664 -- Length --
665 ------------
667 function Length (Container : Map) return Count_Type is
668 begin
669 return Container.Length;
670 end Length;
672 ----------
673 -- Move --
674 ----------
676 procedure Move
677 (Target : in out Map;
678 Source : in out Map)
680 NN : HT_Types.Nodes_Type renames Source.Nodes;
681 X, Y : Count_Type;
683 begin
684 if Target'Address = Source'Address then
685 return;
686 end if;
688 if Target.Capacity < Length (Source) then
689 raise Constraint_Error with -- ???
690 "Source length exceeds Target capacity";
691 end if;
693 Clear (Target);
695 if Source.Length = 0 then
696 return;
697 end if;
699 X := HT_Ops.First (Source);
700 while X /= 0 loop
701 Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
703 Y := HT_Ops.Next (Source, X);
705 HT_Ops.Delete_Node_Sans_Free (Source, X);
706 Free (Source, X);
708 X := Y;
709 end loop;
710 end Move;
712 ----------
713 -- Next --
714 ----------
716 function Next (Node : Node_Type) return Count_Type is
717 begin
718 return Node.Next;
719 end Next;
721 function Next (Container : Map; Position : Cursor) return Cursor is
722 begin
723 if Position.Node = 0 then
724 return No_Element;
725 end if;
727 if not Has_Element (Container, Position) then
728 raise Constraint_Error
729 with "Position has no element";
730 end if;
732 pragma Assert (Vet (Container, Position), "bad cursor in function Next");
734 declare
735 Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
737 begin
738 if Node = 0 then
739 return No_Element;
740 end if;
742 return (Node => Node);
743 end;
744 end Next;
746 procedure Next (Container : Map; Position : in out Cursor) is
747 begin
748 Position := Next (Container, Position);
749 end Next;
751 -------------
752 -- Overlap --
753 -------------
755 function Overlap (Left, Right : Map) return Boolean is
756 Left_Node : Count_Type;
757 Left_Nodes : Nodes_Type renames Left.Nodes;
759 begin
760 if Length (Right) = 0 or Length (Left) = 0 then
761 return False;
762 end if;
764 if Left'Address = Right'Address then
765 return True;
766 end if;
768 Left_Node := First (Left).Node;
769 while Left_Node /= 0 loop
770 declare
771 N : Node_Type renames Left_Nodes (Left_Node);
772 E : Key_Type renames N.Key;
773 begin
774 if Find (Right, E).Node /= 0 then
775 return True;
776 end if;
777 end;
779 Left_Node := HT_Ops.Next (Left, Left_Node);
780 end loop;
782 return False;
783 end Overlap;
785 -------------
786 -- Replace --
787 -------------
789 procedure Replace
790 (Container : in out Map;
791 Key : Key_Type;
792 New_Item : Element_Type)
794 Node : constant Count_Type := Key_Ops.Find (Container, Key);
796 begin
797 if Node = 0 then
798 raise Constraint_Error with
799 "attempt to replace key not in map";
800 end if;
802 declare
803 N : Node_Type renames Container.Nodes (Node);
804 begin
805 N.Key := Key;
806 N.Element := New_Item;
807 end;
808 end Replace;
810 ---------------------
811 -- Replace_Element --
812 ---------------------
814 procedure Replace_Element
815 (Container : in out Map;
816 Position : Cursor;
817 New_Item : Element_Type)
819 begin
820 if not Has_Element (Container, Position) then
821 raise Constraint_Error with
822 "Position cursor of Replace_Element has no element";
823 end if;
825 pragma Assert (Vet (Container, Position),
826 "bad cursor in Replace_Element");
828 Container.Nodes (Position.Node).Element := New_Item;
829 end Replace_Element;
831 ----------------------
832 -- Reserve_Capacity --
833 ----------------------
835 procedure Reserve_Capacity
836 (Container : in out Map;
837 Capacity : Count_Type)
839 begin
840 if Capacity > Container.Capacity then
841 raise Capacity_Error with "requested capacity is too large";
842 end if;
843 end Reserve_Capacity;
845 --------------
846 -- Set_Next --
847 --------------
849 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
850 begin
851 Node.Next := Next;
852 end Set_Next;
854 ------------------
855 -- Strict_Equal --
856 ------------------
858 function Strict_Equal (Left, Right : Map) return Boolean is
859 CuL : Cursor := First (Left);
860 CuR : Cursor := First (Right);
862 begin
863 if Length (Left) /= Length (Right) then
864 return False;
865 end if;
867 while CuL.Node /= 0 or else CuR.Node /= 0 loop
868 if CuL.Node /= CuR.Node
869 or else
870 Left.Nodes (CuL.Node).Element /= Right.Nodes (CuR.Node).Element
871 or else Left.Nodes (CuL.Node).Key /= Right.Nodes (CuR.Node).Key
872 then
873 return False;
874 end if;
876 CuL := Next (Left, CuL);
877 CuR := Next (Right, CuR);
878 end loop;
880 return True;
881 end Strict_Equal;
883 ---------
884 -- Vet --
885 ---------
887 function Vet (Container : Map; Position : Cursor) return Boolean is
888 begin
889 if Position.Node = 0 then
890 return True;
891 end if;
893 declare
894 X : Count_Type;
896 begin
897 if Container.Length = 0 then
898 return False;
899 end if;
901 if Container.Capacity = 0 then
902 return False;
903 end if;
905 if Container.Buckets'Length = 0 then
906 return False;
907 end if;
909 if Position.Node > Container.Capacity then
910 return False;
911 end if;
913 if Container.Nodes (Position.Node).Next = Position.Node then
914 return False;
915 end if;
917 X := Container.Buckets
918 (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
920 for J in 1 .. Container.Length loop
921 if X = Position.Node then
922 return True;
923 end if;
925 if X = 0 then
926 return False;
927 end if;
929 if X = Container.Nodes (X).Next then
931 -- Prevent unnecessary looping
933 return False;
934 end if;
936 X := Container.Nodes (X).Next;
937 end loop;
939 return False;
940 end;
941 end Vet;
943 end Ada.Containers.Formal_Hashed_Maps;