annotate gcc/ada/libgnat/a-coinve.adb @ 145:1830386684a0

gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT LIBRARY COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
9 -- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
kono
parents:
diff changeset
17 -- --
kono
parents:
diff changeset
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
kono
parents:
diff changeset
19 -- additional permissions described in the GCC Runtime Library Exception, --
kono
parents:
diff changeset
20 -- version 3.1, as published by the Free Software Foundation. --
kono
parents:
diff changeset
21 -- --
kono
parents:
diff changeset
22 -- You should have received a copy of the GNU General Public License and --
kono
parents:
diff changeset
23 -- a copy of the GCC Runtime Library Exception along with this program; --
kono
parents:
diff changeset
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
kono
parents:
diff changeset
25 -- <http://www.gnu.org/licenses/>. --
kono
parents:
diff changeset
26 -- --
kono
parents:
diff changeset
27 -- This unit was originally developed by Matthew J Heaney. --
kono
parents:
diff changeset
28 ------------------------------------------------------------------------------
kono
parents:
diff changeset
29
kono
parents:
diff changeset
30 with Ada.Containers.Generic_Array_Sort;
kono
parents:
diff changeset
31 with Ada.Unchecked_Deallocation;
kono
parents:
diff changeset
32
kono
parents:
diff changeset
33 with System; use type System.Address;
kono
parents:
diff changeset
34
kono
parents:
diff changeset
35 package body Ada.Containers.Indefinite_Vectors is
kono
parents:
diff changeset
36
kono
parents:
diff changeset
37 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
kono
parents:
diff changeset
38 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
kono
parents:
diff changeset
39 -- See comment in Ada.Containers.Helpers
kono
parents:
diff changeset
40
kono
parents:
diff changeset
41 procedure Free is
kono
parents:
diff changeset
42 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
kono
parents:
diff changeset
43
kono
parents:
diff changeset
44 procedure Free is
kono
parents:
diff changeset
45 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
kono
parents:
diff changeset
46
kono
parents:
diff changeset
47 procedure Append_Slow_Path
kono
parents:
diff changeset
48 (Container : in out Vector;
kono
parents:
diff changeset
49 New_Item : Element_Type;
kono
parents:
diff changeset
50 Count : Count_Type);
kono
parents:
diff changeset
51 -- This is the slow path for Append. This is split out to minimize the size
kono
parents:
diff changeset
52 -- of Append, because we have Inline (Append).
kono
parents:
diff changeset
53
kono
parents:
diff changeset
54 ---------
kono
parents:
diff changeset
55 -- "&" --
kono
parents:
diff changeset
56 ---------
kono
parents:
diff changeset
57
kono
parents:
diff changeset
58 -- We decide that the capacity of the result of "&" is the minimum needed
kono
parents:
diff changeset
59 -- -- the sum of the lengths of the vector parameters. We could decide to
kono
parents:
diff changeset
60 -- make it larger, but we have no basis for knowing how much larger, so we
kono
parents:
diff changeset
61 -- just allocate the minimum amount of storage.
kono
parents:
diff changeset
62
kono
parents:
diff changeset
63 function "&" (Left, Right : Vector) return Vector is
kono
parents:
diff changeset
64 begin
kono
parents:
diff changeset
65 return Result : Vector do
kono
parents:
diff changeset
66 Reserve_Capacity (Result, Length (Left) + Length (Right));
kono
parents:
diff changeset
67 Append (Result, Left);
kono
parents:
diff changeset
68 Append (Result, Right);
kono
parents:
diff changeset
69 end return;
kono
parents:
diff changeset
70 end "&";
kono
parents:
diff changeset
71
kono
parents:
diff changeset
72 function "&" (Left : Vector; Right : Element_Type) return Vector is
kono
parents:
diff changeset
73 begin
kono
parents:
diff changeset
74 return Result : Vector do
kono
parents:
diff changeset
75 Reserve_Capacity (Result, Length (Left) + 1);
kono
parents:
diff changeset
76 Append (Result, Left);
kono
parents:
diff changeset
77 Append (Result, Right);
kono
parents:
diff changeset
78 end return;
kono
parents:
diff changeset
79 end "&";
kono
parents:
diff changeset
80
kono
parents:
diff changeset
81 function "&" (Left : Element_Type; Right : Vector) return Vector is
kono
parents:
diff changeset
82 begin
kono
parents:
diff changeset
83 return Result : Vector do
kono
parents:
diff changeset
84 Reserve_Capacity (Result, 1 + Length (Right));
kono
parents:
diff changeset
85 Append (Result, Left);
kono
parents:
diff changeset
86 Append (Result, Right);
kono
parents:
diff changeset
87 end return;
kono
parents:
diff changeset
88 end "&";
kono
parents:
diff changeset
89
kono
parents:
diff changeset
90 function "&" (Left, Right : Element_Type) return Vector is
kono
parents:
diff changeset
91 begin
kono
parents:
diff changeset
92 return Result : Vector do
kono
parents:
diff changeset
93 Reserve_Capacity (Result, 1 + 1);
kono
parents:
diff changeset
94 Append (Result, Left);
kono
parents:
diff changeset
95 Append (Result, Right);
kono
parents:
diff changeset
96 end return;
kono
parents:
diff changeset
97 end "&";
kono
parents:
diff changeset
98
kono
parents:
diff changeset
99 ---------
kono
parents:
diff changeset
100 -- "=" --
kono
parents:
diff changeset
101 ---------
kono
parents:
diff changeset
102
kono
parents:
diff changeset
103 overriding function "=" (Left, Right : Vector) return Boolean is
kono
parents:
diff changeset
104 begin
kono
parents:
diff changeset
105 if Left.Last /= Right.Last then
kono
parents:
diff changeset
106 return False;
kono
parents:
diff changeset
107 end if;
kono
parents:
diff changeset
108
kono
parents:
diff changeset
109 if Left.Length = 0 then
kono
parents:
diff changeset
110 return True;
kono
parents:
diff changeset
111 end if;
kono
parents:
diff changeset
112
kono
parents:
diff changeset
113 declare
kono
parents:
diff changeset
114 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
115 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
116
kono
parents:
diff changeset
117 Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
kono
parents:
diff changeset
118 Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
kono
parents:
diff changeset
119 begin
kono
parents:
diff changeset
120 for J in Index_Type range Index_Type'First .. Left.Last loop
kono
parents:
diff changeset
121 if Left.Elements.EA (J) = null then
kono
parents:
diff changeset
122 if Right.Elements.EA (J) /= null then
kono
parents:
diff changeset
123 return False;
kono
parents:
diff changeset
124 end if;
kono
parents:
diff changeset
125
kono
parents:
diff changeset
126 elsif Right.Elements.EA (J) = null then
kono
parents:
diff changeset
127 return False;
kono
parents:
diff changeset
128
kono
parents:
diff changeset
129 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
kono
parents:
diff changeset
130 return False;
kono
parents:
diff changeset
131 end if;
kono
parents:
diff changeset
132 end loop;
kono
parents:
diff changeset
133 end;
kono
parents:
diff changeset
134
kono
parents:
diff changeset
135 return True;
kono
parents:
diff changeset
136 end "=";
kono
parents:
diff changeset
137
kono
parents:
diff changeset
138 ------------
kono
parents:
diff changeset
139 -- Adjust --
kono
parents:
diff changeset
140 ------------
kono
parents:
diff changeset
141
kono
parents:
diff changeset
142 procedure Adjust (Container : in out Vector) is
kono
parents:
diff changeset
143 begin
kono
parents:
diff changeset
144 -- If the counts are nonzero, execution is technically erroneous, but
kono
parents:
diff changeset
145 -- it seems friendly to allow things like concurrent "=" on shared
kono
parents:
diff changeset
146 -- constants.
kono
parents:
diff changeset
147
kono
parents:
diff changeset
148 Zero_Counts (Container.TC);
kono
parents:
diff changeset
149
kono
parents:
diff changeset
150 if Container.Last = No_Index then
kono
parents:
diff changeset
151 Container.Elements := null;
kono
parents:
diff changeset
152 return;
kono
parents:
diff changeset
153 end if;
kono
parents:
diff changeset
154
kono
parents:
diff changeset
155 declare
kono
parents:
diff changeset
156 L : constant Index_Type := Container.Last;
kono
parents:
diff changeset
157 E : Elements_Array renames
kono
parents:
diff changeset
158 Container.Elements.EA (Index_Type'First .. L);
kono
parents:
diff changeset
159
kono
parents:
diff changeset
160 begin
kono
parents:
diff changeset
161 Container.Elements := null;
kono
parents:
diff changeset
162 Container.Last := No_Index;
kono
parents:
diff changeset
163
kono
parents:
diff changeset
164 Container.Elements := new Elements_Type (L);
kono
parents:
diff changeset
165
kono
parents:
diff changeset
166 for J in E'Range loop
kono
parents:
diff changeset
167 if E (J) /= null then
kono
parents:
diff changeset
168 Container.Elements.EA (J) := new Element_Type'(E (J).all);
kono
parents:
diff changeset
169 end if;
kono
parents:
diff changeset
170
kono
parents:
diff changeset
171 Container.Last := J;
kono
parents:
diff changeset
172 end loop;
kono
parents:
diff changeset
173 end;
kono
parents:
diff changeset
174 end Adjust;
kono
parents:
diff changeset
175
kono
parents:
diff changeset
176 ------------
kono
parents:
diff changeset
177 -- Append --
kono
parents:
diff changeset
178 ------------
kono
parents:
diff changeset
179
kono
parents:
diff changeset
180 procedure Append (Container : in out Vector; New_Item : Vector) is
kono
parents:
diff changeset
181 begin
kono
parents:
diff changeset
182 if Is_Empty (New_Item) then
kono
parents:
diff changeset
183 return;
kono
parents:
diff changeset
184 elsif Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
185 raise Constraint_Error with "vector is already at its maximum length";
kono
parents:
diff changeset
186 else
kono
parents:
diff changeset
187 Insert (Container, Container.Last + 1, New_Item);
kono
parents:
diff changeset
188 end if;
kono
parents:
diff changeset
189 end Append;
kono
parents:
diff changeset
190
kono
parents:
diff changeset
191 procedure Append
kono
parents:
diff changeset
192 (Container : in out Vector;
kono
parents:
diff changeset
193 New_Item : Element_Type;
kono
parents:
diff changeset
194 Count : Count_Type := 1)
kono
parents:
diff changeset
195 is
kono
parents:
diff changeset
196 begin
kono
parents:
diff changeset
197 -- In the general case, we pass the buck to Insert, but for efficiency,
kono
parents:
diff changeset
198 -- we check for the usual case where Count = 1 and the vector has enough
kono
parents:
diff changeset
199 -- room for at least one more element.
kono
parents:
diff changeset
200
kono
parents:
diff changeset
201 if Count = 1
kono
parents:
diff changeset
202 and then Container.Elements /= null
kono
parents:
diff changeset
203 and then Container.Last /= Container.Elements.Last
kono
parents:
diff changeset
204 then
kono
parents:
diff changeset
205 TC_Check (Container.TC);
kono
parents:
diff changeset
206
kono
parents:
diff changeset
207 -- Increment Container.Last after assigning the New_Item, so we
kono
parents:
diff changeset
208 -- leave the Container unmodified in case Finalize/Adjust raises
kono
parents:
diff changeset
209 -- an exception.
kono
parents:
diff changeset
210
kono
parents:
diff changeset
211 declare
kono
parents:
diff changeset
212 New_Last : constant Index_Type := Container.Last + 1;
kono
parents:
diff changeset
213
kono
parents:
diff changeset
214 -- The element allocator may need an accessibility check in the
kono
parents:
diff changeset
215 -- case actual type is class-wide or has access discriminants
kono
parents:
diff changeset
216 -- (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
217
kono
parents:
diff changeset
218 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
219 begin
kono
parents:
diff changeset
220 Container.Elements.EA (New_Last) := new Element_Type'(New_Item);
kono
parents:
diff changeset
221 Container.Last := New_Last;
kono
parents:
diff changeset
222 end;
kono
parents:
diff changeset
223
kono
parents:
diff changeset
224 else
kono
parents:
diff changeset
225 Append_Slow_Path (Container, New_Item, Count);
kono
parents:
diff changeset
226 end if;
kono
parents:
diff changeset
227 end Append;
kono
parents:
diff changeset
228
kono
parents:
diff changeset
229 ----------------------
kono
parents:
diff changeset
230 -- Append_Slow_Path --
kono
parents:
diff changeset
231 ----------------------
kono
parents:
diff changeset
232
kono
parents:
diff changeset
233 procedure Append_Slow_Path
kono
parents:
diff changeset
234 (Container : in out Vector;
kono
parents:
diff changeset
235 New_Item : Element_Type;
kono
parents:
diff changeset
236 Count : Count_Type)
kono
parents:
diff changeset
237 is
kono
parents:
diff changeset
238 begin
kono
parents:
diff changeset
239 if Count = 0 then
kono
parents:
diff changeset
240 return;
kono
parents:
diff changeset
241 elsif Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
242 raise Constraint_Error with "vector is already at its maximum length";
kono
parents:
diff changeset
243 else
kono
parents:
diff changeset
244 Insert (Container, Container.Last + 1, New_Item, Count);
kono
parents:
diff changeset
245 end if;
kono
parents:
diff changeset
246 end Append_Slow_Path;
kono
parents:
diff changeset
247
kono
parents:
diff changeset
248 ------------
kono
parents:
diff changeset
249 -- Assign --
kono
parents:
diff changeset
250 ------------
kono
parents:
diff changeset
251
kono
parents:
diff changeset
252 procedure Assign (Target : in out Vector; Source : Vector) is
kono
parents:
diff changeset
253 begin
kono
parents:
diff changeset
254 if Target'Address = Source'Address then
kono
parents:
diff changeset
255 return;
kono
parents:
diff changeset
256 else
kono
parents:
diff changeset
257 Target.Clear;
kono
parents:
diff changeset
258 Target.Append (Source);
kono
parents:
diff changeset
259 end if;
kono
parents:
diff changeset
260 end Assign;
kono
parents:
diff changeset
261
kono
parents:
diff changeset
262 --------------
kono
parents:
diff changeset
263 -- Capacity --
kono
parents:
diff changeset
264 --------------
kono
parents:
diff changeset
265
kono
parents:
diff changeset
266 function Capacity (Container : Vector) return Count_Type is
kono
parents:
diff changeset
267 begin
kono
parents:
diff changeset
268 if Container.Elements = null then
kono
parents:
diff changeset
269 return 0;
kono
parents:
diff changeset
270 else
kono
parents:
diff changeset
271 return Container.Elements.EA'Length;
kono
parents:
diff changeset
272 end if;
kono
parents:
diff changeset
273 end Capacity;
kono
parents:
diff changeset
274
kono
parents:
diff changeset
275 -----------
kono
parents:
diff changeset
276 -- Clear --
kono
parents:
diff changeset
277 -----------
kono
parents:
diff changeset
278
kono
parents:
diff changeset
279 procedure Clear (Container : in out Vector) is
kono
parents:
diff changeset
280 begin
kono
parents:
diff changeset
281 TC_Check (Container.TC);
kono
parents:
diff changeset
282
kono
parents:
diff changeset
283 while Container.Last >= Index_Type'First loop
kono
parents:
diff changeset
284 declare
kono
parents:
diff changeset
285 X : Element_Access := Container.Elements.EA (Container.Last);
kono
parents:
diff changeset
286 begin
kono
parents:
diff changeset
287 Container.Elements.EA (Container.Last) := null;
kono
parents:
diff changeset
288 Container.Last := Container.Last - 1;
kono
parents:
diff changeset
289 Free (X);
kono
parents:
diff changeset
290 end;
kono
parents:
diff changeset
291 end loop;
kono
parents:
diff changeset
292 end Clear;
kono
parents:
diff changeset
293
kono
parents:
diff changeset
294 ------------------------
kono
parents:
diff changeset
295 -- Constant_Reference --
kono
parents:
diff changeset
296 ------------------------
kono
parents:
diff changeset
297
kono
parents:
diff changeset
298 function Constant_Reference
kono
parents:
diff changeset
299 (Container : aliased Vector;
kono
parents:
diff changeset
300 Position : Cursor) return Constant_Reference_Type
kono
parents:
diff changeset
301 is
kono
parents:
diff changeset
302 begin
kono
parents:
diff changeset
303 if Checks then
kono
parents:
diff changeset
304 if Position.Container = null then
kono
parents:
diff changeset
305 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
306 end if;
kono
parents:
diff changeset
307
kono
parents:
diff changeset
308 if Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
309 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
310 end if;
kono
parents:
diff changeset
311
kono
parents:
diff changeset
312 if Position.Index > Position.Container.Last then
kono
parents:
diff changeset
313 raise Constraint_Error with "Position cursor is out of range";
kono
parents:
diff changeset
314 end if;
kono
parents:
diff changeset
315 end if;
kono
parents:
diff changeset
316
kono
parents:
diff changeset
317 declare
kono
parents:
diff changeset
318 TC : constant Tamper_Counts_Access :=
kono
parents:
diff changeset
319 Container.TC'Unrestricted_Access;
kono
parents:
diff changeset
320 begin
kono
parents:
diff changeset
321 -- The following will raise Constraint_Error if Element is null
kono
parents:
diff changeset
322
kono
parents:
diff changeset
323 return R : constant Constant_Reference_Type :=
kono
parents:
diff changeset
324 (Element => Container.Elements.EA (Position.Index),
kono
parents:
diff changeset
325 Control => (Controlled with TC))
kono
parents:
diff changeset
326 do
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
327 Busy (TC.all);
111
kono
parents:
diff changeset
328 end return;
kono
parents:
diff changeset
329 end;
kono
parents:
diff changeset
330 end Constant_Reference;
kono
parents:
diff changeset
331
kono
parents:
diff changeset
332 function Constant_Reference
kono
parents:
diff changeset
333 (Container : aliased Vector;
kono
parents:
diff changeset
334 Index : Index_Type) return Constant_Reference_Type
kono
parents:
diff changeset
335 is
kono
parents:
diff changeset
336 begin
kono
parents:
diff changeset
337 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
338 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
339 end if;
kono
parents:
diff changeset
340
kono
parents:
diff changeset
341 declare
kono
parents:
diff changeset
342 TC : constant Tamper_Counts_Access :=
kono
parents:
diff changeset
343 Container.TC'Unrestricted_Access;
kono
parents:
diff changeset
344 begin
kono
parents:
diff changeset
345 -- The following will raise Constraint_Error if Element is null
kono
parents:
diff changeset
346
kono
parents:
diff changeset
347 return R : constant Constant_Reference_Type :=
kono
parents:
diff changeset
348 (Element => Container.Elements.EA (Index),
kono
parents:
diff changeset
349 Control => (Controlled with TC))
kono
parents:
diff changeset
350 do
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
351 Busy (TC.all);
111
kono
parents:
diff changeset
352 end return;
kono
parents:
diff changeset
353 end;
kono
parents:
diff changeset
354 end Constant_Reference;
kono
parents:
diff changeset
355
kono
parents:
diff changeset
356 --------------
kono
parents:
diff changeset
357 -- Contains --
kono
parents:
diff changeset
358 --------------
kono
parents:
diff changeset
359
kono
parents:
diff changeset
360 function Contains
kono
parents:
diff changeset
361 (Container : Vector;
kono
parents:
diff changeset
362 Item : Element_Type) return Boolean
kono
parents:
diff changeset
363 is
kono
parents:
diff changeset
364 begin
kono
parents:
diff changeset
365 return Find_Index (Container, Item) /= No_Index;
kono
parents:
diff changeset
366 end Contains;
kono
parents:
diff changeset
367
kono
parents:
diff changeset
368 ----------
kono
parents:
diff changeset
369 -- Copy --
kono
parents:
diff changeset
370 ----------
kono
parents:
diff changeset
371
kono
parents:
diff changeset
372 function Copy
kono
parents:
diff changeset
373 (Source : Vector;
kono
parents:
diff changeset
374 Capacity : Count_Type := 0) return Vector
kono
parents:
diff changeset
375 is
kono
parents:
diff changeset
376 C : Count_Type;
kono
parents:
diff changeset
377
kono
parents:
diff changeset
378 begin
kono
parents:
diff changeset
379 if Capacity < Source.Length then
kono
parents:
diff changeset
380 if Checks and then Capacity /= 0 then
kono
parents:
diff changeset
381 raise Capacity_Error
kono
parents:
diff changeset
382 with "Requested capacity is less than Source length";
kono
parents:
diff changeset
383 end if;
kono
parents:
diff changeset
384
kono
parents:
diff changeset
385 C := Source.Length;
kono
parents:
diff changeset
386 else
kono
parents:
diff changeset
387 C := Capacity;
kono
parents:
diff changeset
388 end if;
kono
parents:
diff changeset
389
kono
parents:
diff changeset
390 return Target : Vector do
kono
parents:
diff changeset
391 Target.Reserve_Capacity (C);
kono
parents:
diff changeset
392 Target.Assign (Source);
kono
parents:
diff changeset
393 end return;
kono
parents:
diff changeset
394 end Copy;
kono
parents:
diff changeset
395
kono
parents:
diff changeset
396 ------------
kono
parents:
diff changeset
397 -- Delete --
kono
parents:
diff changeset
398 ------------
kono
parents:
diff changeset
399
kono
parents:
diff changeset
400 procedure Delete
kono
parents:
diff changeset
401 (Container : in out Vector;
kono
parents:
diff changeset
402 Index : Extended_Index;
kono
parents:
diff changeset
403 Count : Count_Type := 1)
kono
parents:
diff changeset
404 is
kono
parents:
diff changeset
405 Old_Last : constant Index_Type'Base := Container.Last;
kono
parents:
diff changeset
406 New_Last : Index_Type'Base;
kono
parents:
diff changeset
407 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
kono
parents:
diff changeset
408 J : Index_Type'Base; -- first index of items that slide down
kono
parents:
diff changeset
409
kono
parents:
diff changeset
410 begin
kono
parents:
diff changeset
411 -- Delete removes items from the vector, the number of which is the
kono
parents:
diff changeset
412 -- minimum of the specified Count and the items (if any) that exist from
kono
parents:
diff changeset
413 -- Index to Container.Last. There are no constraints on the specified
kono
parents:
diff changeset
414 -- value of Count (it can be larger than what's available at this
kono
parents:
diff changeset
415 -- position in the vector, for example), but there are constraints on
kono
parents:
diff changeset
416 -- the allowed values of the Index.
kono
parents:
diff changeset
417
kono
parents:
diff changeset
418 -- As a precondition on the generic actual Index_Type, the base type
kono
parents:
diff changeset
419 -- must include Index_Type'Pred (Index_Type'First); this is the value
kono
parents:
diff changeset
420 -- that Container.Last assumes when the vector is empty. However, we do
kono
parents:
diff changeset
421 -- not allow that as the value for Index when specifying which items
kono
parents:
diff changeset
422 -- should be deleted, so we must manually check. (That the user is
kono
parents:
diff changeset
423 -- allowed to specify the value at all here is a consequence of the
kono
parents:
diff changeset
424 -- declaration of the Extended_Index subtype, which includes the values
kono
parents:
diff changeset
425 -- in the base range that immediately precede and immediately follow the
kono
parents:
diff changeset
426 -- values in the Index_Type.)
kono
parents:
diff changeset
427
kono
parents:
diff changeset
428 if Checks and then Index < Index_Type'First then
kono
parents:
diff changeset
429 raise Constraint_Error with "Index is out of range (too small)";
kono
parents:
diff changeset
430 end if;
kono
parents:
diff changeset
431
kono
parents:
diff changeset
432 -- We do allow a value greater than Container.Last to be specified as
kono
parents:
diff changeset
433 -- the Index, but only if it's immediately greater. This allows the
kono
parents:
diff changeset
434 -- corner case of deleting no items from the back end of the vector to
kono
parents:
diff changeset
435 -- be treated as a no-op. (It is assumed that specifying an index value
kono
parents:
diff changeset
436 -- greater than Last + 1 indicates some deeper flaw in the caller's
kono
parents:
diff changeset
437 -- algorithm, so that case is treated as a proper error.)
kono
parents:
diff changeset
438
kono
parents:
diff changeset
439 if Index > Old_Last then
kono
parents:
diff changeset
440 if Checks and then Index > Old_Last + 1 then
kono
parents:
diff changeset
441 raise Constraint_Error with "Index is out of range (too large)";
kono
parents:
diff changeset
442 else
kono
parents:
diff changeset
443 return;
kono
parents:
diff changeset
444 end if;
kono
parents:
diff changeset
445 end if;
kono
parents:
diff changeset
446
kono
parents:
diff changeset
447 -- Here and elsewhere we treat deleting 0 items from the container as a
kono
parents:
diff changeset
448 -- no-op, even when the container is busy, so we simply return.
kono
parents:
diff changeset
449
kono
parents:
diff changeset
450 if Count = 0 then
kono
parents:
diff changeset
451 return;
kono
parents:
diff changeset
452 end if;
kono
parents:
diff changeset
453
kono
parents:
diff changeset
454 -- The internal elements array isn't guaranteed to exist unless we have
kono
parents:
diff changeset
455 -- elements, so we handle that case here in order to avoid having to
kono
parents:
diff changeset
456 -- check it later. (Note that an empty vector can never be busy, so
kono
parents:
diff changeset
457 -- there's no semantic harm in returning early.)
kono
parents:
diff changeset
458
kono
parents:
diff changeset
459 if Container.Is_Empty then
kono
parents:
diff changeset
460 return;
kono
parents:
diff changeset
461 end if;
kono
parents:
diff changeset
462
kono
parents:
diff changeset
463 -- The tampering bits exist to prevent an item from being deleted (or
kono
parents:
diff changeset
464 -- otherwise harmfully manipulated) while it is being visited. Query,
kono
parents:
diff changeset
465 -- Update, and Iterate increment the busy count on entry, and decrement
kono
parents:
diff changeset
466 -- the count on exit. Delete checks the count to determine whether it is
kono
parents:
diff changeset
467 -- being called while the associated callback procedure is executing.
kono
parents:
diff changeset
468
kono
parents:
diff changeset
469 TC_Check (Container.TC);
kono
parents:
diff changeset
470
kono
parents:
diff changeset
471 -- We first calculate what's available for deletion starting at
kono
parents:
diff changeset
472 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
kono
parents:
diff changeset
473 -- Count_Type'Base as the type for intermediate values. (See function
kono
parents:
diff changeset
474 -- Length for more information.)
kono
parents:
diff changeset
475
kono
parents:
diff changeset
476 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
kono
parents:
diff changeset
477 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
kono
parents:
diff changeset
478 else
kono
parents:
diff changeset
479 Count2 := Count_Type'Base (Old_Last - Index + 1);
kono
parents:
diff changeset
480 end if;
kono
parents:
diff changeset
481
kono
parents:
diff changeset
482 -- If the number of elements requested (Count) for deletion is equal to
kono
parents:
diff changeset
483 -- (or greater than) the number of elements available (Count2) for
kono
parents:
diff changeset
484 -- deletion beginning at Index, then everything from Index to
kono
parents:
diff changeset
485 -- Container.Last is deleted (this is equivalent to Delete_Last).
kono
parents:
diff changeset
486
kono
parents:
diff changeset
487 if Count >= Count2 then
kono
parents:
diff changeset
488 -- Elements in an indefinite vector are allocated, so we must iterate
kono
parents:
diff changeset
489 -- over the loop and deallocate elements one-at-a-time. We work from
kono
parents:
diff changeset
490 -- back to front, deleting the last element during each pass, in
kono
parents:
diff changeset
491 -- order to gracefully handle deallocation failures.
kono
parents:
diff changeset
492
kono
parents:
diff changeset
493 declare
kono
parents:
diff changeset
494 EA : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
495
kono
parents:
diff changeset
496 begin
kono
parents:
diff changeset
497 while Container.Last >= Index loop
kono
parents:
diff changeset
498 declare
kono
parents:
diff changeset
499 K : constant Index_Type := Container.Last;
kono
parents:
diff changeset
500 X : Element_Access := EA (K);
kono
parents:
diff changeset
501
kono
parents:
diff changeset
502 begin
kono
parents:
diff changeset
503 -- We first isolate the element we're deleting, removing it
kono
parents:
diff changeset
504 -- from the vector before we attempt to deallocate it, in
kono
parents:
diff changeset
505 -- case the deallocation fails.
kono
parents:
diff changeset
506
kono
parents:
diff changeset
507 EA (K) := null;
kono
parents:
diff changeset
508 Container.Last := K - 1;
kono
parents:
diff changeset
509
kono
parents:
diff changeset
510 -- Container invariants have been restored, so it is now
kono
parents:
diff changeset
511 -- safe to attempt to deallocate the element.
kono
parents:
diff changeset
512
kono
parents:
diff changeset
513 Free (X);
kono
parents:
diff changeset
514 end;
kono
parents:
diff changeset
515 end loop;
kono
parents:
diff changeset
516 end;
kono
parents:
diff changeset
517
kono
parents:
diff changeset
518 return;
kono
parents:
diff changeset
519 end if;
kono
parents:
diff changeset
520
kono
parents:
diff changeset
521 -- There are some elements that aren't being deleted (the requested
kono
parents:
diff changeset
522 -- count was less than the available count), so we must slide them down
kono
parents:
diff changeset
523 -- to Index. We first calculate the index values of the respective array
kono
parents:
diff changeset
524 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
kono
parents:
diff changeset
525 -- type for intermediate calculations. For the elements that slide down,
kono
parents:
diff changeset
526 -- index value New_Last is the last index value of their new home, and
kono
parents:
diff changeset
527 -- index value J is the first index of their old home.
kono
parents:
diff changeset
528
kono
parents:
diff changeset
529 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
530 New_Last := Old_Last - Index_Type'Base (Count);
kono
parents:
diff changeset
531 J := Index + Index_Type'Base (Count);
kono
parents:
diff changeset
532 else
kono
parents:
diff changeset
533 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
kono
parents:
diff changeset
534 J := Index_Type'Base (Count_Type'Base (Index) + Count);
kono
parents:
diff changeset
535 end if;
kono
parents:
diff changeset
536
kono
parents:
diff changeset
537 -- The internal elements array isn't guaranteed to exist unless we have
kono
parents:
diff changeset
538 -- elements, but we have that guarantee here because we know we have
kono
parents:
diff changeset
539 -- elements to slide. The array index values for each slice have
kono
parents:
diff changeset
540 -- already been determined, so what remains to be done is to first
kono
parents:
diff changeset
541 -- deallocate the elements that are being deleted, and then slide down
kono
parents:
diff changeset
542 -- to Index the elements that aren't being deleted.
kono
parents:
diff changeset
543
kono
parents:
diff changeset
544 declare
kono
parents:
diff changeset
545 EA : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
546
kono
parents:
diff changeset
547 begin
kono
parents:
diff changeset
548 -- Before we can slide down the elements that aren't being deleted,
kono
parents:
diff changeset
549 -- we need to deallocate the elements that are being deleted.
kono
parents:
diff changeset
550
kono
parents:
diff changeset
551 for K in Index .. J - 1 loop
kono
parents:
diff changeset
552 declare
kono
parents:
diff changeset
553 X : Element_Access := EA (K);
kono
parents:
diff changeset
554
kono
parents:
diff changeset
555 begin
kono
parents:
diff changeset
556 -- First we remove the element we're about to deallocate from
kono
parents:
diff changeset
557 -- the vector, in case the deallocation fails, in order to
kono
parents:
diff changeset
558 -- preserve representation invariants.
kono
parents:
diff changeset
559
kono
parents:
diff changeset
560 EA (K) := null;
kono
parents:
diff changeset
561
kono
parents:
diff changeset
562 -- The element has been removed from the vector, so it is now
kono
parents:
diff changeset
563 -- safe to attempt to deallocate it.
kono
parents:
diff changeset
564
kono
parents:
diff changeset
565 Free (X);
kono
parents:
diff changeset
566 end;
kono
parents:
diff changeset
567 end loop;
kono
parents:
diff changeset
568
kono
parents:
diff changeset
569 EA (Index .. New_Last) := EA (J .. Old_Last);
kono
parents:
diff changeset
570 Container.Last := New_Last;
kono
parents:
diff changeset
571 end;
kono
parents:
diff changeset
572 end Delete;
kono
parents:
diff changeset
573
kono
parents:
diff changeset
574 procedure Delete
kono
parents:
diff changeset
575 (Container : in out Vector;
kono
parents:
diff changeset
576 Position : in out Cursor;
kono
parents:
diff changeset
577 Count : Count_Type := 1)
kono
parents:
diff changeset
578 is
kono
parents:
diff changeset
579 begin
kono
parents:
diff changeset
580 if Checks then
kono
parents:
diff changeset
581 if Position.Container = null then
kono
parents:
diff changeset
582 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
583
kono
parents:
diff changeset
584 elsif Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
585 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
586
kono
parents:
diff changeset
587 elsif Position.Index > Container.Last then
kono
parents:
diff changeset
588 raise Program_Error with "Position index is out of range";
kono
parents:
diff changeset
589 end if;
kono
parents:
diff changeset
590 end if;
kono
parents:
diff changeset
591
kono
parents:
diff changeset
592 Delete (Container, Position.Index, Count);
kono
parents:
diff changeset
593 Position := No_Element;
kono
parents:
diff changeset
594 end Delete;
kono
parents:
diff changeset
595
kono
parents:
diff changeset
596 ------------------
kono
parents:
diff changeset
597 -- Delete_First --
kono
parents:
diff changeset
598 ------------------
kono
parents:
diff changeset
599
kono
parents:
diff changeset
600 procedure Delete_First
kono
parents:
diff changeset
601 (Container : in out Vector;
kono
parents:
diff changeset
602 Count : Count_Type := 1)
kono
parents:
diff changeset
603 is
kono
parents:
diff changeset
604 begin
kono
parents:
diff changeset
605 if Count = 0 then
kono
parents:
diff changeset
606 return;
kono
parents:
diff changeset
607
kono
parents:
diff changeset
608 elsif Count >= Length (Container) then
kono
parents:
diff changeset
609 Clear (Container);
kono
parents:
diff changeset
610 return;
kono
parents:
diff changeset
611
kono
parents:
diff changeset
612 else
kono
parents:
diff changeset
613 Delete (Container, Index_Type'First, Count);
kono
parents:
diff changeset
614 end if;
kono
parents:
diff changeset
615 end Delete_First;
kono
parents:
diff changeset
616
kono
parents:
diff changeset
617 -----------------
kono
parents:
diff changeset
618 -- Delete_Last --
kono
parents:
diff changeset
619 -----------------
kono
parents:
diff changeset
620
kono
parents:
diff changeset
621 procedure Delete_Last
kono
parents:
diff changeset
622 (Container : in out Vector;
kono
parents:
diff changeset
623 Count : Count_Type := 1)
kono
parents:
diff changeset
624 is
kono
parents:
diff changeset
625 begin
kono
parents:
diff changeset
626 -- It is not permitted to delete items while the container is busy (for
kono
parents:
diff changeset
627 -- example, we're in the middle of a passive iteration). However, we
kono
parents:
diff changeset
628 -- always treat deleting 0 items as a no-op, even when we're busy, so we
kono
parents:
diff changeset
629 -- simply return without checking.
kono
parents:
diff changeset
630
kono
parents:
diff changeset
631 if Count = 0 then
kono
parents:
diff changeset
632 return;
kono
parents:
diff changeset
633 end if;
kono
parents:
diff changeset
634
kono
parents:
diff changeset
635 -- We cannot simply subsume the empty case into the loop below (the loop
kono
parents:
diff changeset
636 -- would iterate 0 times), because we rename the internal array object
kono
parents:
diff changeset
637 -- (which is allocated), but an empty vector isn't guaranteed to have
kono
parents:
diff changeset
638 -- actually allocated an array. (Note that an empty vector can never be
kono
parents:
diff changeset
639 -- busy, so there's no semantic harm in returning early here.)
kono
parents:
diff changeset
640
kono
parents:
diff changeset
641 if Container.Is_Empty then
kono
parents:
diff changeset
642 return;
kono
parents:
diff changeset
643 end if;
kono
parents:
diff changeset
644
kono
parents:
diff changeset
645 -- The tampering bits exist to prevent an item from being deleted (or
kono
parents:
diff changeset
646 -- otherwise harmfully manipulated) while it is being visited. Query,
kono
parents:
diff changeset
647 -- Update, and Iterate increment the busy count on entry, and decrement
kono
parents:
diff changeset
648 -- the count on exit. Delete_Last checks the count to determine whether
kono
parents:
diff changeset
649 -- it is being called while the associated callback procedure is
kono
parents:
diff changeset
650 -- executing.
kono
parents:
diff changeset
651
kono
parents:
diff changeset
652 TC_Check (Container.TC);
kono
parents:
diff changeset
653
kono
parents:
diff changeset
654 -- Elements in an indefinite vector are allocated, so we must iterate
kono
parents:
diff changeset
655 -- over the loop and deallocate elements one-at-a-time. We work from
kono
parents:
diff changeset
656 -- back to front, deleting the last element during each pass, in order
kono
parents:
diff changeset
657 -- to gracefully handle deallocation failures.
kono
parents:
diff changeset
658
kono
parents:
diff changeset
659 declare
kono
parents:
diff changeset
660 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
661
kono
parents:
diff changeset
662 begin
kono
parents:
diff changeset
663 for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
kono
parents:
diff changeset
664 declare
kono
parents:
diff changeset
665 J : constant Index_Type := Container.Last;
kono
parents:
diff changeset
666 X : Element_Access := E (J);
kono
parents:
diff changeset
667
kono
parents:
diff changeset
668 begin
kono
parents:
diff changeset
669 -- Note that we first isolate the element we're deleting,
kono
parents:
diff changeset
670 -- removing it from the vector, before we actually deallocate
kono
parents:
diff changeset
671 -- it, in order to preserve representation invariants even if
kono
parents:
diff changeset
672 -- the deallocation fails.
kono
parents:
diff changeset
673
kono
parents:
diff changeset
674 E (J) := null;
kono
parents:
diff changeset
675 Container.Last := J - 1;
kono
parents:
diff changeset
676
kono
parents:
diff changeset
677 -- Container invariants have been restored, so it is now safe
kono
parents:
diff changeset
678 -- to deallocate the element.
kono
parents:
diff changeset
679
kono
parents:
diff changeset
680 Free (X);
kono
parents:
diff changeset
681 end;
kono
parents:
diff changeset
682 end loop;
kono
parents:
diff changeset
683 end;
kono
parents:
diff changeset
684 end Delete_Last;
kono
parents:
diff changeset
685
kono
parents:
diff changeset
686 -------------
kono
parents:
diff changeset
687 -- Element --
kono
parents:
diff changeset
688 -------------
kono
parents:
diff changeset
689
kono
parents:
diff changeset
690 function Element
kono
parents:
diff changeset
691 (Container : Vector;
kono
parents:
diff changeset
692 Index : Index_Type) return Element_Type
kono
parents:
diff changeset
693 is
kono
parents:
diff changeset
694 begin
kono
parents:
diff changeset
695 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
696 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
697 end if;
kono
parents:
diff changeset
698
kono
parents:
diff changeset
699 declare
kono
parents:
diff changeset
700 EA : constant Element_Access := Container.Elements.EA (Index);
kono
parents:
diff changeset
701 begin
kono
parents:
diff changeset
702 if Checks and then EA = null then
kono
parents:
diff changeset
703 raise Constraint_Error with "element is empty";
kono
parents:
diff changeset
704 else
kono
parents:
diff changeset
705 return EA.all;
kono
parents:
diff changeset
706 end if;
kono
parents:
diff changeset
707 end;
kono
parents:
diff changeset
708 end Element;
kono
parents:
diff changeset
709
kono
parents:
diff changeset
710 function Element (Position : Cursor) return Element_Type is
kono
parents:
diff changeset
711 begin
kono
parents:
diff changeset
712 if Checks then
kono
parents:
diff changeset
713 if Position.Container = null then
kono
parents:
diff changeset
714 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
715 end if;
kono
parents:
diff changeset
716
kono
parents:
diff changeset
717 if Position.Index > Position.Container.Last then
kono
parents:
diff changeset
718 raise Constraint_Error with "Position cursor is out of range";
kono
parents:
diff changeset
719 end if;
kono
parents:
diff changeset
720 end if;
kono
parents:
diff changeset
721
kono
parents:
diff changeset
722 declare
kono
parents:
diff changeset
723 EA : constant Element_Access :=
kono
parents:
diff changeset
724 Position.Container.Elements.EA (Position.Index);
kono
parents:
diff changeset
725 begin
kono
parents:
diff changeset
726 if Checks and then EA = null then
kono
parents:
diff changeset
727 raise Constraint_Error with "element is empty";
kono
parents:
diff changeset
728 else
kono
parents:
diff changeset
729 return EA.all;
kono
parents:
diff changeset
730 end if;
kono
parents:
diff changeset
731 end;
kono
parents:
diff changeset
732 end Element;
kono
parents:
diff changeset
733
kono
parents:
diff changeset
734 --------------
kono
parents:
diff changeset
735 -- Finalize --
kono
parents:
diff changeset
736 --------------
kono
parents:
diff changeset
737
kono
parents:
diff changeset
738 procedure Finalize (Container : in out Vector) is
kono
parents:
diff changeset
739 begin
kono
parents:
diff changeset
740 Clear (Container); -- Checks busy-bit
kono
parents:
diff changeset
741
kono
parents:
diff changeset
742 declare
kono
parents:
diff changeset
743 X : Elements_Access := Container.Elements;
kono
parents:
diff changeset
744 begin
kono
parents:
diff changeset
745 Container.Elements := null;
kono
parents:
diff changeset
746 Free (X);
kono
parents:
diff changeset
747 end;
kono
parents:
diff changeset
748 end Finalize;
kono
parents:
diff changeset
749
kono
parents:
diff changeset
750 procedure Finalize (Object : in out Iterator) is
kono
parents:
diff changeset
751 begin
kono
parents:
diff changeset
752 Unbusy (Object.Container.TC);
kono
parents:
diff changeset
753 end Finalize;
kono
parents:
diff changeset
754
kono
parents:
diff changeset
755 ----------
kono
parents:
diff changeset
756 -- Find --
kono
parents:
diff changeset
757 ----------
kono
parents:
diff changeset
758
kono
parents:
diff changeset
759 function Find
kono
parents:
diff changeset
760 (Container : Vector;
kono
parents:
diff changeset
761 Item : Element_Type;
kono
parents:
diff changeset
762 Position : Cursor := No_Element) return Cursor
kono
parents:
diff changeset
763 is
kono
parents:
diff changeset
764 begin
kono
parents:
diff changeset
765 if Checks and then Position.Container /= null then
kono
parents:
diff changeset
766 if Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
767 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
768 end if;
kono
parents:
diff changeset
769
kono
parents:
diff changeset
770 if Position.Index > Container.Last then
kono
parents:
diff changeset
771 raise Program_Error with "Position index is out of range";
kono
parents:
diff changeset
772 end if;
kono
parents:
diff changeset
773 end if;
kono
parents:
diff changeset
774
kono
parents:
diff changeset
775 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
776 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
777
kono
parents:
diff changeset
778 declare
kono
parents:
diff changeset
779 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
780 begin
kono
parents:
diff changeset
781 for J in Position.Index .. Container.Last loop
kono
parents:
diff changeset
782 if Container.Elements.EA (J).all = Item then
kono
parents:
diff changeset
783 return Cursor'(Container'Unrestricted_Access, J);
kono
parents:
diff changeset
784 end if;
kono
parents:
diff changeset
785 end loop;
kono
parents:
diff changeset
786
kono
parents:
diff changeset
787 return No_Element;
kono
parents:
diff changeset
788 end;
kono
parents:
diff changeset
789 end Find;
kono
parents:
diff changeset
790
kono
parents:
diff changeset
791 ----------------
kono
parents:
diff changeset
792 -- Find_Index --
kono
parents:
diff changeset
793 ----------------
kono
parents:
diff changeset
794
kono
parents:
diff changeset
795 function Find_Index
kono
parents:
diff changeset
796 (Container : Vector;
kono
parents:
diff changeset
797 Item : Element_Type;
kono
parents:
diff changeset
798 Index : Index_Type := Index_Type'First) return Extended_Index
kono
parents:
diff changeset
799 is
kono
parents:
diff changeset
800 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
801 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
802
kono
parents:
diff changeset
803 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
804 begin
kono
parents:
diff changeset
805 for Indx in Index .. Container.Last loop
kono
parents:
diff changeset
806 if Container.Elements.EA (Indx).all = Item then
kono
parents:
diff changeset
807 return Indx;
kono
parents:
diff changeset
808 end if;
kono
parents:
diff changeset
809 end loop;
kono
parents:
diff changeset
810
kono
parents:
diff changeset
811 return No_Index;
kono
parents:
diff changeset
812 end Find_Index;
kono
parents:
diff changeset
813
kono
parents:
diff changeset
814 -----------
kono
parents:
diff changeset
815 -- First --
kono
parents:
diff changeset
816 -----------
kono
parents:
diff changeset
817
kono
parents:
diff changeset
818 function First (Container : Vector) return Cursor is
kono
parents:
diff changeset
819 begin
kono
parents:
diff changeset
820 if Is_Empty (Container) then
kono
parents:
diff changeset
821 return No_Element;
kono
parents:
diff changeset
822 end if;
kono
parents:
diff changeset
823
kono
parents:
diff changeset
824 return (Container'Unrestricted_Access, Index_Type'First);
kono
parents:
diff changeset
825 end First;
kono
parents:
diff changeset
826
kono
parents:
diff changeset
827 function First (Object : Iterator) return Cursor is
kono
parents:
diff changeset
828 begin
kono
parents:
diff changeset
829 -- The value of the iterator object's Index component influences the
kono
parents:
diff changeset
830 -- behavior of the First (and Last) selector function.
kono
parents:
diff changeset
831
kono
parents:
diff changeset
832 -- When the Index component is No_Index, this means the iterator
kono
parents:
diff changeset
833 -- object was constructed without a start expression, in which case the
kono
parents:
diff changeset
834 -- (forward) iteration starts from the (logical) beginning of the entire
kono
parents:
diff changeset
835 -- sequence of items (corresponding to Container.First, for a forward
kono
parents:
diff changeset
836 -- iterator).
kono
parents:
diff changeset
837
kono
parents:
diff changeset
838 -- Otherwise, this is iteration over a partial sequence of items.
kono
parents:
diff changeset
839 -- When the Index component isn't No_Index, the iterator object was
kono
parents:
diff changeset
840 -- constructed with a start expression, that specifies the position
kono
parents:
diff changeset
841 -- from which the (forward) partial iteration begins.
kono
parents:
diff changeset
842
kono
parents:
diff changeset
843 if Object.Index = No_Index then
kono
parents:
diff changeset
844 return First (Object.Container.all);
kono
parents:
diff changeset
845 else
kono
parents:
diff changeset
846 return Cursor'(Object.Container, Object.Index);
kono
parents:
diff changeset
847 end if;
kono
parents:
diff changeset
848 end First;
kono
parents:
diff changeset
849
kono
parents:
diff changeset
850 -------------------
kono
parents:
diff changeset
851 -- First_Element --
kono
parents:
diff changeset
852 -------------------
kono
parents:
diff changeset
853
kono
parents:
diff changeset
854 function First_Element (Container : Vector) return Element_Type is
kono
parents:
diff changeset
855 begin
kono
parents:
diff changeset
856 if Checks and then Container.Last = No_Index then
kono
parents:
diff changeset
857 raise Constraint_Error with "Container is empty";
kono
parents:
diff changeset
858 end if;
kono
parents:
diff changeset
859
kono
parents:
diff changeset
860 declare
kono
parents:
diff changeset
861 EA : constant Element_Access :=
kono
parents:
diff changeset
862 Container.Elements.EA (Index_Type'First);
kono
parents:
diff changeset
863 begin
kono
parents:
diff changeset
864 if Checks and then EA = null then
kono
parents:
diff changeset
865 raise Constraint_Error with "first element is empty";
kono
parents:
diff changeset
866 else
kono
parents:
diff changeset
867 return EA.all;
kono
parents:
diff changeset
868 end if;
kono
parents:
diff changeset
869 end;
kono
parents:
diff changeset
870 end First_Element;
kono
parents:
diff changeset
871
kono
parents:
diff changeset
872 -----------------
kono
parents:
diff changeset
873 -- First_Index --
kono
parents:
diff changeset
874 -----------------
kono
parents:
diff changeset
875
kono
parents:
diff changeset
876 function First_Index (Container : Vector) return Index_Type is
kono
parents:
diff changeset
877 pragma Unreferenced (Container);
kono
parents:
diff changeset
878 begin
kono
parents:
diff changeset
879 return Index_Type'First;
kono
parents:
diff changeset
880 end First_Index;
kono
parents:
diff changeset
881
kono
parents:
diff changeset
882 ---------------------
kono
parents:
diff changeset
883 -- Generic_Sorting --
kono
parents:
diff changeset
884 ---------------------
kono
parents:
diff changeset
885
kono
parents:
diff changeset
886 package body Generic_Sorting is
kono
parents:
diff changeset
887
kono
parents:
diff changeset
888 -----------------------
kono
parents:
diff changeset
889 -- Local Subprograms --
kono
parents:
diff changeset
890 -----------------------
kono
parents:
diff changeset
891
kono
parents:
diff changeset
892 function Is_Less (L, R : Element_Access) return Boolean;
kono
parents:
diff changeset
893 pragma Inline (Is_Less);
kono
parents:
diff changeset
894
kono
parents:
diff changeset
895 -------------
kono
parents:
diff changeset
896 -- Is_Less --
kono
parents:
diff changeset
897 -------------
kono
parents:
diff changeset
898
kono
parents:
diff changeset
899 function Is_Less (L, R : Element_Access) return Boolean is
kono
parents:
diff changeset
900 begin
kono
parents:
diff changeset
901 if L = null then
kono
parents:
diff changeset
902 return R /= null;
kono
parents:
diff changeset
903 elsif R = null then
kono
parents:
diff changeset
904 return False;
kono
parents:
diff changeset
905 else
kono
parents:
diff changeset
906 return L.all < R.all;
kono
parents:
diff changeset
907 end if;
kono
parents:
diff changeset
908 end Is_Less;
kono
parents:
diff changeset
909
kono
parents:
diff changeset
910 ---------------
kono
parents:
diff changeset
911 -- Is_Sorted --
kono
parents:
diff changeset
912 ---------------
kono
parents:
diff changeset
913
kono
parents:
diff changeset
914 function Is_Sorted (Container : Vector) return Boolean is
kono
parents:
diff changeset
915 begin
kono
parents:
diff changeset
916 if Container.Last <= Index_Type'First then
kono
parents:
diff changeset
917 return True;
kono
parents:
diff changeset
918 end if;
kono
parents:
diff changeset
919
kono
parents:
diff changeset
920 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
921 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
922
kono
parents:
diff changeset
923 declare
kono
parents:
diff changeset
924 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
925 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
926 begin
kono
parents:
diff changeset
927 for J in Index_Type'First .. Container.Last - 1 loop
kono
parents:
diff changeset
928 if Is_Less (E (J + 1), E (J)) then
kono
parents:
diff changeset
929 return False;
kono
parents:
diff changeset
930 end if;
kono
parents:
diff changeset
931 end loop;
kono
parents:
diff changeset
932
kono
parents:
diff changeset
933 return True;
kono
parents:
diff changeset
934 end;
kono
parents:
diff changeset
935 end Is_Sorted;
kono
parents:
diff changeset
936
kono
parents:
diff changeset
937 -----------
kono
parents:
diff changeset
938 -- Merge --
kono
parents:
diff changeset
939 -----------
kono
parents:
diff changeset
940
kono
parents:
diff changeset
941 procedure Merge (Target, Source : in out Vector) is
kono
parents:
diff changeset
942 I, J : Index_Type'Base;
kono
parents:
diff changeset
943
kono
parents:
diff changeset
944 begin
kono
parents:
diff changeset
945 -- The semantics of Merge changed slightly per AI05-0021. It was
kono
parents:
diff changeset
946 -- originally the case that if Target and Source denoted the same
kono
parents:
diff changeset
947 -- container object, then the GNAT implementation of Merge did
kono
parents:
diff changeset
948 -- nothing. However, it was argued that RM05 did not precisely
kono
parents:
diff changeset
949 -- specify the semantics for this corner case. The decision of the
kono
parents:
diff changeset
950 -- ARG was that if Target and Source denote the same non-empty
kono
parents:
diff changeset
951 -- container object, then Program_Error is raised.
kono
parents:
diff changeset
952
kono
parents:
diff changeset
953 if Source.Last < Index_Type'First then -- Source is empty
kono
parents:
diff changeset
954 return;
kono
parents:
diff changeset
955 end if;
kono
parents:
diff changeset
956
kono
parents:
diff changeset
957 if Checks and then Target'Address = Source'Address then
kono
parents:
diff changeset
958 raise Program_Error with
kono
parents:
diff changeset
959 "Target and Source denote same non-empty container";
kono
parents:
diff changeset
960 end if;
kono
parents:
diff changeset
961
kono
parents:
diff changeset
962 if Target.Last < Index_Type'First then -- Target is empty
kono
parents:
diff changeset
963 Move (Target => Target, Source => Source);
kono
parents:
diff changeset
964 return;
kono
parents:
diff changeset
965 end if;
kono
parents:
diff changeset
966
kono
parents:
diff changeset
967 TC_Check (Source.TC);
kono
parents:
diff changeset
968
kono
parents:
diff changeset
969 I := Target.Last; -- original value (before Set_Length)
kono
parents:
diff changeset
970 Target.Set_Length (Length (Target) + Length (Source));
kono
parents:
diff changeset
971
kono
parents:
diff changeset
972 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
973 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
974
kono
parents:
diff changeset
975 declare
kono
parents:
diff changeset
976 TA : Elements_Array renames Target.Elements.EA;
kono
parents:
diff changeset
977 SA : Elements_Array renames Source.Elements.EA;
kono
parents:
diff changeset
978
kono
parents:
diff changeset
979 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
kono
parents:
diff changeset
980 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
kono
parents:
diff changeset
981 begin
kono
parents:
diff changeset
982 J := Target.Last; -- new value (after Set_Length)
kono
parents:
diff changeset
983 while Source.Last >= Index_Type'First loop
kono
parents:
diff changeset
984 pragma Assert
kono
parents:
diff changeset
985 (Source.Last <= Index_Type'First
kono
parents:
diff changeset
986 or else not (Is_Less (SA (Source.Last),
kono
parents:
diff changeset
987 SA (Source.Last - 1))));
kono
parents:
diff changeset
988
kono
parents:
diff changeset
989 if I < Index_Type'First then
kono
parents:
diff changeset
990 declare
kono
parents:
diff changeset
991 Src : Elements_Array renames
kono
parents:
diff changeset
992 SA (Index_Type'First .. Source.Last);
kono
parents:
diff changeset
993 begin
kono
parents:
diff changeset
994 TA (Index_Type'First .. J) := Src;
kono
parents:
diff changeset
995 Src := (others => null);
kono
parents:
diff changeset
996 end;
kono
parents:
diff changeset
997
kono
parents:
diff changeset
998 Source.Last := No_Index;
kono
parents:
diff changeset
999 exit;
kono
parents:
diff changeset
1000 end if;
kono
parents:
diff changeset
1001
kono
parents:
diff changeset
1002 pragma Assert
kono
parents:
diff changeset
1003 (I <= Index_Type'First
kono
parents:
diff changeset
1004 or else not (Is_Less (TA (I), TA (I - 1))));
kono
parents:
diff changeset
1005
kono
parents:
diff changeset
1006 declare
kono
parents:
diff changeset
1007 Src : Element_Access renames SA (Source.Last);
kono
parents:
diff changeset
1008 Tgt : Element_Access renames TA (I);
kono
parents:
diff changeset
1009
kono
parents:
diff changeset
1010 begin
kono
parents:
diff changeset
1011 if Is_Less (Src, Tgt) then
kono
parents:
diff changeset
1012 Target.Elements.EA (J) := Tgt;
kono
parents:
diff changeset
1013 Tgt := null;
kono
parents:
diff changeset
1014 I := I - 1;
kono
parents:
diff changeset
1015
kono
parents:
diff changeset
1016 else
kono
parents:
diff changeset
1017 Target.Elements.EA (J) := Src;
kono
parents:
diff changeset
1018 Src := null;
kono
parents:
diff changeset
1019 Source.Last := Source.Last - 1;
kono
parents:
diff changeset
1020 end if;
kono
parents:
diff changeset
1021 end;
kono
parents:
diff changeset
1022
kono
parents:
diff changeset
1023 J := J - 1;
kono
parents:
diff changeset
1024 end loop;
kono
parents:
diff changeset
1025 end;
kono
parents:
diff changeset
1026 end Merge;
kono
parents:
diff changeset
1027
kono
parents:
diff changeset
1028 ----------
kono
parents:
diff changeset
1029 -- Sort --
kono
parents:
diff changeset
1030 ----------
kono
parents:
diff changeset
1031
kono
parents:
diff changeset
1032 procedure Sort (Container : in out Vector) is
kono
parents:
diff changeset
1033 procedure Sort is new Generic_Array_Sort
kono
parents:
diff changeset
1034 (Index_Type => Index_Type,
kono
parents:
diff changeset
1035 Element_Type => Element_Access,
kono
parents:
diff changeset
1036 Array_Type => Elements_Array,
kono
parents:
diff changeset
1037 "<" => Is_Less);
kono
parents:
diff changeset
1038
kono
parents:
diff changeset
1039 -- Start of processing for Sort
kono
parents:
diff changeset
1040
kono
parents:
diff changeset
1041 begin
kono
parents:
diff changeset
1042 if Container.Last <= Index_Type'First then
kono
parents:
diff changeset
1043 return;
kono
parents:
diff changeset
1044 end if;
kono
parents:
diff changeset
1045
kono
parents:
diff changeset
1046 -- The exception behavior for the vector container must match that
kono
parents:
diff changeset
1047 -- for the list container, so we check for cursor tampering here
kono
parents:
diff changeset
1048 -- (which will catch more things) instead of for element tampering
kono
parents:
diff changeset
1049 -- (which will catch fewer things). It's true that the elements of
kono
parents:
diff changeset
1050 -- this vector container could be safely moved around while (say) an
kono
parents:
diff changeset
1051 -- iteration is taking place (iteration only increments the busy
kono
parents:
diff changeset
1052 -- counter), and so technically all we would need here is a test for
kono
parents:
diff changeset
1053 -- element tampering (indicated by the lock counter), that's simply
kono
parents:
diff changeset
1054 -- an artifact of our array-based implementation. Logically Sort
kono
parents:
diff changeset
1055 -- requires a check for cursor tampering.
kono
parents:
diff changeset
1056
kono
parents:
diff changeset
1057 TC_Check (Container.TC);
kono
parents:
diff changeset
1058
kono
parents:
diff changeset
1059 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
1060 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
1061
kono
parents:
diff changeset
1062 declare
kono
parents:
diff changeset
1063 Lock : With_Lock (Container.TC'Unchecked_Access);
kono
parents:
diff changeset
1064 begin
kono
parents:
diff changeset
1065 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
kono
parents:
diff changeset
1066 end;
kono
parents:
diff changeset
1067 end Sort;
kono
parents:
diff changeset
1068
kono
parents:
diff changeset
1069 end Generic_Sorting;
kono
parents:
diff changeset
1070
kono
parents:
diff changeset
1071 ------------------------
kono
parents:
diff changeset
1072 -- Get_Element_Access --
kono
parents:
diff changeset
1073 ------------------------
kono
parents:
diff changeset
1074
kono
parents:
diff changeset
1075 function Get_Element_Access
kono
parents:
diff changeset
1076 (Position : Cursor) return not null Element_Access
kono
parents:
diff changeset
1077 is
kono
parents:
diff changeset
1078 Ptr : constant Element_Access :=
kono
parents:
diff changeset
1079 Position.Container.Elements.EA (Position.Index);
kono
parents:
diff changeset
1080
kono
parents:
diff changeset
1081 begin
kono
parents:
diff changeset
1082 -- An indefinite vector may contain spaces that hold no elements.
kono
parents:
diff changeset
1083 -- Any iteration over an indefinite vector with spaces will raise
kono
parents:
diff changeset
1084 -- Constraint_Error.
kono
parents:
diff changeset
1085
kono
parents:
diff changeset
1086 if Ptr = null then
kono
parents:
diff changeset
1087 raise Constraint_Error;
kono
parents:
diff changeset
1088
kono
parents:
diff changeset
1089 else
kono
parents:
diff changeset
1090 return Ptr;
kono
parents:
diff changeset
1091 end if;
kono
parents:
diff changeset
1092 end Get_Element_Access;
kono
parents:
diff changeset
1093
kono
parents:
diff changeset
1094 -----------------
kono
parents:
diff changeset
1095 -- Has_Element --
kono
parents:
diff changeset
1096 -----------------
kono
parents:
diff changeset
1097
kono
parents:
diff changeset
1098 function Has_Element (Position : Cursor) return Boolean is
kono
parents:
diff changeset
1099 begin
kono
parents:
diff changeset
1100 if Position.Container = null then
kono
parents:
diff changeset
1101 return False;
kono
parents:
diff changeset
1102 else
kono
parents:
diff changeset
1103 return Position.Index <= Position.Container.Last;
kono
parents:
diff changeset
1104 end if;
kono
parents:
diff changeset
1105 end Has_Element;
kono
parents:
diff changeset
1106
kono
parents:
diff changeset
1107 ------------
kono
parents:
diff changeset
1108 -- Insert --
kono
parents:
diff changeset
1109 ------------
kono
parents:
diff changeset
1110
kono
parents:
diff changeset
1111 procedure Insert
kono
parents:
diff changeset
1112 (Container : in out Vector;
kono
parents:
diff changeset
1113 Before : Extended_Index;
kono
parents:
diff changeset
1114 New_Item : Element_Type;
kono
parents:
diff changeset
1115 Count : Count_Type := 1)
kono
parents:
diff changeset
1116 is
kono
parents:
diff changeset
1117 Old_Length : constant Count_Type := Container.Length;
kono
parents:
diff changeset
1118
kono
parents:
diff changeset
1119 Max_Length : Count_Type'Base; -- determined from range of Index_Type
kono
parents:
diff changeset
1120 New_Length : Count_Type'Base; -- sum of current length and Count
kono
parents:
diff changeset
1121 New_Last : Index_Type'Base; -- last index of vector after insertion
kono
parents:
diff changeset
1122
kono
parents:
diff changeset
1123 Index : Index_Type'Base; -- scratch for intermediate values
kono
parents:
diff changeset
1124 J : Count_Type'Base; -- scratch
kono
parents:
diff changeset
1125
kono
parents:
diff changeset
1126 New_Capacity : Count_Type'Base; -- length of new, expanded array
kono
parents:
diff changeset
1127 Dst_Last : Index_Type'Base; -- last index of new, expanded array
kono
parents:
diff changeset
1128 Dst : Elements_Access; -- new, expanded internal array
kono
parents:
diff changeset
1129
kono
parents:
diff changeset
1130 begin
kono
parents:
diff changeset
1131 if Checks then
kono
parents:
diff changeset
1132 -- As a precondition on the generic actual Index_Type, the base type
kono
parents:
diff changeset
1133 -- must include Index_Type'Pred (Index_Type'First); this is the value
kono
parents:
diff changeset
1134 -- that Container.Last assumes when the vector is empty. However, we
kono
parents:
diff changeset
1135 -- do not allow that as the value for Index when specifying where the
kono
parents:
diff changeset
1136 -- new items should be inserted, so we must manually check. (That the
kono
parents:
diff changeset
1137 -- user is allowed to specify the value at all here is a consequence
kono
parents:
diff changeset
1138 -- of the declaration of the Extended_Index subtype, which includes
kono
parents:
diff changeset
1139 -- the values in the base range that immediately precede and
kono
parents:
diff changeset
1140 -- immediately follow the values in the Index_Type.)
kono
parents:
diff changeset
1141
kono
parents:
diff changeset
1142 if Before < Index_Type'First then
kono
parents:
diff changeset
1143 raise Constraint_Error with
kono
parents:
diff changeset
1144 "Before index is out of range (too small)";
kono
parents:
diff changeset
1145 end if;
kono
parents:
diff changeset
1146
kono
parents:
diff changeset
1147 -- We do allow a value greater than Container.Last to be specified as
kono
parents:
diff changeset
1148 -- the Index, but only if it's immediately greater. This allows for
kono
parents:
diff changeset
1149 -- the case of appending items to the back end of the vector. (It is
kono
parents:
diff changeset
1150 -- assumed that specifying an index value greater than Last + 1
kono
parents:
diff changeset
1151 -- indicates some deeper flaw in the caller's algorithm, so that case
kono
parents:
diff changeset
1152 -- is treated as a proper error.)
kono
parents:
diff changeset
1153
kono
parents:
diff changeset
1154 if Before > Container.Last + 1 then
kono
parents:
diff changeset
1155 raise Constraint_Error with
kono
parents:
diff changeset
1156 "Before index is out of range (too large)";
kono
parents:
diff changeset
1157 end if;
kono
parents:
diff changeset
1158 end if;
kono
parents:
diff changeset
1159
kono
parents:
diff changeset
1160 -- We treat inserting 0 items into the container as a no-op, even when
kono
parents:
diff changeset
1161 -- the container is busy, so we simply return.
kono
parents:
diff changeset
1162
kono
parents:
diff changeset
1163 if Count = 0 then
kono
parents:
diff changeset
1164 return;
kono
parents:
diff changeset
1165 end if;
kono
parents:
diff changeset
1166
kono
parents:
diff changeset
1167 -- There are two constraints we need to satisfy. The first constraint is
kono
parents:
diff changeset
1168 -- that a container cannot have more than Count_Type'Last elements, so
kono
parents:
diff changeset
1169 -- we must check the sum of the current length and the insertion count.
kono
parents:
diff changeset
1170 -- Note: we cannot simply add these values, because of the possibility
kono
parents:
diff changeset
1171 -- of overflow.
kono
parents:
diff changeset
1172
kono
parents:
diff changeset
1173 if Checks and then Old_Length > Count_Type'Last - Count then
kono
parents:
diff changeset
1174 raise Constraint_Error with "Count is out of range";
kono
parents:
diff changeset
1175 end if;
kono
parents:
diff changeset
1176
kono
parents:
diff changeset
1177 -- It is now safe compute the length of the new vector, without fear of
kono
parents:
diff changeset
1178 -- overflow.
kono
parents:
diff changeset
1179
kono
parents:
diff changeset
1180 New_Length := Old_Length + Count;
kono
parents:
diff changeset
1181
kono
parents:
diff changeset
1182 -- The second constraint is that the new Last index value cannot exceed
kono
parents:
diff changeset
1183 -- Index_Type'Last. In each branch below, we calculate the maximum
kono
parents:
diff changeset
1184 -- length (computed from the range of values in Index_Type), and then
kono
parents:
diff changeset
1185 -- compare the new length to the maximum length. If the new length is
kono
parents:
diff changeset
1186 -- acceptable, then we compute the new last index from that.
kono
parents:
diff changeset
1187
kono
parents:
diff changeset
1188 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1189
kono
parents:
diff changeset
1190 -- We have to handle the case when there might be more values in the
kono
parents:
diff changeset
1191 -- range of Index_Type than in the range of Count_Type.
kono
parents:
diff changeset
1192
kono
parents:
diff changeset
1193 if Index_Type'First <= 0 then
kono
parents:
diff changeset
1194
kono
parents:
diff changeset
1195 -- We know that No_Index (the same as Index_Type'First - 1) is
kono
parents:
diff changeset
1196 -- less than 0, so it is safe to compute the following sum without
kono
parents:
diff changeset
1197 -- fear of overflow.
kono
parents:
diff changeset
1198
kono
parents:
diff changeset
1199 Index := No_Index + Index_Type'Base (Count_Type'Last);
kono
parents:
diff changeset
1200
kono
parents:
diff changeset
1201 if Index <= Index_Type'Last then
kono
parents:
diff changeset
1202
kono
parents:
diff changeset
1203 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
1204 -- many values as in Count_Type, so Count_Type'Last is the
kono
parents:
diff changeset
1205 -- maximum number of items that are allowed.
kono
parents:
diff changeset
1206
kono
parents:
diff changeset
1207 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
1208
kono
parents:
diff changeset
1209 else
kono
parents:
diff changeset
1210 -- The range of Index_Type has fewer values than in Count_Type,
kono
parents:
diff changeset
1211 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
1212 -- the Index_Type.
kono
parents:
diff changeset
1213
kono
parents:
diff changeset
1214 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
kono
parents:
diff changeset
1215 end if;
kono
parents:
diff changeset
1216
kono
parents:
diff changeset
1217 else
kono
parents:
diff changeset
1218 -- No_Index is equal or greater than 0, so we can safely compute
kono
parents:
diff changeset
1219 -- the difference without fear of overflow (which we would have to
kono
parents:
diff changeset
1220 -- worry about if No_Index were less than 0, but that case is
kono
parents:
diff changeset
1221 -- handled above).
kono
parents:
diff changeset
1222
kono
parents:
diff changeset
1223 if Index_Type'Last - No_Index >= Count_Type_Last then
kono
parents:
diff changeset
1224 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
1225 -- many values as in Count_Type, so Count_Type'Last is the
kono
parents:
diff changeset
1226 -- maximum number of items that are allowed.
kono
parents:
diff changeset
1227
kono
parents:
diff changeset
1228 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
1229
kono
parents:
diff changeset
1230 else
kono
parents:
diff changeset
1231 -- The range of Index_Type has fewer values than in Count_Type,
kono
parents:
diff changeset
1232 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
1233 -- the Index_Type.
kono
parents:
diff changeset
1234
kono
parents:
diff changeset
1235 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
kono
parents:
diff changeset
1236 end if;
kono
parents:
diff changeset
1237 end if;
kono
parents:
diff changeset
1238
kono
parents:
diff changeset
1239 elsif Index_Type'First <= 0 then
kono
parents:
diff changeset
1240
kono
parents:
diff changeset
1241 -- We know that No_Index (the same as Index_Type'First - 1) is less
kono
parents:
diff changeset
1242 -- than 0, so it is safe to compute the following sum without fear of
kono
parents:
diff changeset
1243 -- overflow.
kono
parents:
diff changeset
1244
kono
parents:
diff changeset
1245 J := Count_Type'Base (No_Index) + Count_Type'Last;
kono
parents:
diff changeset
1246
kono
parents:
diff changeset
1247 if J <= Count_Type'Base (Index_Type'Last) then
kono
parents:
diff changeset
1248
kono
parents:
diff changeset
1249 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
1250 -- many values as in Count_Type, so Count_Type'Last is the maximum
kono
parents:
diff changeset
1251 -- number of items that are allowed.
kono
parents:
diff changeset
1252
kono
parents:
diff changeset
1253 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
1254
kono
parents:
diff changeset
1255 else
kono
parents:
diff changeset
1256 -- The range of Index_Type has fewer values than Count_Type does,
kono
parents:
diff changeset
1257 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
1258 -- the Index_Type.
kono
parents:
diff changeset
1259
kono
parents:
diff changeset
1260 Max_Length :=
kono
parents:
diff changeset
1261 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
kono
parents:
diff changeset
1262 end if;
kono
parents:
diff changeset
1263
kono
parents:
diff changeset
1264 else
kono
parents:
diff changeset
1265 -- No_Index is equal or greater than 0, so we can safely compute the
kono
parents:
diff changeset
1266 -- difference without fear of overflow (which we would have to worry
kono
parents:
diff changeset
1267 -- about if No_Index were less than 0, but that case is handled
kono
parents:
diff changeset
1268 -- above).
kono
parents:
diff changeset
1269
kono
parents:
diff changeset
1270 Max_Length :=
kono
parents:
diff changeset
1271 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
kono
parents:
diff changeset
1272 end if;
kono
parents:
diff changeset
1273
kono
parents:
diff changeset
1274 -- We have just computed the maximum length (number of items). We must
kono
parents:
diff changeset
1275 -- now compare the requested length to the maximum length, as we do not
kono
parents:
diff changeset
1276 -- allow a vector expand beyond the maximum (because that would create
kono
parents:
diff changeset
1277 -- an internal array with a last index value greater than
kono
parents:
diff changeset
1278 -- Index_Type'Last, with no way to index those elements).
kono
parents:
diff changeset
1279
kono
parents:
diff changeset
1280 if Checks and then New_Length > Max_Length then
kono
parents:
diff changeset
1281 raise Constraint_Error with "Count is out of range";
kono
parents:
diff changeset
1282 end if;
kono
parents:
diff changeset
1283
kono
parents:
diff changeset
1284 -- New_Last is the last index value of the items in the container after
kono
parents:
diff changeset
1285 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
kono
parents:
diff changeset
1286 -- compute its value from the New_Length.
kono
parents:
diff changeset
1287
kono
parents:
diff changeset
1288 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1289 New_Last := No_Index + Index_Type'Base (New_Length);
kono
parents:
diff changeset
1290 else
kono
parents:
diff changeset
1291 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
kono
parents:
diff changeset
1292 end if;
kono
parents:
diff changeset
1293
kono
parents:
diff changeset
1294 if Container.Elements = null then
kono
parents:
diff changeset
1295 pragma Assert (Container.Last = No_Index);
kono
parents:
diff changeset
1296
kono
parents:
diff changeset
1297 -- This is the simplest case, with which we must always begin: we're
kono
parents:
diff changeset
1298 -- inserting items into an empty vector that hasn't allocated an
kono
parents:
diff changeset
1299 -- internal array yet. Note that we don't need to check the busy bit
kono
parents:
diff changeset
1300 -- here, because an empty container cannot be busy.
kono
parents:
diff changeset
1301
kono
parents:
diff changeset
1302 -- In an indefinite vector, elements are allocated individually, and
kono
parents:
diff changeset
1303 -- stored as access values on the internal array (the length of which
kono
parents:
diff changeset
1304 -- represents the vector "capacity"), which is separately allocated.
kono
parents:
diff changeset
1305
kono
parents:
diff changeset
1306 Container.Elements := new Elements_Type (New_Last);
kono
parents:
diff changeset
1307
kono
parents:
diff changeset
1308 -- The element backbone has been successfully allocated, so now we
kono
parents:
diff changeset
1309 -- allocate the elements.
kono
parents:
diff changeset
1310
kono
parents:
diff changeset
1311 for Idx in Container.Elements.EA'Range loop
kono
parents:
diff changeset
1312
kono
parents:
diff changeset
1313 -- In order to preserve container invariants, we always attempt
kono
parents:
diff changeset
1314 -- the element allocation first, before setting the Last index
kono
parents:
diff changeset
1315 -- value, in case the allocation fails (either because there is no
kono
parents:
diff changeset
1316 -- storage available, or because element initialization fails).
kono
parents:
diff changeset
1317
kono
parents:
diff changeset
1318 declare
kono
parents:
diff changeset
1319 -- The element allocator may need an accessibility check in the
kono
parents:
diff changeset
1320 -- case actual type is class-wide or has access discriminants
kono
parents:
diff changeset
1321 -- (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
1322
kono
parents:
diff changeset
1323 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
1324
kono
parents:
diff changeset
1325 begin
kono
parents:
diff changeset
1326 Container.Elements.EA (Idx) := new Element_Type'(New_Item);
kono
parents:
diff changeset
1327 end;
kono
parents:
diff changeset
1328
kono
parents:
diff changeset
1329 -- The allocation of the element succeeded, so it is now safe to
kono
parents:
diff changeset
1330 -- update the Last index, restoring container invariants.
kono
parents:
diff changeset
1331
kono
parents:
diff changeset
1332 Container.Last := Idx;
kono
parents:
diff changeset
1333 end loop;
kono
parents:
diff changeset
1334
kono
parents:
diff changeset
1335 return;
kono
parents:
diff changeset
1336 end if;
kono
parents:
diff changeset
1337
kono
parents:
diff changeset
1338 -- The tampering bits exist to prevent an item from being harmfully
kono
parents:
diff changeset
1339 -- manipulated while it is being visited. Query, Update, and Iterate
kono
parents:
diff changeset
1340 -- increment the busy count on entry, and decrement the count on
kono
parents:
diff changeset
1341 -- exit. Insert checks the count to determine whether it is being called
kono
parents:
diff changeset
1342 -- while the associated callback procedure is executing.
kono
parents:
diff changeset
1343
kono
parents:
diff changeset
1344 TC_Check (Container.TC);
kono
parents:
diff changeset
1345
kono
parents:
diff changeset
1346 if New_Length <= Container.Elements.EA'Length then
kono
parents:
diff changeset
1347
kono
parents:
diff changeset
1348 -- In this case, we're inserting elements into a vector that has
kono
parents:
diff changeset
1349 -- already allocated an internal array, and the existing array has
kono
parents:
diff changeset
1350 -- enough unused storage for the new items.
kono
parents:
diff changeset
1351
kono
parents:
diff changeset
1352 declare
kono
parents:
diff changeset
1353 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
1354 K : Index_Type'Base;
kono
parents:
diff changeset
1355
kono
parents:
diff changeset
1356 begin
kono
parents:
diff changeset
1357 if Before > Container.Last then
kono
parents:
diff changeset
1358
kono
parents:
diff changeset
1359 -- The new items are being appended to the vector, so no
kono
parents:
diff changeset
1360 -- sliding of existing elements is required.
kono
parents:
diff changeset
1361
kono
parents:
diff changeset
1362 for Idx in Before .. New_Last loop
kono
parents:
diff changeset
1363
kono
parents:
diff changeset
1364 -- In order to preserve container invariants, we always
kono
parents:
diff changeset
1365 -- attempt the element allocation first, before setting the
kono
parents:
diff changeset
1366 -- Last index value, in case the allocation fails (either
kono
parents:
diff changeset
1367 -- because there is no storage available, or because element
kono
parents:
diff changeset
1368 -- initialization fails).
kono
parents:
diff changeset
1369
kono
parents:
diff changeset
1370 declare
kono
parents:
diff changeset
1371 -- The element allocator may need an accessibility check
kono
parents:
diff changeset
1372 -- in case the actual type is class-wide or has access
kono
parents:
diff changeset
1373 -- discriminants (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
1374
kono
parents:
diff changeset
1375 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
1376
kono
parents:
diff changeset
1377 begin
kono
parents:
diff changeset
1378 E (Idx) := new Element_Type'(New_Item);
kono
parents:
diff changeset
1379 end;
kono
parents:
diff changeset
1380
kono
parents:
diff changeset
1381 -- The allocation of the element succeeded, so it is now
kono
parents:
diff changeset
1382 -- safe to update the Last index, restoring container
kono
parents:
diff changeset
1383 -- invariants.
kono
parents:
diff changeset
1384
kono
parents:
diff changeset
1385 Container.Last := Idx;
kono
parents:
diff changeset
1386 end loop;
kono
parents:
diff changeset
1387
kono
parents:
diff changeset
1388 else
kono
parents:
diff changeset
1389 -- The new items are being inserted before some existing
kono
parents:
diff changeset
1390 -- elements, so we must slide the existing elements up to their
kono
parents:
diff changeset
1391 -- new home. We use the wider of Index_Type'Base and
kono
parents:
diff changeset
1392 -- Count_Type'Base as the type for intermediate index values.
kono
parents:
diff changeset
1393
kono
parents:
diff changeset
1394 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1395 Index := Before + Index_Type'Base (Count);
kono
parents:
diff changeset
1396 else
kono
parents:
diff changeset
1397 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
kono
parents:
diff changeset
1398 end if;
kono
parents:
diff changeset
1399
kono
parents:
diff changeset
1400 -- The new items are being inserted in the middle of the array,
kono
parents:
diff changeset
1401 -- in the range [Before, Index). Copy the existing elements to
kono
parents:
diff changeset
1402 -- the end of the array, to make room for the new items.
kono
parents:
diff changeset
1403
kono
parents:
diff changeset
1404 E (Index .. New_Last) := E (Before .. Container.Last);
kono
parents:
diff changeset
1405 Container.Last := New_Last;
kono
parents:
diff changeset
1406
kono
parents:
diff changeset
1407 -- We have copied the existing items up to the end of the
kono
parents:
diff changeset
1408 -- array, to make room for the new items in the middle of
kono
parents:
diff changeset
1409 -- the array. Now we actually allocate the new items.
kono
parents:
diff changeset
1410
kono
parents:
diff changeset
1411 -- Note: initialize K outside loop to make it clear that
kono
parents:
diff changeset
1412 -- K always has a value if the exception handler triggers.
kono
parents:
diff changeset
1413
kono
parents:
diff changeset
1414 K := Before;
kono
parents:
diff changeset
1415
kono
parents:
diff changeset
1416 declare
kono
parents:
diff changeset
1417 -- The element allocator may need an accessibility check in
kono
parents:
diff changeset
1418 -- the case the actual type is class-wide or has access
kono
parents:
diff changeset
1419 -- discriminants (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
1420
kono
parents:
diff changeset
1421 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
1422
kono
parents:
diff changeset
1423 begin
kono
parents:
diff changeset
1424 while K < Index loop
kono
parents:
diff changeset
1425 E (K) := new Element_Type'(New_Item);
kono
parents:
diff changeset
1426 K := K + 1;
kono
parents:
diff changeset
1427 end loop;
kono
parents:
diff changeset
1428
kono
parents:
diff changeset
1429 exception
kono
parents:
diff changeset
1430 when others =>
kono
parents:
diff changeset
1431
kono
parents:
diff changeset
1432 -- Values in the range [Before, K) were successfully
kono
parents:
diff changeset
1433 -- allocated, but values in the range [K, Index) are
kono
parents:
diff changeset
1434 -- stale (these array positions contain copies of the
kono
parents:
diff changeset
1435 -- old items, that did not get assigned a new item,
kono
parents:
diff changeset
1436 -- because the allocation failed). We must finish what
kono
parents:
diff changeset
1437 -- we started by clearing out all of the stale values,
kono
parents:
diff changeset
1438 -- leaving a "hole" in the middle of the array.
kono
parents:
diff changeset
1439
kono
parents:
diff changeset
1440 E (K .. Index - 1) := (others => null);
kono
parents:
diff changeset
1441 raise;
kono
parents:
diff changeset
1442 end;
kono
parents:
diff changeset
1443 end if;
kono
parents:
diff changeset
1444 end;
kono
parents:
diff changeset
1445
kono
parents:
diff changeset
1446 return;
kono
parents:
diff changeset
1447 end if;
kono
parents:
diff changeset
1448
kono
parents:
diff changeset
1449 -- In this case, we're inserting elements into a vector that has already
kono
parents:
diff changeset
1450 -- allocated an internal array, but the existing array does not have
kono
parents:
diff changeset
1451 -- enough storage, so we must allocate a new, longer array. In order to
kono
parents:
diff changeset
1452 -- guarantee that the amortized insertion cost is O(1), we always
kono
parents:
diff changeset
1453 -- allocate an array whose length is some power-of-two factor of the
kono
parents:
diff changeset
1454 -- current array length. (The new array cannot have a length less than
kono
parents:
diff changeset
1455 -- the New_Length of the container, but its last index value cannot be
kono
parents:
diff changeset
1456 -- greater than Index_Type'Last.)
kono
parents:
diff changeset
1457
kono
parents:
diff changeset
1458 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
kono
parents:
diff changeset
1459 while New_Capacity < New_Length loop
kono
parents:
diff changeset
1460 if New_Capacity > Count_Type'Last / 2 then
kono
parents:
diff changeset
1461 New_Capacity := Count_Type'Last;
kono
parents:
diff changeset
1462 exit;
kono
parents:
diff changeset
1463 end if;
kono
parents:
diff changeset
1464
kono
parents:
diff changeset
1465 New_Capacity := 2 * New_Capacity;
kono
parents:
diff changeset
1466 end loop;
kono
parents:
diff changeset
1467
kono
parents:
diff changeset
1468 if New_Capacity > Max_Length then
kono
parents:
diff changeset
1469
kono
parents:
diff changeset
1470 -- We have reached the limit of capacity, so no further expansion
kono
parents:
diff changeset
1471 -- will occur. (This is not a problem, as there is never a need to
kono
parents:
diff changeset
1472 -- have more capacity than the maximum container length.)
kono
parents:
diff changeset
1473
kono
parents:
diff changeset
1474 New_Capacity := Max_Length;
kono
parents:
diff changeset
1475 end if;
kono
parents:
diff changeset
1476
kono
parents:
diff changeset
1477 -- We have computed the length of the new internal array (and this is
kono
parents:
diff changeset
1478 -- what "vector capacity" means), so use that to compute its last index.
kono
parents:
diff changeset
1479
kono
parents:
diff changeset
1480 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1481 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
kono
parents:
diff changeset
1482 else
kono
parents:
diff changeset
1483 Dst_Last :=
kono
parents:
diff changeset
1484 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
kono
parents:
diff changeset
1485 end if;
kono
parents:
diff changeset
1486
kono
parents:
diff changeset
1487 -- Now we allocate the new, longer internal array. If the allocation
kono
parents:
diff changeset
1488 -- fails, we have not changed any container state, so no side-effect
kono
parents:
diff changeset
1489 -- will occur as a result of propagating the exception.
kono
parents:
diff changeset
1490
kono
parents:
diff changeset
1491 Dst := new Elements_Type (Dst_Last);
kono
parents:
diff changeset
1492
kono
parents:
diff changeset
1493 -- We have our new internal array. All that needs to be done now is to
kono
parents:
diff changeset
1494 -- copy the existing items (if any) from the old array (the "source"
kono
parents:
diff changeset
1495 -- array) to the new array (the "destination" array), and then
kono
parents:
diff changeset
1496 -- deallocate the old array.
kono
parents:
diff changeset
1497
kono
parents:
diff changeset
1498 declare
kono
parents:
diff changeset
1499 Src : Elements_Access := Container.Elements;
kono
parents:
diff changeset
1500
kono
parents:
diff changeset
1501 begin
kono
parents:
diff changeset
1502 Dst.EA (Index_Type'First .. Before - 1) :=
kono
parents:
diff changeset
1503 Src.EA (Index_Type'First .. Before - 1);
kono
parents:
diff changeset
1504
kono
parents:
diff changeset
1505 if Before > Container.Last then
kono
parents:
diff changeset
1506
kono
parents:
diff changeset
1507 -- The new items are being appended to the vector, so no
kono
parents:
diff changeset
1508 -- sliding of existing elements is required.
kono
parents:
diff changeset
1509
kono
parents:
diff changeset
1510 -- We have copied the elements from to the old source array to the
kono
parents:
diff changeset
1511 -- new destination array, so we can now deallocate the old array.
kono
parents:
diff changeset
1512
kono
parents:
diff changeset
1513 Container.Elements := Dst;
kono
parents:
diff changeset
1514 Free (Src);
kono
parents:
diff changeset
1515
kono
parents:
diff changeset
1516 -- Now we append the new items.
kono
parents:
diff changeset
1517
kono
parents:
diff changeset
1518 for Idx in Before .. New_Last loop
kono
parents:
diff changeset
1519
kono
parents:
diff changeset
1520 -- In order to preserve container invariants, we always attempt
kono
parents:
diff changeset
1521 -- the element allocation first, before setting the Last index
kono
parents:
diff changeset
1522 -- value, in case the allocation fails (either because there
kono
parents:
diff changeset
1523 -- is no storage available, or because element initialization
kono
parents:
diff changeset
1524 -- fails).
kono
parents:
diff changeset
1525
kono
parents:
diff changeset
1526 declare
kono
parents:
diff changeset
1527 -- The element allocator may need an accessibility check in
kono
parents:
diff changeset
1528 -- the case the actual type is class-wide or has access
kono
parents:
diff changeset
1529 -- discriminants (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
1530
kono
parents:
diff changeset
1531 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
1532
kono
parents:
diff changeset
1533 begin
kono
parents:
diff changeset
1534 Dst.EA (Idx) := new Element_Type'(New_Item);
kono
parents:
diff changeset
1535 end;
kono
parents:
diff changeset
1536
kono
parents:
diff changeset
1537 -- The allocation of the element succeeded, so it is now safe
kono
parents:
diff changeset
1538 -- to update the Last index, restoring container invariants.
kono
parents:
diff changeset
1539
kono
parents:
diff changeset
1540 Container.Last := Idx;
kono
parents:
diff changeset
1541 end loop;
kono
parents:
diff changeset
1542
kono
parents:
diff changeset
1543 else
kono
parents:
diff changeset
1544 -- The new items are being inserted before some existing elements,
kono
parents:
diff changeset
1545 -- so we must slide the existing elements up to their new home.
kono
parents:
diff changeset
1546
kono
parents:
diff changeset
1547 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1548 Index := Before + Index_Type'Base (Count);
kono
parents:
diff changeset
1549 else
kono
parents:
diff changeset
1550 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
kono
parents:
diff changeset
1551 end if;
kono
parents:
diff changeset
1552
kono
parents:
diff changeset
1553 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
kono
parents:
diff changeset
1554
kono
parents:
diff changeset
1555 -- We have copied the elements from to the old source array to the
kono
parents:
diff changeset
1556 -- new destination array, so we can now deallocate the old array.
kono
parents:
diff changeset
1557
kono
parents:
diff changeset
1558 Container.Elements := Dst;
kono
parents:
diff changeset
1559 Container.Last := New_Last;
kono
parents:
diff changeset
1560 Free (Src);
kono
parents:
diff changeset
1561
kono
parents:
diff changeset
1562 -- The new array has a range in the middle containing null access
kono
parents:
diff changeset
1563 -- values. Fill in that partition of the array with the new items.
kono
parents:
diff changeset
1564
kono
parents:
diff changeset
1565 for Idx in Before .. Index - 1 loop
kono
parents:
diff changeset
1566
kono
parents:
diff changeset
1567 -- Note that container invariants have already been satisfied
kono
parents:
diff changeset
1568 -- (in particular, the Last index value of the vector has
kono
parents:
diff changeset
1569 -- already been updated), so if this allocation fails we simply
kono
parents:
diff changeset
1570 -- let it propagate.
kono
parents:
diff changeset
1571
kono
parents:
diff changeset
1572 declare
kono
parents:
diff changeset
1573 -- The element allocator may need an accessibility check in
kono
parents:
diff changeset
1574 -- the case the actual type is class-wide or has access
kono
parents:
diff changeset
1575 -- discriminants (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
1576
kono
parents:
diff changeset
1577 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
1578
kono
parents:
diff changeset
1579 begin
kono
parents:
diff changeset
1580 Dst.EA (Idx) := new Element_Type'(New_Item);
kono
parents:
diff changeset
1581 end;
kono
parents:
diff changeset
1582 end loop;
kono
parents:
diff changeset
1583 end if;
kono
parents:
diff changeset
1584 end;
kono
parents:
diff changeset
1585 end Insert;
kono
parents:
diff changeset
1586
kono
parents:
diff changeset
1587 procedure Insert
kono
parents:
diff changeset
1588 (Container : in out Vector;
kono
parents:
diff changeset
1589 Before : Extended_Index;
kono
parents:
diff changeset
1590 New_Item : Vector)
kono
parents:
diff changeset
1591 is
kono
parents:
diff changeset
1592 N : constant Count_Type := Length (New_Item);
kono
parents:
diff changeset
1593 J : Index_Type'Base;
kono
parents:
diff changeset
1594
kono
parents:
diff changeset
1595 begin
kono
parents:
diff changeset
1596 -- Use Insert_Space to create the "hole" (the destination slice) into
kono
parents:
diff changeset
1597 -- which we copy the source items.
kono
parents:
diff changeset
1598
kono
parents:
diff changeset
1599 Insert_Space (Container, Before, Count => N);
kono
parents:
diff changeset
1600
kono
parents:
diff changeset
1601 if N = 0 then
kono
parents:
diff changeset
1602
kono
parents:
diff changeset
1603 -- There's nothing else to do here (vetting of parameters was
kono
parents:
diff changeset
1604 -- performed already in Insert_Space), so we simply return.
kono
parents:
diff changeset
1605
kono
parents:
diff changeset
1606 return;
kono
parents:
diff changeset
1607 end if;
kono
parents:
diff changeset
1608
kono
parents:
diff changeset
1609 if Container'Address /= New_Item'Address then
kono
parents:
diff changeset
1610
kono
parents:
diff changeset
1611 -- This is the simple case. New_Item denotes an object different
kono
parents:
diff changeset
1612 -- from Container, so there's nothing special we need to do to copy
kono
parents:
diff changeset
1613 -- the source items to their destination, because all of the source
kono
parents:
diff changeset
1614 -- items are contiguous.
kono
parents:
diff changeset
1615
kono
parents:
diff changeset
1616 declare
kono
parents:
diff changeset
1617 subtype Src_Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
1618 Index_Type'First .. New_Item.Last;
kono
parents:
diff changeset
1619
kono
parents:
diff changeset
1620 Src : Elements_Array renames
kono
parents:
diff changeset
1621 New_Item.Elements.EA (Src_Index_Subtype);
kono
parents:
diff changeset
1622
kono
parents:
diff changeset
1623 Dst : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
1624
kono
parents:
diff changeset
1625 Dst_Index : Index_Type'Base;
kono
parents:
diff changeset
1626
kono
parents:
diff changeset
1627 begin
kono
parents:
diff changeset
1628 Dst_Index := Before - 1;
kono
parents:
diff changeset
1629 for Src_Index in Src'Range loop
kono
parents:
diff changeset
1630 Dst_Index := Dst_Index + 1;
kono
parents:
diff changeset
1631
kono
parents:
diff changeset
1632 if Src (Src_Index) /= null then
kono
parents:
diff changeset
1633 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
kono
parents:
diff changeset
1634 end if;
kono
parents:
diff changeset
1635 end loop;
kono
parents:
diff changeset
1636 end;
kono
parents:
diff changeset
1637
kono
parents:
diff changeset
1638 return;
kono
parents:
diff changeset
1639 end if;
kono
parents:
diff changeset
1640
kono
parents:
diff changeset
1641 -- New_Item denotes the same object as Container, so an insertion has
kono
parents:
diff changeset
1642 -- potentially split the source items. The first source slice is
kono
parents:
diff changeset
1643 -- [Index_Type'First, Before), and the second source slice is
kono
parents:
diff changeset
1644 -- [J, Container.Last], where index value J is the first index of the
kono
parents:
diff changeset
1645 -- second slice. (J gets computed below, but only after we have
kono
parents:
diff changeset
1646 -- determined that the second source slice is non-empty.) The
kono
parents:
diff changeset
1647 -- destination slice is always the range [Before, J). We perform the
kono
parents:
diff changeset
1648 -- copy in two steps, using each of the two slices of the source items.
kono
parents:
diff changeset
1649
kono
parents:
diff changeset
1650 declare
kono
parents:
diff changeset
1651 L : constant Index_Type'Base := Before - 1;
kono
parents:
diff changeset
1652
kono
parents:
diff changeset
1653 subtype Src_Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
1654 Index_Type'First .. L;
kono
parents:
diff changeset
1655
kono
parents:
diff changeset
1656 Src : Elements_Array renames
kono
parents:
diff changeset
1657 Container.Elements.EA (Src_Index_Subtype);
kono
parents:
diff changeset
1658
kono
parents:
diff changeset
1659 Dst : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
1660
kono
parents:
diff changeset
1661 Dst_Index : Index_Type'Base;
kono
parents:
diff changeset
1662
kono
parents:
diff changeset
1663 begin
kono
parents:
diff changeset
1664 -- We first copy the source items that precede the space we
kono
parents:
diff changeset
1665 -- inserted. (If Before equals Index_Type'First, then this first
kono
parents:
diff changeset
1666 -- source slice will be empty, which is harmless.)
kono
parents:
diff changeset
1667
kono
parents:
diff changeset
1668 Dst_Index := Before - 1;
kono
parents:
diff changeset
1669 for Src_Index in Src'Range loop
kono
parents:
diff changeset
1670 Dst_Index := Dst_Index + 1;
kono
parents:
diff changeset
1671
kono
parents:
diff changeset
1672 if Src (Src_Index) /= null then
kono
parents:
diff changeset
1673 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
kono
parents:
diff changeset
1674 end if;
kono
parents:
diff changeset
1675 end loop;
kono
parents:
diff changeset
1676
kono
parents:
diff changeset
1677 if Src'Length = N then
kono
parents:
diff changeset
1678
kono
parents:
diff changeset
1679 -- The new items were effectively appended to the container, so we
kono
parents:
diff changeset
1680 -- have already copied all of the items that need to be copied.
kono
parents:
diff changeset
1681 -- We return early here, even though the source slice below is
kono
parents:
diff changeset
1682 -- empty (so the assignment would be harmless), because we want to
kono
parents:
diff changeset
1683 -- avoid computing J, which will overflow if J is greater than
kono
parents:
diff changeset
1684 -- Index_Type'Base'Last.
kono
parents:
diff changeset
1685
kono
parents:
diff changeset
1686 return;
kono
parents:
diff changeset
1687 end if;
kono
parents:
diff changeset
1688 end;
kono
parents:
diff changeset
1689
kono
parents:
diff changeset
1690 -- Index value J is the first index of the second source slice. (It is
kono
parents:
diff changeset
1691 -- also 1 greater than the last index of the destination slice.) Note:
kono
parents:
diff changeset
1692 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
kono
parents:
diff changeset
1693 -- to avoid overflow. Prevent that by returning early above, immediately
kono
parents:
diff changeset
1694 -- after copying the first slice of the source, and determining that
kono
parents:
diff changeset
1695 -- this second slice of the source is empty.
kono
parents:
diff changeset
1696
kono
parents:
diff changeset
1697 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1698 J := Before + Index_Type'Base (N);
kono
parents:
diff changeset
1699 else
kono
parents:
diff changeset
1700 J := Index_Type'Base (Count_Type'Base (Before) + N);
kono
parents:
diff changeset
1701 end if;
kono
parents:
diff changeset
1702
kono
parents:
diff changeset
1703 declare
kono
parents:
diff changeset
1704 subtype Src_Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
1705 J .. Container.Last;
kono
parents:
diff changeset
1706
kono
parents:
diff changeset
1707 Src : Elements_Array renames
kono
parents:
diff changeset
1708 Container.Elements.EA (Src_Index_Subtype);
kono
parents:
diff changeset
1709
kono
parents:
diff changeset
1710 Dst : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
1711
kono
parents:
diff changeset
1712 Dst_Index : Index_Type'Base;
kono
parents:
diff changeset
1713
kono
parents:
diff changeset
1714 begin
kono
parents:
diff changeset
1715 -- We next copy the source items that follow the space we inserted.
kono
parents:
diff changeset
1716 -- Index value Dst_Index is the first index of that portion of the
kono
parents:
diff changeset
1717 -- destination that receives this slice of the source. (For the
kono
parents:
diff changeset
1718 -- reasons given above, this slice is guaranteed to be non-empty.)
kono
parents:
diff changeset
1719
kono
parents:
diff changeset
1720 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1721 Dst_Index := J - Index_Type'Base (Src'Length);
kono
parents:
diff changeset
1722 else
kono
parents:
diff changeset
1723 Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
kono
parents:
diff changeset
1724 end if;
kono
parents:
diff changeset
1725
kono
parents:
diff changeset
1726 for Src_Index in Src'Range loop
kono
parents:
diff changeset
1727 if Src (Src_Index) /= null then
kono
parents:
diff changeset
1728 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
kono
parents:
diff changeset
1729 end if;
kono
parents:
diff changeset
1730
kono
parents:
diff changeset
1731 Dst_Index := Dst_Index + 1;
kono
parents:
diff changeset
1732 end loop;
kono
parents:
diff changeset
1733 end;
kono
parents:
diff changeset
1734 end Insert;
kono
parents:
diff changeset
1735
kono
parents:
diff changeset
1736 procedure Insert
kono
parents:
diff changeset
1737 (Container : in out Vector;
kono
parents:
diff changeset
1738 Before : Cursor;
kono
parents:
diff changeset
1739 New_Item : Vector)
kono
parents:
diff changeset
1740 is
kono
parents:
diff changeset
1741 Index : Index_Type'Base;
kono
parents:
diff changeset
1742
kono
parents:
diff changeset
1743 begin
kono
parents:
diff changeset
1744 if Checks and then Before.Container /= null
kono
parents:
diff changeset
1745 and then Before.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
1746 then
kono
parents:
diff changeset
1747 raise Program_Error with "Before cursor denotes wrong container";
kono
parents:
diff changeset
1748 end if;
kono
parents:
diff changeset
1749
kono
parents:
diff changeset
1750 if Is_Empty (New_Item) then
kono
parents:
diff changeset
1751 return;
kono
parents:
diff changeset
1752 end if;
kono
parents:
diff changeset
1753
kono
parents:
diff changeset
1754 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1755 if Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
1756 raise Constraint_Error with
kono
parents:
diff changeset
1757 "vector is already at its maximum length";
kono
parents:
diff changeset
1758 end if;
kono
parents:
diff changeset
1759
kono
parents:
diff changeset
1760 Index := Container.Last + 1;
kono
parents:
diff changeset
1761
kono
parents:
diff changeset
1762 else
kono
parents:
diff changeset
1763 Index := Before.Index;
kono
parents:
diff changeset
1764 end if;
kono
parents:
diff changeset
1765
kono
parents:
diff changeset
1766 Insert (Container, Index, New_Item);
kono
parents:
diff changeset
1767 end Insert;
kono
parents:
diff changeset
1768
kono
parents:
diff changeset
1769 procedure Insert
kono
parents:
diff changeset
1770 (Container : in out Vector;
kono
parents:
diff changeset
1771 Before : Cursor;
kono
parents:
diff changeset
1772 New_Item : Vector;
kono
parents:
diff changeset
1773 Position : out Cursor)
kono
parents:
diff changeset
1774 is
kono
parents:
diff changeset
1775 Index : Index_Type'Base;
kono
parents:
diff changeset
1776
kono
parents:
diff changeset
1777 begin
kono
parents:
diff changeset
1778 if Checks and then Before.Container /= null
kono
parents:
diff changeset
1779 and then Before.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
1780 then
kono
parents:
diff changeset
1781 raise Program_Error with "Before cursor denotes wrong container";
kono
parents:
diff changeset
1782 end if;
kono
parents:
diff changeset
1783
kono
parents:
diff changeset
1784 if Is_Empty (New_Item) then
kono
parents:
diff changeset
1785 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1786 Position := No_Element;
kono
parents:
diff changeset
1787 else
kono
parents:
diff changeset
1788 Position := (Container'Unrestricted_Access, Before.Index);
kono
parents:
diff changeset
1789 end if;
kono
parents:
diff changeset
1790
kono
parents:
diff changeset
1791 return;
kono
parents:
diff changeset
1792 end if;
kono
parents:
diff changeset
1793
kono
parents:
diff changeset
1794 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1795 if Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
1796 raise Constraint_Error with
kono
parents:
diff changeset
1797 "vector is already at its maximum length";
kono
parents:
diff changeset
1798 end if;
kono
parents:
diff changeset
1799
kono
parents:
diff changeset
1800 Index := Container.Last + 1;
kono
parents:
diff changeset
1801
kono
parents:
diff changeset
1802 else
kono
parents:
diff changeset
1803 Index := Before.Index;
kono
parents:
diff changeset
1804 end if;
kono
parents:
diff changeset
1805
kono
parents:
diff changeset
1806 Insert (Container, Index, New_Item);
kono
parents:
diff changeset
1807
kono
parents:
diff changeset
1808 Position := (Container'Unrestricted_Access, Index);
kono
parents:
diff changeset
1809 end Insert;
kono
parents:
diff changeset
1810
kono
parents:
diff changeset
1811 procedure Insert
kono
parents:
diff changeset
1812 (Container : in out Vector;
kono
parents:
diff changeset
1813 Before : Cursor;
kono
parents:
diff changeset
1814 New_Item : Element_Type;
kono
parents:
diff changeset
1815 Count : Count_Type := 1)
kono
parents:
diff changeset
1816 is
kono
parents:
diff changeset
1817 Index : Index_Type'Base;
kono
parents:
diff changeset
1818
kono
parents:
diff changeset
1819 begin
kono
parents:
diff changeset
1820 if Checks and then Before.Container /= null
kono
parents:
diff changeset
1821 and then Before.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
1822 then
kono
parents:
diff changeset
1823 raise Program_Error with "Before cursor denotes wrong container";
kono
parents:
diff changeset
1824 end if;
kono
parents:
diff changeset
1825
kono
parents:
diff changeset
1826 if Count = 0 then
kono
parents:
diff changeset
1827 return;
kono
parents:
diff changeset
1828 end if;
kono
parents:
diff changeset
1829
kono
parents:
diff changeset
1830 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1831 if Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
1832 raise Constraint_Error with
kono
parents:
diff changeset
1833 "vector is already at its maximum length";
kono
parents:
diff changeset
1834 end if;
kono
parents:
diff changeset
1835
kono
parents:
diff changeset
1836 Index := Container.Last + 1;
kono
parents:
diff changeset
1837
kono
parents:
diff changeset
1838 else
kono
parents:
diff changeset
1839 Index := Before.Index;
kono
parents:
diff changeset
1840 end if;
kono
parents:
diff changeset
1841
kono
parents:
diff changeset
1842 Insert (Container, Index, New_Item, Count);
kono
parents:
diff changeset
1843 end Insert;
kono
parents:
diff changeset
1844
kono
parents:
diff changeset
1845 procedure Insert
kono
parents:
diff changeset
1846 (Container : in out Vector;
kono
parents:
diff changeset
1847 Before : Cursor;
kono
parents:
diff changeset
1848 New_Item : Element_Type;
kono
parents:
diff changeset
1849 Position : out Cursor;
kono
parents:
diff changeset
1850 Count : Count_Type := 1)
kono
parents:
diff changeset
1851 is
kono
parents:
diff changeset
1852 Index : Index_Type'Base;
kono
parents:
diff changeset
1853
kono
parents:
diff changeset
1854 begin
kono
parents:
diff changeset
1855 if Checks and then Before.Container /= null
kono
parents:
diff changeset
1856 and then Before.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
1857 then
kono
parents:
diff changeset
1858 raise Program_Error with "Before cursor denotes wrong container";
kono
parents:
diff changeset
1859 end if;
kono
parents:
diff changeset
1860
kono
parents:
diff changeset
1861 if Count = 0 then
kono
parents:
diff changeset
1862 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1863 Position := No_Element;
kono
parents:
diff changeset
1864 else
kono
parents:
diff changeset
1865 Position := (Container'Unrestricted_Access, Before.Index);
kono
parents:
diff changeset
1866 end if;
kono
parents:
diff changeset
1867
kono
parents:
diff changeset
1868 return;
kono
parents:
diff changeset
1869 end if;
kono
parents:
diff changeset
1870
kono
parents:
diff changeset
1871 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
1872 if Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
1873 raise Constraint_Error with
kono
parents:
diff changeset
1874 "vector is already at its maximum length";
kono
parents:
diff changeset
1875 end if;
kono
parents:
diff changeset
1876
kono
parents:
diff changeset
1877 Index := Container.Last + 1;
kono
parents:
diff changeset
1878
kono
parents:
diff changeset
1879 else
kono
parents:
diff changeset
1880 Index := Before.Index;
kono
parents:
diff changeset
1881 end if;
kono
parents:
diff changeset
1882
kono
parents:
diff changeset
1883 Insert (Container, Index, New_Item, Count);
kono
parents:
diff changeset
1884
kono
parents:
diff changeset
1885 Position := (Container'Unrestricted_Access, Index);
kono
parents:
diff changeset
1886 end Insert;
kono
parents:
diff changeset
1887
kono
parents:
diff changeset
1888 ------------------
kono
parents:
diff changeset
1889 -- Insert_Space --
kono
parents:
diff changeset
1890 ------------------
kono
parents:
diff changeset
1891
kono
parents:
diff changeset
1892 procedure Insert_Space
kono
parents:
diff changeset
1893 (Container : in out Vector;
kono
parents:
diff changeset
1894 Before : Extended_Index;
kono
parents:
diff changeset
1895 Count : Count_Type := 1)
kono
parents:
diff changeset
1896 is
kono
parents:
diff changeset
1897 Old_Length : constant Count_Type := Container.Length;
kono
parents:
diff changeset
1898
kono
parents:
diff changeset
1899 Max_Length : Count_Type'Base; -- determined from range of Index_Type
kono
parents:
diff changeset
1900 New_Length : Count_Type'Base; -- sum of current length and Count
kono
parents:
diff changeset
1901 New_Last : Index_Type'Base; -- last index of vector after insertion
kono
parents:
diff changeset
1902
kono
parents:
diff changeset
1903 Index : Index_Type'Base; -- scratch for intermediate values
kono
parents:
diff changeset
1904 J : Count_Type'Base; -- scratch
kono
parents:
diff changeset
1905
kono
parents:
diff changeset
1906 New_Capacity : Count_Type'Base; -- length of new, expanded array
kono
parents:
diff changeset
1907 Dst_Last : Index_Type'Base; -- last index of new, expanded array
kono
parents:
diff changeset
1908 Dst : Elements_Access; -- new, expanded internal array
kono
parents:
diff changeset
1909
kono
parents:
diff changeset
1910 begin
kono
parents:
diff changeset
1911 if Checks then
kono
parents:
diff changeset
1912 -- As a precondition on the generic actual Index_Type, the base type
kono
parents:
diff changeset
1913 -- must include Index_Type'Pred (Index_Type'First); this is the value
kono
parents:
diff changeset
1914 -- that Container.Last assumes when the vector is empty. However, we
kono
parents:
diff changeset
1915 -- do not allow that as the value for Index when specifying where the
kono
parents:
diff changeset
1916 -- new items should be inserted, so we must manually check. (That the
kono
parents:
diff changeset
1917 -- user is allowed to specify the value at all here is a consequence
kono
parents:
diff changeset
1918 -- of the declaration of the Extended_Index subtype, which includes
kono
parents:
diff changeset
1919 -- the values in the base range that immediately precede and
kono
parents:
diff changeset
1920 -- immediately follow the values in the Index_Type.)
kono
parents:
diff changeset
1921
kono
parents:
diff changeset
1922 if Before < Index_Type'First then
kono
parents:
diff changeset
1923 raise Constraint_Error with
kono
parents:
diff changeset
1924 "Before index is out of range (too small)";
kono
parents:
diff changeset
1925 end if;
kono
parents:
diff changeset
1926
kono
parents:
diff changeset
1927 -- We do allow a value greater than Container.Last to be specified as
kono
parents:
diff changeset
1928 -- the Index, but only if it's immediately greater. This allows for
kono
parents:
diff changeset
1929 -- the case of appending items to the back end of the vector. (It is
kono
parents:
diff changeset
1930 -- assumed that specifying an index value greater than Last + 1
kono
parents:
diff changeset
1931 -- indicates some deeper flaw in the caller's algorithm, so that case
kono
parents:
diff changeset
1932 -- is treated as a proper error.)
kono
parents:
diff changeset
1933
kono
parents:
diff changeset
1934 if Before > Container.Last + 1 then
kono
parents:
diff changeset
1935 raise Constraint_Error with
kono
parents:
diff changeset
1936 "Before index is out of range (too large)";
kono
parents:
diff changeset
1937 end if;
kono
parents:
diff changeset
1938 end if;
kono
parents:
diff changeset
1939
kono
parents:
diff changeset
1940 -- We treat inserting 0 items into the container as a no-op, even when
kono
parents:
diff changeset
1941 -- the container is busy, so we simply return.
kono
parents:
diff changeset
1942
kono
parents:
diff changeset
1943 if Count = 0 then
kono
parents:
diff changeset
1944 return;
kono
parents:
diff changeset
1945 end if;
kono
parents:
diff changeset
1946
kono
parents:
diff changeset
1947 -- There are two constraints we need to satisfy. The first constraint is
kono
parents:
diff changeset
1948 -- that a container cannot have more than Count_Type'Last elements, so
kono
parents:
diff changeset
1949 -- we must check the sum of the current length and the insertion count.
kono
parents:
diff changeset
1950 -- Note: we cannot simply add these values, because of the possibility
kono
parents:
diff changeset
1951 -- of overflow.
kono
parents:
diff changeset
1952
kono
parents:
diff changeset
1953 if Checks and then Old_Length > Count_Type'Last - Count then
kono
parents:
diff changeset
1954 raise Constraint_Error with "Count is out of range";
kono
parents:
diff changeset
1955 end if;
kono
parents:
diff changeset
1956
kono
parents:
diff changeset
1957 -- It is now safe compute the length of the new vector, without fear of
kono
parents:
diff changeset
1958 -- overflow.
kono
parents:
diff changeset
1959
kono
parents:
diff changeset
1960 New_Length := Old_Length + Count;
kono
parents:
diff changeset
1961
kono
parents:
diff changeset
1962 -- The second constraint is that the new Last index value cannot exceed
kono
parents:
diff changeset
1963 -- Index_Type'Last. In each branch below, we calculate the maximum
kono
parents:
diff changeset
1964 -- length (computed from the range of values in Index_Type), and then
kono
parents:
diff changeset
1965 -- compare the new length to the maximum length. If the new length is
kono
parents:
diff changeset
1966 -- acceptable, then we compute the new last index from that.
kono
parents:
diff changeset
1967
kono
parents:
diff changeset
1968 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
1969 -- We have to handle the case when there might be more values in the
kono
parents:
diff changeset
1970 -- range of Index_Type than in the range of Count_Type.
kono
parents:
diff changeset
1971
kono
parents:
diff changeset
1972 if Index_Type'First <= 0 then
kono
parents:
diff changeset
1973
kono
parents:
diff changeset
1974 -- We know that No_Index (the same as Index_Type'First - 1) is
kono
parents:
diff changeset
1975 -- less than 0, so it is safe to compute the following sum without
kono
parents:
diff changeset
1976 -- fear of overflow.
kono
parents:
diff changeset
1977
kono
parents:
diff changeset
1978 Index := No_Index + Index_Type'Base (Count_Type'Last);
kono
parents:
diff changeset
1979
kono
parents:
diff changeset
1980 if Index <= Index_Type'Last then
kono
parents:
diff changeset
1981
kono
parents:
diff changeset
1982 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
1983 -- many values as in Count_Type, so Count_Type'Last is the
kono
parents:
diff changeset
1984 -- maximum number of items that are allowed.
kono
parents:
diff changeset
1985
kono
parents:
diff changeset
1986 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
1987
kono
parents:
diff changeset
1988 else
kono
parents:
diff changeset
1989 -- The range of Index_Type has fewer values than in Count_Type,
kono
parents:
diff changeset
1990 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
1991 -- the Index_Type.
kono
parents:
diff changeset
1992
kono
parents:
diff changeset
1993 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
kono
parents:
diff changeset
1994 end if;
kono
parents:
diff changeset
1995
kono
parents:
diff changeset
1996 else
kono
parents:
diff changeset
1997 -- No_Index is equal or greater than 0, so we can safely compute
kono
parents:
diff changeset
1998 -- the difference without fear of overflow (which we would have to
kono
parents:
diff changeset
1999 -- worry about if No_Index were less than 0, but that case is
kono
parents:
diff changeset
2000 -- handled above).
kono
parents:
diff changeset
2001
kono
parents:
diff changeset
2002 if Index_Type'Last - No_Index >= Count_Type_Last then
kono
parents:
diff changeset
2003 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
2004 -- many values as in Count_Type, so Count_Type'Last is the
kono
parents:
diff changeset
2005 -- maximum number of items that are allowed.
kono
parents:
diff changeset
2006
kono
parents:
diff changeset
2007 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
2008
kono
parents:
diff changeset
2009 else
kono
parents:
diff changeset
2010 -- The range of Index_Type has fewer values than in Count_Type,
kono
parents:
diff changeset
2011 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
2012 -- the Index_Type.
kono
parents:
diff changeset
2013
kono
parents:
diff changeset
2014 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
kono
parents:
diff changeset
2015 end if;
kono
parents:
diff changeset
2016 end if;
kono
parents:
diff changeset
2017
kono
parents:
diff changeset
2018 elsif Index_Type'First <= 0 then
kono
parents:
diff changeset
2019
kono
parents:
diff changeset
2020 -- We know that No_Index (the same as Index_Type'First - 1) is less
kono
parents:
diff changeset
2021 -- than 0, so it is safe to compute the following sum without fear of
kono
parents:
diff changeset
2022 -- overflow.
kono
parents:
diff changeset
2023
kono
parents:
diff changeset
2024 J := Count_Type'Base (No_Index) + Count_Type'Last;
kono
parents:
diff changeset
2025
kono
parents:
diff changeset
2026 if J <= Count_Type'Base (Index_Type'Last) then
kono
parents:
diff changeset
2027
kono
parents:
diff changeset
2028 -- We have determined that range of Index_Type has at least as
kono
parents:
diff changeset
2029 -- many values as in Count_Type, so Count_Type'Last is the maximum
kono
parents:
diff changeset
2030 -- number of items that are allowed.
kono
parents:
diff changeset
2031
kono
parents:
diff changeset
2032 Max_Length := Count_Type'Last;
kono
parents:
diff changeset
2033
kono
parents:
diff changeset
2034 else
kono
parents:
diff changeset
2035 -- The range of Index_Type has fewer values than Count_Type does,
kono
parents:
diff changeset
2036 -- so the maximum number of items is computed from the range of
kono
parents:
diff changeset
2037 -- the Index_Type.
kono
parents:
diff changeset
2038
kono
parents:
diff changeset
2039 Max_Length :=
kono
parents:
diff changeset
2040 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
kono
parents:
diff changeset
2041 end if;
kono
parents:
diff changeset
2042
kono
parents:
diff changeset
2043 else
kono
parents:
diff changeset
2044 -- No_Index is equal or greater than 0, so we can safely compute the
kono
parents:
diff changeset
2045 -- difference without fear of overflow (which we would have to worry
kono
parents:
diff changeset
2046 -- about if No_Index were less than 0, but that case is handled
kono
parents:
diff changeset
2047 -- above).
kono
parents:
diff changeset
2048
kono
parents:
diff changeset
2049 Max_Length :=
kono
parents:
diff changeset
2050 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
kono
parents:
diff changeset
2051 end if;
kono
parents:
diff changeset
2052
kono
parents:
diff changeset
2053 -- We have just computed the maximum length (number of items). We must
kono
parents:
diff changeset
2054 -- now compare the requested length to the maximum length, as we do not
kono
parents:
diff changeset
2055 -- allow a vector expand beyond the maximum (because that would create
kono
parents:
diff changeset
2056 -- an internal array with a last index value greater than
kono
parents:
diff changeset
2057 -- Index_Type'Last, with no way to index those elements).
kono
parents:
diff changeset
2058
kono
parents:
diff changeset
2059 if Checks and then New_Length > Max_Length then
kono
parents:
diff changeset
2060 raise Constraint_Error with "Count is out of range";
kono
parents:
diff changeset
2061 end if;
kono
parents:
diff changeset
2062
kono
parents:
diff changeset
2063 -- New_Last is the last index value of the items in the container after
kono
parents:
diff changeset
2064 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
kono
parents:
diff changeset
2065 -- compute its value from the New_Length.
kono
parents:
diff changeset
2066
kono
parents:
diff changeset
2067 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
2068 New_Last := No_Index + Index_Type'Base (New_Length);
kono
parents:
diff changeset
2069 else
kono
parents:
diff changeset
2070 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
kono
parents:
diff changeset
2071 end if;
kono
parents:
diff changeset
2072
kono
parents:
diff changeset
2073 if Container.Elements = null then
kono
parents:
diff changeset
2074 pragma Assert (Container.Last = No_Index);
kono
parents:
diff changeset
2075
kono
parents:
diff changeset
2076 -- This is the simplest case, with which we must always begin: we're
kono
parents:
diff changeset
2077 -- inserting items into an empty vector that hasn't allocated an
kono
parents:
diff changeset
2078 -- internal array yet. Note that we don't need to check the busy bit
kono
parents:
diff changeset
2079 -- here, because an empty container cannot be busy.
kono
parents:
diff changeset
2080
kono
parents:
diff changeset
2081 -- In an indefinite vector, elements are allocated individually, and
kono
parents:
diff changeset
2082 -- stored as access values on the internal array (the length of which
kono
parents:
diff changeset
2083 -- represents the vector "capacity"), which is separately allocated.
kono
parents:
diff changeset
2084 -- We have no elements here (because we're inserting "space"), so all
kono
parents:
diff changeset
2085 -- we need to do is allocate the backbone.
kono
parents:
diff changeset
2086
kono
parents:
diff changeset
2087 Container.Elements := new Elements_Type (New_Last);
kono
parents:
diff changeset
2088 Container.Last := New_Last;
kono
parents:
diff changeset
2089
kono
parents:
diff changeset
2090 return;
kono
parents:
diff changeset
2091 end if;
kono
parents:
diff changeset
2092
kono
parents:
diff changeset
2093 -- The tampering bits exist to prevent an item from being harmfully
kono
parents:
diff changeset
2094 -- manipulated while it is being visited. Query, Update, and Iterate
kono
parents:
diff changeset
2095 -- increment the busy count on entry, and decrement the count on exit.
kono
parents:
diff changeset
2096 -- Insert checks the count to determine whether it is being called while
kono
parents:
diff changeset
2097 -- the associated callback procedure is executing.
kono
parents:
diff changeset
2098
kono
parents:
diff changeset
2099 TC_Check (Container.TC);
kono
parents:
diff changeset
2100
kono
parents:
diff changeset
2101 if New_Length <= Container.Elements.EA'Length then
kono
parents:
diff changeset
2102
kono
parents:
diff changeset
2103 -- In this case, we are inserting elements into a vector that has
kono
parents:
diff changeset
2104 -- already allocated an internal array, and the existing array has
kono
parents:
diff changeset
2105 -- enough unused storage for the new items.
kono
parents:
diff changeset
2106
kono
parents:
diff changeset
2107 declare
kono
parents:
diff changeset
2108 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
2109
kono
parents:
diff changeset
2110 begin
kono
parents:
diff changeset
2111 if Before <= Container.Last then
kono
parents:
diff changeset
2112
kono
parents:
diff changeset
2113 -- The new space is being inserted before some existing
kono
parents:
diff changeset
2114 -- elements, so we must slide the existing elements up to
kono
parents:
diff changeset
2115 -- their new home. We use the wider of Index_Type'Base and
kono
parents:
diff changeset
2116 -- Count_Type'Base as the type for intermediate index values.
kono
parents:
diff changeset
2117
kono
parents:
diff changeset
2118 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
2119 Index := Before + Index_Type'Base (Count);
kono
parents:
diff changeset
2120 else
kono
parents:
diff changeset
2121 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
kono
parents:
diff changeset
2122 end if;
kono
parents:
diff changeset
2123
kono
parents:
diff changeset
2124 E (Index .. New_Last) := E (Before .. Container.Last);
kono
parents:
diff changeset
2125 E (Before .. Index - 1) := (others => null);
kono
parents:
diff changeset
2126 end if;
kono
parents:
diff changeset
2127 end;
kono
parents:
diff changeset
2128
kono
parents:
diff changeset
2129 Container.Last := New_Last;
kono
parents:
diff changeset
2130 return;
kono
parents:
diff changeset
2131 end if;
kono
parents:
diff changeset
2132
kono
parents:
diff changeset
2133 -- In this case, we're inserting elements into a vector that has already
kono
parents:
diff changeset
2134 -- allocated an internal array, but the existing array does not have
kono
parents:
diff changeset
2135 -- enough storage, so we must allocate a new, longer array. In order to
kono
parents:
diff changeset
2136 -- guarantee that the amortized insertion cost is O(1), we always
kono
parents:
diff changeset
2137 -- allocate an array whose length is some power-of-two factor of the
kono
parents:
diff changeset
2138 -- current array length. (The new array cannot have a length less than
kono
parents:
diff changeset
2139 -- the New_Length of the container, but its last index value cannot be
kono
parents:
diff changeset
2140 -- greater than Index_Type'Last.)
kono
parents:
diff changeset
2141
kono
parents:
diff changeset
2142 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
kono
parents:
diff changeset
2143 while New_Capacity < New_Length loop
kono
parents:
diff changeset
2144 if New_Capacity > Count_Type'Last / 2 then
kono
parents:
diff changeset
2145 New_Capacity := Count_Type'Last;
kono
parents:
diff changeset
2146 exit;
kono
parents:
diff changeset
2147 end if;
kono
parents:
diff changeset
2148
kono
parents:
diff changeset
2149 New_Capacity := 2 * New_Capacity;
kono
parents:
diff changeset
2150 end loop;
kono
parents:
diff changeset
2151
kono
parents:
diff changeset
2152 if New_Capacity > Max_Length then
kono
parents:
diff changeset
2153
kono
parents:
diff changeset
2154 -- We have reached the limit of capacity, so no further expansion
kono
parents:
diff changeset
2155 -- will occur. (This is not a problem, as there is never a need to
kono
parents:
diff changeset
2156 -- have more capacity than the maximum container length.)
kono
parents:
diff changeset
2157
kono
parents:
diff changeset
2158 New_Capacity := Max_Length;
kono
parents:
diff changeset
2159 end if;
kono
parents:
diff changeset
2160
kono
parents:
diff changeset
2161 -- We have computed the length of the new internal array (and this is
kono
parents:
diff changeset
2162 -- what "vector capacity" means), so use that to compute its last index.
kono
parents:
diff changeset
2163
kono
parents:
diff changeset
2164 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
2165 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
kono
parents:
diff changeset
2166 else
kono
parents:
diff changeset
2167 Dst_Last :=
kono
parents:
diff changeset
2168 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
kono
parents:
diff changeset
2169 end if;
kono
parents:
diff changeset
2170
kono
parents:
diff changeset
2171 -- Now we allocate the new, longer internal array. If the allocation
kono
parents:
diff changeset
2172 -- fails, we have not changed any container state, so no side-effect
kono
parents:
diff changeset
2173 -- will occur as a result of propagating the exception.
kono
parents:
diff changeset
2174
kono
parents:
diff changeset
2175 Dst := new Elements_Type (Dst_Last);
kono
parents:
diff changeset
2176
kono
parents:
diff changeset
2177 -- We have our new internal array. All that needs to be done now is to
kono
parents:
diff changeset
2178 -- copy the existing items (if any) from the old array (the "source"
kono
parents:
diff changeset
2179 -- array) to the new array (the "destination" array), and then
kono
parents:
diff changeset
2180 -- deallocate the old array.
kono
parents:
diff changeset
2181
kono
parents:
diff changeset
2182 declare
kono
parents:
diff changeset
2183 Src : Elements_Access := Container.Elements;
kono
parents:
diff changeset
2184
kono
parents:
diff changeset
2185 begin
kono
parents:
diff changeset
2186 Dst.EA (Index_Type'First .. Before - 1) :=
kono
parents:
diff changeset
2187 Src.EA (Index_Type'First .. Before - 1);
kono
parents:
diff changeset
2188
kono
parents:
diff changeset
2189 if Before <= Container.Last then
kono
parents:
diff changeset
2190
kono
parents:
diff changeset
2191 -- The new items are being inserted before some existing elements,
kono
parents:
diff changeset
2192 -- so we must slide the existing elements up to their new home.
kono
parents:
diff changeset
2193
kono
parents:
diff changeset
2194 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
2195 Index := Before + Index_Type'Base (Count);
kono
parents:
diff changeset
2196 else
kono
parents:
diff changeset
2197 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
kono
parents:
diff changeset
2198 end if;
kono
parents:
diff changeset
2199
kono
parents:
diff changeset
2200 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
kono
parents:
diff changeset
2201 end if;
kono
parents:
diff changeset
2202
kono
parents:
diff changeset
2203 -- We have copied the elements from to the old, source array to the
kono
parents:
diff changeset
2204 -- new, destination array, so we can now restore invariants, and
kono
parents:
diff changeset
2205 -- deallocate the old array.
kono
parents:
diff changeset
2206
kono
parents:
diff changeset
2207 Container.Elements := Dst;
kono
parents:
diff changeset
2208 Container.Last := New_Last;
kono
parents:
diff changeset
2209 Free (Src);
kono
parents:
diff changeset
2210 end;
kono
parents:
diff changeset
2211 end Insert_Space;
kono
parents:
diff changeset
2212
kono
parents:
diff changeset
2213 procedure Insert_Space
kono
parents:
diff changeset
2214 (Container : in out Vector;
kono
parents:
diff changeset
2215 Before : Cursor;
kono
parents:
diff changeset
2216 Position : out Cursor;
kono
parents:
diff changeset
2217 Count : Count_Type := 1)
kono
parents:
diff changeset
2218 is
kono
parents:
diff changeset
2219 Index : Index_Type'Base;
kono
parents:
diff changeset
2220
kono
parents:
diff changeset
2221 begin
kono
parents:
diff changeset
2222 if Checks and then Before.Container /= null
kono
parents:
diff changeset
2223 and then Before.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
2224 then
kono
parents:
diff changeset
2225 raise Program_Error with "Before cursor denotes wrong container";
kono
parents:
diff changeset
2226 end if;
kono
parents:
diff changeset
2227
kono
parents:
diff changeset
2228 if Count = 0 then
kono
parents:
diff changeset
2229 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
2230 Position := No_Element;
kono
parents:
diff changeset
2231 else
kono
parents:
diff changeset
2232 Position := (Container'Unrestricted_Access, Before.Index);
kono
parents:
diff changeset
2233 end if;
kono
parents:
diff changeset
2234
kono
parents:
diff changeset
2235 return;
kono
parents:
diff changeset
2236 end if;
kono
parents:
diff changeset
2237
kono
parents:
diff changeset
2238 if Before.Container = null or else Before.Index > Container.Last then
kono
parents:
diff changeset
2239 if Checks and then Container.Last = Index_Type'Last then
kono
parents:
diff changeset
2240 raise Constraint_Error with
kono
parents:
diff changeset
2241 "vector is already at its maximum length";
kono
parents:
diff changeset
2242 end if;
kono
parents:
diff changeset
2243
kono
parents:
diff changeset
2244 Index := Container.Last + 1;
kono
parents:
diff changeset
2245
kono
parents:
diff changeset
2246 else
kono
parents:
diff changeset
2247 Index := Before.Index;
kono
parents:
diff changeset
2248 end if;
kono
parents:
diff changeset
2249
kono
parents:
diff changeset
2250 Insert_Space (Container, Index, Count);
kono
parents:
diff changeset
2251
kono
parents:
diff changeset
2252 Position := (Container'Unrestricted_Access, Index);
kono
parents:
diff changeset
2253 end Insert_Space;
kono
parents:
diff changeset
2254
kono
parents:
diff changeset
2255 --------------
kono
parents:
diff changeset
2256 -- Is_Empty --
kono
parents:
diff changeset
2257 --------------
kono
parents:
diff changeset
2258
kono
parents:
diff changeset
2259 function Is_Empty (Container : Vector) return Boolean is
kono
parents:
diff changeset
2260 begin
kono
parents:
diff changeset
2261 return Container.Last < Index_Type'First;
kono
parents:
diff changeset
2262 end Is_Empty;
kono
parents:
diff changeset
2263
kono
parents:
diff changeset
2264 -------------
kono
parents:
diff changeset
2265 -- Iterate --
kono
parents:
diff changeset
2266 -------------
kono
parents:
diff changeset
2267
kono
parents:
diff changeset
2268 procedure Iterate
kono
parents:
diff changeset
2269 (Container : Vector;
kono
parents:
diff changeset
2270 Process : not null access procedure (Position : Cursor))
kono
parents:
diff changeset
2271 is
kono
parents:
diff changeset
2272 Busy : With_Busy (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
2273 begin
kono
parents:
diff changeset
2274 for Indx in Index_Type'First .. Container.Last loop
kono
parents:
diff changeset
2275 Process (Cursor'(Container'Unrestricted_Access, Indx));
kono
parents:
diff changeset
2276 end loop;
kono
parents:
diff changeset
2277 end Iterate;
kono
parents:
diff changeset
2278
kono
parents:
diff changeset
2279 function Iterate
kono
parents:
diff changeset
2280 (Container : Vector)
kono
parents:
diff changeset
2281 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
kono
parents:
diff changeset
2282 is
kono
parents:
diff changeset
2283 V : constant Vector_Access := Container'Unrestricted_Access;
kono
parents:
diff changeset
2284 begin
kono
parents:
diff changeset
2285 -- The value of its Index component influences the behavior of the First
kono
parents:
diff changeset
2286 -- and Last selector functions of the iterator object. When the Index
kono
parents:
diff changeset
2287 -- component is No_Index (as is the case here), this means the iterator
kono
parents:
diff changeset
2288 -- object was constructed without a start expression. This is a complete
kono
parents:
diff changeset
2289 -- iterator, meaning that the iteration starts from the (logical)
kono
parents:
diff changeset
2290 -- beginning of the sequence of items.
kono
parents:
diff changeset
2291
kono
parents:
diff changeset
2292 -- Note: For a forward iterator, Container.First is the beginning, and
kono
parents:
diff changeset
2293 -- for a reverse iterator, Container.Last is the beginning.
kono
parents:
diff changeset
2294
kono
parents:
diff changeset
2295 return It : constant Iterator :=
kono
parents:
diff changeset
2296 (Limited_Controlled with
kono
parents:
diff changeset
2297 Container => V,
kono
parents:
diff changeset
2298 Index => No_Index)
kono
parents:
diff changeset
2299 do
kono
parents:
diff changeset
2300 Busy (Container.TC'Unrestricted_Access.all);
kono
parents:
diff changeset
2301 end return;
kono
parents:
diff changeset
2302 end Iterate;
kono
parents:
diff changeset
2303
kono
parents:
diff changeset
2304 function Iterate
kono
parents:
diff changeset
2305 (Container : Vector;
kono
parents:
diff changeset
2306 Start : Cursor)
kono
parents:
diff changeset
2307 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
kono
parents:
diff changeset
2308 is
kono
parents:
diff changeset
2309 V : constant Vector_Access := Container'Unrestricted_Access;
kono
parents:
diff changeset
2310 begin
kono
parents:
diff changeset
2311 -- It was formerly the case that when Start = No_Element, the partial
kono
parents:
diff changeset
2312 -- iterator was defined to behave the same as for a complete iterator,
kono
parents:
diff changeset
2313 -- and iterate over the entire sequence of items. However, those
kono
parents:
diff changeset
2314 -- semantics were unintuitive and arguably error-prone (it is too easy
kono
parents:
diff changeset
2315 -- to accidentally create an endless loop), and so they were changed,
kono
parents:
diff changeset
2316 -- per the ARG meeting in Denver on 2011/11. However, there was no
kono
parents:
diff changeset
2317 -- consensus about what positive meaning this corner case should have,
kono
parents:
diff changeset
2318 -- and so it was decided to simply raise an exception. This does imply,
kono
parents:
diff changeset
2319 -- however, that it is not possible to use a partial iterator to specify
kono
parents:
diff changeset
2320 -- an empty sequence of items.
kono
parents:
diff changeset
2321
kono
parents:
diff changeset
2322 if Checks then
kono
parents:
diff changeset
2323 if Start.Container = null then
kono
parents:
diff changeset
2324 raise Constraint_Error with
kono
parents:
diff changeset
2325 "Start position for iterator equals No_Element";
kono
parents:
diff changeset
2326 end if;
kono
parents:
diff changeset
2327
kono
parents:
diff changeset
2328 if Start.Container /= V then
kono
parents:
diff changeset
2329 raise Program_Error with
kono
parents:
diff changeset
2330 "Start cursor of Iterate designates wrong vector";
kono
parents:
diff changeset
2331 end if;
kono
parents:
diff changeset
2332
kono
parents:
diff changeset
2333 if Start.Index > V.Last then
kono
parents:
diff changeset
2334 raise Constraint_Error with
kono
parents:
diff changeset
2335 "Start position for iterator equals No_Element";
kono
parents:
diff changeset
2336 end if;
kono
parents:
diff changeset
2337 end if;
kono
parents:
diff changeset
2338
kono
parents:
diff changeset
2339 -- The value of its Index component influences the behavior of the First
kono
parents:
diff changeset
2340 -- and Last selector functions of the iterator object. When the Index
kono
parents:
diff changeset
2341 -- component is not No_Index (as is the case here), it means that this
kono
parents:
diff changeset
2342 -- is a partial iteration, over a subset of the complete sequence of
kono
parents:
diff changeset
2343 -- items. The iterator object was constructed with a start expression,
kono
parents:
diff changeset
2344 -- indicating the position from which the iteration begins. Note that
kono
parents:
diff changeset
2345 -- the start position has the same value irrespective of whether this
kono
parents:
diff changeset
2346 -- is a forward or reverse iteration.
kono
parents:
diff changeset
2347
kono
parents:
diff changeset
2348 return It : constant Iterator :=
kono
parents:
diff changeset
2349 (Limited_Controlled with
kono
parents:
diff changeset
2350 Container => V,
kono
parents:
diff changeset
2351 Index => Start.Index)
kono
parents:
diff changeset
2352 do
kono
parents:
diff changeset
2353 Busy (Container.TC'Unrestricted_Access.all);
kono
parents:
diff changeset
2354 end return;
kono
parents:
diff changeset
2355 end Iterate;
kono
parents:
diff changeset
2356
kono
parents:
diff changeset
2357 ----------
kono
parents:
diff changeset
2358 -- Last --
kono
parents:
diff changeset
2359 ----------
kono
parents:
diff changeset
2360
kono
parents:
diff changeset
2361 function Last (Container : Vector) return Cursor is
kono
parents:
diff changeset
2362 begin
kono
parents:
diff changeset
2363 if Is_Empty (Container) then
kono
parents:
diff changeset
2364 return No_Element;
kono
parents:
diff changeset
2365 end if;
kono
parents:
diff changeset
2366
kono
parents:
diff changeset
2367 return (Container'Unrestricted_Access, Container.Last);
kono
parents:
diff changeset
2368 end Last;
kono
parents:
diff changeset
2369
kono
parents:
diff changeset
2370 function Last (Object : Iterator) return Cursor is
kono
parents:
diff changeset
2371 begin
kono
parents:
diff changeset
2372 -- The value of the iterator object's Index component influences the
kono
parents:
diff changeset
2373 -- behavior of the Last (and First) selector function.
kono
parents:
diff changeset
2374
kono
parents:
diff changeset
2375 -- When the Index component is No_Index, this means the iterator
kono
parents:
diff changeset
2376 -- object was constructed without a start expression, in which case the
kono
parents:
diff changeset
2377 -- (reverse) iteration starts from the (logical) beginning of the entire
kono
parents:
diff changeset
2378 -- sequence (corresponding to Container.Last, for a reverse iterator).
kono
parents:
diff changeset
2379
kono
parents:
diff changeset
2380 -- Otherwise, this is iteration over a partial sequence of items.
kono
parents:
diff changeset
2381 -- When the Index component is not No_Index, the iterator object was
kono
parents:
diff changeset
2382 -- constructed with a start expression, that specifies the position
kono
parents:
diff changeset
2383 -- from which the (reverse) partial iteration begins.
kono
parents:
diff changeset
2384
kono
parents:
diff changeset
2385 if Object.Index = No_Index then
kono
parents:
diff changeset
2386 return Last (Object.Container.all);
kono
parents:
diff changeset
2387 else
kono
parents:
diff changeset
2388 return Cursor'(Object.Container, Object.Index);
kono
parents:
diff changeset
2389 end if;
kono
parents:
diff changeset
2390 end Last;
kono
parents:
diff changeset
2391
kono
parents:
diff changeset
2392 ------------------
kono
parents:
diff changeset
2393 -- Last_Element --
kono
parents:
diff changeset
2394 ------------------
kono
parents:
diff changeset
2395
kono
parents:
diff changeset
2396 function Last_Element (Container : Vector) return Element_Type is
kono
parents:
diff changeset
2397 begin
kono
parents:
diff changeset
2398 if Checks and then Container.Last = No_Index then
kono
parents:
diff changeset
2399 raise Constraint_Error with "Container is empty";
kono
parents:
diff changeset
2400 end if;
kono
parents:
diff changeset
2401
kono
parents:
diff changeset
2402 declare
kono
parents:
diff changeset
2403 EA : constant Element_Access :=
kono
parents:
diff changeset
2404 Container.Elements.EA (Container.Last);
kono
parents:
diff changeset
2405 begin
kono
parents:
diff changeset
2406 if Checks and then EA = null then
kono
parents:
diff changeset
2407 raise Constraint_Error with "last element is empty";
kono
parents:
diff changeset
2408 else
kono
parents:
diff changeset
2409 return EA.all;
kono
parents:
diff changeset
2410 end if;
kono
parents:
diff changeset
2411 end;
kono
parents:
diff changeset
2412 end Last_Element;
kono
parents:
diff changeset
2413
kono
parents:
diff changeset
2414 ----------------
kono
parents:
diff changeset
2415 -- Last_Index --
kono
parents:
diff changeset
2416 ----------------
kono
parents:
diff changeset
2417
kono
parents:
diff changeset
2418 function Last_Index (Container : Vector) return Extended_Index is
kono
parents:
diff changeset
2419 begin
kono
parents:
diff changeset
2420 return Container.Last;
kono
parents:
diff changeset
2421 end Last_Index;
kono
parents:
diff changeset
2422
kono
parents:
diff changeset
2423 ------------
kono
parents:
diff changeset
2424 -- Length --
kono
parents:
diff changeset
2425 ------------
kono
parents:
diff changeset
2426
kono
parents:
diff changeset
2427 function Length (Container : Vector) return Count_Type is
kono
parents:
diff changeset
2428 L : constant Index_Type'Base := Container.Last;
kono
parents:
diff changeset
2429 F : constant Index_Type := Index_Type'First;
kono
parents:
diff changeset
2430
kono
parents:
diff changeset
2431 begin
kono
parents:
diff changeset
2432 -- The base range of the index type (Index_Type'Base) might not include
kono
parents:
diff changeset
2433 -- all values for length (Count_Type). Contrariwise, the index type
kono
parents:
diff changeset
2434 -- might include values outside the range of length. Hence we use
kono
parents:
diff changeset
2435 -- whatever type is wider for intermediate values when calculating
kono
parents:
diff changeset
2436 -- length. Note that no matter what the index type is, the maximum
kono
parents:
diff changeset
2437 -- length to which a vector is allowed to grow is always the minimum
kono
parents:
diff changeset
2438 -- of Count_Type'Last and (IT'Last - IT'First + 1).
kono
parents:
diff changeset
2439
kono
parents:
diff changeset
2440 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
kono
parents:
diff changeset
2441 -- to have a base range of -128 .. 127, but the corresponding vector
kono
parents:
diff changeset
2442 -- would have lengths in the range 0 .. 255. In this case we would need
kono
parents:
diff changeset
2443 -- to use Count_Type'Base for intermediate values.
kono
parents:
diff changeset
2444
kono
parents:
diff changeset
2445 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
kono
parents:
diff changeset
2446 -- vector would have a maximum length of 10, but the index values lie
kono
parents:
diff changeset
2447 -- outside the range of Count_Type (which is only 32 bits). In this
kono
parents:
diff changeset
2448 -- case we would need to use Index_Type'Base for intermediate values.
kono
parents:
diff changeset
2449
kono
parents:
diff changeset
2450 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
kono
parents:
diff changeset
2451 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
kono
parents:
diff changeset
2452 else
kono
parents:
diff changeset
2453 return Count_Type (L - F + 1);
kono
parents:
diff changeset
2454 end if;
kono
parents:
diff changeset
2455 end Length;
kono
parents:
diff changeset
2456
kono
parents:
diff changeset
2457 ----------
kono
parents:
diff changeset
2458 -- Move --
kono
parents:
diff changeset
2459 ----------
kono
parents:
diff changeset
2460
kono
parents:
diff changeset
2461 procedure Move
kono
parents:
diff changeset
2462 (Target : in out Vector;
kono
parents:
diff changeset
2463 Source : in out Vector)
kono
parents:
diff changeset
2464 is
kono
parents:
diff changeset
2465 begin
kono
parents:
diff changeset
2466 if Target'Address = Source'Address then
kono
parents:
diff changeset
2467 return;
kono
parents:
diff changeset
2468 end if;
kono
parents:
diff changeset
2469
kono
parents:
diff changeset
2470 TC_Check (Source.TC);
kono
parents:
diff changeset
2471
kono
parents:
diff changeset
2472 Clear (Target); -- Checks busy-bit
kono
parents:
diff changeset
2473
kono
parents:
diff changeset
2474 declare
kono
parents:
diff changeset
2475 Target_Elements : constant Elements_Access := Target.Elements;
kono
parents:
diff changeset
2476 begin
kono
parents:
diff changeset
2477 Target.Elements := Source.Elements;
kono
parents:
diff changeset
2478 Source.Elements := Target_Elements;
kono
parents:
diff changeset
2479 end;
kono
parents:
diff changeset
2480
kono
parents:
diff changeset
2481 Target.Last := Source.Last;
kono
parents:
diff changeset
2482 Source.Last := No_Index;
kono
parents:
diff changeset
2483 end Move;
kono
parents:
diff changeset
2484
kono
parents:
diff changeset
2485 ----------
kono
parents:
diff changeset
2486 -- Next --
kono
parents:
diff changeset
2487 ----------
kono
parents:
diff changeset
2488
kono
parents:
diff changeset
2489 function Next (Position : Cursor) return Cursor is
kono
parents:
diff changeset
2490 begin
kono
parents:
diff changeset
2491 if Position.Container = null then
kono
parents:
diff changeset
2492 return No_Element;
kono
parents:
diff changeset
2493 elsif Position.Index < Position.Container.Last then
kono
parents:
diff changeset
2494 return (Position.Container, Position.Index + 1);
kono
parents:
diff changeset
2495 else
kono
parents:
diff changeset
2496 return No_Element;
kono
parents:
diff changeset
2497 end if;
kono
parents:
diff changeset
2498 end Next;
kono
parents:
diff changeset
2499
kono
parents:
diff changeset
2500 function Next (Object : Iterator; Position : Cursor) return Cursor is
kono
parents:
diff changeset
2501 begin
kono
parents:
diff changeset
2502 if Position.Container = null then
kono
parents:
diff changeset
2503 return No_Element;
kono
parents:
diff changeset
2504 elsif Checks and then Position.Container /= Object.Container then
kono
parents:
diff changeset
2505 raise Program_Error with
kono
parents:
diff changeset
2506 "Position cursor of Next designates wrong vector";
kono
parents:
diff changeset
2507 else
kono
parents:
diff changeset
2508 return Next (Position);
kono
parents:
diff changeset
2509 end if;
kono
parents:
diff changeset
2510 end Next;
kono
parents:
diff changeset
2511
kono
parents:
diff changeset
2512 procedure Next (Position : in out Cursor) is
kono
parents:
diff changeset
2513 begin
kono
parents:
diff changeset
2514 if Position.Container = null then
kono
parents:
diff changeset
2515 return;
kono
parents:
diff changeset
2516 elsif Position.Index < Position.Container.Last then
kono
parents:
diff changeset
2517 Position.Index := Position.Index + 1;
kono
parents:
diff changeset
2518 else
kono
parents:
diff changeset
2519 Position := No_Element;
kono
parents:
diff changeset
2520 end if;
kono
parents:
diff changeset
2521 end Next;
kono
parents:
diff changeset
2522
kono
parents:
diff changeset
2523 -------------
kono
parents:
diff changeset
2524 -- Prepend --
kono
parents:
diff changeset
2525 -------------
kono
parents:
diff changeset
2526
kono
parents:
diff changeset
2527 procedure Prepend (Container : in out Vector; New_Item : Vector) is
kono
parents:
diff changeset
2528 begin
kono
parents:
diff changeset
2529 Insert (Container, Index_Type'First, New_Item);
kono
parents:
diff changeset
2530 end Prepend;
kono
parents:
diff changeset
2531
kono
parents:
diff changeset
2532 procedure Prepend
kono
parents:
diff changeset
2533 (Container : in out Vector;
kono
parents:
diff changeset
2534 New_Item : Element_Type;
kono
parents:
diff changeset
2535 Count : Count_Type := 1)
kono
parents:
diff changeset
2536 is
kono
parents:
diff changeset
2537 begin
kono
parents:
diff changeset
2538 Insert (Container, Index_Type'First, New_Item, Count);
kono
parents:
diff changeset
2539 end Prepend;
kono
parents:
diff changeset
2540
kono
parents:
diff changeset
2541 --------------
kono
parents:
diff changeset
2542 -- Previous --
kono
parents:
diff changeset
2543 --------------
kono
parents:
diff changeset
2544
kono
parents:
diff changeset
2545 function Previous (Position : Cursor) return Cursor is
kono
parents:
diff changeset
2546 begin
kono
parents:
diff changeset
2547 if Position.Container = null then
kono
parents:
diff changeset
2548 return No_Element;
kono
parents:
diff changeset
2549 elsif Position.Index > Index_Type'First then
kono
parents:
diff changeset
2550 return (Position.Container, Position.Index - 1);
kono
parents:
diff changeset
2551 else
kono
parents:
diff changeset
2552 return No_Element;
kono
parents:
diff changeset
2553 end if;
kono
parents:
diff changeset
2554 end Previous;
kono
parents:
diff changeset
2555
kono
parents:
diff changeset
2556 function Previous (Object : Iterator; Position : Cursor) return Cursor is
kono
parents:
diff changeset
2557 begin
kono
parents:
diff changeset
2558 if Position.Container = null then
kono
parents:
diff changeset
2559 return No_Element;
kono
parents:
diff changeset
2560 elsif Checks and then Position.Container /= Object.Container then
kono
parents:
diff changeset
2561 raise Program_Error with
kono
parents:
diff changeset
2562 "Position cursor of Previous designates wrong vector";
kono
parents:
diff changeset
2563 else
kono
parents:
diff changeset
2564 return Previous (Position);
kono
parents:
diff changeset
2565 end if;
kono
parents:
diff changeset
2566 end Previous;
kono
parents:
diff changeset
2567
kono
parents:
diff changeset
2568 procedure Previous (Position : in out Cursor) is
kono
parents:
diff changeset
2569 begin
kono
parents:
diff changeset
2570 if Position.Container = null then
kono
parents:
diff changeset
2571 return;
kono
parents:
diff changeset
2572 elsif Position.Index > Index_Type'First then
kono
parents:
diff changeset
2573 Position.Index := Position.Index - 1;
kono
parents:
diff changeset
2574 else
kono
parents:
diff changeset
2575 Position := No_Element;
kono
parents:
diff changeset
2576 end if;
kono
parents:
diff changeset
2577 end Previous;
kono
parents:
diff changeset
2578
kono
parents:
diff changeset
2579 ----------------------
kono
parents:
diff changeset
2580 -- Pseudo_Reference --
kono
parents:
diff changeset
2581 ----------------------
kono
parents:
diff changeset
2582
kono
parents:
diff changeset
2583 function Pseudo_Reference
kono
parents:
diff changeset
2584 (Container : aliased Vector'Class) return Reference_Control_Type
kono
parents:
diff changeset
2585 is
kono
parents:
diff changeset
2586 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
kono
parents:
diff changeset
2587 begin
kono
parents:
diff changeset
2588 return R : constant Reference_Control_Type := (Controlled with TC) do
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
2589 Busy (TC.all);
111
kono
parents:
diff changeset
2590 end return;
kono
parents:
diff changeset
2591 end Pseudo_Reference;
kono
parents:
diff changeset
2592
kono
parents:
diff changeset
2593 -------------------
kono
parents:
diff changeset
2594 -- Query_Element --
kono
parents:
diff changeset
2595 -------------------
kono
parents:
diff changeset
2596
kono
parents:
diff changeset
2597 procedure Query_Element
kono
parents:
diff changeset
2598 (Container : Vector;
kono
parents:
diff changeset
2599 Index : Index_Type;
kono
parents:
diff changeset
2600 Process : not null access procedure (Element : Element_Type))
kono
parents:
diff changeset
2601 is
kono
parents:
diff changeset
2602 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
2603 V : Vector renames Container'Unrestricted_Access.all;
kono
parents:
diff changeset
2604
kono
parents:
diff changeset
2605 begin
kono
parents:
diff changeset
2606 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
2607 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
2608 end if;
kono
parents:
diff changeset
2609
kono
parents:
diff changeset
2610 if Checks and then V.Elements.EA (Index) = null then
kono
parents:
diff changeset
2611 raise Constraint_Error with "element is null";
kono
parents:
diff changeset
2612 end if;
kono
parents:
diff changeset
2613
kono
parents:
diff changeset
2614 Process (V.Elements.EA (Index).all);
kono
parents:
diff changeset
2615 end Query_Element;
kono
parents:
diff changeset
2616
kono
parents:
diff changeset
2617 procedure Query_Element
kono
parents:
diff changeset
2618 (Position : Cursor;
kono
parents:
diff changeset
2619 Process : not null access procedure (Element : Element_Type))
kono
parents:
diff changeset
2620 is
kono
parents:
diff changeset
2621 begin
kono
parents:
diff changeset
2622 if Checks and then Position.Container = null then
kono
parents:
diff changeset
2623 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
2624 else
kono
parents:
diff changeset
2625 Query_Element (Position.Container.all, Position.Index, Process);
kono
parents:
diff changeset
2626 end if;
kono
parents:
diff changeset
2627 end Query_Element;
kono
parents:
diff changeset
2628
kono
parents:
diff changeset
2629 ----------
kono
parents:
diff changeset
2630 -- Read --
kono
parents:
diff changeset
2631 ----------
kono
parents:
diff changeset
2632
kono
parents:
diff changeset
2633 procedure Read
kono
parents:
diff changeset
2634 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
2635 Container : out Vector)
kono
parents:
diff changeset
2636 is
kono
parents:
diff changeset
2637 Length : Count_Type'Base;
kono
parents:
diff changeset
2638 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
kono
parents:
diff changeset
2639 B : Boolean;
kono
parents:
diff changeset
2640
kono
parents:
diff changeset
2641 begin
kono
parents:
diff changeset
2642 Clear (Container);
kono
parents:
diff changeset
2643
kono
parents:
diff changeset
2644 Count_Type'Base'Read (Stream, Length);
kono
parents:
diff changeset
2645
kono
parents:
diff changeset
2646 if Length > Capacity (Container) then
kono
parents:
diff changeset
2647 Reserve_Capacity (Container, Capacity => Length);
kono
parents:
diff changeset
2648 end if;
kono
parents:
diff changeset
2649
kono
parents:
diff changeset
2650 for J in Count_Type range 1 .. Length loop
kono
parents:
diff changeset
2651 Last := Last + 1;
kono
parents:
diff changeset
2652
kono
parents:
diff changeset
2653 Boolean'Read (Stream, B);
kono
parents:
diff changeset
2654
kono
parents:
diff changeset
2655 if B then
kono
parents:
diff changeset
2656 Container.Elements.EA (Last) :=
kono
parents:
diff changeset
2657 new Element_Type'(Element_Type'Input (Stream));
kono
parents:
diff changeset
2658 end if;
kono
parents:
diff changeset
2659
kono
parents:
diff changeset
2660 Container.Last := Last;
kono
parents:
diff changeset
2661 end loop;
kono
parents:
diff changeset
2662 end Read;
kono
parents:
diff changeset
2663
kono
parents:
diff changeset
2664 procedure Read
kono
parents:
diff changeset
2665 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
2666 Position : out Cursor)
kono
parents:
diff changeset
2667 is
kono
parents:
diff changeset
2668 begin
kono
parents:
diff changeset
2669 raise Program_Error with "attempt to stream vector cursor";
kono
parents:
diff changeset
2670 end Read;
kono
parents:
diff changeset
2671
kono
parents:
diff changeset
2672 procedure Read
kono
parents:
diff changeset
2673 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
2674 Item : out Reference_Type)
kono
parents:
diff changeset
2675 is
kono
parents:
diff changeset
2676 begin
kono
parents:
diff changeset
2677 raise Program_Error with "attempt to stream reference";
kono
parents:
diff changeset
2678 end Read;
kono
parents:
diff changeset
2679
kono
parents:
diff changeset
2680 procedure Read
kono
parents:
diff changeset
2681 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
2682 Item : out Constant_Reference_Type)
kono
parents:
diff changeset
2683 is
kono
parents:
diff changeset
2684 begin
kono
parents:
diff changeset
2685 raise Program_Error with "attempt to stream reference";
kono
parents:
diff changeset
2686 end Read;
kono
parents:
diff changeset
2687
kono
parents:
diff changeset
2688 ---------------
kono
parents:
diff changeset
2689 -- Reference --
kono
parents:
diff changeset
2690 ---------------
kono
parents:
diff changeset
2691
kono
parents:
diff changeset
2692 function Reference
kono
parents:
diff changeset
2693 (Container : aliased in out Vector;
kono
parents:
diff changeset
2694 Position : Cursor) return Reference_Type
kono
parents:
diff changeset
2695 is
kono
parents:
diff changeset
2696 begin
kono
parents:
diff changeset
2697 if Checks then
kono
parents:
diff changeset
2698 if Position.Container = null then
kono
parents:
diff changeset
2699 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
2700 end if;
kono
parents:
diff changeset
2701
kono
parents:
diff changeset
2702 if Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
2703 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
2704 end if;
kono
parents:
diff changeset
2705
kono
parents:
diff changeset
2706 if Position.Index > Position.Container.Last then
kono
parents:
diff changeset
2707 raise Constraint_Error with "Position cursor is out of range";
kono
parents:
diff changeset
2708 end if;
kono
parents:
diff changeset
2709 end if;
kono
parents:
diff changeset
2710
kono
parents:
diff changeset
2711 declare
kono
parents:
diff changeset
2712 TC : constant Tamper_Counts_Access :=
kono
parents:
diff changeset
2713 Container.TC'Unrestricted_Access;
kono
parents:
diff changeset
2714 begin
kono
parents:
diff changeset
2715 -- The following will raise Constraint_Error if Element is null
kono
parents:
diff changeset
2716
kono
parents:
diff changeset
2717 return R : constant Reference_Type :=
kono
parents:
diff changeset
2718 (Element => Container.Elements.EA (Position.Index),
kono
parents:
diff changeset
2719 Control => (Controlled with TC))
kono
parents:
diff changeset
2720 do
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
2721 Busy (TC.all);
111
kono
parents:
diff changeset
2722 end return;
kono
parents:
diff changeset
2723 end;
kono
parents:
diff changeset
2724 end Reference;
kono
parents:
diff changeset
2725
kono
parents:
diff changeset
2726 function Reference
kono
parents:
diff changeset
2727 (Container : aliased in out Vector;
kono
parents:
diff changeset
2728 Index : Index_Type) return Reference_Type
kono
parents:
diff changeset
2729 is
kono
parents:
diff changeset
2730 begin
kono
parents:
diff changeset
2731 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
2732 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
2733 end if;
kono
parents:
diff changeset
2734
kono
parents:
diff changeset
2735 declare
kono
parents:
diff changeset
2736 TC : constant Tamper_Counts_Access :=
kono
parents:
diff changeset
2737 Container.TC'Unrestricted_Access;
kono
parents:
diff changeset
2738 begin
kono
parents:
diff changeset
2739 -- The following will raise Constraint_Error if Element is null
kono
parents:
diff changeset
2740
kono
parents:
diff changeset
2741 return R : constant Reference_Type :=
kono
parents:
diff changeset
2742 (Element => Container.Elements.EA (Index),
kono
parents:
diff changeset
2743 Control => (Controlled with TC))
kono
parents:
diff changeset
2744 do
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
2745 Busy (TC.all);
111
kono
parents:
diff changeset
2746 end return;
kono
parents:
diff changeset
2747 end;
kono
parents:
diff changeset
2748 end Reference;
kono
parents:
diff changeset
2749
kono
parents:
diff changeset
2750 ---------------------
kono
parents:
diff changeset
2751 -- Replace_Element --
kono
parents:
diff changeset
2752 ---------------------
kono
parents:
diff changeset
2753
kono
parents:
diff changeset
2754 procedure Replace_Element
kono
parents:
diff changeset
2755 (Container : in out Vector;
kono
parents:
diff changeset
2756 Index : Index_Type;
kono
parents:
diff changeset
2757 New_Item : Element_Type)
kono
parents:
diff changeset
2758 is
kono
parents:
diff changeset
2759 begin
kono
parents:
diff changeset
2760 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
2761 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
2762 end if;
kono
parents:
diff changeset
2763
kono
parents:
diff changeset
2764 TE_Check (Container.TC);
kono
parents:
diff changeset
2765
kono
parents:
diff changeset
2766 declare
kono
parents:
diff changeset
2767 X : Element_Access := Container.Elements.EA (Index);
kono
parents:
diff changeset
2768
kono
parents:
diff changeset
2769 -- The element allocator may need an accessibility check in the case
kono
parents:
diff changeset
2770 -- where the actual type is class-wide or has access discriminants
kono
parents:
diff changeset
2771 -- (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
2772
kono
parents:
diff changeset
2773 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
2774
kono
parents:
diff changeset
2775 begin
kono
parents:
diff changeset
2776 Container.Elements.EA (Index) := new Element_Type'(New_Item);
kono
parents:
diff changeset
2777 Free (X);
kono
parents:
diff changeset
2778 end;
kono
parents:
diff changeset
2779 end Replace_Element;
kono
parents:
diff changeset
2780
kono
parents:
diff changeset
2781 procedure Replace_Element
kono
parents:
diff changeset
2782 (Container : in out Vector;
kono
parents:
diff changeset
2783 Position : Cursor;
kono
parents:
diff changeset
2784 New_Item : Element_Type)
kono
parents:
diff changeset
2785 is
kono
parents:
diff changeset
2786 begin
kono
parents:
diff changeset
2787 if Checks then
kono
parents:
diff changeset
2788 if Position.Container = null then
kono
parents:
diff changeset
2789 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
2790 end if;
kono
parents:
diff changeset
2791
kono
parents:
diff changeset
2792 if Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
2793 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
2794 end if;
kono
parents:
diff changeset
2795
kono
parents:
diff changeset
2796 if Position.Index > Container.Last then
kono
parents:
diff changeset
2797 raise Constraint_Error with "Position cursor is out of range";
kono
parents:
diff changeset
2798 end if;
kono
parents:
diff changeset
2799 end if;
kono
parents:
diff changeset
2800
kono
parents:
diff changeset
2801 TE_Check (Container.TC);
kono
parents:
diff changeset
2802
kono
parents:
diff changeset
2803 declare
kono
parents:
diff changeset
2804 X : Element_Access := Container.Elements.EA (Position.Index);
kono
parents:
diff changeset
2805
kono
parents:
diff changeset
2806 -- The element allocator may need an accessibility check in the case
kono
parents:
diff changeset
2807 -- where the actual type is class-wide or has access discriminants
kono
parents:
diff changeset
2808 -- (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
2809
kono
parents:
diff changeset
2810 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
2811
kono
parents:
diff changeset
2812 begin
kono
parents:
diff changeset
2813 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
kono
parents:
diff changeset
2814 Free (X);
kono
parents:
diff changeset
2815 end;
kono
parents:
diff changeset
2816 end Replace_Element;
kono
parents:
diff changeset
2817
kono
parents:
diff changeset
2818 ----------------------
kono
parents:
diff changeset
2819 -- Reserve_Capacity --
kono
parents:
diff changeset
2820 ----------------------
kono
parents:
diff changeset
2821
kono
parents:
diff changeset
2822 procedure Reserve_Capacity
kono
parents:
diff changeset
2823 (Container : in out Vector;
kono
parents:
diff changeset
2824 Capacity : Count_Type)
kono
parents:
diff changeset
2825 is
kono
parents:
diff changeset
2826 N : constant Count_Type := Length (Container);
kono
parents:
diff changeset
2827
kono
parents:
diff changeset
2828 Index : Count_Type'Base;
kono
parents:
diff changeset
2829 Last : Index_Type'Base;
kono
parents:
diff changeset
2830
kono
parents:
diff changeset
2831 begin
kono
parents:
diff changeset
2832 -- Reserve_Capacity can be used to either expand the storage available
kono
parents:
diff changeset
2833 -- for elements (this would be its typical use, in anticipation of
kono
parents:
diff changeset
2834 -- future insertion), or to trim back storage. In the latter case,
kono
parents:
diff changeset
2835 -- storage can only be trimmed back to the limit of the container
kono
parents:
diff changeset
2836 -- length. Note that Reserve_Capacity neither deletes (active) elements
kono
parents:
diff changeset
2837 -- nor inserts elements; it only affects container capacity, never
kono
parents:
diff changeset
2838 -- container length.
kono
parents:
diff changeset
2839
kono
parents:
diff changeset
2840 if Capacity = 0 then
kono
parents:
diff changeset
2841
kono
parents:
diff changeset
2842 -- This is a request to trim back storage, to the minimum amount
kono
parents:
diff changeset
2843 -- possible given the current state of the container.
kono
parents:
diff changeset
2844
kono
parents:
diff changeset
2845 if N = 0 then
kono
parents:
diff changeset
2846
kono
parents:
diff changeset
2847 -- The container is empty, so in this unique case we can
kono
parents:
diff changeset
2848 -- deallocate the entire internal array. Note that an empty
kono
parents:
diff changeset
2849 -- container can never be busy, so there's no need to check the
kono
parents:
diff changeset
2850 -- tampering bits.
kono
parents:
diff changeset
2851
kono
parents:
diff changeset
2852 declare
kono
parents:
diff changeset
2853 X : Elements_Access := Container.Elements;
kono
parents:
diff changeset
2854
kono
parents:
diff changeset
2855 begin
kono
parents:
diff changeset
2856 -- First we remove the internal array from the container, to
kono
parents:
diff changeset
2857 -- handle the case when the deallocation raises an exception
kono
parents:
diff changeset
2858 -- (although that's unlikely, since this is simply an array of
kono
parents:
diff changeset
2859 -- access values, all of which are null).
kono
parents:
diff changeset
2860
kono
parents:
diff changeset
2861 Container.Elements := null;
kono
parents:
diff changeset
2862
kono
parents:
diff changeset
2863 -- Container invariants have been restored, so it is now safe
kono
parents:
diff changeset
2864 -- to attempt to deallocate the internal array.
kono
parents:
diff changeset
2865
kono
parents:
diff changeset
2866 Free (X);
kono
parents:
diff changeset
2867 end;
kono
parents:
diff changeset
2868
kono
parents:
diff changeset
2869 elsif N < Container.Elements.EA'Length then
kono
parents:
diff changeset
2870
kono
parents:
diff changeset
2871 -- The container is not empty, and the current length is less than
kono
parents:
diff changeset
2872 -- the current capacity, so there's storage available to trim. In
kono
parents:
diff changeset
2873 -- this case, we allocate a new internal array having a length
kono
parents:
diff changeset
2874 -- that exactly matches the number of items in the
kono
parents:
diff changeset
2875 -- container. (Reserve_Capacity does not delete active elements,
kono
parents:
diff changeset
2876 -- so this is the best we can do with respect to minimizing
kono
parents:
diff changeset
2877 -- storage).
kono
parents:
diff changeset
2878
kono
parents:
diff changeset
2879 TC_Check (Container.TC);
kono
parents:
diff changeset
2880
kono
parents:
diff changeset
2881 declare
kono
parents:
diff changeset
2882 subtype Array_Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
2883 Index_Type'First .. Container.Last;
kono
parents:
diff changeset
2884
kono
parents:
diff changeset
2885 Src : Elements_Array renames
kono
parents:
diff changeset
2886 Container.Elements.EA (Array_Index_Subtype);
kono
parents:
diff changeset
2887
kono
parents:
diff changeset
2888 X : Elements_Access := Container.Elements;
kono
parents:
diff changeset
2889
kono
parents:
diff changeset
2890 begin
kono
parents:
diff changeset
2891 -- Although we have isolated the old internal array that we're
kono
parents:
diff changeset
2892 -- going to deallocate, we don't deallocate it until we have
kono
parents:
diff changeset
2893 -- successfully allocated a new one. If there is an exception
kono
parents:
diff changeset
2894 -- during allocation (because there is not enough storage), we
kono
parents:
diff changeset
2895 -- let it propagate without causing any side-effect.
kono
parents:
diff changeset
2896
kono
parents:
diff changeset
2897 Container.Elements := new Elements_Type'(Container.Last, Src);
kono
parents:
diff changeset
2898
kono
parents:
diff changeset
2899 -- We have successfully allocated a new internal array (with a
kono
parents:
diff changeset
2900 -- smaller length than the old one, and containing a copy of
kono
parents:
diff changeset
2901 -- just the active elements in the container), so we can
kono
parents:
diff changeset
2902 -- deallocate the old array.
kono
parents:
diff changeset
2903
kono
parents:
diff changeset
2904 Free (X);
kono
parents:
diff changeset
2905 end;
kono
parents:
diff changeset
2906 end if;
kono
parents:
diff changeset
2907
kono
parents:
diff changeset
2908 return;
kono
parents:
diff changeset
2909 end if;
kono
parents:
diff changeset
2910
kono
parents:
diff changeset
2911 -- Reserve_Capacity can be used to expand the storage available for
kono
parents:
diff changeset
2912 -- elements, but we do not let the capacity grow beyond the number of
kono
parents:
diff changeset
2913 -- values in Index_Type'Range. (Were it otherwise, there would be no way
kono
parents:
diff changeset
2914 -- to refer to the elements with index values greater than
kono
parents:
diff changeset
2915 -- Index_Type'Last, so that storage would be wasted.) Here we compute
kono
parents:
diff changeset
2916 -- the Last index value of the new internal array, in a way that avoids
kono
parents:
diff changeset
2917 -- any possibility of overflow.
kono
parents:
diff changeset
2918
kono
parents:
diff changeset
2919 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
2920
kono
parents:
diff changeset
2921 -- We perform a two-part test. First we determine whether the
kono
parents:
diff changeset
2922 -- computed Last value lies in the base range of the type, and then
kono
parents:
diff changeset
2923 -- determine whether it lies in the range of the index (sub)type.
kono
parents:
diff changeset
2924
kono
parents:
diff changeset
2925 -- Last must satisfy this relation:
kono
parents:
diff changeset
2926 -- First + Length - 1 <= Last
kono
parents:
diff changeset
2927 -- We regroup terms:
kono
parents:
diff changeset
2928 -- First - 1 <= Last - Length
kono
parents:
diff changeset
2929 -- Which can rewrite as:
kono
parents:
diff changeset
2930 -- No_Index <= Last - Length
kono
parents:
diff changeset
2931
kono
parents:
diff changeset
2932 if Checks and then
kono
parents:
diff changeset
2933 Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index
kono
parents:
diff changeset
2934 then
kono
parents:
diff changeset
2935 raise Constraint_Error with "Capacity is out of range";
kono
parents:
diff changeset
2936 end if;
kono
parents:
diff changeset
2937
kono
parents:
diff changeset
2938 -- We now know that the computed value of Last is within the base
kono
parents:
diff changeset
2939 -- range of the type, so it is safe to compute its value:
kono
parents:
diff changeset
2940
kono
parents:
diff changeset
2941 Last := No_Index + Index_Type'Base (Capacity);
kono
parents:
diff changeset
2942
kono
parents:
diff changeset
2943 -- Finally we test whether the value is within the range of the
kono
parents:
diff changeset
2944 -- generic actual index subtype:
kono
parents:
diff changeset
2945
kono
parents:
diff changeset
2946 if Checks and then Last > Index_Type'Last then
kono
parents:
diff changeset
2947 raise Constraint_Error with "Capacity is out of range";
kono
parents:
diff changeset
2948 end if;
kono
parents:
diff changeset
2949
kono
parents:
diff changeset
2950 elsif Index_Type'First <= 0 then
kono
parents:
diff changeset
2951
kono
parents:
diff changeset
2952 -- Here we can compute Last directly, in the normal way. We know that
kono
parents:
diff changeset
2953 -- No_Index is less than 0, so there is no danger of overflow when
kono
parents:
diff changeset
2954 -- adding the (positive) value of Capacity.
kono
parents:
diff changeset
2955
kono
parents:
diff changeset
2956 Index := Count_Type'Base (No_Index) + Capacity; -- Last
kono
parents:
diff changeset
2957
kono
parents:
diff changeset
2958 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
kono
parents:
diff changeset
2959 raise Constraint_Error with "Capacity is out of range";
kono
parents:
diff changeset
2960 end if;
kono
parents:
diff changeset
2961
kono
parents:
diff changeset
2962 -- We know that the computed value (having type Count_Type) of Last
kono
parents:
diff changeset
2963 -- is within the range of the generic actual index subtype, so it is
kono
parents:
diff changeset
2964 -- safe to convert to Index_Type:
kono
parents:
diff changeset
2965
kono
parents:
diff changeset
2966 Last := Index_Type'Base (Index);
kono
parents:
diff changeset
2967
kono
parents:
diff changeset
2968 else
kono
parents:
diff changeset
2969 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
kono
parents:
diff changeset
2970 -- must test the length indirectly (by working backwards from the
kono
parents:
diff changeset
2971 -- largest possible value of Last), in order to prevent overflow.
kono
parents:
diff changeset
2972
kono
parents:
diff changeset
2973 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
kono
parents:
diff changeset
2974
kono
parents:
diff changeset
2975 if Checks and then Index < Count_Type'Base (No_Index) then
kono
parents:
diff changeset
2976 raise Constraint_Error with "Capacity is out of range";
kono
parents:
diff changeset
2977 end if;
kono
parents:
diff changeset
2978
kono
parents:
diff changeset
2979 -- We have determined that the value of Capacity would not create a
kono
parents:
diff changeset
2980 -- Last index value outside of the range of Index_Type, so we can now
kono
parents:
diff changeset
2981 -- safely compute its value.
kono
parents:
diff changeset
2982
kono
parents:
diff changeset
2983 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
kono
parents:
diff changeset
2984 end if;
kono
parents:
diff changeset
2985
kono
parents:
diff changeset
2986 -- The requested capacity is non-zero, but we don't know yet whether
kono
parents:
diff changeset
2987 -- this is a request for expansion or contraction of storage.
kono
parents:
diff changeset
2988
kono
parents:
diff changeset
2989 if Container.Elements = null then
kono
parents:
diff changeset
2990
kono
parents:
diff changeset
2991 -- The container is empty (it doesn't even have an internal array),
kono
parents:
diff changeset
2992 -- so this represents a request to allocate storage having the given
kono
parents:
diff changeset
2993 -- capacity.
kono
parents:
diff changeset
2994
kono
parents:
diff changeset
2995 Container.Elements := new Elements_Type (Last);
kono
parents:
diff changeset
2996 return;
kono
parents:
diff changeset
2997 end if;
kono
parents:
diff changeset
2998
kono
parents:
diff changeset
2999 if Capacity <= N then
kono
parents:
diff changeset
3000
kono
parents:
diff changeset
3001 -- This is a request to trim back storage, but only to the limit of
kono
parents:
diff changeset
3002 -- what's already in the container. (Reserve_Capacity never deletes
kono
parents:
diff changeset
3003 -- active elements, it only reclaims excess storage.)
kono
parents:
diff changeset
3004
kono
parents:
diff changeset
3005 if N < Container.Elements.EA'Length then
kono
parents:
diff changeset
3006
kono
parents:
diff changeset
3007 -- The container is not empty (because the requested capacity is
kono
parents:
diff changeset
3008 -- positive, and less than or equal to the container length), and
kono
parents:
diff changeset
3009 -- the current length is less than the current capacity, so there
kono
parents:
diff changeset
3010 -- is storage available to trim. In this case, we allocate a new
kono
parents:
diff changeset
3011 -- internal array having a length that exactly matches the number
kono
parents:
diff changeset
3012 -- of items in the container.
kono
parents:
diff changeset
3013
kono
parents:
diff changeset
3014 TC_Check (Container.TC);
kono
parents:
diff changeset
3015
kono
parents:
diff changeset
3016 declare
kono
parents:
diff changeset
3017 subtype Array_Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
3018 Index_Type'First .. Container.Last;
kono
parents:
diff changeset
3019
kono
parents:
diff changeset
3020 Src : Elements_Array renames
kono
parents:
diff changeset
3021 Container.Elements.EA (Array_Index_Subtype);
kono
parents:
diff changeset
3022
kono
parents:
diff changeset
3023 X : Elements_Access := Container.Elements;
kono
parents:
diff changeset
3024
kono
parents:
diff changeset
3025 begin
kono
parents:
diff changeset
3026 -- Although we have isolated the old internal array that we're
kono
parents:
diff changeset
3027 -- going to deallocate, we don't deallocate it until we have
kono
parents:
diff changeset
3028 -- successfully allocated a new one. If there is an exception
kono
parents:
diff changeset
3029 -- during allocation (because there is not enough storage), we
kono
parents:
diff changeset
3030 -- let it propagate without causing any side-effect.
kono
parents:
diff changeset
3031
kono
parents:
diff changeset
3032 Container.Elements := new Elements_Type'(Container.Last, Src);
kono
parents:
diff changeset
3033
kono
parents:
diff changeset
3034 -- We have successfully allocated a new internal array (with a
kono
parents:
diff changeset
3035 -- smaller length than the old one, and containing a copy of
kono
parents:
diff changeset
3036 -- just the active elements in the container), so it is now
kono
parents:
diff changeset
3037 -- safe to deallocate the old array.
kono
parents:
diff changeset
3038
kono
parents:
diff changeset
3039 Free (X);
kono
parents:
diff changeset
3040 end;
kono
parents:
diff changeset
3041 end if;
kono
parents:
diff changeset
3042
kono
parents:
diff changeset
3043 return;
kono
parents:
diff changeset
3044 end if;
kono
parents:
diff changeset
3045
kono
parents:
diff changeset
3046 -- The requested capacity is larger than the container length (the
kono
parents:
diff changeset
3047 -- number of active elements). Whether this represents a request for
kono
parents:
diff changeset
3048 -- expansion or contraction of the current capacity depends on what the
kono
parents:
diff changeset
3049 -- current capacity is.
kono
parents:
diff changeset
3050
kono
parents:
diff changeset
3051 if Capacity = Container.Elements.EA'Length then
kono
parents:
diff changeset
3052
kono
parents:
diff changeset
3053 -- The requested capacity matches the existing capacity, so there's
kono
parents:
diff changeset
3054 -- nothing to do here. We treat this case as a no-op, and simply
kono
parents:
diff changeset
3055 -- return without checking the busy bit.
kono
parents:
diff changeset
3056
kono
parents:
diff changeset
3057 return;
kono
parents:
diff changeset
3058 end if;
kono
parents:
diff changeset
3059
kono
parents:
diff changeset
3060 -- There is a change in the capacity of a non-empty container, so a new
kono
parents:
diff changeset
3061 -- internal array will be allocated. (The length of the new internal
kono
parents:
diff changeset
3062 -- array could be less or greater than the old internal array. We know
kono
parents:
diff changeset
3063 -- only that the length of the new internal array is greater than the
kono
parents:
diff changeset
3064 -- number of active elements in the container.) We must check whether
kono
parents:
diff changeset
3065 -- the container is busy before doing anything else.
kono
parents:
diff changeset
3066
kono
parents:
diff changeset
3067 TC_Check (Container.TC);
kono
parents:
diff changeset
3068
kono
parents:
diff changeset
3069 -- We now allocate a new internal array, having a length different from
kono
parents:
diff changeset
3070 -- its current value.
kono
parents:
diff changeset
3071
kono
parents:
diff changeset
3072 declare
kono
parents:
diff changeset
3073 X : Elements_Access := Container.Elements;
kono
parents:
diff changeset
3074
kono
parents:
diff changeset
3075 subtype Index_Subtype is Index_Type'Base range
kono
parents:
diff changeset
3076 Index_Type'First .. Container.Last;
kono
parents:
diff changeset
3077
kono
parents:
diff changeset
3078 begin
kono
parents:
diff changeset
3079 -- We now allocate a new internal array, having a length different
kono
parents:
diff changeset
3080 -- from its current value.
kono
parents:
diff changeset
3081
kono
parents:
diff changeset
3082 Container.Elements := new Elements_Type (Last);
kono
parents:
diff changeset
3083
kono
parents:
diff changeset
3084 -- We have successfully allocated the new internal array, so now we
kono
parents:
diff changeset
3085 -- move the existing elements from the existing the old internal
kono
parents:
diff changeset
3086 -- array onto the new one. Note that we're just copying access
kono
parents:
diff changeset
3087 -- values, to this should not raise any exceptions.
kono
parents:
diff changeset
3088
kono
parents:
diff changeset
3089 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
kono
parents:
diff changeset
3090
kono
parents:
diff changeset
3091 -- We have moved the elements from the old internal array, so now we
kono
parents:
diff changeset
3092 -- can deallocate it.
kono
parents:
diff changeset
3093
kono
parents:
diff changeset
3094 Free (X);
kono
parents:
diff changeset
3095 end;
kono
parents:
diff changeset
3096 end Reserve_Capacity;
kono
parents:
diff changeset
3097
kono
parents:
diff changeset
3098 ----------------------
kono
parents:
diff changeset
3099 -- Reverse_Elements --
kono
parents:
diff changeset
3100 ----------------------
kono
parents:
diff changeset
3101
kono
parents:
diff changeset
3102 procedure Reverse_Elements (Container : in out Vector) is
kono
parents:
diff changeset
3103 begin
kono
parents:
diff changeset
3104 if Container.Length <= 1 then
kono
parents:
diff changeset
3105 return;
kono
parents:
diff changeset
3106 end if;
kono
parents:
diff changeset
3107
kono
parents:
diff changeset
3108 -- The exception behavior for the vector container must match that for
kono
parents:
diff changeset
3109 -- the list container, so we check for cursor tampering here (which will
kono
parents:
diff changeset
3110 -- catch more things) instead of for element tampering (which will catch
kono
parents:
diff changeset
3111 -- fewer things). It's true that the elements of this vector container
kono
parents:
diff changeset
3112 -- could be safely moved around while (say) an iteration is taking place
kono
parents:
diff changeset
3113 -- (iteration only increments the busy counter), and so technically all
kono
parents:
diff changeset
3114 -- we would need here is a test for element tampering (indicated by the
kono
parents:
diff changeset
3115 -- lock counter), that's simply an artifact of our array-based
kono
parents:
diff changeset
3116 -- implementation. Logically Reverse_Elements requires a check for
kono
parents:
diff changeset
3117 -- cursor tampering.
kono
parents:
diff changeset
3118
kono
parents:
diff changeset
3119 TC_Check (Container.TC);
kono
parents:
diff changeset
3120
kono
parents:
diff changeset
3121 declare
kono
parents:
diff changeset
3122 I : Index_Type;
kono
parents:
diff changeset
3123 J : Index_Type;
kono
parents:
diff changeset
3124 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
3125
kono
parents:
diff changeset
3126 begin
kono
parents:
diff changeset
3127 I := Index_Type'First;
kono
parents:
diff changeset
3128 J := Container.Last;
kono
parents:
diff changeset
3129 while I < J loop
kono
parents:
diff changeset
3130 declare
kono
parents:
diff changeset
3131 EI : constant Element_Access := E (I);
kono
parents:
diff changeset
3132
kono
parents:
diff changeset
3133 begin
kono
parents:
diff changeset
3134 E (I) := E (J);
kono
parents:
diff changeset
3135 E (J) := EI;
kono
parents:
diff changeset
3136 end;
kono
parents:
diff changeset
3137
kono
parents:
diff changeset
3138 I := I + 1;
kono
parents:
diff changeset
3139 J := J - 1;
kono
parents:
diff changeset
3140 end loop;
kono
parents:
diff changeset
3141 end;
kono
parents:
diff changeset
3142 end Reverse_Elements;
kono
parents:
diff changeset
3143
kono
parents:
diff changeset
3144 ------------------
kono
parents:
diff changeset
3145 -- Reverse_Find --
kono
parents:
diff changeset
3146 ------------------
kono
parents:
diff changeset
3147
kono
parents:
diff changeset
3148 function Reverse_Find
kono
parents:
diff changeset
3149 (Container : Vector;
kono
parents:
diff changeset
3150 Item : Element_Type;
kono
parents:
diff changeset
3151 Position : Cursor := No_Element) return Cursor
kono
parents:
diff changeset
3152 is
kono
parents:
diff changeset
3153 Last : Index_Type'Base;
kono
parents:
diff changeset
3154
kono
parents:
diff changeset
3155 begin
kono
parents:
diff changeset
3156 if Checks and then Position.Container /= null
kono
parents:
diff changeset
3157 and then Position.Container /= Container'Unrestricted_Access
kono
parents:
diff changeset
3158 then
kono
parents:
diff changeset
3159 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
3160 end if;
kono
parents:
diff changeset
3161
kono
parents:
diff changeset
3162 Last :=
kono
parents:
diff changeset
3163 (if Position.Container = null or else Position.Index > Container.Last
kono
parents:
diff changeset
3164 then Container.Last
kono
parents:
diff changeset
3165 else Position.Index);
kono
parents:
diff changeset
3166
kono
parents:
diff changeset
3167 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
3168 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
3169
kono
parents:
diff changeset
3170 declare
kono
parents:
diff changeset
3171 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
3172 begin
kono
parents:
diff changeset
3173 for Indx in reverse Index_Type'First .. Last loop
kono
parents:
diff changeset
3174 if Container.Elements.EA (Indx) /= null
kono
parents:
diff changeset
3175 and then Container.Elements.EA (Indx).all = Item
kono
parents:
diff changeset
3176 then
kono
parents:
diff changeset
3177 return Cursor'(Container'Unrestricted_Access, Indx);
kono
parents:
diff changeset
3178 end if;
kono
parents:
diff changeset
3179 end loop;
kono
parents:
diff changeset
3180
kono
parents:
diff changeset
3181 return No_Element;
kono
parents:
diff changeset
3182 end;
kono
parents:
diff changeset
3183 end Reverse_Find;
kono
parents:
diff changeset
3184
kono
parents:
diff changeset
3185 ------------------------
kono
parents:
diff changeset
3186 -- Reverse_Find_Index --
kono
parents:
diff changeset
3187 ------------------------
kono
parents:
diff changeset
3188
kono
parents:
diff changeset
3189 function Reverse_Find_Index
kono
parents:
diff changeset
3190 (Container : Vector;
kono
parents:
diff changeset
3191 Item : Element_Type;
kono
parents:
diff changeset
3192 Index : Index_Type := Index_Type'Last) return Extended_Index
kono
parents:
diff changeset
3193 is
kono
parents:
diff changeset
3194 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
3195 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
3196
kono
parents:
diff changeset
3197 Lock : With_Lock (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
3198
kono
parents:
diff changeset
3199 Last : constant Index_Type'Base :=
kono
parents:
diff changeset
3200 Index_Type'Min (Container.Last, Index);
kono
parents:
diff changeset
3201
kono
parents:
diff changeset
3202 begin
kono
parents:
diff changeset
3203 for Indx in reverse Index_Type'First .. Last loop
kono
parents:
diff changeset
3204 if Container.Elements.EA (Indx) /= null
kono
parents:
diff changeset
3205 and then Container.Elements.EA (Indx).all = Item
kono
parents:
diff changeset
3206 then
kono
parents:
diff changeset
3207 return Indx;
kono
parents:
diff changeset
3208 end if;
kono
parents:
diff changeset
3209 end loop;
kono
parents:
diff changeset
3210
kono
parents:
diff changeset
3211 return No_Index;
kono
parents:
diff changeset
3212 end Reverse_Find_Index;
kono
parents:
diff changeset
3213
kono
parents:
diff changeset
3214 ---------------------
kono
parents:
diff changeset
3215 -- Reverse_Iterate --
kono
parents:
diff changeset
3216 ---------------------
kono
parents:
diff changeset
3217
kono
parents:
diff changeset
3218 procedure Reverse_Iterate
kono
parents:
diff changeset
3219 (Container : Vector;
kono
parents:
diff changeset
3220 Process : not null access procedure (Position : Cursor))
kono
parents:
diff changeset
3221 is
kono
parents:
diff changeset
3222 Busy : With_Busy (Container.TC'Unrestricted_Access);
kono
parents:
diff changeset
3223 begin
kono
parents:
diff changeset
3224 for Indx in reverse Index_Type'First .. Container.Last loop
kono
parents:
diff changeset
3225 Process (Cursor'(Container'Unrestricted_Access, Indx));
kono
parents:
diff changeset
3226 end loop;
kono
parents:
diff changeset
3227 end Reverse_Iterate;
kono
parents:
diff changeset
3228
kono
parents:
diff changeset
3229 ----------------
kono
parents:
diff changeset
3230 -- Set_Length --
kono
parents:
diff changeset
3231 ----------------
kono
parents:
diff changeset
3232
kono
parents:
diff changeset
3233 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
kono
parents:
diff changeset
3234 Count : constant Count_Type'Base := Container.Length - Length;
kono
parents:
diff changeset
3235
kono
parents:
diff changeset
3236 begin
kono
parents:
diff changeset
3237 -- Set_Length allows the user to set the length explicitly, instead of
kono
parents:
diff changeset
3238 -- implicitly as a side-effect of deletion or insertion. If the
kono
parents:
diff changeset
3239 -- requested length is less than the current length, this is equivalent
kono
parents:
diff changeset
3240 -- to deleting items from the back end of the vector. If the requested
kono
parents:
diff changeset
3241 -- length is greater than the current length, then this is equivalent to
kono
parents:
diff changeset
3242 -- inserting "space" (nonce items) at the end.
kono
parents:
diff changeset
3243
kono
parents:
diff changeset
3244 if Count >= 0 then
kono
parents:
diff changeset
3245 Container.Delete_Last (Count);
kono
parents:
diff changeset
3246
kono
parents:
diff changeset
3247 elsif Checks and then Container.Last >= Index_Type'Last then
kono
parents:
diff changeset
3248 raise Constraint_Error with "vector is already at its maximum length";
kono
parents:
diff changeset
3249
kono
parents:
diff changeset
3250 else
kono
parents:
diff changeset
3251 Container.Insert_Space (Container.Last + 1, -Count);
kono
parents:
diff changeset
3252 end if;
kono
parents:
diff changeset
3253 end Set_Length;
kono
parents:
diff changeset
3254
kono
parents:
diff changeset
3255 ----------
kono
parents:
diff changeset
3256 -- Swap --
kono
parents:
diff changeset
3257 ----------
kono
parents:
diff changeset
3258
kono
parents:
diff changeset
3259 procedure Swap (Container : in out Vector; I, J : Index_Type) is
kono
parents:
diff changeset
3260 begin
kono
parents:
diff changeset
3261 if Checks then
kono
parents:
diff changeset
3262 if I > Container.Last then
kono
parents:
diff changeset
3263 raise Constraint_Error with "I index is out of range";
kono
parents:
diff changeset
3264 end if;
kono
parents:
diff changeset
3265
kono
parents:
diff changeset
3266 if J > Container.Last then
kono
parents:
diff changeset
3267 raise Constraint_Error with "J index is out of range";
kono
parents:
diff changeset
3268 end if;
kono
parents:
diff changeset
3269 end if;
kono
parents:
diff changeset
3270
kono
parents:
diff changeset
3271 if I = J then
kono
parents:
diff changeset
3272 return;
kono
parents:
diff changeset
3273 end if;
kono
parents:
diff changeset
3274
kono
parents:
diff changeset
3275 TE_Check (Container.TC);
kono
parents:
diff changeset
3276
kono
parents:
diff changeset
3277 declare
kono
parents:
diff changeset
3278 EI : Element_Access renames Container.Elements.EA (I);
kono
parents:
diff changeset
3279 EJ : Element_Access renames Container.Elements.EA (J);
kono
parents:
diff changeset
3280
kono
parents:
diff changeset
3281 EI_Copy : constant Element_Access := EI;
kono
parents:
diff changeset
3282
kono
parents:
diff changeset
3283 begin
kono
parents:
diff changeset
3284 EI := EJ;
kono
parents:
diff changeset
3285 EJ := EI_Copy;
kono
parents:
diff changeset
3286 end;
kono
parents:
diff changeset
3287 end Swap;
kono
parents:
diff changeset
3288
kono
parents:
diff changeset
3289 procedure Swap
kono
parents:
diff changeset
3290 (Container : in out Vector;
kono
parents:
diff changeset
3291 I, J : Cursor)
kono
parents:
diff changeset
3292 is
kono
parents:
diff changeset
3293 begin
kono
parents:
diff changeset
3294 if Checks then
kono
parents:
diff changeset
3295 if I.Container = null then
kono
parents:
diff changeset
3296 raise Constraint_Error with "I cursor has no element";
kono
parents:
diff changeset
3297 end if;
kono
parents:
diff changeset
3298
kono
parents:
diff changeset
3299 if J.Container = null then
kono
parents:
diff changeset
3300 raise Constraint_Error with "J cursor has no element";
kono
parents:
diff changeset
3301 end if;
kono
parents:
diff changeset
3302
kono
parents:
diff changeset
3303 if I.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
3304 raise Program_Error with "I cursor denotes wrong container";
kono
parents:
diff changeset
3305 end if;
kono
parents:
diff changeset
3306
kono
parents:
diff changeset
3307 if J.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
3308 raise Program_Error with "J cursor denotes wrong container";
kono
parents:
diff changeset
3309 end if;
kono
parents:
diff changeset
3310 end if;
kono
parents:
diff changeset
3311
kono
parents:
diff changeset
3312 Swap (Container, I.Index, J.Index);
kono
parents:
diff changeset
3313 end Swap;
kono
parents:
diff changeset
3314
kono
parents:
diff changeset
3315 ---------------
kono
parents:
diff changeset
3316 -- To_Cursor --
kono
parents:
diff changeset
3317 ---------------
kono
parents:
diff changeset
3318
kono
parents:
diff changeset
3319 function To_Cursor
kono
parents:
diff changeset
3320 (Container : Vector;
kono
parents:
diff changeset
3321 Index : Extended_Index) return Cursor
kono
parents:
diff changeset
3322 is
kono
parents:
diff changeset
3323 begin
kono
parents:
diff changeset
3324 if Index not in Index_Type'First .. Container.Last then
kono
parents:
diff changeset
3325 return No_Element;
kono
parents:
diff changeset
3326 end if;
kono
parents:
diff changeset
3327
kono
parents:
diff changeset
3328 return Cursor'(Container'Unrestricted_Access, Index);
kono
parents:
diff changeset
3329 end To_Cursor;
kono
parents:
diff changeset
3330
kono
parents:
diff changeset
3331 --------------
kono
parents:
diff changeset
3332 -- To_Index --
kono
parents:
diff changeset
3333 --------------
kono
parents:
diff changeset
3334
kono
parents:
diff changeset
3335 function To_Index (Position : Cursor) return Extended_Index is
kono
parents:
diff changeset
3336 begin
kono
parents:
diff changeset
3337 if Position.Container = null then
kono
parents:
diff changeset
3338 return No_Index;
kono
parents:
diff changeset
3339 elsif Position.Index <= Position.Container.Last then
kono
parents:
diff changeset
3340 return Position.Index;
kono
parents:
diff changeset
3341 else
kono
parents:
diff changeset
3342 return No_Index;
kono
parents:
diff changeset
3343 end if;
kono
parents:
diff changeset
3344 end To_Index;
kono
parents:
diff changeset
3345
kono
parents:
diff changeset
3346 ---------------
kono
parents:
diff changeset
3347 -- To_Vector --
kono
parents:
diff changeset
3348 ---------------
kono
parents:
diff changeset
3349
kono
parents:
diff changeset
3350 function To_Vector (Length : Count_Type) return Vector is
kono
parents:
diff changeset
3351 Index : Count_Type'Base;
kono
parents:
diff changeset
3352 Last : Index_Type'Base;
kono
parents:
diff changeset
3353 Elements : Elements_Access;
kono
parents:
diff changeset
3354
kono
parents:
diff changeset
3355 begin
kono
parents:
diff changeset
3356 if Length = 0 then
kono
parents:
diff changeset
3357 return Empty_Vector;
kono
parents:
diff changeset
3358 end if;
kono
parents:
diff changeset
3359
kono
parents:
diff changeset
3360 -- We create a vector object with a capacity that matches the specified
kono
parents:
diff changeset
3361 -- Length, but we do not allow the vector capacity (the length of the
kono
parents:
diff changeset
3362 -- internal array) to exceed the number of values in Index_Type'Range
kono
parents:
diff changeset
3363 -- (otherwise, there would be no way to refer to those components via an
kono
parents:
diff changeset
3364 -- index). We must therefore check whether the specified Length would
kono
parents:
diff changeset
3365 -- create a Last index value greater than Index_Type'Last.
kono
parents:
diff changeset
3366
kono
parents:
diff changeset
3367 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
3368
kono
parents:
diff changeset
3369 -- We perform a two-part test. First we determine whether the
kono
parents:
diff changeset
3370 -- computed Last value lies in the base range of the type, and then
kono
parents:
diff changeset
3371 -- determine whether it lies in the range of the index (sub)type.
kono
parents:
diff changeset
3372
kono
parents:
diff changeset
3373 -- Last must satisfy this relation:
kono
parents:
diff changeset
3374 -- First + Length - 1 <= Last
kono
parents:
diff changeset
3375 -- We regroup terms:
kono
parents:
diff changeset
3376 -- First - 1 <= Last - Length
kono
parents:
diff changeset
3377 -- Which can rewrite as:
kono
parents:
diff changeset
3378 -- No_Index <= Last - Length
kono
parents:
diff changeset
3379
kono
parents:
diff changeset
3380 if Checks and then
kono
parents:
diff changeset
3381 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
kono
parents:
diff changeset
3382 then
kono
parents:
diff changeset
3383 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3384 end if;
kono
parents:
diff changeset
3385
kono
parents:
diff changeset
3386 -- We now know that the computed value of Last is within the base
kono
parents:
diff changeset
3387 -- range of the type, so it is safe to compute its value:
kono
parents:
diff changeset
3388
kono
parents:
diff changeset
3389 Last := No_Index + Index_Type'Base (Length);
kono
parents:
diff changeset
3390
kono
parents:
diff changeset
3391 -- Finally we test whether the value is within the range of the
kono
parents:
diff changeset
3392 -- generic actual index subtype:
kono
parents:
diff changeset
3393
kono
parents:
diff changeset
3394 if Checks and then Last > Index_Type'Last then
kono
parents:
diff changeset
3395 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3396 end if;
kono
parents:
diff changeset
3397
kono
parents:
diff changeset
3398 elsif Index_Type'First <= 0 then
kono
parents:
diff changeset
3399
kono
parents:
diff changeset
3400 -- Here we can compute Last directly, in the normal way. We know that
kono
parents:
diff changeset
3401 -- No_Index is less than 0, so there is no danger of overflow when
kono
parents:
diff changeset
3402 -- adding the (positive) value of Length.
kono
parents:
diff changeset
3403
kono
parents:
diff changeset
3404 Index := Count_Type'Base (No_Index) + Length; -- Last
kono
parents:
diff changeset
3405
kono
parents:
diff changeset
3406 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
kono
parents:
diff changeset
3407 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3408 end if;
kono
parents:
diff changeset
3409
kono
parents:
diff changeset
3410 -- We know that the computed value (having type Count_Type) of Last
kono
parents:
diff changeset
3411 -- is within the range of the generic actual index subtype, so it is
kono
parents:
diff changeset
3412 -- safe to convert to Index_Type:
kono
parents:
diff changeset
3413
kono
parents:
diff changeset
3414 Last := Index_Type'Base (Index);
kono
parents:
diff changeset
3415
kono
parents:
diff changeset
3416 else
kono
parents:
diff changeset
3417 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
kono
parents:
diff changeset
3418 -- must test the length indirectly (by working backwards from the
kono
parents:
diff changeset
3419 -- largest possible value of Last), in order to prevent overflow.
kono
parents:
diff changeset
3420
kono
parents:
diff changeset
3421 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
kono
parents:
diff changeset
3422
kono
parents:
diff changeset
3423 if Checks and then Index < Count_Type'Base (No_Index) then
kono
parents:
diff changeset
3424 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3425 end if;
kono
parents:
diff changeset
3426
kono
parents:
diff changeset
3427 -- We have determined that the value of Length would not create a
kono
parents:
diff changeset
3428 -- Last index value outside of the range of Index_Type, so we can now
kono
parents:
diff changeset
3429 -- safely compute its value.
kono
parents:
diff changeset
3430
kono
parents:
diff changeset
3431 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
kono
parents:
diff changeset
3432 end if;
kono
parents:
diff changeset
3433
kono
parents:
diff changeset
3434 Elements := new Elements_Type (Last);
kono
parents:
diff changeset
3435
kono
parents:
diff changeset
3436 return Vector'(Controlled with Elements, Last, TC => <>);
kono
parents:
diff changeset
3437 end To_Vector;
kono
parents:
diff changeset
3438
kono
parents:
diff changeset
3439 function To_Vector
kono
parents:
diff changeset
3440 (New_Item : Element_Type;
kono
parents:
diff changeset
3441 Length : Count_Type) return Vector
kono
parents:
diff changeset
3442 is
kono
parents:
diff changeset
3443 Index : Count_Type'Base;
kono
parents:
diff changeset
3444 Last : Index_Type'Base;
kono
parents:
diff changeset
3445 Elements : Elements_Access;
kono
parents:
diff changeset
3446
kono
parents:
diff changeset
3447 begin
kono
parents:
diff changeset
3448 if Length = 0 then
kono
parents:
diff changeset
3449 return Empty_Vector;
kono
parents:
diff changeset
3450 end if;
kono
parents:
diff changeset
3451
kono
parents:
diff changeset
3452 -- We create a vector object with a capacity that matches the specified
kono
parents:
diff changeset
3453 -- Length, but we do not allow the vector capacity (the length of the
kono
parents:
diff changeset
3454 -- internal array) to exceed the number of values in Index_Type'Range
kono
parents:
diff changeset
3455 -- (otherwise, there would be no way to refer to those components via an
kono
parents:
diff changeset
3456 -- index). We must therefore check whether the specified Length would
kono
parents:
diff changeset
3457 -- create a Last index value greater than Index_Type'Last.
kono
parents:
diff changeset
3458
kono
parents:
diff changeset
3459 if Index_Type'Base'Last >= Count_Type_Last then
kono
parents:
diff changeset
3460
kono
parents:
diff changeset
3461 -- We perform a two-part test. First we determine whether the
kono
parents:
diff changeset
3462 -- computed Last value lies in the base range of the type, and then
kono
parents:
diff changeset
3463 -- determine whether it lies in the range of the index (sub)type.
kono
parents:
diff changeset
3464
kono
parents:
diff changeset
3465 -- Last must satisfy this relation:
kono
parents:
diff changeset
3466 -- First + Length - 1 <= Last
kono
parents:
diff changeset
3467 -- We regroup terms:
kono
parents:
diff changeset
3468 -- First - 1 <= Last - Length
kono
parents:
diff changeset
3469 -- Which can rewrite as:
kono
parents:
diff changeset
3470 -- No_Index <= Last - Length
kono
parents:
diff changeset
3471
kono
parents:
diff changeset
3472 if Checks and then
kono
parents:
diff changeset
3473 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
kono
parents:
diff changeset
3474 then
kono
parents:
diff changeset
3475 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3476 end if;
kono
parents:
diff changeset
3477
kono
parents:
diff changeset
3478 -- We now know that the computed value of Last is within the base
kono
parents:
diff changeset
3479 -- range of the type, so it is safe to compute its value:
kono
parents:
diff changeset
3480
kono
parents:
diff changeset
3481 Last := No_Index + Index_Type'Base (Length);
kono
parents:
diff changeset
3482
kono
parents:
diff changeset
3483 -- Finally we test whether the value is within the range of the
kono
parents:
diff changeset
3484 -- generic actual index subtype:
kono
parents:
diff changeset
3485
kono
parents:
diff changeset
3486 if Checks and then Last > Index_Type'Last then
kono
parents:
diff changeset
3487 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3488 end if;
kono
parents:
diff changeset
3489
kono
parents:
diff changeset
3490 elsif Index_Type'First <= 0 then
kono
parents:
diff changeset
3491
kono
parents:
diff changeset
3492 -- Here we can compute Last directly, in the normal way. We know that
kono
parents:
diff changeset
3493 -- No_Index is less than 0, so there is no danger of overflow when
kono
parents:
diff changeset
3494 -- adding the (positive) value of Length.
kono
parents:
diff changeset
3495
kono
parents:
diff changeset
3496 Index := Count_Type'Base (No_Index) + Length; -- Last
kono
parents:
diff changeset
3497
kono
parents:
diff changeset
3498 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
kono
parents:
diff changeset
3499 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3500 end if;
kono
parents:
diff changeset
3501
kono
parents:
diff changeset
3502 -- We know that the computed value (having type Count_Type) of Last
kono
parents:
diff changeset
3503 -- is within the range of the generic actual index subtype, so it is
kono
parents:
diff changeset
3504 -- safe to convert to Index_Type:
kono
parents:
diff changeset
3505
kono
parents:
diff changeset
3506 Last := Index_Type'Base (Index);
kono
parents:
diff changeset
3507
kono
parents:
diff changeset
3508 else
kono
parents:
diff changeset
3509 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
kono
parents:
diff changeset
3510 -- must test the length indirectly (by working backwards from the
kono
parents:
diff changeset
3511 -- largest possible value of Last), in order to prevent overflow.
kono
parents:
diff changeset
3512
kono
parents:
diff changeset
3513 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
kono
parents:
diff changeset
3514
kono
parents:
diff changeset
3515 if Checks and then Index < Count_Type'Base (No_Index) then
kono
parents:
diff changeset
3516 raise Constraint_Error with "Length is out of range";
kono
parents:
diff changeset
3517 end if;
kono
parents:
diff changeset
3518
kono
parents:
diff changeset
3519 -- We have determined that the value of Length would not create a
kono
parents:
diff changeset
3520 -- Last index value outside of the range of Index_Type, so we can now
kono
parents:
diff changeset
3521 -- safely compute its value.
kono
parents:
diff changeset
3522
kono
parents:
diff changeset
3523 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
kono
parents:
diff changeset
3524 end if;
kono
parents:
diff changeset
3525
kono
parents:
diff changeset
3526 Elements := new Elements_Type (Last);
kono
parents:
diff changeset
3527
kono
parents:
diff changeset
3528 -- We use Last as the index of the loop used to populate the internal
kono
parents:
diff changeset
3529 -- array with items. In general, we prefer to initialize the loop index
kono
parents:
diff changeset
3530 -- immediately prior to entering the loop. However, Last is also used in
kono
parents:
diff changeset
3531 -- the exception handler (to reclaim elements that have been allocated,
kono
parents:
diff changeset
3532 -- before propagating the exception), and the initialization of Last
kono
parents:
diff changeset
3533 -- after entering the block containing the handler confuses some static
kono
parents:
diff changeset
3534 -- analysis tools, with respect to whether Last has been properly
kono
parents:
diff changeset
3535 -- initialized when the handler executes. So here we initialize our loop
kono
parents:
diff changeset
3536 -- variable earlier than we prefer, before entering the block, so there
kono
parents:
diff changeset
3537 -- is no ambiguity.
kono
parents:
diff changeset
3538
kono
parents:
diff changeset
3539 Last := Index_Type'First;
kono
parents:
diff changeset
3540
kono
parents:
diff changeset
3541 declare
kono
parents:
diff changeset
3542 -- The element allocator may need an accessibility check in the case
kono
parents:
diff changeset
3543 -- where the actual type is class-wide or has access discriminants
kono
parents:
diff changeset
3544 -- (see RM 4.8(10.1) and AI12-0035).
kono
parents:
diff changeset
3545
kono
parents:
diff changeset
3546 pragma Unsuppress (Accessibility_Check);
kono
parents:
diff changeset
3547
kono
parents:
diff changeset
3548 begin
kono
parents:
diff changeset
3549 loop
kono
parents:
diff changeset
3550 Elements.EA (Last) := new Element_Type'(New_Item);
kono
parents:
diff changeset
3551 exit when Last = Elements.Last;
kono
parents:
diff changeset
3552 Last := Last + 1;
kono
parents:
diff changeset
3553 end loop;
kono
parents:
diff changeset
3554
kono
parents:
diff changeset
3555 exception
kono
parents:
diff changeset
3556 when others =>
kono
parents:
diff changeset
3557 for J in Index_Type'First .. Last - 1 loop
kono
parents:
diff changeset
3558 Free (Elements.EA (J));
kono
parents:
diff changeset
3559 end loop;
kono
parents:
diff changeset
3560
kono
parents:
diff changeset
3561 Free (Elements);
kono
parents:
diff changeset
3562 raise;
kono
parents:
diff changeset
3563 end;
kono
parents:
diff changeset
3564
kono
parents:
diff changeset
3565 return (Controlled with Elements, Last, TC => <>);
kono
parents:
diff changeset
3566 end To_Vector;
kono
parents:
diff changeset
3567
kono
parents:
diff changeset
3568 --------------------
kono
parents:
diff changeset
3569 -- Update_Element --
kono
parents:
diff changeset
3570 --------------------
kono
parents:
diff changeset
3571
kono
parents:
diff changeset
3572 procedure Update_Element
kono
parents:
diff changeset
3573 (Container : in out Vector;
kono
parents:
diff changeset
3574 Index : Index_Type;
kono
parents:
diff changeset
3575 Process : not null access procedure (Element : in out Element_Type))
kono
parents:
diff changeset
3576 is
kono
parents:
diff changeset
3577 Lock : With_Lock (Container.TC'Unchecked_Access);
kono
parents:
diff changeset
3578 begin
kono
parents:
diff changeset
3579 if Checks and then Index > Container.Last then
kono
parents:
diff changeset
3580 raise Constraint_Error with "Index is out of range";
kono
parents:
diff changeset
3581 end if;
kono
parents:
diff changeset
3582
kono
parents:
diff changeset
3583 if Checks and then Container.Elements.EA (Index) = null then
kono
parents:
diff changeset
3584 raise Constraint_Error with "element is null";
kono
parents:
diff changeset
3585 end if;
kono
parents:
diff changeset
3586
kono
parents:
diff changeset
3587 Process (Container.Elements.EA (Index).all);
kono
parents:
diff changeset
3588 end Update_Element;
kono
parents:
diff changeset
3589
kono
parents:
diff changeset
3590 procedure Update_Element
kono
parents:
diff changeset
3591 (Container : in out Vector;
kono
parents:
diff changeset
3592 Position : Cursor;
kono
parents:
diff changeset
3593 Process : not null access procedure (Element : in out Element_Type))
kono
parents:
diff changeset
3594 is
kono
parents:
diff changeset
3595 begin
kono
parents:
diff changeset
3596 if Checks then
kono
parents:
diff changeset
3597 if Position.Container = null then
kono
parents:
diff changeset
3598 raise Constraint_Error with "Position cursor has no element";
kono
parents:
diff changeset
3599 elsif Position.Container /= Container'Unrestricted_Access then
kono
parents:
diff changeset
3600 raise Program_Error with "Position cursor denotes wrong container";
kono
parents:
diff changeset
3601 end if;
kono
parents:
diff changeset
3602 end if;
kono
parents:
diff changeset
3603
kono
parents:
diff changeset
3604 Update_Element (Container, Position.Index, Process);
kono
parents:
diff changeset
3605 end Update_Element;
kono
parents:
diff changeset
3606
kono
parents:
diff changeset
3607 -----------
kono
parents:
diff changeset
3608 -- Write --
kono
parents:
diff changeset
3609 -----------
kono
parents:
diff changeset
3610
kono
parents:
diff changeset
3611 procedure Write
kono
parents:
diff changeset
3612 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
3613 Container : Vector)
kono
parents:
diff changeset
3614 is
kono
parents:
diff changeset
3615 N : constant Count_Type := Length (Container);
kono
parents:
diff changeset
3616
kono
parents:
diff changeset
3617 begin
kono
parents:
diff changeset
3618 Count_Type'Base'Write (Stream, N);
kono
parents:
diff changeset
3619
kono
parents:
diff changeset
3620 if N = 0 then
kono
parents:
diff changeset
3621 return;
kono
parents:
diff changeset
3622 end if;
kono
parents:
diff changeset
3623
kono
parents:
diff changeset
3624 declare
kono
parents:
diff changeset
3625 E : Elements_Array renames Container.Elements.EA;
kono
parents:
diff changeset
3626
kono
parents:
diff changeset
3627 begin
kono
parents:
diff changeset
3628 for Indx in Index_Type'First .. Container.Last loop
kono
parents:
diff changeset
3629 if E (Indx) = null then
kono
parents:
diff changeset
3630 Boolean'Write (Stream, False);
kono
parents:
diff changeset
3631 else
kono
parents:
diff changeset
3632 Boolean'Write (Stream, True);
kono
parents:
diff changeset
3633 Element_Type'Output (Stream, E (Indx).all);
kono
parents:
diff changeset
3634 end if;
kono
parents:
diff changeset
3635 end loop;
kono
parents:
diff changeset
3636 end;
kono
parents:
diff changeset
3637 end Write;
kono
parents:
diff changeset
3638
kono
parents:
diff changeset
3639 procedure Write
kono
parents:
diff changeset
3640 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
3641 Position : Cursor)
kono
parents:
diff changeset
3642 is
kono
parents:
diff changeset
3643 begin
kono
parents:
diff changeset
3644 raise Program_Error with "attempt to stream vector cursor";
kono
parents:
diff changeset
3645 end Write;
kono
parents:
diff changeset
3646
kono
parents:
diff changeset
3647 procedure Write
kono
parents:
diff changeset
3648 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
3649 Item : Reference_Type)
kono
parents:
diff changeset
3650 is
kono
parents:
diff changeset
3651 begin
kono
parents:
diff changeset
3652 raise Program_Error with "attempt to stream reference";
kono
parents:
diff changeset
3653 end Write;
kono
parents:
diff changeset
3654
kono
parents:
diff changeset
3655 procedure Write
kono
parents:
diff changeset
3656 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
3657 Item : Constant_Reference_Type)
kono
parents:
diff changeset
3658 is
kono
parents:
diff changeset
3659 begin
kono
parents:
diff changeset
3660 raise Program_Error with "attempt to stream reference";
kono
parents:
diff changeset
3661 end Write;
kono
parents:
diff changeset
3662
kono
parents:
diff changeset
3663 end Ada.Containers.Indefinite_Vectors;