GCC v8.2
[gcc.git] / gcc / ada / libgnat / a-cofuba.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT LIBRARY COMPONENTS                          --
4 --                                                                          --
5 --                      ADA.CONTAINERS.FUNCTIONAL_BASE                      --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 2016-2018, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the  contents of the part following the private keyword. --
14 --                                                                          --
15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
16 -- terms of the  GNU General Public License as published  by the Free Soft- --
17 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
21 --                                                                          --
22 -- As a special exception under Section 7 of GPL version 3, you are granted --
23 -- additional permissions described in the GCC Runtime Library Exception,   --
24 -- version 3.1, as published by the Free Software Foundation.               --
25 --                                                                          --
26 -- You should have received a copy of the GNU General Public License and    --
27 -- a copy of the GCC Runtime Library Exception along with this program;     --
28 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
29 -- <http://www.gnu.org/licenses/>.                                          --
30 ------------------------------------------------------------------------------
31
32 pragma Ada_2012;
33
34 package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
35
36    function To_Count (Idx : Extended_Index) return Count_Type is
37      (Count_Type
38        (Extended_Index'Pos (Idx) -
39         Extended_Index'Pos (Extended_Index'First)));
40
41    function To_Index (Position : Count_Type) return Extended_Index is
42      (Extended_Index'Val
43        (Position + Extended_Index'Pos (Extended_Index'First)));
44    --  Conversion functions between Index_Type and Count_Type
45
46    function Find (C : Container; E : access Element_Type) return Count_Type;
47    --  Search a container C for an element equal to E.all, returning the
48    --  position in the underlying array.
49
50    ---------
51    -- "=" --
52    ---------
53
54    function "=" (C1 : Container; C2 : Container) return Boolean is
55    begin
56       if C1.Elements'Length /= C2.Elements'Length then
57          return False;
58       end if;
59
60       for I in C1.Elements'Range loop
61          if C1.Elements (I).all /= C2.Elements (I).all then
62             return False;
63          end if;
64       end loop;
65
66       return True;
67    end "=";
68
69    ----------
70    -- "<=" --
71    ----------
72
73    function "<=" (C1 : Container; C2 : Container) return Boolean is
74    begin
75       for I in C1.Elements'Range loop
76          if Find (C2, C1.Elements (I)) = 0 then
77             return False;
78          end if;
79       end loop;
80
81       return True;
82    end "<=";
83
84    ---------
85    -- Add --
86    ---------
87
88    function Add
89      (C : Container;
90       I : Index_Type;
91       E : Element_Type) return Container
92    is
93       A : constant Element_Array_Access :=
94             new Element_Array'(1 .. C.Elements'Last + 1 => <>);
95       P : Count_Type := 0;
96
97    begin
98       for J in 1 .. C.Elements'Last + 1 loop
99          if J /= To_Count (I) then
100             P := P + 1;
101             A (J) := C.Elements (P);
102          else
103             A (J) := new Element_Type'(E);
104          end if;
105       end loop;
106
107       return Container'(Elements => A);
108    end Add;
109
110    ----------
111    -- Find --
112    ----------
113
114    function Find (C : Container; E : access Element_Type) return Count_Type is
115    begin
116       for I in C.Elements'Range loop
117          if C.Elements (I).all = E.all then
118             return I;
119          end if;
120       end loop;
121
122       return 0;
123    end Find;
124
125    function Find (C : Container; E : Element_Type) return Extended_Index is
126      (To_Index (Find (C, E'Unrestricted_Access)));
127
128    ---------
129    -- Get --
130    ---------
131
132    function Get (C : Container; I : Index_Type) return Element_Type is
133      (C.Elements (To_Count (I)).all);
134
135    ------------------
136    -- Intersection --
137    ------------------
138
139    function Intersection (C1 : Container; C2 : Container) return Container is
140       A : constant Element_Array_Access :=
141             new Element_Array'(1 .. Num_Overlaps (C1, C2) => <>);
142       P : Count_Type := 0;
143
144    begin
145       for I in C1.Elements'Range loop
146          if Find (C2, C1.Elements (I)) > 0 then
147             P := P + 1;
148             A (P) := C1.Elements (I);
149          end if;
150       end loop;
151
152       return Container'(Elements => A);
153    end Intersection;
154
155    ------------
156    -- Length --
157    ------------
158
159    function Length (C : Container) return Count_Type is (C.Elements'Length);
160
161    ---------------------
162    -- Num_Overlaps --
163    ---------------------
164
165    function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
166       P : Count_Type := 0;
167
168    begin
169       for I in C1.Elements'Range loop
170          if Find (C2, C1.Elements (I)) > 0 then
171             P := P + 1;
172          end if;
173       end loop;
174
175       return P;
176    end Num_Overlaps;
177
178    ------------
179    -- Remove --
180    ------------
181
182    function Remove (C : Container; I : Index_Type) return Container is
183       A : constant Element_Array_Access :=
184             new Element_Array'(1 .. C.Elements'Last - 1 => <>);
185       P : Count_Type := 0;
186
187    begin
188       for J in C.Elements'Range loop
189          if J /= To_Count (I) then
190             P := P + 1;
191             A (P) := C.Elements (J);
192          end if;
193       end loop;
194
195       return Container'(Elements => A);
196    end Remove;
197
198    ---------
199    -- Set --
200    ---------
201
202    function Set
203      (C : Container;
204       I : Index_Type;
205       E : Element_Type) return Container
206    is
207       Result : constant Container :=
208                  Container'(Elements => new Element_Array'(C.Elements.all));
209
210    begin
211       Result.Elements (To_Count (I)) := new Element_Type'(E);
212       return Result;
213    end Set;
214
215    -----------
216    -- Union --
217    -----------
218
219    function Union (C1 : Container; C2 : Container) return Container is
220       N : constant Count_Type := Num_Overlaps (C1, C2);
221
222    begin
223       --  if C2 is completely included in C1 then return C1
224
225       if N = Length (C2) then
226          return C1;
227       end if;
228
229       --  else loop through C2 to find the remaining elements
230
231       declare
232          L : constant Count_Type := Length (C1) - N + Length (C2);
233          A : constant Element_Array_Access :=
234                new Element_Array'
235                      (C1.Elements.all & (Length (C1) + 1 .. L => <>));
236          P : Count_Type := Length (C1);
237
238       begin
239          for I in C2.Elements'Range loop
240             if Find (C1, C2.Elements (I)) = 0 then
241                P := P + 1;
242                A (P) := C2.Elements (I);
243             end if;
244          end loop;
245
246          return Container'(Elements => A);
247       end;
248    end Union;
249
250 end Ada.Containers.Functional_Base;