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