From a8c075f72b231c37823661ba0d7d082a21cd39d9 Mon Sep 17 00:00:00 2001 From: Dan Albert Date: Tue, 13 Oct 2015 16:28:19 -0700 Subject: Remove gcc-4.8. Change-Id: Iee9c6985c613f58c82e33a91722d371579eb290f --- gcc-4.8/gcc/ada/a-coinve.adb | 4140 ------------------------------------------ 1 file changed, 4140 deletions(-) delete mode 100644 gcc-4.8/gcc/ada/a-coinve.adb (limited to 'gcc-4.8/gcc/ada/a-coinve.adb') diff --git a/gcc-4.8/gcc/ada/a-coinve.adb b/gcc-4.8/gcc/ada/a-coinve.adb deleted file mode 100644 index 5b59c019d..000000000 --- a/gcc-4.8/gcc/ada/a-coinve.adb +++ /dev/null @@ -1,4140 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- 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 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Vectors is - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - - --------- - -- "&" -- - --------- - - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate values - Last : Index_Type'Base; -- Last index of result - - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Right.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Right vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if RE (I) /= null then - Elements.EA (I) := new Element_Type'(RE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Right.Last, 0, 0); - end; - - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - Elements : Elements_Access := new Elements_Type (Left.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Left vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Left.Last, 0, 0); - end; - end if; - - -- Neither of the vector parameters is empty, so we must compute the - -- length of the result vector and its last index. (This is the harder - -- case, because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe compute the length of the new vector. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := No_Index; - - begin - -- Elements of an indefinite vector are allocated, so we cannot use - -- simple slice assignment to give a value to our result. Hence we - -- must walk the array of each vector parameter, and copy each source - -- element individually. - - for LI in LE'Range loop - I := I + 1; - - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; - end "&"; - - function "&" (Left : Vector; Right : Element_Type) return Vector is - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Here we handle the easy case first, when the vector parameter (Left) - -- is empty. - - if Left.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Right); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Left.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Left.Last + 1; - - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - begin - for I in LE'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - begin - Elements.EA (Last) := new Element_Type'(Right); - - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end; - end "&"; - - function "&" (Left : Element_Type; Right : Vector) return Vector is - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Here we handle the easy case first, when the vector parameter (Right) - -- is empty. - - if Right.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Right.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Right.Last + 1; - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := Index_Type'First; - - begin - begin - Elements.EA (I) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; - end "&"; - - function "&" (Left, Right : Element_Type) return Vector is - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type'First + 1; - Elements : Elements_Access := new Elements_Type (Last); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - begin - Elements.EA (Last) := new Element_Type'(Right); - exception - when others => - Free (Elements.EA (Index_Type'First)); - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end; - end "&"; - - --------- - -- "=" -- - --------- - - overriding function "=" (Left, Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Last /= Right.Last then - return False; - end if; - - for J in Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) = null then - if Right.Elements.EA (J) /= null then - return False; - end if; - - elsif Right.Elements.EA (J) = null then - return False; - - elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Vector) is - begin - if Container.Last = No_Index then - Container.Elements := null; - return; - end if; - - declare - L : constant Index_Type := Container.Last; - E : Elements_Array renames - Container.Elements.EA (Index_Type'First .. L); - - begin - Container.Elements := null; - Container.Last := No_Index; - Container.Busy := 0; - Container.Lock := 0; - - Container.Elements := new Elements_Type (L); - - for I in E'Range loop - if E (I) /= null then - Container.Elements.EA (I) := new Element_Type'(E (I).all); - end if; - - Container.Last := I; - end loop; - end; - end Adjust; - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert - (Container, - Container.Last + 1, - New_Item); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert - (Container, - Container.Last + 1, - New_Item, - Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Append (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Count_Type is - begin - if Container.Elements = null then - return 0; - end if; - - return Container.Elements.EA'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - while Container.Last >= Index_Type'First loop - declare - X : Element_Access := Container.Elements.EA (Container.Last); - begin - Container.Elements.EA (Container.Last) := null; - Container.Last := Container.Last - 1; - Free (X); - end; - end loop; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type - is - E : Element_Access; - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - E := Container.Elements.EA (Position.Index); - - if E = null then - raise Constraint_Error with "element at Position is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type - is - E : Element_Access; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Count_Type := 0) return Vector - is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Length; - - elsif Capacity >= Source.Length then - C := Capacity; - - else - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - return Target : Vector do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1) - is - Old_Last : constant Index_Type'Base := Container.Last; - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - J : Index_Type'Base; -- first index of items that slide down - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - -- Here and elsewhere we treat deleting 0 items from the container as a - -- no-op, even when the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- The internal elements array isn't guaranteed to exist unless we have - -- elements, so we handle that case here in order to avoid having to - -- check it later. (Note that an empty vector can never be busy, so - -- there's no semantic harm in returning early.) - - if Container.Is_Empty then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete checks the count to determine whether it is - -- being called while the associated callback procedure is executing. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If the number of elements requested (Count) for deletion is equal to - -- (or greater than) the number of elements available (Count2) for - -- deletion beginning at Index, then everything from Index to - -- Container.Last is deleted (this is equivalent to Delete_Last). - - if Count >= Count2 then - -- Elements in an indefinite vector are allocated, so we must iterate - -- over the loop and deallocate elements one-at-a-time. We work from - -- back to front, deleting the last element during each pass, in - -- order to gracefully handle deallocation failures. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - while Container.Last >= Index loop - declare - K : constant Index_Type := Container.Last; - X : Element_Access := EA (K); - - begin - -- We first isolate the element we're deleting, removing it - -- from the vector before we attempt to deallocate it, in - -- case the deallocation fails. - - EA (K) := null; - Container.Last := K - 1; - - -- Container invariants have been restored, so it is now - -- safe to attempt to deallocate the element. - - Free (X); - end; - end loop; - end; - - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. For the elements that slide down, - -- index value New_Last is the last index value of their new home, and - -- index value J is the first index of their old home. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - New_Last := Old_Last - Index_Type'Base (Count); - J := Index + Index_Type'Base (Count); - - else - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - J := Index_Type'Base (Count_Type'Base (Index) + Count); - end if; - - -- The internal elements array isn't guaranteed to exist unless we have - -- elements, but we have that guarantee here because we know we have - -- elements to slide. The array index values for each slice have - -- already been determined, so what remains to be done is to first - -- deallocate the elements that are being deleted, and then slide down - -- to Index the elements that aren't being deleted. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - -- Before we can slide down the elements that aren't being deleted, - -- we need to deallocate the elements that are being deleted. - - for K in Index .. J - 1 loop - declare - X : Element_Access := EA (K); - - begin - -- First we remove the element we're about to deallocate from - -- the vector, in case the deallocation fails, in order to - -- preserve representation invariants. - - EA (K) := null; - - -- The element has been removed from the vector, so it is now - -- safe to attempt to deallocate it. - - Free (X); - end; - end loop; - - EA (Index .. New_Last) := EA (J .. Old_Last); - Container.Last := New_Last; - end; - end Delete; - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1) - is - pragma Warnings (Off, Position); - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - - Delete (Container, Position.Index, Count); - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - end if; - - if Count >= Length (Container) then - Clear (Container); - return; - end if; - - Delete (Container, Index_Type'First, Count); - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - -- It is not permitted to delete items while the container is busy (for - -- example, we're in the middle of a passive iteration). However, we - -- always treat deleting 0 items as a no-op, even when we're busy, so we - -- simply return without checking. - - if Count = 0 then - return; - end if; - - -- We cannot simply subsume the empty case into the loop below (the loop - -- would iterate 0 times), because we rename the internal array object - -- (which is allocated), but an empty vector isn't guaranteed to have - -- actually allocated an array. (Note that an empty vector can never be - -- busy, so there's no semantic harm in returning early here.) - - if Container.Is_Empty then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete_Last checks the count to determine whether - -- it is being called while the associated callback procedure is - -- executing. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - -- Elements in an indefinite vector are allocated, so we must iterate - -- over the loop and deallocate elements one-at-a-time. We work from - -- back to front, deleting the last element during each pass, in order - -- to gracefully handle deallocation failures. - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop - declare - J : constant Index_Type := Container.Last; - X : Element_Access := E (J); - - begin - -- Note that we first isolate the element we're deleting, - -- removing it from the vector, before we actually deallocate - -- it, in order to preserve representation invariants even if - -- the deallocation fails. - - E (J) := null; - Container.Last := J - 1; - - -- Container invariants have been restored, so it is now safe - -- to deallocate the element. - - Free (X); - end; - end loop; - end; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - EA : constant Element_Access := Container.Elements.EA (Index); - - begin - if EA = null then - raise Constraint_Error with "element is empty"; - end if; - - return EA.all; - end; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - declare - EA : constant Element_Access := - Position.Container.Elements.EA (Position.Index); - - begin - if EA = null then - raise Constraint_Error with "element is empty"; - end if; - - return EA.all; - end; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Vector) is - begin - Clear (Container); -- Checks busy-bit - - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := null; - Free (X); - end; - end Finalize; - - procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - begin - if Position.Container /= null then - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) /= null - and then Container.Elements.EA (J).all = Item - then - return (Container'Unrestricted_Access, J); - end if; - end loop; - - return No_Element; - end Find; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - begin - for Indx in Index .. Container.Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return Indx; - end if; - end loop; - - return No_Index; - end Find_Index; - - ----------- - -- First -- - ----------- - - function First (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - end if; - - return (Container'Unrestricted_Access, Index_Type'First); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the First (and Last) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (forward) iteration starts from the (logical) beginning of the entire - -- sequence of items (corresponding to Container.First, for a forward - -- iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component isn't No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (forward) partial iteration begins. - - if Object.Index = No_Index then - return First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - declare - EA : constant Element_Access := - Container.Elements.EA (Index_Type'First); - - begin - if EA = null then - raise Constraint_Error with "first element is empty"; - end if; - - return EA.all; - end; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Less (L, R : Element_Access) return Boolean; - pragma Inline (Is_Less); - - ------------- - -- Is_Less -- - ------------- - - function Is_Less (L, R : Element_Access) return Boolean is - begin - if L = null then - return R /= null; - elsif R = null then - return False; - else - return L.all < R.all; - end if; - end Is_Less; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - begin - if Container.Last <= Index_Type'First then - return True; - end if; - - declare - E : Elements_Array renames Container.Elements.EA; - begin - for I in Index_Type'First .. Container.Last - 1 loop - if Is_Less (E (I + 1), E (I)) then - return False; - end if; - end loop; - end; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target, Source : in out Vector) is - I, J : Index_Type'Base; - - begin - - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Last < Index_Type'First then -- Source is empty - return; - end if; - - if Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Target.Last < Index_Type'First then -- Target is empty - Move (Target => Target, Source => Source); - return; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - I := Target.Last; -- original value (before Set_Length) - Target.Set_Length (Length (Target) + Length (Source)); - - J := Target.Last; -- new value (after Set_Length) - while Source.Last >= Index_Type'First loop - pragma Assert - (Source.Last <= Index_Type'First - or else not (Is_Less - (Source.Elements.EA (Source.Last), - Source.Elements.EA (Source.Last - 1)))); - - if I < Index_Type'First then - declare - Src : Elements_Array renames - Source.Elements.EA (Index_Type'First .. Source.Last); - - begin - Target.Elements.EA (Index_Type'First .. J) := Src; - Src := (others => null); - end; - - Source.Last := No_Index; - return; - end if; - - pragma Assert - (I <= Index_Type'First - or else not (Is_Less - (Target.Elements.EA (I), - Target.Elements.EA (I - 1)))); - - declare - Src : Element_Access renames Source.Elements.EA (Source.Last); - Tgt : Element_Access renames Target.Elements.EA (I); - - begin - if Is_Less (Src, Tgt) then - Target.Elements.EA (J) := Tgt; - Tgt := null; - I := I - 1; - - else - Target.Elements.EA (J) := Src; - Src := null; - Source.Last := Source.Last - 1; - end if; - end; - - J := J - 1; - end loop; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is new Generic_Array_Sort - (Index_Type => Index_Type, - Element_Type => Element_Access, - Array_Type => Elements_Array, - "<" => Is_Less); - - -- Start of processing for Sort - - begin - if Container.Last <= Index_Type'First then - return; - end if; - - -- The exception behavior for the vector container must match that - -- for the list container, so we check for cursor tampering here - -- (which will catch more things) instead of for element tampering - -- (which will catch fewer things). It's true that the elements of - -- this vector container could be safely moved around while (say) an - -- iteration is taking place (iteration only increments the busy - -- counter), and so technically all we would need here is a test for - -- element tampering (indicated by the lock counter), that's simply - -- an artifact of our array-based implementation. Logically Sort - -- requires a check for cursor tampering. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - end Sort; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - end if; - - return Position.Index <= Position.Container.Last; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - New_Last := No_Index + Index_Type'Base (New_Length); - - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In an indefinite vector, elements are allocated individually, and - -- stored as access values on the internal array (the length of which - -- represents the vector "capacity"), which is separately allocated. - - Container.Elements := new Elements_Type (New_Last); - - -- The element backbone has been successfully allocated, so now we - -- allocate the elements. - - for Idx in Container.Elements.EA'Range loop - - -- In order to preserve container invariants, we always attempt - -- the element allocation first, before setting the Last index - -- value, in case the allocation fails (either because there is no - -- storage available, or because element initialization fails). - - declare - -- The element allocator may need an accessibility check in the - -- case actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now safe to - -- update the Last index, restoring container invariants. - - Container.Last := Idx; - end loop; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - if New_Length <= Container.Elements.EA'Length then - - -- In this case, we're inserting elements into a vector that has - -- already allocated an internal array, and the existing array has - -- enough unused storage for the new items. - - declare - E : Elements_Array renames Container.Elements.EA; - K : Index_Type'Base; - - begin - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - for Idx in Before .. New_Last loop - - -- In order to preserve container invariants, we always - -- attempt the element allocation first, before setting the - -- Last index value, in case the allocation fails (either - -- because there is no storage available, or because element - -- initialization fails). - - declare - -- The element allocator may need an accessibility check - -- in case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - E (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now - -- safe to update the Last index, restoring container - -- invariants. - - Container.Last := Idx; - end loop; - - else - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - -- The new items are being inserted in the middle of the array, - -- in the range [Before, Index). Copy the existing elements to - -- the end of the array, to make room for the new items. - - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; - - -- We have copied the existing items up to the end of the - -- array, to make room for the new items in the middle of - -- the array. Now we actually allocate the new items. - - -- Note: initialize K outside loop to make it clear that - -- K always has a value if the exception handler triggers. - - K := Before; - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - while K < Index loop - E (K) := new Element_Type'(New_Item); - K := K + 1; - end loop; - - exception - when others => - - -- Values in the range [Before, K) were successfully - -- allocated, but values in the range [K, Index) are - -- stale (these array positions contain copies of the - -- old items, that did not get assigned a new item, - -- because the allocation failed). We must finish what - -- we started by clearing out all of the stale values, - -- leaving a "hole" in the middle of the array. - - E (K .. Index - 1) := (others => null); - raise; - end; - end if; - end; - - return; - end if; - - -- In this case, we're inserting elements into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - end if; - - New_Capacity := 2 * New_Capacity; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array) to the new array (the "destination" array), and then - -- deallocate the old array. - - declare - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. - - Container.Elements := Dst; - Free (Src); - - -- Now we append the new items. - - for Idx in Before .. New_Last loop - - -- In order to preserve container invariants, we always - -- attempt the element allocation first, before setting the - -- Last index value, in case the allocation fails (either - -- because there is no storage available, or because element - -- initialization fails). - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Dst.EA (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now safe - -- to update the Last index, restoring container invariants. - - Container.Last := Idx; - end loop; - - else - -- The new items are being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Index := Before + Index_Type'Base (Count); - - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. - - Container.Elements := Dst; - Container.Last := New_Last; - Free (Src); - - -- The new array has a range in the middle containing null access - -- values. We now fill in that partition of the array with the new - -- items. - - for Idx in Before .. Index - 1 loop - - -- Note that container invariants have already been satisfied - -- (in particular, the Last index value of the vector has - -- already been updated), so if this allocation fails we simply - -- let it propagate. - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Dst.EA (Idx) := new Element_Type'(New_Item); - end; - end loop; - end if; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - J : Index_Type'Base; - - begin - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - if Container'Address /= New_Item'Address then - - -- This is the simple case. New_Item denotes an object different - -- from Container, so there's nothing special we need to do to copy - -- the source items to their destination, because all of the source - -- items are contiguous. - - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. New_Item.Last; - - Src : Elements_Array renames - New_Item.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - Dst_Index := Before - 1; - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; - - return; - end if; - - -- New_Item denotes the same object as Container, so an insertion has - -- potentially split the source items. The first source slice is - -- [Index_Type'First, Before), and the second source slice is - -- [J, Container.Last], where index value J is the first index of the - -- second slice. (J gets computed below, but only after we have - -- determined that the second source slice is non-empty.) The - -- destination slice is always the range [Before, J). We perform the - -- copy in two steps, using each of the two slices of the source items. - - declare - L : constant Index_Type'Base := Before - 1; - - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. L; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - -- We first copy the source items that precede the space we - -- inserted. (If Before equals Index_Type'First, then this first - -- source slice will be empty, which is harmless.) - - Dst_Index := Before - 1; - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - - if Src'Length = N then - - -- The new items were effectively appended to the container, so we - -- have already copied all of the items that need to be copied. - -- We return early here, even though the source slice below is - -- empty (so the assignment would be harmless), because we want to - -- avoid computing J, which will overflow if J is greater than - -- Index_Type'Base'Last. - - return; - end if; - end; - - -- Index value J is the first index of the second source slice. (It is - -- also 1 greater than the last index of the destination slice.) Note: - -- avoid computing J if J is greater than Index_Type'Base'Last, in order - -- to avoid overflow. Prevent that by returning early above, immediately - -- after copying the first slice of the source, and determining that - -- this second slice of the source is empty. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - J := Before + Index_Type'Base (N); - - else - J := Index_Type'Base (Count_Type'Base (Before) + N); - end if; - - declare - subtype Src_Index_Subtype is Index_Type'Base range - J .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - -- We next copy the source items that follow the space we inserted. - -- Index value Dst_Index is the first index of that portion of the - -- destination that receives this slice of the source. (For the - -- reasons given above, this slice is guaranteed to be non-empty.) - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Dst_Index := J - Index_Type'Base (Src'Length); - - else - Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); - end if; - - for Src_Index in Src'Range loop - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - - Dst_Index := Dst_Index + 1; - end loop; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector) - is - Index : Index_Type'Base; - - begin - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor) - is - Index : Index_Type'Base; - - begin - if Before.Container /= null - and then Before.Container /= - Vector_Access'(Container'Unrestricted_Access) - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - - Position := Cursor'(Container'Unrestricted_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - - Position := (Container'Unrestricted_Access, Index); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - New_Last := No_Index + Index_Type'Base (New_Length); - - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In an indefinite vector, elements are allocated individually, and - -- stored as access values on the internal array (the length of which - -- represents the vector "capacity"), which is separately allocated. - -- We have no elements here (because we're inserting "space"), so all - -- we need to do is allocate the backbone. - - Container.Elements := new Elements_Type (New_Last); - Container.Last := New_Last; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on exit. - -- Insert checks the count to determine whether it is being called while - -- the associated callback procedure is executing. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - if New_Length <= Container.Elements.EA'Length then - -- In this case, we're inserting elements into a vector that has - -- already allocated an internal array, and the existing array has - -- enough unused storage for the new items. - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - if Before <= Container.Last then - - -- The new space is being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Index := Before + Index_Type'Base (Count); - - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index - 1) := (others => null); - end if; - end; - - Container.Last := New_Last; - return; - end if; - - -- In this case, we're inserting elements into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - end if; - - New_Capacity := 2 * New_Capacity; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array) to the new array (the "destination" array), and then - -- deallocate the old array. - - declare - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - - if Before <= Container.Last then - - -- The new items are being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Index := Before + Index_Type'Base (Count); - - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - end if; - - -- We have copied the elements from to the old, source array to the - -- new, destination array, so we can now restore invariants, and - -- deallocate the old array. - - Container.Elements := Dst; - Container.Last := New_Last; - Free (Src); - end; - end Insert_Space; - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count); - - Position := Cursor'(Container'Unrestricted_Access, Index); - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - B : Natural renames Container'Unrestricted_Access.all.Busy; - - begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - - function Iterate (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - - begin - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is No_Index (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) - do - B := B + 1; - end return; - end Iterate; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; - - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is not No_Index (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) - do - B := B + 1; - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - end if; - - return (Container'Unrestricted_Access, Container.Last); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the Last (and First) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (reverse) iteration starts from the (logical) beginning of the entire - -- sequence (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component is not No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (reverse) partial iteration begins. - - if Object.Index = No_Index then - return Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end Last; - - ----------------- - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - declare - EA : constant Element_Access := - Container.Elements.EA (Container.Last); - - begin - if EA = null then - raise Constraint_Error with "last element is empty"; - end if; - - return EA.all; - end; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Count_Type is - L : constant Index_Type'Base := Container.Last; - F : constant Index_Type := Index_Type'First; - - begin - -- The base range of the index type (Index_Type'Base) might not include - -- all values for length (Count_Type). Contrariwise, the index type - -- might include values outside the range of length. Hence we use - -- whatever type is wider for intermediate values when calculating - -- length. Note that no matter what the index type is, the maximum - -- length to which a vector is allowed to grow is always the minimum - -- of Count_Type'Last and (IT'Last - IT'First + 1). - - -- For example, an Index_Type with range -127 .. 127 is only guaranteed - -- to have a base range of -128 .. 127, but the corresponding vector - -- would have lengths in the range 0 .. 255. In this case we would need - -- to use Count_Type'Base for intermediate values. - - -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The - -- vector would have a maximum length of 10, but the index values lie - -- outside the range of Count_Type (which is only 32 bits). In this - -- case we would need to use Index_Type'Base for intermediate values. - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - return Count_Type'Base (L) - Count_Type'Base (F) + 1; - else - return Count_Type (L - F + 1); - end if; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Vector; - Source : in out Vector) - is - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; - - Clear (Target); -- Checks busy-bit - - declare - Target_Elements : constant Elements_Access := Target.Elements; - begin - Target.Elements := Source.Elements; - Source.Elements := Target_Elements; - end; - - Target.Last := Source.Last; - Source.Last := No_Index; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Index < Position.Container.Last then - return (Position.Container, Position.Index + 1); - end if; - - return No_Element; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong vector"; - end if; - - return Next (Position); - end Next; - - procedure Next (Position : in out Cursor) is - begin - if Position.Container = null then - return; - end if; - - if Position.Index < Position.Container.Last then - Position.Index := Position.Index + 1; - else - Position := No_Element; - end if; - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, - Index_Type'First, - New_Item, - Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - end if; - - if Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Index > Index_Type'First then - return (Position.Container, Position.Index - 1); - end if; - - return No_Element; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong vector"; - end if; - - return Previous (Position); - end Previous; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - if V.Elements.EA (Index) = null then - raise Constraint_Error with "element is null"; - end if; - - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Query_Element; - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Query_Element (Position.Container.all, Position.Index, Process); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); - - B : Boolean; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - for J in Count_Type range 1 .. Length loop - Last := Last + 1; - - Boolean'Read (Stream, B); - - if B then - Container.Elements.EA (Last) := - new Element_Type'(Element_Type'Input (Stream)); - end if; - - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type - is - E : Element_Access; - - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - E := Container.Elements.EA (Position.Index); - - if E = null then - raise Constraint_Error with "element at Position is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type - is - E : Element_Access; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; - - declare - X : Element_Access := Container.Elements.EA (Index); - - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Index) := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; - - declare - X : Element_Access := Container.Elements.EA (Position.Index); - - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Position.Index) := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type) - is - N : constant Count_Type := Length (Container); - - Index : Count_Type'Base; - Last : Index_Type'Base; - - begin - -- Reserve_Capacity can be used to either expand the storage available - -- for elements (this would be its typical use, in anticipation of - -- future insertion), or to trim back storage. In the latter case, - -- storage can only be trimmed back to the limit of the container - -- length. Note that Reserve_Capacity neither deletes (active) elements - -- nor inserts elements; it only affects container capacity, never - -- container length. - - if Capacity = 0 then - - -- This is a request to trim back storage, to the minimum amount - -- possible given the current state of the container. - - if N = 0 then - - -- The container is empty, so in this unique case we can - -- deallocate the entire internal array. Note that an empty - -- container can never be busy, so there's no need to check the - -- tampering bits. - - declare - X : Elements_Access := Container.Elements; - - begin - -- First we remove the internal array from the container, to - -- handle the case when the deallocation raises an exception - -- (although that's unlikely, since this is simply an array of - -- access values, all of which are null). - - Container.Elements := null; - - -- Container invariants have been restored, so it is now safe - -- to attempt to deallocate the internal array. - - Free (X); - end; - - elsif N < Container.Elements.EA'Length then - - -- The container is not empty, and the current length is less than - -- the current capacity, so there's storage available to trim. In - -- this case, we allocate a new internal array having a length - -- that exactly matches the number of items in the - -- container. (Reserve_Capacity does not delete active elements, - -- so this is the best we can do with respect to minimizing - -- storage). - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (because there is not enough storage), we - -- let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so we can - -- deallocate the old array. - - Free (X); - end; - end if; - - return; - end if; - - -- Reserve_Capacity can be used to expand the storage available for - -- elements, but we do not let the capacity grow beyond the number of - -- values in Index_Type'Range. (Were it otherwise, there would be no way - -- to refer to the elements with index values greater than - -- Index_Type'Last, so that storage would be wasted.) Here we compute - -- the Last index value of the new internal array, in a way that avoids - -- any possibility of overflow. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Capacity); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "Capacity is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Capacity. - - Index := Count_Type'Base (No_Index) + Capacity; -- Last - - if Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - - if Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We have determined that the value of Capacity would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); - end if; - - -- The requested capacity is non-zero, but we don't know yet whether - -- this is a request for expansion or contraction of storage. - - if Container.Elements = null then - - -- The container is empty (it doesn't even have an internal array), - -- so this represents a request to allocate storage having the given - -- capacity. - - Container.Elements := new Elements_Type (Last); - return; - end if; - - if Capacity <= N then - - -- This is a request to trim back storage, but only to the limit of - -- what's already in the container. (Reserve_Capacity never deletes - -- active elements, it only reclaims excess storage.) - - if N < Container.Elements.EA'Length then - - -- The container is not empty (because the requested capacity is - -- positive, and less than or equal to the container length), and - -- the current length is less than the current capacity, so there - -- is storage available to trim. In this case, we allocate a new - -- internal array having a length that exactly matches the number - -- of items in the container. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (because there is not enough storage), we - -- let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so it is now - -- safe to deallocate the old array. - - Free (X); - end; - end if; - - return; - end if; - - -- The requested capacity is larger than the container length (the - -- number of active elements). Whether this represents a request for - -- expansion or contraction of the current capacity depends on what the - -- current capacity is. - - if Capacity = Container.Elements.EA'Length then - - -- The requested capacity matches the existing capacity, so there's - -- nothing to do here. We treat this case as a no-op, and simply - -- return without checking the busy bit. - - return; - end if; - - -- There is a change in the capacity of a non-empty container, so a new - -- internal array will be allocated. (The length of the new internal - -- array could be less or greater than the old internal array. We know - -- only that the length of the new internal array is greater than the - -- number of active elements in the container.) We must check whether - -- the container is busy before doing anything else. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - -- We now allocate a new internal array, having a length different from - -- its current value. - - declare - X : Elements_Access := Container.Elements; - - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - begin - -- We now allocate a new internal array, having a length different - -- from its current value. - - Container.Elements := new Elements_Type (Last); - - -- We have successfully allocated the new internal array, so now we - -- move the existing elements from the existing the old internal - -- array onto the new one. Note that we're just copying access - -- values, to this should not raise any exceptions. - - Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); - - -- We have moved the elements from the old internal array, so now we - -- can deallocate it. - - Free (X); - end; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Container.Length <= 1 then - return; - end if; - - -- The exception behavior for the vector container must match that for - -- the list container, so we check for cursor tampering here (which will - -- catch more things) instead of for element tampering (which will catch - -- fewer things). It's true that the elements of this vector container - -- could be safely moved around while (say) an iteration is taking place - -- (iteration only increments the busy counter), and so technically all - -- we would need here is a test for element tampering (indicated by the - -- lock counter), that's simply an artifact of our array-based - -- implementation. Logically Reverse_Elements requires a check for - -- cursor tampering. - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; - - declare - I : Index_Type; - J : Index_Type; - E : Elements_Array renames Container.Elements.EA; - - begin - I := Index_Type'First; - J := Container.Last; - while I < J loop - declare - EI : constant Element_Access := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Last : Index_Type'Base; - - begin - if Position.Container /= null - and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Container = null - or else Position.Index > Container.Last - then - Last := Container.Last; - else - Last := Position.Index; - end if; - - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return (Container'Unrestricted_Access, Indx); - end if; - end loop; - - return No_Element; - end Reverse_Find; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : constant Index_Type'Base := - (if Index > Container.Last then Container.Last else Index); - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return Indx; - end if; - end loop; - - return No_Index; - end Reverse_Find_Index; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - - begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Container : in out Vector; - Length : Count_Type) - is - Count : constant Count_Type'Base := Container.Length - Length; - - begin - -- Set_Length allows the user to set the length explicitly, instead of - -- implicitly as a side-effect of deletion or insertion. If the - -- requested length is less than the current length, this is equivalent - -- to deleting items from the back end of the vector. If the requested - -- length is greater than the current length, then this is equivalent to - -- inserting "space" (nonce items) at the end. - - if Count >= 0 then - Container.Delete_Last (Count); - - elsif Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - - else - Container.Insert_Space (Container.Last + 1, -Count); - end if; - end Set_Length; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I, J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; - - declare - EI : Element_Access renames Container.Elements.EA (I); - EJ : Element_Access renames Container.Elements.EA (J); - - EI_Copy : constant Element_Access := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - procedure Swap - (Container : in out Vector; - I, J : Cursor) - is - begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Container = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - end if; - - if J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - end if; - - Swap (Container, I.Index, J.Index); - end Swap; - - --------------- - -- To_Cursor -- - --------------- - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor - is - begin - if Index not in Index_Type'First .. Container.Last then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Index); - end To_Cursor; - - -------------- - -- To_Index -- - -------------- - - function To_Index (Position : Cursor) return Extended_Index is - begin - if Position.Container = null then - return No_Index; - end if; - - if Position.Index <= Position.Container.Last then - return Position.Index; - end if; - - return No_Index; - end To_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector (Length : Count_Type) return Vector is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type (Last); - - return Vector'(Controlled with Elements, Last, 0, 0); - end To_Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector - is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type (Last); - - -- We use Last as the index of the loop used to populate the internal - -- array with items. In general, we prefer to initialize the loop index - -- immediately prior to entering the loop. However, Last is also used in - -- the exception handler (to reclaim elements that have been allocated, - -- before propagating the exception), and the initialization of Last - -- after entering the block containing the handler confuses some static - -- analysis tools, with respect to whether Last has been properly - -- initialized when the handler executes. So here we initialize our loop - -- variable earlier than we prefer, before entering the block, so there - -- is no ambiguity. - - Last := Index_Type'First; - - declare - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - loop - Elements.EA (Last) := new Element_Type'(New_Item); - exit when Last = Elements.Last; - Last := Last + 1; - end loop; - - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end To_Vector; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Elements.EA (Index) = null then - raise Constraint_Error with "element is null"; - end if; - - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - N : constant Count_Type := Length (Container); - - begin - Count_Type'Base'Write (Stream, N); - - if N = 0 then - return; - end if; - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - for Indx in Index_Type'First .. Container.Last loop - if E (Indx) = null then - Boolean'Write (Stream, False); - else - Boolean'Write (Stream, True); - Element_Type'Output (Stream, E (Indx).all); - end if; - end loop; - end; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Vectors; -- cgit v1.2.3