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 Vector_Iterator_Interfaces.Reversible_Iterator with
+ record
Container : Vector_Access;
Index : Index_Type;
end record;
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
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;
--------------
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;
--------------
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unchecked_Access, Index_Type'First);
end if;
-
- return (Container'Unchecked_Access, Index_Type'First);
end First;
function First (Object : Iterator) return Cursor is
begin
if Is_Empty (Object.Container.all) then
return No_Element;
+ else
+ return Cursor'(Object.Container, Index_Type'First);
end if;
-
- return Cursor'(Object.Container, Index_Type'First);
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;
-- 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_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
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;
-- 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
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;
B := B - 1;
end Iterate;
- function Iterate (Container : Vector)
+ function Iterate
+ (Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
return It;
end Iterate;
- function Iterate (Container : Vector; Start : Cursor)
+ function Iterate
+ (Container : Vector;
+ Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Start.Index);
begin
if Is_Empty (Container) then
return No_Element;
+ else
+ return (Container'Unchecked_Access, Container.Last);
end if;
-
- return (Container'Unchecked_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if Is_Empty (Object.Container.all) then
return No_Element;
+ else
+ return Cursor'(Object.Container, Object.Container.Last);
end if;
-
- return Cursor'(Object.Container, Object.Container.Last);
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 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
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 Index not in Index_Type'First .. Container.Last then
return No_Element;
+ else
+ return Cursor'(Container'Unchecked_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.
Set_Last_Entity
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
-
- -- Update the scope of anonymous access types of discriminants and other
- -- components, to prevent scope anomalies in gigi, when the derivation
- -- appears in a scope nested within that of the parent.
-
- declare
- D : Entity_Id;
-
- begin
- D := First_Entity (Derived_Type);
- while Present (D) loop
- if Ekind_In (D, E_Discriminant, E_Component) then
- if Is_Itype (Etype (D))
- and then Ekind (Etype (D)) = E_Anonymous_Access_Type
- then
- Set_Scope (Etype (D), Current_Scope);
- end if;
- end if;
-
- Next_Entity (D);
- end loop;
- end;
end Build_Derived_Record_Type;
------------------------
Plain_Discrim : Boolean := False;
Stored_Discrim : Boolean := False)
is
+ procedure Set_Anonymous_Type (Id : Entity_Id);
+ -- Id denotes the entity of an access discriminant or anonymous
+ -- access component. Set the type of Id to either the same type of
+ -- Old_C or create a new one depending on whether the parent and
+ -- the child types are in the same scope.
+
+ ------------------------
+ -- Set_Anonymous_Type --
+ ------------------------
+
+ procedure Set_Anonymous_Type (Id : Entity_Id) is
+ Typ : constant Entity_Id := Etype (Old_C);
+
+ begin
+ if Scope (Parent_Base) = Scope (Derived_Base) then
+ Set_Etype (Id, Typ);
+
+ -- The parent and the derived type are in two different scopes.
+ -- Reuse the type of the original discriminant / component by
+ -- copying it in order to preserve all attributes and update the
+ -- scope.
+
+ else
+ Set_Etype (Id, New_Copy (Typ));
+ Set_Scope (Etype (Id), Current_Scope);
+ end if;
+ end Set_Anonymous_Type;
+
+ -- Local variables and constants
+
New_C : constant Entity_Id := New_Copy (Old_C);
- Discrim : Entity_Id;
Corr_Discrim : Entity_Id;
+ Discrim : Entity_Id;
+
+ -- Start of processing for Inherit_Component
begin
pragma Assert (not Is_Tagged or else not Stored_Discrim);
Set_Original_Record_Component (New_C, New_C);
end if;
+ -- Set the proper type of an access discriminant
+
+ if Ekind (New_C) = E_Discriminant
+ and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
+ then
+ Set_Anonymous_Type (New_C);
+ end if;
+
-- If we have inherited a component then see if its Etype contains
-- references to Parent_Base discriminants. In this case, replace
-- these references with the constraints given in Discs. We do not
-- transformation in some error situations.
if Ekind (New_C) = E_Component then
- if (Is_Private_Type (Derived_Base)
- and then not Is_Generic_Type (Derived_Base))
+
+ -- Set the proper type of an anonymous access component
+
+ if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
+ Set_Anonymous_Type (New_C);
+
+ elsif (Is_Private_Type (Derived_Base)
+ and then not Is_Generic_Type (Derived_Base))
or else (Is_Empty_Elmt_List (Discs)
- and then not Expander_Active)
+ and then not Expander_Active)
then
Set_Etype (New_C, Etype (Old_C));
-- type T_2 is new Pack_1.T_1 with ...;
-- end Pack_2;
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
+ Set_Etype (New_C,
+ Constrain_Component_Type
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
end if;
end if;
projects / platform / upstream / linaro-gcc.git / commitdiff