-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, 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- --
with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
+
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Vectors is
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;
+ 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;
+
---------
-- "&" --
---------
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 --
--------------
end loop;
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : Vector;
+ Position : Cursor) return Constant_Reference_Type
+ is
+ begin
+ pragma Unreferenced (Container);
+
+ 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;
+
+ return
+ (Element => Position.Container.Elements.EA (Position.Index).all'Access);
+ end Constant_Reference;
+
+ function Constant_Reference
+ (Container : Vector;
+ Position : Index_Type) return Constant_Reference_Type
+ is
+ begin
+ if (Position) > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return (Element => Container.Elements.EA (Position).all'Access);
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
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 --
------------
end;
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 --
----------
if Container.Elements.EA (J) /= null
and then Container.Elements.EA (J).all = Item
then
- return (Container'Unchecked_Access, J);
+ return (Container'Unrestricted_Access, J);
end if;
end loop;
return No_Element;
end if;
- return (Container'Unchecked_Access, Index_Type'First);
+ return (Container'Unrestricted_Access, Index_Type'First);
+ end First;
+
+ function First (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Index_Type'First);
+ begin
+ return C;
end First;
-------------------
I, 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
+ -- 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
-- 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.
-- 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
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.
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
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;
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.)
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.
-- 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
-- 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
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
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
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
- -- that we want to avoid computing J, if J is greater than
- -- Index_Type'Base'Last, in order to avoid overflow. We 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.
+ -- 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);
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.)
+ -- 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);
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 /= Vector_Access'(Container'Unchecked_Access)
+ and then Before.Container /=
+ Vector_Access'(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 := Cursor'(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;
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 := (Container'Unchecked_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
------------------
-- 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.
-- 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.
+ -- 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;
-- 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.
+ -- 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
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
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.)
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.
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_Space (Container, Index, Count);
- Position := Cursor'(Container'Unchecked_Access, Index);
+ Position := Cursor'(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
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
+ begin
+ 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.Reversible_Iterator'class
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
+ begin
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Index => Start.Index)
+ do
+ B := B + 1;
+ end return;
+ end Iterate;
+
----------
-- Last --
----------
return No_Element;
end if;
- return (Container'Unchecked_Access, Container.Last);
+ return (Container'Unrestricted_Access, Container.Last);
+ end Last;
+
+ function Last (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Object.Container.Last);
+ begin
+ return C;
end Last;
-----------------
return No_Element;
end Next;
- ----------
- -- Next --
- ----------
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Index = Object.Container.Last then
+ return No_Element;
+ else
+ return (Object.Container, Position.Index + 1);
+ end if;
+ end Next;
procedure Next (Position : in out Cursor) is
begin
return No_Element;
end Previous;
+ function Previous (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Index > Index_Type'First then
+ return (Object.Container, Position.Index - 1);
+ else
+ return No_Element;
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
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 : Vector;
+ Position : Cursor) return Reference_Type
+ is
+ begin
+ pragma Unreferenced (Container);
+
+ 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;
+
+ return
+ (Element =>
+ Position.Container.Elements.EA (Position.Index).all'Access);
+ end Reference;
+
+ function Reference
+ (Container : Vector;
+ Position : Index_Type) return Reference_Type
+ is
+ begin
+ if Position > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return (Element => Container.Elements.EA (Position).all'Access);
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
-- 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 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
- -- 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.
+ -- 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
-- 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.
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;
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = 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 =>
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Index);
+ return Cursor'(Container'Unrestricted_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.
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.
-- 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;
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;
OSDN Git Service
