procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
- type Iterator is new
- Vector_Iterator_Interfaces.Reversible_Iterator with record
+ type Iterator is new Limited_Controlled and
+ Vector_Iterator_Interfaces.Reversible_Iterator with
+ record
Container : Vector_Access;
Index : Index_Type;
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;
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
---------
-- "&" --
-- 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.
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.
-- 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.
+ -- Handle easy case first, when the vector parameter (Left) is empty
if Left.Is_Empty then
declare
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
- new Elements_Type'
- (Last => Last,
- EA => LE & Right);
+ new Elements_Type'(Last => Last, EA => LE & Right);
begin
return (Controlled with Elements, Last, 0, 0);
-- 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.
+ -- Handle easy case first, when the vector parameter (Right) is empty
if Right.Is_Empty then
declare
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 --
--------------
begin
if Container.Elements = null then
return 0;
+ else
+ return Container.Elements.EA'Length;
end if;
-
- return Container.Elements.EA'Length;
end Capacity;
-----------
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
+ else
+ Container.Last := No_Index;
end if;
-
- Container.Last := No_Index;
end Clear;
--------------
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 --
------------
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
- end if;
-
- if Position.Index > Position.Container.Last then
+ elsif Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
+ else
+ return Position.Container.Elements.EA (Position.Index);
end if;
-
- return Position.Container.Elements.EA (Position.Index);
end Element;
--------------
Free (X);
end Finalize;
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Busy;
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) = Item then
- return (Container'Unchecked_Access, J);
+ return (Container'Unrestricted_Access, J);
end if;
end loop;
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unrestricted_Access, Index_Type'First);
end if;
-
- return (Container'Unchecked_Access, Index_Type'First);
end First;
function First (Object : Iterator) return Cursor is
- C : constant Cursor := (Object.Container, Index_Type'First);
begin
- return C;
+ if Is_Empty (Object.Container.all) then
+ return No_Element;
+ else
+ return (Object.Container, Index_Type'First);
+ end if;
end First;
-------------------
begin
if Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
+ else
+ return Container.Elements.EA (Index_Type'First);
end if;
-
- return Container.Elements.EA (Index_Type'First);
end First_Element;
-----------------
declare
EA : Elements_Array renames Container.Elements.EA;
begin
- for I in Index_Type'First .. Container.Last - 1 loop
- if EA (I + 1) < EA (I) then
+ for J in Index_Type'First .. Container.Last - 1 loop
+ if EA (J + 1) < EA (J) then
return False;
end if;
end loop;
J : Index_Type'Base;
begin
- if Target.Last < Index_Type'First then
- Move (Target => Target, Source => Source);
+ -- 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
- return;
+ raise Program_Error with
+ "Target and Source denote same non-empty container";
end if;
- if Source.Last < Index_Type'First then
+ if Target.Last < Index_Type'First then -- Target is empty
+ Move (Target => Target, Source => Source);
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.
+ -- we must check the sum of the current length and the insertion count.
+ -- Note: 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";
-- 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.
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.
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;
-- whether there is enough unused storage for the new items.
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.
begin
if Before > Container.Last then
+
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
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.)
DA (Before .. Index - 1) := (others => New_Item);
DA (Index .. New_Last) := SA (Before .. Container.Last);
end if;
+
exception
when others =>
Free (Dst);
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.
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
Container.Elements.EA (Before .. K) := Src;
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
K : Index_Type'Base;
begin
- -- We next copy the source items that follow the space we
- -- inserted. Index value K is the first index of that portion of the
+ -- We next copy the source items that follow the space we inserted.
+ -- Index value K 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.)
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
+ else
+ Index := Container.Last + 1;
end if;
- Index := Container.Last + 1;
-
else
Index := Before.Index;
end if;
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
Insert (Container, Index, New_Item, Count);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
-- 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.
+ -- we must check the sum of the current length and the insertion count.
+ -- Note: 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";
-- 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.
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.
-- whether there is enough unused storage for the new items.
if New_Last <= Container.Elements.Last then
+
-- In this case, we're inserting space into a vector that has already
-- allocated an internal array, and the existing array has enough
-- unused storage for the new items.
begin
if Before <= Container.Last then
+
-- The 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
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.)
SA (Index_Type'First .. Before - 1);
if Before <= Container.Last then
+
-- The space is being inserted before some existing elements, so
-- we must slide the existing elements up to their new home.
DA (Index .. New_Last) := SA (Before .. Container.Last);
end if;
+
exception
when others =>
Free (Dst);
declare
X : Elements_Access := Container.Elements;
+
begin
-- We first isolate the old internal array, removing it from the
-- container and replacing it with the new internal array, before we
begin
if Before.Container /= null
- and then Before.Container /= Container'Unchecked_Access
+ and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
then
Position := No_Element;
else
- Position := (Container'Unchecked_Access, Before.Index);
+ Position := (Container'Unrestricted_Access, Before.Index);
end if;
return;
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
+ else
+ Index := Container.Last + 1;
end if;
- Index := Container.Last + 1;
-
else
Index := Before.Index;
end if;
Insert_Space (Container, Index, Count => Count);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert_Space;
--------------
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
- V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Busy;
+ 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'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
B := B - 1;
end Iterate;
- function Iterate (Container : Vector)
- return Vector_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : Vector)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
- It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Index_Type'First)
+ do
+ B := B + 1;
+ end return;
end Iterate;
- function Iterate (Container : Vector; Start : Cursor)
- return Vector_Iterator_Interfaces.Forward_Iterator'class
+ function Iterate
+ (Container : Vector;
+ Start : Cursor)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
- It : constant Iterator :=
- (Container'Unchecked_Access, Start.Index);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Start.Index)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Last);
end if;
-
- return (Container'Unchecked_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
- C : constant Cursor := (Object.Container, Object.Container.Last);
begin
- return C;
+ if Is_Empty (Object.Container.all) then
+ return No_Element;
+ else
+ return (Object.Container, Object.Container.Last);
+ end if;
end Last;
------------------
begin
if Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
+ else
+ return Container.Elements.EA (Container.Last);
end if;
-
- return Container.Elements.EA (Container.Last);
end Last_Element;
----------------
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Next;
- function Next (Object : Iterator; Position : Cursor) return Cursor
- is
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
- if Position.Index = Object.Container.Last then
- return No_Element;
-
- else
+ if Position.Index < Object.Container.Last then
return (Object.Container, Position.Index + 1);
+ else
+ return No_Element;
end if;
end Next;
- ----------
- -- Next --
- ----------
-
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1;
else
Position := No_Element;
-- 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
+ elsif Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Previous;
- function Previous (Object : Iterator; Position : Cursor) return Cursor
- is
+ function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Index > Index_Type'First then
return (Object.Container, Position.Index - 1);
end if;
end Previous;
+ procedure Previous (Position : in out Cursor) is
+ begin
+ if Position.Container = null then
+ return;
+ elsif Position.Index > Index_Type'First then
+ Position.Index := Position.Index - 1;
+ else
+ Position := No_Element;
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
---------------
function Constant_Reference
- (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED
- return Constant_Reference_Type is
+ (Container : Vector;
+ Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type
+ is
begin
pragma Unreferenced (Container);
end Constant_Reference;
function Constant_Reference
- (Container : Vector; Position : Index_Type)
- return Constant_Reference_Type is
+ (Container : Vector;
+ Position : Index_Type)
+ return Constant_Reference_Type
+ is
begin
- if (Position) > Container.Last then
+ if Position > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return (Element => Container.Elements.EA (Position)'Access);
end if;
-
- return (Element => Container.Elements.EA (Position)'Access);
end Constant_Reference;
function Reference (Container : Vector; Position : Cursor)
begin
if Position > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return (Element => Container.Elements.EA (Position)'Access);
end if;
-
- return (Element => Container.Elements.EA (Position)'Access);
end Reference;
---------------------
-- 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
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.
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
-- 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.
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.
-- 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 (expand) storage having
-- the given capacity.
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
-- 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.
declare
X : Elements_Access := Container.Elements;
+
begin
-- First we isolate the old internal array, and replace it in the
-- container with the new internal array.
begin
if Position.Container /= null
- and then Position.Container /= Container'Unchecked_Access
+ and then Position.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Position cursor denotes wrong container";
end if;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
- return (Container'Unchecked_Access, Indx);
+ return (Container'Unrestricted_Access, Indx);
end if;
end loop;
begin
for Indx in reverse Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
begin
if Index not in Index_Type'First .. Container.Last then
return No_Element;
+ else
+ return (Container'Unrestricted_Access, Index);
end if;
-
- return Cursor'(Container'Unchecked_Access, Index);
end To_Cursor;
--------------
-- 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.
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.
-- 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.
OSDN Git Service
