|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- ADA.CONTAINERS.FUNCTIONAL_BASE --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 2016-2019, Free Software Foundation, Inc. --
|
|
111
|
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;
|
|
145
|
33 with Ada.Unchecked_Deallocation;
|
|
111
|
34
|
|
|
35 package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
|
|
|
36
|
|
|
37 function To_Count (Idx : Extended_Index) return Count_Type is
|
|
|
38 (Count_Type
|
|
|
39 (Extended_Index'Pos (Idx) -
|
|
|
40 Extended_Index'Pos (Extended_Index'First)));
|
|
|
41
|
|
|
42 function To_Index (Position : Count_Type) return Extended_Index is
|
|
|
43 (Extended_Index'Val
|
|
|
44 (Position + Extended_Index'Pos (Extended_Index'First)));
|
|
|
45 -- Conversion functions between Index_Type and Count_Type
|
|
|
46
|
|
|
47 function Find (C : Container; E : access Element_Type) return Count_Type;
|
|
|
48 -- Search a container C for an element equal to E.all, returning the
|
|
|
49 -- position in the underlying array.
|
|
|
50
|
|
145
|
51 procedure Resize (Base : Array_Base_Access);
|
|
|
52 -- Resize the underlying array if needed so that it can contain one more
|
|
|
53 -- element.
|
|
|
54
|
|
111
|
55 ---------
|
|
|
56 -- "=" --
|
|
|
57 ---------
|
|
|
58
|
|
|
59 function "=" (C1 : Container; C2 : Container) return Boolean is
|
|
|
60 begin
|
|
145
|
61 if C1.Length /= C2.Length then
|
|
111
|
62 return False;
|
|
|
63 end if;
|
|
|
64
|
|
145
|
65 for I in 1 .. C1.Length loop
|
|
|
66 if C1.Base.Elements (I).all /= C2.Base.Elements (I).all then
|
|
111
|
67 return False;
|
|
|
68 end if;
|
|
|
69 end loop;
|
|
|
70
|
|
|
71 return True;
|
|
|
72 end "=";
|
|
|
73
|
|
|
74 ----------
|
|
|
75 -- "<=" --
|
|
|
76 ----------
|
|
|
77
|
|
|
78 function "<=" (C1 : Container; C2 : Container) return Boolean is
|
|
|
79 begin
|
|
145
|
80 for I in 1 .. C1.Length loop
|
|
|
81 if Find (C2, C1.Base.Elements (I)) = 0 then
|
|
111
|
82 return False;
|
|
|
83 end if;
|
|
|
84 end loop;
|
|
|
85
|
|
|
86 return True;
|
|
|
87 end "<=";
|
|
|
88
|
|
|
89 ---------
|
|
|
90 -- Add --
|
|
|
91 ---------
|
|
|
92
|
|
|
93 function Add
|
|
|
94 (C : Container;
|
|
|
95 I : Index_Type;
|
|
|
96 E : Element_Type) return Container
|
|
|
97 is
|
|
|
98 begin
|
|
145
|
99 if To_Count (I) = C.Length + 1 and then C.Length = C.Base.Max_Length then
|
|
|
100 Resize (C.Base);
|
|
|
101 C.Base.Max_Length := C.Base.Max_Length + 1;
|
|
|
102 C.Base.Elements (C.Base.Max_Length) := new Element_Type'(E);
|
|
|
103
|
|
|
104 return Container'(Length => C.Base.Max_Length, Base => C.Base);
|
|
|
105 else
|
|
|
106 declare
|
|
|
107 A : constant Array_Base_Access := Content_Init (C.Length);
|
|
|
108 P : Count_Type := 0;
|
|
|
109 begin
|
|
|
110 A.Max_Length := C.Length + 1;
|
|
|
111 for J in 1 .. C.Length + 1 loop
|
|
|
112 if J /= To_Count (I) then
|
|
|
113 P := P + 1;
|
|
|
114 A.Elements (J) := C.Base.Elements (P);
|
|
|
115 else
|
|
|
116 A.Elements (J) := new Element_Type'(E);
|
|
|
117 end if;
|
|
|
118 end loop;
|
|
111
|
119
|
|
145
|
120 return Container'(Length => A.Max_Length,
|
|
|
121 Base => A);
|
|
|
122 end;
|
|
|
123 end if;
|
|
111
|
124 end Add;
|
|
|
125
|
|
145
|
126 ------------------
|
|
|
127 -- Content_Init --
|
|
|
128 ------------------
|
|
|
129
|
|
|
130 function Content_Init (L : Count_Type := 0) return Array_Base_Access
|
|
|
131 is
|
|
|
132 Max_Init : constant Count_Type := 100;
|
|
|
133 Size : constant Count_Type :=
|
|
|
134 (if L < Count_Type'Last - Max_Init then L + Max_Init
|
|
|
135 else Count_Type'Last);
|
|
|
136 Elements : constant Element_Array_Access :=
|
|
|
137 new Element_Array'(1 .. Size => <>);
|
|
|
138 begin
|
|
|
139 return new Array_Base'(Max_Length => 0, Elements => Elements);
|
|
|
140 end Content_Init;
|
|
|
141
|
|
111
|
142 ----------
|
|
|
143 -- Find --
|
|
|
144 ----------
|
|
|
145
|
|
|
146 function Find (C : Container; E : access Element_Type) return Count_Type is
|
|
|
147 begin
|
|
145
|
148 for I in 1 .. C.Length loop
|
|
|
149 if C.Base.Elements (I).all = E.all then
|
|
111
|
150 return I;
|
|
|
151 end if;
|
|
|
152 end loop;
|
|
|
153
|
|
|
154 return 0;
|
|
|
155 end Find;
|
|
|
156
|
|
|
157 function Find (C : Container; E : Element_Type) return Extended_Index is
|
|
|
158 (To_Index (Find (C, E'Unrestricted_Access)));
|
|
|
159
|
|
|
160 ---------
|
|
|
161 -- Get --
|
|
|
162 ---------
|
|
|
163
|
|
|
164 function Get (C : Container; I : Index_Type) return Element_Type is
|
|
145
|
165 (C.Base.Elements (To_Count (I)).all);
|
|
111
|
166
|
|
|
167 ------------------
|
|
|
168 -- Intersection --
|
|
|
169 ------------------
|
|
|
170
|
|
|
171 function Intersection (C1 : Container; C2 : Container) return Container is
|
|
145
|
172 L : constant Count_Type := Num_Overlaps (C1, C2);
|
|
|
173 A : constant Array_Base_Access := Content_Init (L);
|
|
111
|
174 P : Count_Type := 0;
|
|
|
175
|
|
|
176 begin
|
|
145
|
177 A.Max_Length := L;
|
|
|
178 for I in 1 .. C1.Length loop
|
|
|
179 if Find (C2, C1.Base.Elements (I)) > 0 then
|
|
111
|
180 P := P + 1;
|
|
145
|
181 A.Elements (P) := C1.Base.Elements (I);
|
|
111
|
182 end if;
|
|
|
183 end loop;
|
|
|
184
|
|
145
|
185 return Container'(Length => P, Base => A);
|
|
111
|
186 end Intersection;
|
|
|
187
|
|
|
188 ------------
|
|
|
189 -- Length --
|
|
|
190 ------------
|
|
|
191
|
|
145
|
192 function Length (C : Container) return Count_Type is (C.Length);
|
|
111
|
193 ---------------------
|
|
|
194 -- Num_Overlaps --
|
|
|
195 ---------------------
|
|
|
196
|
|
|
197 function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
|
|
|
198 P : Count_Type := 0;
|
|
|
199
|
|
|
200 begin
|
|
145
|
201 for I in 1 .. C1.Length loop
|
|
|
202 if Find (C2, C1.Base.Elements (I)) > 0 then
|
|
111
|
203 P := P + 1;
|
|
|
204 end if;
|
|
|
205 end loop;
|
|
|
206
|
|
|
207 return P;
|
|
|
208 end Num_Overlaps;
|
|
|
209
|
|
|
210 ------------
|
|
|
211 -- Remove --
|
|
|
212 ------------
|
|
|
213
|
|
|
214 function Remove (C : Container; I : Index_Type) return Container is
|
|
145
|
215 begin
|
|
|
216 if To_Count (I) = C.Length then
|
|
|
217 return Container'(Length => C.Length - 1, Base => C.Base);
|
|
|
218 else
|
|
|
219 declare
|
|
|
220 A : constant Array_Base_Access := Content_Init (C.Length - 1);
|
|
|
221 P : Count_Type := 0;
|
|
|
222 begin
|
|
|
223 A.Max_Length := C.Length - 1;
|
|
|
224 for J in 1 .. C.Length loop
|
|
|
225 if J /= To_Count (I) then
|
|
|
226 P := P + 1;
|
|
|
227 A.Elements (P) := C.Base.Elements (J);
|
|
|
228 end if;
|
|
|
229 end loop;
|
|
111
|
230
|
|
145
|
231 return Container'(Length => C.Length - 1, Base => A);
|
|
|
232 end;
|
|
|
233 end if;
|
|
|
234 end Remove;
|
|
|
235
|
|
|
236 ------------
|
|
|
237 -- Resize --
|
|
|
238 ------------
|
|
|
239
|
|
|
240 procedure Resize (Base : Array_Base_Access) is
|
|
111
|
241 begin
|
|
145
|
242 if Base.Max_Length < Base.Elements'Length then
|
|
|
243 return;
|
|
|
244 end if;
|
|
|
245
|
|
|
246 pragma Assert (Base.Max_Length = Base.Elements'Length);
|
|
|
247
|
|
|
248 if Base.Max_Length = Count_Type'Last then
|
|
|
249 raise Constraint_Error;
|
|
|
250 end if;
|
|
111
|
251
|
|
145
|
252 declare
|
|
|
253 procedure Finalize is new Ada.Unchecked_Deallocation
|
|
|
254 (Object => Element_Array,
|
|
|
255 Name => Element_Array_Access_Base);
|
|
|
256
|
|
|
257 New_Length : constant Positive_Count_Type :=
|
|
|
258 (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last
|
|
|
259 else 2 * Base.Max_Length);
|
|
|
260 Elements : constant Element_Array_Access :=
|
|
|
261 new Element_Array (1 .. New_Length);
|
|
|
262 Old_Elmts : Element_Array_Access_Base := Base.Elements;
|
|
|
263 begin
|
|
|
264 Elements (1 .. Base.Max_Length) := Base.Elements.all;
|
|
|
265 Base.Elements := Elements;
|
|
|
266 Finalize (Old_Elmts);
|
|
|
267 end;
|
|
|
268 end Resize;
|
|
111
|
269
|
|
|
270 ---------
|
|
|
271 -- Set --
|
|
|
272 ---------
|
|
|
273
|
|
|
274 function Set
|
|
|
275 (C : Container;
|
|
|
276 I : Index_Type;
|
|
|
277 E : Element_Type) return Container
|
|
|
278 is
|
|
|
279 Result : constant Container :=
|
|
145
|
280 Container'(Length => C.Length,
|
|
|
281 Base => Content_Init (C.Length));
|
|
111
|
282
|
|
|
283 begin
|
|
145
|
284 Result.Base.Max_Length := C.Length;
|
|
|
285 Result.Base.Elements (1 .. C.Length) := C.Base.Elements (1 .. C.Length);
|
|
|
286 Result.Base.Elements (To_Count (I)) := new Element_Type'(E);
|
|
111
|
287 return Result;
|
|
|
288 end Set;
|
|
|
289
|
|
|
290 -----------
|
|
|
291 -- Union --
|
|
|
292 -----------
|
|
|
293
|
|
|
294 function Union (C1 : Container; C2 : Container) return Container is
|
|
|
295 N : constant Count_Type := Num_Overlaps (C1, C2);
|
|
|
296
|
|
|
297 begin
|
|
|
298 -- if C2 is completely included in C1 then return C1
|
|
|
299
|
|
|
300 if N = Length (C2) then
|
|
|
301 return C1;
|
|
|
302 end if;
|
|
|
303
|
|
|
304 -- else loop through C2 to find the remaining elements
|
|
|
305
|
|
|
306 declare
|
|
|
307 L : constant Count_Type := Length (C1) - N + Length (C2);
|
|
145
|
308 A : constant Array_Base_Access := Content_Init (L);
|
|
111
|
309 P : Count_Type := Length (C1);
|
|
|
310
|
|
|
311 begin
|
|
145
|
312 A.Max_Length := L;
|
|
|
313 A.Elements (1 .. C1.Length) := C1.Base.Elements (1 .. C1.Length);
|
|
|
314 for I in 1 .. C2.Length loop
|
|
|
315 if Find (C1, C2.Base.Elements (I)) = 0 then
|
|
111
|
316 P := P + 1;
|
|
145
|
317 A.Elements (P) := C2.Base.Elements (I);
|
|
111
|
318 end if;
|
|
|
319 end loop;
|
|
|
320
|
|
145
|
321 return Container'(Length => L, Base => A);
|
|
111
|
322 end;
|
|
|
323 end Union;
|
|
|
324
|
|
|
325 end Ada.Containers.Functional_Base;
|
