Skip to content

R
riscv-gcc-1
Commit e9f97e79 by Arnaud Charlet
Options

[multiple changes] 

2015-10-20  Bob Duff  <duff@adacore.com>

	* a-coinve.ads, a-coinve.adb: Do the same efficiency
	improvements that were already done in the definite case
	(Ada.Containers.Vectors, i.e. a-convec). This includes the
	ability to suppress checks, the fast path for Append, inlining
	as appropriate, and special-casing of "for ... of" loops. Reuse
	the tampering machinery that is now in Ada.Containers. Simplify
	many operations.
	* a-convec.ads, a-convec.adb: Change the code to be more similar
	to a-coinve.
	* a-finali.ads, a-finali.adb: Expose the "null"-ness of the
	operations. This may enable optimizations in the future, and
	seems cleaner anyway.

2015-10-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Is_Operational_Item): Attributes related to
	Ada 2012 iterators are operational items, and can be specified
	on partial views.

From-SVN: r229033
parent 0489576c
Showing with 598 additions and 1238 deletions
gcc/ada/ChangeLog
2015-10-20 Bob Duff <duff@adacore.com>
* a-coinve.ads, a-coinve.adb: Do the same efficiency
improvements that were already done in the definite case
(Ada.Containers.Vectors, i.e. a-convec). This includes the
ability to suppress checks, the fast path for Append, inlining
as appropriate, and special-casing of "for ... of" loops. Reuse
the tampering machinery that is now in Ada.Containers. Simplify
many operations.
* a-convec.ads, a-convec.adb: Change the code to be more similar
to a-coinve.
* a-finali.ads, a-finali.adb: Expose the "null"-ness of the
operations. This may enable optimizations in the future, and
seems cleaner anyway.
2015-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Is_Operational_Item): Attributes related to
Ada 2012 iterators are operational items, and can be specified
on partial views.
2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> 2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Check_Usage): Update the calls to Usage_Error. * sem_prag.adb (Check_Usage): Update the calls to Usage_Error.
......
gcc/ada/a-coinve.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -36,457 +36,66 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -36,457 +36,66 @@ package body Ada.Containers.Indefinite_Vectors is
pragma Annotate (CodePeer, Skip_Analysis); pragma Annotate (CodePeer, Skip_Analysis);
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
-- See comment in Ada.Containers
procedure Free is procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
procedure Free is procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access); new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
procedure Append_Slow_Path
(Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type);
-- This is the slow path for Append. This is split out to minimize the size
-- of Append, because we have Inline (Append).
--------- ---------
-- "&" -- -- "&" --
--------- ---------
function "&" (Left, Right : Vector) return Vector is -- We decide that the capacity of the result of "&" is the minimum needed
LN : constant Count_Type := Length (Left); -- -- the sum of the lengths of the vector parameters. We could decide to
RN : constant Count_Type := Length (Right); -- make it larger, but we have no basis for knowing how much larger, so we
N : Count_Type'Base; -- length of result -- just allocate the minimum amount of storage.
J : Count_Type'Base; -- for computing intermediate values
Last : Index_Type'Base; -- Last index of result
function "&" (Left, Right : Vector) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the vector parameters. We could decide to make it larger, but we Reserve_Capacity (Result, Length (Left) + Length (Right));
-- have no basis for knowing how much larger, so we just allocate the Append (Result, Left);
-- minimum amount of storage. Append (Result, Right);
end return;
-- 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 "&"; end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is function "&" (Left : Vector; Right : Element_Type) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, Length (Left) + 1);
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- 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 "&"; end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is function "&" (Left : Element_Type; Right : Vector) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, 1 + Length (Right));
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- 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 "&"; end "&";
function "&" (Left, Right : Element_Type) return Vector is function "&" (Left, Right : Element_Type) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, 1 + 1);
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- 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 "&"; end "&";
--------- ---------
...@@ -494,67 +103,31 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -494,67 +103,31 @@ package body Ada.Containers.Indefinite_Vectors is
--------- ---------
overriding function "=" (Left, Right : Vector) return Boolean is overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy; -- Per AI05-0022, the container implementation is required to detect
LL : Natural renames Left'Unrestricted_Access.Lock; -- element tampering by a generic actual subprogram.
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin begin
if Left'Address = Right'Address then
return True;
end if;
if Left.Last /= Right.Last then if Left.Last /= Right.Last then
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect for J in Index_Type range Index_Type'First .. Left.Last loop
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Result := True;
for J in Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) = null then if Left.Elements.EA (J) = null then
if Right.Elements.EA (J) /= null then if Right.Elements.EA (J) /= null then
Result := False; return False;
exit;
end if; end if;
elsif Right.Elements.EA (J) = null then elsif Right.Elements.EA (J) = null then
Result := False; return False;
exit;
elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
Result := False; return False;
exit;
end if; end if;
end loop; end loop;
BL := BL - 1; return True;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end "="; end "=";
------------ ------------
...@@ -576,8 +149,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -576,8 +149,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
Container.Elements := null; Container.Elements := null;
Container.Last := No_Index; Container.Last := No_Index;
Container.Busy := 0; Zero_Counts (Container.TC);
Container.Lock := 0;
Container.Elements := new Elements_Type (L); Container.Elements := new Elements_Type (L);
...@@ -591,20 +163,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -591,20 +163,6 @@ package body Ada.Containers.Indefinite_Vectors is
end; end;
end Adjust; 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 -- -- Append --
------------ ------------
...@@ -613,7 +171,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -613,7 +171,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
elsif Container.Last = Index_Type'Last then elsif Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else else
Insert (Container, Container.Last + 1, New_Item); Insert (Container, Container.Last + 1, New_Item);
...@@ -626,14 +184,56 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -626,14 +184,56 @@ package body Ada.Containers.Indefinite_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
-- In the general case, we pass the buck to Insert, but for efficiency,
-- we check for the usual case where Count = 1 and the vector has enough
-- room for at least one more element.
if Count = 1
and then Container.Elements /= null
and then Container.Last /= Container.Elements.Last
then
TC_Check (Container.TC);
-- Increment Container.Last after assigning the New_Item, so we
-- leave the Container unmodified in case Finalize/Adjust raises
-- an exception.
declare
New_Last : constant Index_Type := Container.Last + 1;
-- 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 (New_Last) := new Element_Type'(New_Item);
Container.Last := New_Last;
end;
else
Append_Slow_Path (Container, New_Item, Count);
end if;
end Append;
----------------------
-- Append_Slow_Path --
----------------------
procedure Append_Slow_Path
(Container : in out Vector;
New_Item : Element_Type;
Count : Count_Type)
is
begin
if Count = 0 then if Count = 0 then
return; return;
elsif Container.Last = Index_Type'Last then elsif Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else else
Insert (Container, Container.Last + 1, New_Item, Count); Insert (Container, Container.Last + 1, New_Item, Count);
end if; end if;
end Append; end Append_Slow_Path;
------------ ------------
-- Assign -- -- Assign --
...@@ -668,21 +268,17 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -668,21 +268,17 @@ package body Ada.Containers.Indefinite_Vectors is
procedure Clear (Container : in out Vector) is procedure Clear (Container : in out Vector) is
begin begin
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
else while Container.Last >= Index_Type'First loop
while Container.Last >= Index_Type'First loop declare
declare X : Element_Access := Container.Elements.EA (Container.Last);
X : Element_Access := Container.Elements.EA (Container.Last); begin
begin Container.Elements.EA (Container.Last) := null;
Container.Elements.EA (Container.Last) := null; Container.Last := Container.Last - 1;
Container.Last := Container.Last - 1; Free (X);
Free (X); end;
end; end loop;
end loop;
end if;
end Clear; end Clear;
------------------------ ------------------------
...@@ -693,72 +289,70 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -693,72 +289,70 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : aliased Vector; (Container : aliased Vector;
Position : Cursor) return Constant_Reference_Type Position : Cursor) return Constant_Reference_Type
is is
E : Element_Access;
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; 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 Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if E = null then if Position.Index > Position.Container.Last then
raise Constraint_Error with "element at Position is empty"; raise Constraint_Error with "Position cursor is out of range";
end if;
end if; end if;
declare if T_Check then
C : Vector renames Container'Unrestricted_Access.all; declare
B : Natural renames C.Busy; TC : constant Tamper_Counts_Access :=
L : Natural renames C.Lock; Container.TC'Unrestricted_Access;
begin begin
-- The following will raise Constraint_Error if Element is null
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Constant_Reference_Type := return R : constant Constant_Reference_Type :=
(Element => E.all'Access, (Element => Container.Elements.EA (Position.Index),
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
(Container : aliased Vector; (Container : aliased Vector;
Index : Index_Type) return Constant_Reference_Type Index : Index_Type) return Constant_Reference_Type
is is
E : Element_Access;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
E := Container.Elements.EA (Index); if T_Check then
declare
if E = null then TC : constant Tamper_Counts_Access :=
raise Constraint_Error with "element at Index is empty"; Container.TC'Unrestricted_Access;
end if; begin
-- The following will raise Constraint_Error if Element is null
declare
C : Vector renames Container'Unrestricted_Access.all; return R : constant Constant_Reference_Type :=
B : Natural renames C.Busy; (Element => Container.Elements.EA (Index),
L : Natural renames C.Lock; Control => (Controlled with TC))
begin do
Lock (TC.all);
end return;
end;
else
return R : constant Constant_Reference_Type := return R : constant Constant_Reference_Type :=
(Element => E.all'Access, (Element => Container.Elements.EA (Index),
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
...@@ -790,9 +384,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -790,9 +384,9 @@ package body Ada.Containers.Indefinite_Vectors is
elsif Capacity >= Source.Length then elsif Capacity >= Source.Length then
C := Capacity; C := Capacity;
else elsif Checks then
raise Capacity_Error raise Capacity_Error with
with "Requested capacity is less than Source length"; "Requested capacity is less than Source length";
end if; end if;
return Target : Vector do return Target : Vector do
...@@ -833,7 +427,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -833,7 +427,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- in the base range that immediately precede and immediately follow the -- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.) -- values in the Index_Type.)
if Index < Index_Type'First then if Checks and then Index < Index_Type'First then
raise Constraint_Error with "Index is out of range (too small)"; raise Constraint_Error with "Index is out of range (too small)";
end if; end if;
...@@ -845,7 +439,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -845,7 +439,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- algorithm, so that case is treated as a proper error.) -- algorithm, so that case is treated as a proper error.)
if Index > Old_Last then if Index > Old_Last then
if Index > Old_Last + 1 then if Checks and then Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)"; raise Constraint_Error with "Index is out of range (too large)";
else else
return; return;
...@@ -874,10 +468,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -874,10 +468,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- the count on exit. Delete checks the count to determine whether it is -- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing. -- being called while the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- We first calculate what's available for deletion starting at -- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and -- Index. Here and elsewhere we use the wider of Index_Type'Base and
...@@ -886,7 +477,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -886,7 +477,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else else
Count2 := Count_Type'Base (Old_Last - Index + 1); Count2 := Count_Type'Base (Old_Last - Index + 1);
end if; end if;
...@@ -938,7 +528,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -938,7 +528,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- index value New_Last is the last index value of their new home, and -- 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. -- index value J is the first index of their old home.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
New_Last := Old_Last - Index_Type'Base (Count); New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count); J := Index + Index_Type'Base (Count);
else else
...@@ -988,22 +578,21 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -988,22 +578,21 @@ package body Ada.Containers.Indefinite_Vectors is
Position : in out Cursor; Position : in out Cursor;
Count : Count_Type := 1) Count : Count_Type := 1)
is is
pragma Warnings (Off, Position);
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
elsif Position.Index > Container.Last then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position index is out of range"; raise Program_Error with "Position cursor denotes wrong container";
else elsif Position.Index > Container.Last then
Delete (Container, Position.Index, Count); raise Program_Error with "Position index is out of range";
Position := No_Element; end if;
end if; end if;
Delete (Container, Position.Index, Count);
Position := No_Element;
end Delete; end Delete;
------------------ ------------------
...@@ -1062,10 +651,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1062,10 +651,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- it is being called while the associated callback procedure is -- it is being called while the associated callback procedure is
-- executing. -- executing.
if Container.Busy > 0 then TC_Check (Container.TC);
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 -- Elements in an indefinite vector are allocated, so we must iterate
-- over the loop and deallocate elements one-at-a-time. We work from -- over the loop and deallocate elements one-at-a-time. We work from
...@@ -1108,14 +694,14 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1108,14 +694,14 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type) return Element_Type Index : Index_Type) return Element_Type
is is
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
declare declare
EA : constant Element_Access := Container.Elements.EA (Index); EA : constant Element_Access := Container.Elements.EA (Index);
begin begin
if EA = null then if Checks and then EA = null then
raise Constraint_Error with "element is empty"; raise Constraint_Error with "element is empty";
else else
return EA.all; return EA.all;
...@@ -1125,19 +711,21 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1125,19 +711,21 @@ package body Ada.Containers.Indefinite_Vectors is
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Index > Position.Container.Last then if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if;
end if; end if;
declare declare
EA : constant Element_Access := EA : constant Element_Access :=
Position.Container.Elements.EA (Position.Index); Position.Container.Elements.EA (Position.Index);
begin begin
if EA = null then if Checks and then EA = null then
raise Constraint_Error with "element is empty"; raise Constraint_Error with "element is empty";
else else
return EA.all; return EA.all;
...@@ -1162,25 +750,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1162,25 +750,9 @@ package body Ada.Containers.Indefinite_Vectors is
end Finalize; end Finalize;
procedure Finalize (Object : in out Iterator) is procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy; pragma Assert (T_Check); -- not called if check suppressed
begin
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin begin
if Control.Container /= null then Unbusy (Object.Container.TC);
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; end Finalize;
---------- ----------
...@@ -1193,7 +765,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1193,7 +765,7 @@ package body Ada.Containers.Indefinite_Vectors is
Position : Cursor := No_Element) return Cursor Position : Cursor := No_Element) return Cursor
is is
begin begin
if Position.Container /= null then if Checks and then Position.Container /= null then
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if; end if;
...@@ -1207,39 +779,15 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1207,39 +779,15 @@ package body Ada.Containers.Indefinite_Vectors is
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container'Unrestricted_Access.Busy; Lock : With_Lock (Container.TC'Unrestricted_Access);
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) /= null if Container.Elements.EA (J).all = Item then
and then Container.Elements.EA (J).all = Item return Cursor'(Container'Unrestricted_Access, J);
then
Result := J;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Element;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end; end;
end Find; end Find;
...@@ -1252,39 +800,18 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1252,39 +800,18 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index Index : Index_Type := Index_Type'First) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
B := B + 1; Lock : With_Lock (Container.TC'Unrestricted_Access);
L := L + 1; begin
Result := No_Index;
for Indx in Index .. Container.Last loop for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx).all = Item then
and then Container.Elements.EA (Indx).all = Item return Indx;
then
Result := Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Index;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index; end Find_Index;
----------- -----------
...@@ -1329,7 +856,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1329,7 +856,7 @@ package body Ada.Containers.Indefinite_Vectors is
function First_Element (Container : Vector) return Element_Type is function First_Element (Container : Vector) return Element_Type is
begin begin
if Container.Last = No_Index then if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty"; raise Constraint_Error with "Container is empty";
end if; end if;
...@@ -1337,7 +864,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1337,7 +864,7 @@ package body Ada.Containers.Indefinite_Vectors is
EA : constant Element_Access := EA : constant Element_Access :=
Container.Elements.EA (Index_Type'First); Container.Elements.EA (Index_Type'First);
begin begin
if EA = null then if Checks and then EA = null then
raise Constraint_Error with "first element is empty"; raise Constraint_Error with "first element is empty";
else else
return EA.all; return EA.all;
...@@ -1397,36 +924,16 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1397,36 +924,16 @@ package body Ada.Containers.Indefinite_Vectors is
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
Lock : With_Lock (Container.TC'Unrestricted_Access);
E : Elements_Array renames Container.Elements.EA; E : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
B := B + 1; for J in Index_Type'First .. Container.Last - 1 loop
L := L + 1; if Is_Less (E (J + 1), E (J)) then
return False;
Result := True;
for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then
Result := False;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return True;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end; end;
end Is_Sorted; end Is_Sorted;
...@@ -1450,7 +957,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1450,7 +957,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Target'Address = Source'Address then if Checks and then Target'Address = Source'Address then
raise Program_Error with raise Program_Error with
"Target and Source denote same non-empty container"; "Target and Source denote same non-empty container";
end if; end if;
...@@ -1460,10 +967,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1460,10 +967,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Source.Busy > 0 then TC_Check (Source.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
I := Target.Last; -- original value (before Set_Length) I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source)); Target.Set_Length (Length (Target) + Length (Source));
...@@ -1475,19 +979,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1475,19 +979,9 @@ package body Ada.Containers.Indefinite_Vectors is
TA : Elements_Array renames Target.Elements.EA; TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA; SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy; Lock_Target : With_Lock (Target.TC'Unchecked_Access);
TL : Natural renames Target.Lock; Lock_Source : With_Lock (Source.TC'Unchecked_Access);
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last; -- new value (after Set_Length) J := Target.Last; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop while Source.Last >= Index_Type'First loop
pragma Assert pragma Assert
...@@ -1531,22 +1025,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1531,22 +1025,6 @@ package body Ada.Containers.Indefinite_Vectors is
J := J - 1; J := J - 1;
end loop; end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end; end;
end Merge; end Merge;
...@@ -1579,38 +1057,30 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1579,38 +1057,30 @@ package body Ada.Containers.Indefinite_Vectors is
-- an artifact of our array-based implementation. Logically Sort -- an artifact of our array-based implementation. Logically Sort
-- requires a check for cursor tampering. -- requires a check for cursor tampering.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container.Busy; Lock : With_Lock (Container.TC'Unchecked_Access);
L : Natural renames Container.Lock;
begin begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end; end;
end Sort; end Sort;
end Generic_Sorting; end Generic_Sorting;
------------------------
-- Get_Element_Access --
------------------------
function Get_Element_Access
(Position : Cursor) return not null Element_Access is
begin
return Position.Container.Elements.EA (Position.Index);
end Get_Element_Access;
----------------- -----------------
-- Has_Element -- -- Has_Element --
----------------- -----------------
...@@ -1648,33 +1118,33 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1648,33 +1118,33 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array Dst : Elements_Access; -- new, expanded internal array
begin begin
-- As a precondition on the generic actual Index_Type, the base type if Checks then
-- must include Index_Type'Pred (Index_Type'First); this is the value -- As a precondition on the generic actual Index_Type, the base type
-- that Container.Last assumes when the vector is empty. However, we do -- must include Index_Type'Pred (Index_Type'First); this is the value
-- not allow that as the value for Index when specifying where the new -- that Container.Last assumes when the vector is empty. However, we
-- items should be inserted, so we must manually check. (That the user -- do not allow that as the value for Index when specifying where the
-- is allowed to specify the value at all here is a consequence of the -- new items should be inserted, so we must manually check. (That the
-- declaration of the Extended_Index subtype, which includes the values -- user is allowed to specify the value at all here is a consequence
-- in the base range that immediately precede and immediately follow the -- of the declaration of the Extended_Index subtype, which includes
-- values in the Index_Type.) -- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
end if; end if;
-- We do allow a value greater than Container.Last to be specified as -- 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 -- the Index, but only if it's immediately greater. This allows for
-- case of appending items to the back end of the vector. (It is assumed -- the case of appending items to the back end of the vector. (It is
-- that specifying an index value greater than Last + 1 indicates some -- assumed that specifying an index value greater than Last + 1
-- deeper flaw in the caller's algorithm, so that case is treated as a -- indicates some deeper flaw in the caller's algorithm, so that case
-- proper error.) -- is treated as a proper error.)
if Before > Container.Last if Before > Container.Last + 1 then
and then Before > Container.Last + 1 raise Constraint_Error with
then "Before index is out of range (too large)";
raise Constraint_Error with end if;
"Before index is out of range (too large)";
end if; end if;
-- We treat inserting 0 items into the container as a no-op, even when -- We treat inserting 0 items into the container as a no-op, even when
...@@ -1687,10 +1157,10 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1687,10 +1157,10 @@ package body Ada.Containers.Indefinite_Vectors is
-- There are two constraints we need to satisfy. The first constraint is -- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so -- 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. -- we must check the sum of the current length and the insertion count.
-- Note that we cannot simply add these values, because of the -- Note: we cannot simply add these values, because of the possibility
-- possibility of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Checks and then Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -1705,7 +1175,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1705,7 +1175,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- compare the new length to the maximum length. If the new length is -- compare the new length to the maximum length. If the new length is
-- acceptable, then we compute the new last index from that. -- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the -- 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. -- range of Index_Type than in the range of Count_Type.
...@@ -1740,9 +1210,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1740,9 +1210,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- worry about if No_Index were less than 0, but that case is -- worry about if No_Index were less than 0, but that case is
-- handled above). -- handled above).
if Index_Type'Last - No_Index >= if Index_Type'Last - No_Index >= Count_Type_Last then
Count_Type'Pos (Count_Type'Last)
then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -1799,7 +1267,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1799,7 +1267,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- an internal array with a last index value greater than -- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements). -- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -1807,7 +1275,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1807,7 +1275,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
-- compute its value from the New_Length. -- compute its value from the New_Length.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
...@@ -1863,10 +1331,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1863,10 +1331,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- exit. Insert checks the count to determine whether it is being called -- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing. -- while the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
if New_Length <= Container.Elements.EA'Length then if New_Length <= Container.Elements.EA'Length then
...@@ -1916,7 +1381,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1916,7 +1381,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- new home. We use the wider of Index_Type'Base and -- new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values. -- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
...@@ -2002,7 +1467,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2002,7 +1467,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- We have computed the length of the new internal array (and this is -- 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. -- what "vector capacity" means), so use that to compute its last index.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
...@@ -2069,7 +1534,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2069,7 +1534,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being inserted before some existing elements, -- The new items are being inserted before some existing elements,
-- so we must slide the existing elements up to their new home. -- so we must slide the existing elements up to their new home.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
...@@ -2219,7 +1684,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2219,7 +1684,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- after copying the first slice of the source, and determining that -- after copying the first slice of the source, and determining that
-- this second slice of the source is empty. -- this second slice of the source is empty.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
J := Before + Index_Type'Base (N); J := Before + Index_Type'Base (N);
else else
J := Index_Type'Base (Count_Type'Base (Before) + N); J := Index_Type'Base (Count_Type'Base (Before) + N);
...@@ -2242,7 +1707,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2242,7 +1707,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- destination that receives this slice of the source. (For the -- destination that receives this slice of the source. (For the
-- reasons given above, this slice is guaranteed to be non-empty.) -- reasons given above, this slice is guaranteed to be non-empty.)
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Dst_Index := J - Index_Type'Base (Src'Length); Dst_Index := J - Index_Type'Base (Src'Length);
else else
Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
...@@ -2266,7 +1731,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2266,7 +1731,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -2277,7 +1742,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2277,7 +1742,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Before.Container = null or else Before.Index > Container.Last then if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then if Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
end if; end if;
...@@ -2300,9 +1765,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2300,9 +1765,8 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= and then Before.Container /= Container'Unrestricted_Access
Vector_Access'(Container'Unrestricted_Access)
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
end if; end if;
...@@ -2318,7 +1782,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2318,7 +1782,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Before.Container = null or else Before.Index > Container.Last then if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then if Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
end if; end if;
...@@ -2331,7 +1795,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2331,7 +1795,7 @@ package body Ada.Containers.Indefinite_Vectors is
Insert (Container, Index, New_Item); Insert (Container, Index, New_Item);
Position := Cursor'(Container'Unrestricted_Access, Index); Position := (Container'Unrestricted_Access, Index);
end Insert; end Insert;
procedure Insert procedure Insert
...@@ -2343,7 +1807,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2343,7 +1807,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -2354,7 +1818,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2354,7 +1818,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Before.Container = null or else Before.Index > Container.Last then if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then if Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
end if; end if;
...@@ -2378,16 +1842,14 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2378,16 +1842,14 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
end if; end if;
if Count = 0 then if Count = 0 then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -2397,7 +1859,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2397,7 +1859,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Before.Container = null or else Before.Index > Container.Last then if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then if Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
end if; end if;
...@@ -2436,31 +1898,33 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2436,31 +1898,33 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array Dst : Elements_Access; -- new, expanded internal array
begin begin
-- As a precondition on the generic actual Index_Type, the base type if Checks then
-- must include Index_Type'Pred (Index_Type'First); this is the value -- As a precondition on the generic actual Index_Type, the base type
-- that Container.Last assumes when the vector is empty. However, we do -- must include Index_Type'Pred (Index_Type'First); this is the value
-- not allow that as the value for Index when specifying where the new -- that Container.Last assumes when the vector is empty. However, we
-- items should be inserted, so we must manually check. (That the user -- do not allow that as the value for Index when specifying where the
-- is allowed to specify the value at all here is a consequence of the -- new items should be inserted, so we must manually check. (That the
-- declaration of the Extended_Index subtype, which includes the values -- user is allowed to specify the value at all here is a consequence
-- in the base range that immediately precede and immediately follow the -- of the declaration of the Extended_Index subtype, which includes
-- values in the Index_Type.) -- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
end if; end if;
-- We do allow a value greater than Container.Last to be specified as -- 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 -- the Index, but only if it's immediately greater. This allows for
-- case of appending items to the back end of the vector. (It is assumed -- the case of appending items to the back end of the vector. (It is
-- that specifying an index value greater than Last + 1 indicates some -- assumed that specifying an index value greater than Last + 1
-- deeper flaw in the caller's algorithm, so that case is treated as a -- indicates some deeper flaw in the caller's algorithm, so that case
-- proper error.) -- is treated as a proper error.)
if Before > Container.Last and then Before > Container.Last + 1 then if Before > Container.Last + 1 then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too large)"; "Before index is out of range (too large)";
end if;
end if; end if;
-- We treat inserting 0 items into the container as a no-op, even when -- We treat inserting 0 items into the container as a no-op, even when
...@@ -2472,11 +1936,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2472,11 +1936,11 @@ package body Ada.Containers.Indefinite_Vectors is
-- There are two constraints we need to satisfy. The first constraint is -- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so -- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion -- we must check the sum of the current length and the insertion count.
-- count. Note that we cannot simply add these values, because of the -- Note: we cannot simply add these values, because of the possibility
-- possibility of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Checks and then Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -2491,7 +1955,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2491,7 +1955,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- compare the new length to the maximum length. If the new length is -- compare the new length to the maximum length. If the new length is
-- acceptable, then we compute the new last index from that. -- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the -- 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. -- range of Index_Type than in the range of Count_Type.
...@@ -2525,9 +1989,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2525,9 +1989,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- worry about if No_Index were less than 0, but that case is -- worry about if No_Index were less than 0, but that case is
-- handled above). -- handled above).
if Index_Type'Last - No_Index >= if Index_Type'Last - No_Index >= Count_Type_Last then
Count_Type'Pos (Count_Type'Last)
then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -2584,7 +2046,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2584,7 +2046,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- an internal array with a last index value greater than -- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements). -- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -2592,7 +2054,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2592,7 +2054,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
-- compute its value from the New_Length. -- compute its value from the New_Length.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
...@@ -2624,10 +2086,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2624,10 +2086,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Insert checks the count to determine whether it is being called while -- Insert checks the count to determine whether it is being called while
-- the associated callback procedure is executing. -- the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
if New_Length <= Container.Elements.EA'Length then if New_Length <= Container.Elements.EA'Length then
...@@ -2646,7 +2105,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2646,7 +2105,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- their new home. We use the wider of Index_Type'Base and -- their new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values. -- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
...@@ -2692,7 +2151,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2692,7 +2151,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- We have computed the length of the new internal array (and this is -- 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. -- what "vector capacity" means), so use that to compute its last index.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
...@@ -2722,7 +2181,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2722,7 +2181,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being inserted before some existing elements, -- The new items are being inserted before some existing elements,
-- so we must slide the existing elements up to their new home. -- so we must slide the existing elements up to their new home.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
...@@ -2750,7 +2209,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2750,7 +2209,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -2766,10 +2225,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2766,10 +2225,8 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last if Checks and then Container.Last = Index_Type'Last then
then
if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
end if; end if;
...@@ -2782,7 +2239,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2782,7 +2239,7 @@ package body Ada.Containers.Indefinite_Vectors is
Insert_Space (Container, Index, Count); Insert_Space (Container, Index, Count);
Position := Cursor'(Container'Unrestricted_Access, Index); Position := (Container'Unrestricted_Access, Index);
end Insert_Space; end Insert_Space;
-------------- --------------
...@@ -2802,30 +2259,18 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2802,30 +2259,18 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : Vector; (Container : Vector;
Process : not null access procedure (Position : Cursor)) Process : not null access procedure (Position : Cursor))
is is
B : Natural renames Container'Unrestricted_Access.all.Busy; Busy : With_Busy (Container.TC'Unrestricted_Access);
begin begin
B := B + 1; for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
begin end loop;
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; end Iterate;
function Iterate (Container : Vector) function Iterate
(Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is is
V : constant Vector_Access := Container'Unrestricted_Access; V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin begin
-- The value of its Index component influences the behavior of the First -- The value of its Index component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Index -- and Last selector functions of the iterator object. When the Index
...@@ -2842,7 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2842,7 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is
Container => V, Container => V,
Index => No_Index) Index => No_Index)
do do
B := B + 1; Busy (Container.TC'Unrestricted_Access.all);
end return; end return;
end Iterate; end Iterate;
...@@ -2852,8 +2297,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2852,8 +2297,6 @@ package body Ada.Containers.Indefinite_Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'Class return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is is
V : constant Vector_Access := Container'Unrestricted_Access; V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin begin
-- It was formerly the case that when Start = No_Element, the partial -- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator, -- iterator was defined to behave the same as for a complete iterator,
...@@ -2866,19 +2309,21 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2866,19 +2309,21 @@ package body Ada.Containers.Indefinite_Vectors is
-- however, that it is not possible to use a partial iterator to specify -- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items. -- an empty sequence of items.
if Start.Container = null then if Checks then
raise Constraint_Error with if Start.Container = null then
"Start position for iterator equals No_Element"; raise Constraint_Error with
end if; "Start position for iterator equals No_Element";
end if;
if Start.Container /= V then if Start.Container /= V then
raise Program_Error with raise Program_Error with
"Start cursor of Iterate designates wrong vector"; "Start cursor of Iterate designates wrong vector";
end if; end if;
if Start.Index > V.Last then if Start.Index > V.Last then
raise Constraint_Error with raise Constraint_Error with
"Start position for iterator equals No_Element"; "Start position for iterator equals No_Element";
end if;
end if; end if;
-- The value of its Index component influences the behavior of the First -- The value of its Index component influences the behavior of the First
...@@ -2895,7 +2340,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2895,7 +2340,7 @@ package body Ada.Containers.Indefinite_Vectors is
Container => V, Container => V,
Index => Start.Index) Index => Start.Index)
do do
B := B + 1; Busy (Container.TC'Unrestricted_Access.all);
end return; end return;
end Iterate; end Iterate;
...@@ -2934,13 +2379,13 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2934,13 +2379,13 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
end Last; end Last;
----------------- ------------------
-- Last_Element -- -- Last_Element --
------------------ ------------------
function Last_Element (Container : Vector) return Element_Type is function Last_Element (Container : Vector) return Element_Type is
begin begin
if Container.Last = No_Index then if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty"; raise Constraint_Error with "Container is empty";
end if; end if;
...@@ -2948,7 +2393,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2948,7 +2393,7 @@ package body Ada.Containers.Indefinite_Vectors is
EA : constant Element_Access := EA : constant Element_Access :=
Container.Elements.EA (Container.Last); Container.Elements.EA (Container.Last);
begin begin
if EA = null then if Checks and then EA = null then
raise Constraint_Error with "last element is empty"; raise Constraint_Error with "last element is empty";
else else
return EA.all; return EA.all;
...@@ -3012,10 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3012,10 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Source.Busy > 0 then TC_Check (Source.TC);
raise Program_Error with
"attempt to tamper with cursors (Source is busy)";
end if;
Clear (Target); -- Checks busy-bit Clear (Target); -- Checks busy-bit
...@@ -3049,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3049,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
elsif Position.Container /= Object.Container then elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong vector"; "Position cursor of Next designates wrong vector";
else else
...@@ -3090,17 +2532,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3090,17 +2532,6 @@ package body Ada.Containers.Indefinite_Vectors is
-- Previous -- -- 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;
function Previous (Position : Cursor) return Cursor is function Previous (Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
...@@ -3116,7 +2547,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3116,7 +2547,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
elsif Position.Container /= Object.Container then elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong vector"; "Position cursor of Previous designates wrong vector";
else else
...@@ -3124,6 +2555,31 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3124,6 +2555,31 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
end Previous; 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;
----------------------
-- Pseudo_Reference --
----------------------
function Pseudo_Reference
(Container : aliased Vector'Class) return Reference_Control_Type
is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
Lock (TC.all);
end return;
end Pseudo_Reference;
------------------- -------------------
-- Query_Element -- -- Query_Element --
------------------- -------------------
...@@ -3133,33 +2589,19 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3133,33 +2589,19 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type; Index : Index_Type;
Process : not null access procedure (Element : Element_Type)) Process : not null access procedure (Element : Element_Type))
is is
Lock : With_Lock (Container.TC'Unrestricted_Access);
V : Vector renames Container'Unrestricted_Access.all; V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
if V.Elements.EA (Index) = null then if Checks and then V.Elements.EA (Index) = null then
raise Constraint_Error with "element is null"; raise Constraint_Error with "element is null";
end if; end if;
B := B + 1; Process (V.Elements.EA (Index).all);
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; end Query_Element;
procedure Query_Element procedure Query_Element
...@@ -3167,7 +2609,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3167,7 +2609,7 @@ package body Ada.Containers.Indefinite_Vectors is
Process : not null access procedure (Element : Element_Type)) Process : not null access procedure (Element : Element_Type))
is is
begin begin
if Position.Container = null then if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
else else
Query_Element (Position.Container.all, Position.Index, Process); Query_Element (Position.Container.all, Position.Index, Process);
...@@ -3241,72 +2683,70 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3241,72 +2683,70 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : aliased in out Vector; (Container : aliased in out Vector;
Position : Cursor) return Reference_Type Position : Cursor) return Reference_Type
is is
E : Element_Access;
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; 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 Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if E = null then if Position.Index > Position.Container.Last then
raise Constraint_Error with "element at Position is empty"; raise Constraint_Error with "Position cursor is out of range";
end if;
end if; end if;
declare if T_Check then
C : Vector renames Container'Unrestricted_Access.all; declare
B : Natural renames C.Busy; TC : constant Tamper_Counts_Access :=
L : Natural renames C.Lock; Container.TC'Unrestricted_Access;
begin begin
-- The following will raise Constraint_Error if Element is null
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => E.all'Access, (Element => Container.Elements.EA (Position.Index),
Control => (Controlled with Position.Container)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
(Container : aliased in out Vector; (Container : aliased in out Vector;
Index : Index_Type) return Reference_Type Index : Index_Type) return Reference_Type
is is
E : Element_Access;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
E := Container.Elements.EA (Index); if T_Check then
declare
if E = null then TC : constant Tamper_Counts_Access :=
raise Constraint_Error with "element at Index is empty"; Container.TC'Unrestricted_Access;
end if; begin
-- The following will raise Constraint_Error if Element is null
declare
C : Vector renames Container'Unrestricted_Access.all; return R : constant Reference_Type :=
B : Natural renames C.Busy; (Element => Container.Elements.EA (Index),
L : Natural renames C.Lock; Control => (Controlled with TC))
begin do
Lock (TC.all);
end return;
end;
else
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => E.all'Access, (Element => Container.Elements.EA (Index),
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
--------------------- ---------------------
...@@ -3319,14 +2759,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3319,14 +2759,11 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type) New_Item : Element_Type)
is is
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
if Container.Lock > 0 then TE_Check (Container.TC);
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
declare declare
X : Element_Access := Container.Elements.EA (Index); X : Element_Access := Container.Elements.EA (Index);
...@@ -3349,22 +2786,21 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3349,22 +2786,21 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type) New_Item : Element_Type)
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if; end if;
if Position.Index > Container.Last then if Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if;
end if; end if;
if Container.Lock > 0 then TE_Check (Container.TC);
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
declare declare
X : Element_Access := Container.Elements.EA (Position.Index); X : Element_Access := Container.Elements.EA (Position.Index);
...@@ -3442,10 +2878,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3442,10 +2878,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- so this is the best we can do with respect to minimizing -- so this is the best we can do with respect to minimizing
-- storage). -- storage).
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
subtype Array_Index_Subtype is Index_Type'Base range subtype Array_Index_Subtype is Index_Type'Base range
...@@ -3485,7 +2918,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3485,7 +2918,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- the Last index value of the new internal array, in a way that avoids -- the Last index value of the new internal array, in a way that avoids
-- any possibility of overflow. -- any possibility of overflow.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
-- We perform a two-part test. First we determine whether the -- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then -- computed Last value lies in the base range of the type, and then
...@@ -3498,7 +2931,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3498,7 +2931,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index
then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3510,7 +2945,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3510,7 +2945,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3522,7 +2957,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3522,7 +2957,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (No_Index) + Capacity; -- Last Index := Count_Type'Base (No_Index) + Capacity; -- Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3539,7 +2974,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3539,7 +2974,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3578,10 +3013,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3578,10 +3013,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- internal array having a length that exactly matches the number -- internal array having a length that exactly matches the number
-- of items in the container. -- of items in the container.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
subtype Array_Index_Subtype is Index_Type'Base range subtype Array_Index_Subtype is Index_Type'Base range
...@@ -3634,10 +3066,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3634,10 +3066,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- number of active elements in the container.) We must check whether -- number of active elements in the container.) We must check whether
-- the container is busy before doing anything else. -- the container is busy before doing anything else.
if Container.Busy > 0 then TC_Check (Container.TC);
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 -- We now allocate a new internal array, having a length different from
-- its current value. -- its current value.
...@@ -3689,10 +3118,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3689,10 +3118,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- implementation. Logically Reverse_Elements requires a check for -- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering. -- cursor tampering.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
I : Index_Type; I : Index_Type;
...@@ -3729,55 +3155,32 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3729,55 +3155,32 @@ package body Ada.Containers.Indefinite_Vectors is
Last : Index_Type'Base; Last : Index_Type'Base;
begin begin
if Position.Container /= null if Checks and then Position.Container /= null
and then Position.Container /= Container'Unrestricted_Access and then Position.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if; end if;
if Position.Container = null or else Position.Index > Container.Last then Last :=
Last := Container.Last; (if Position.Container = null or else Position.Index > Container.Last
else then Container.Last
Last := Position.Index; else Position.Index);
end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container'Unrestricted_Access.Busy; Lock : With_Lock (Container.TC'Unrestricted_Access);
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item and then Container.Elements.EA (Indx).all = Item
then then
Result := Indx; return Cursor'(Container'Unrestricted_Access, Indx);
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Element;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end; end;
end Reverse_Find; end Reverse_Find;
...@@ -3790,41 +3193,24 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3790,41 +3193,24 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index Index : Index_Type := Index_Type'Last) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base :=
(if Index > Container.Last then Container.Last else Index);
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
B := B + 1; Lock : With_Lock (Container.TC'Unrestricted_Access);
L := L + 1;
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
Result := No_Index; begin
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item and then Container.Elements.EA (Indx).all = Item
then then
Result := Indx; return Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Index;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index; end Reverse_Find_Index;
--------------------- ---------------------
...@@ -3835,33 +3221,18 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3835,33 +3221,18 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : Vector; (Container : Vector;
Process : not null access procedure (Position : Cursor)) Process : not null access procedure (Position : Cursor))
is is
V : Vector renames Container'Unrestricted_Access.all; Busy : With_Busy (Container.TC'Unrestricted_Access);
B : Natural renames V.Busy;
begin begin
B := B + 1; for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
begin end loop;
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; end Reverse_Iterate;
---------------- ----------------
-- Set_Length -- -- Set_Length --
---------------- ----------------
procedure Set_Length procedure Set_Length (Container : in out Vector; Length : Count_Type) is
(Container : in out Vector;
Length : Count_Type)
is
Count : constant Count_Type'Base := Container.Length - Length; Count : constant Count_Type'Base := Container.Length - Length;
begin begin
...@@ -3875,7 +3246,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3875,7 +3246,7 @@ package body Ada.Containers.Indefinite_Vectors is
if Count >= 0 then if Count >= 0 then
Container.Delete_Last (Count); Container.Delete_Last (Count);
elsif Container.Last >= Index_Type'Last then elsif Checks and then Container.Last >= Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else else
...@@ -3887,27 +3258,23 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3887,27 +3258,23 @@ package body Ada.Containers.Indefinite_Vectors is
-- Swap -- -- Swap --
---------- ----------
procedure Swap procedure Swap (Container : in out Vector; I, J : Index_Type) is
(Container : in out Vector;
I, J : Index_Type)
is
begin begin
if I > Container.Last then if Checks then
raise Constraint_Error with "I index is out of range"; if I > Container.Last then
end if; raise Constraint_Error with "I index is out of range";
end if;
if J > Container.Last then if J > Container.Last then
raise Constraint_Error with "J index is out of range"; raise Constraint_Error with "J index is out of range";
end if;
end if; end if;
if I = J then if I = J then
return; return;
end if; end if;
if Container.Lock > 0 then TE_Check (Container.TC);
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
declare declare
EI : Element_Access renames Container.Elements.EA (I); EI : Element_Access renames Container.Elements.EA (I);
...@@ -3926,20 +3293,22 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3926,20 +3293,22 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Container = null then if Checks then
raise Constraint_Error with "I cursor has no element"; if I.Container = null then
end if; raise Constraint_Error with "I cursor has no element";
end if;
if J.Container = null then if J.Container = null then
raise Constraint_Error with "J cursor has no element"; raise Constraint_Error with "J cursor has no element";
end if; end if;
if I.Container /= Container'Unrestricted_Access then if I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container"; raise Program_Error with "I cursor denotes wrong container";
end if; end if;
if J.Container /= Container'Unrestricted_Access then if J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container"; raise Program_Error with "J cursor denotes wrong container";
end if;
end if; end if;
Swap (Container, I.Index, J.Index); Swap (Container, I.Index, J.Index);
...@@ -3997,7 +3366,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3997,7 +3366,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- index). We must therefore check whether the specified Length would -- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last. -- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
-- We perform a two-part test. First we determine whether the -- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then -- computed Last value lies in the base range of the type, and then
...@@ -4010,7 +3379,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4010,7 +3379,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4022,7 +3393,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4022,7 +3393,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4034,7 +3405,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4034,7 +3405,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (No_Index) + Length; -- Last Index := Count_Type'Base (No_Index) + Length; -- Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4051,7 +3422,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4051,7 +3422,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4064,7 +3435,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4064,7 +3435,7 @@ package body Ada.Containers.Indefinite_Vectors is
Elements := new Elements_Type (Last); Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, 0, 0); return Vector'(Controlled with Elements, Last, TC => <>);
end To_Vector; end To_Vector;
function To_Vector function To_Vector
...@@ -4087,7 +3458,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4087,7 +3458,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- index). We must therefore check whether the specified Length would -- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last. -- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type_Last then
-- We perform a two-part test. First we determine whether the -- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then -- computed Last value lies in the base range of the type, and then
...@@ -4100,7 +3471,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4100,7 +3471,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4112,7 +3485,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4112,7 +3485,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4124,7 +3497,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4124,7 +3497,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (No_Index) + Length; -- Last Index := Count_Type'Base (No_Index) + Length; -- Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4141,7 +3514,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4141,7 +3514,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -4191,7 +3564,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4191,7 +3564,7 @@ package body Ada.Containers.Indefinite_Vectors is
raise; raise;
end; end;
return (Controlled with Elements, Last, 0, 0); return (Controlled with Elements, Last, TC => <>);
end To_Vector; end To_Vector;
-------------------- --------------------
...@@ -4203,32 +3576,17 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4203,32 +3576,17 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type; Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type)) Process : not null access procedure (Element : in out Element_Type))
is is
B : Natural renames Container.Busy; Lock : With_Lock (Container.TC'Unchecked_Access);
L : Natural renames Container.Lock;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
if Container.Elements.EA (Index) = null then if Checks and then Container.Elements.EA (Index) = null then
raise Constraint_Error with "element is null"; raise Constraint_Error with "element is null";
end if; end if;
B := B + 1; Process (Container.Elements.EA (Index).all);
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; end Update_Element;
procedure Update_Element procedure Update_Element
...@@ -4237,15 +3595,15 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4237,15 +3595,15 @@ package body Ada.Containers.Indefinite_Vectors is
Process : not null access procedure (Element : in out Element_Type)) Process : not null access procedure (Element : in out Element_Type))
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
else
Update_Element (Container, Position.Index, Process);
end if; end if;
Update_Element (Container, Position.Index, Process);
end Update_Element; end Update_Element;
----------- -----------
......
gcc/ada/a-coinve.ads
...@@ -343,6 +343,7 @@ package Ada.Containers.Indefinite_Vectors is ...@@ -343,6 +343,7 @@ package Ada.Containers.Indefinite_Vectors is
private private
pragma Inline (Append);
pragma Inline (First_Index); pragma Inline (First_Index);
pragma Inline (Last_Index); pragma Inline (Last_Index);
pragma Inline (Element); pragma Inline (Element);
...@@ -351,35 +352,37 @@ private ...@@ -351,35 +352,37 @@ private
pragma Inline (Query_Element); pragma Inline (Query_Element);
pragma Inline (Update_Element); pragma Inline (Update_Element);
pragma Inline (Replace_Element); pragma Inline (Replace_Element);
pragma Inline (Is_Empty);
pragma Inline (Contains); pragma Inline (Contains);
pragma Inline (Next); pragma Inline (Next);
pragma Inline (Previous); pragma Inline (Previous);
package Implementation is new Generic_Implementation;
use Implementation;
type Element_Access is access Element_Type; type Element_Access is access Element_Type;
type Elements_Array is array (Index_Type range <>) of Element_Access; type Elements_Array is array (Index_Type range <>) of Element_Access;
function "=" (L, R : Elements_Array) return Boolean is abstract; function "=" (L, R : Elements_Array) return Boolean is abstract;
type Elements_Type (Last : Index_Type) is limited record type Elements_Type (Last : Extended_Index) is limited record
EA : Elements_Array (Index_Type'First .. Last); EA : Elements_Array (Index_Type'First .. Last);
end record; end record;
type Elements_Access is access Elements_Type; type Elements_Access is access all Elements_Type;
use Finalization;
use Streams;
type Vector is new Ada.Finalization.Controlled with record type Vector is new Controlled with record
Elements : Elements_Access; Elements : Elements_Access := null;
Last : Extended_Index := No_Index; Last : Extended_Index := No_Index;
Busy : Natural := 0; TC : aliased Tamper_Counts;
Lock : Natural := 0;
end record; end record;
overriding procedure Adjust (Container : in out Vector); overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector); overriding procedure Finalize (Container : in out Vector);
use Ada.Finalization;
use Ada.Streams;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Container : Vector); Container : Vector);
...@@ -412,16 +415,8 @@ private ...@@ -412,16 +415,8 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is subtype Reference_Control_Type is Implementation.Reference_Control_Type;
new Controlled with record -- It is necessary to rename this here, so that the compiler can find it
Container : Vector_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is (Element : not null access constant Element_Type) is
...@@ -467,16 +462,33 @@ private ...@@ -467,16 +462,33 @@ private
for Reference_Type'Read use Read; for Reference_Type'Read use Read;
Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); -- Three operations are used to optimize in the expansion of "for ... of"
-- loops: the Next(Cursor) procedure in the visible part, and the following
-- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
-- details.
function Pseudo_Reference
(Container : aliased Vector'Class) return Reference_Control_Type;
pragma Inline (Pseudo_Reference);
-- Creates an object of type Reference_Control_Type pointing to the
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
No_Element : constant Cursor := Cursor'(null, Index_Type'First); No_Element : constant Cursor := Cursor'(null, Index_Type'First);
Empty_Vector : constant Vector := (Controlled with others => <>);
type Iterator is new Limited_Controlled and type Iterator is new Limited_Controlled and
Vector_Iterator_Interfaces.Reversible_Iterator with Vector_Iterator_Interfaces.Reversible_Iterator with
record record
Container : Vector_Access; Container : Vector_Access;
Index : Index_Type'Base; Index : Index_Type'Base;
end record; end record
with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator); overriding procedure Finalize (Object : in out Iterator);
......
gcc/ada/a-convec.adb
...@@ -450,9 +450,9 @@ package body Ada.Containers.Vectors is ...@@ -450,9 +450,9 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
-- There are some elements aren't being deleted (the requested count was -- There are some elements that aren't being deleted (the requested
-- less than the available count), so we must slide them down to -- count was less than the available count), so we must slide them down
-- Index. We first calculate the index values of the respective array -- 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 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
-- type for intermediate calculations. For the elements that slide down, -- 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 New_Last is the last index value of their new home, and
...@@ -583,9 +583,9 @@ package body Ada.Containers.Vectors is ...@@ -583,9 +583,9 @@ package body Ada.Containers.Vectors is
begin begin
if Checks and then Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else
return Container.Elements.EA (Index);
end if; end if;
return Container.Elements.EA (Index);
end Element; end Element;
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
...@@ -692,9 +692,9 @@ package body Ada.Containers.Vectors is ...@@ -692,9 +692,9 @@ package body Ada.Containers.Vectors is
begin begin
if Is_Empty (Container) then if Is_Empty (Container) then
return No_Element; return No_Element;
else
return (Container'Unrestricted_Access, Index_Type'First);
end if; end if;
return (Container'Unrestricted_Access, Index_Type'First);
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
...@@ -1030,7 +1030,6 @@ package body Ada.Containers.Vectors is ...@@ -1030,7 +1030,6 @@ package body Ada.Containers.Vectors is
-- handled above). -- handled above).
if Index_Type'Last - No_Index >= Count_Type_Last then if Index_Type'Last - No_Index >= Count_Type_Last then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -1655,7 +1654,6 @@ package body Ada.Containers.Vectors is ...@@ -1655,7 +1654,6 @@ package body Ada.Containers.Vectors is
-- acceptable, then we compute the new last index from that. -- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type_Last then if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the -- 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. -- range of Index_Type than in the range of Count_Type.
...@@ -1690,7 +1688,6 @@ package body Ada.Containers.Vectors is ...@@ -1690,7 +1688,6 @@ package body Ada.Containers.Vectors is
-- handled above). -- handled above).
if Index_Type'Last - No_Index >= Count_Type_Last then if Index_Type'Last - No_Index >= Count_Type_Last then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -1965,7 +1962,7 @@ package body Ada.Containers.Vectors is ...@@ -1965,7 +1962,7 @@ package body Ada.Containers.Vectors is
Index := Before.Index; Index := Before.Index;
end if; end if;
Insert_Space (Container, Index, Count => Count); Insert_Space (Container, Index, Count);
Position := (Container'Unrestricted_Access, Index); Position := (Container'Unrestricted_Access, Index);
end Insert_Space; end Insert_Space;
...@@ -2022,7 +2019,7 @@ package body Ada.Containers.Vectors is ...@@ -2022,7 +2019,7 @@ package body Ada.Containers.Vectors is
function Iterate function Iterate
(Container : Vector; (Container : Vector;
Start : Cursor) Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is is
V : constant Vector_Access := Container'Unrestricted_Access; V : constant Vector_Access := Container'Unrestricted_Access;
begin begin
...@@ -2911,6 +2908,7 @@ package body Ada.Containers.Vectors is ...@@ -2911,6 +2908,7 @@ package body Ada.Containers.Vectors is
--------------------- ---------------------
-- Reverse_Iterate -- -- Reverse_Iterate --
--------------------- ---------------------
procedure Reverse_Iterate procedure Reverse_Iterate
(Container : Vector; (Container : Vector;
Process : not null access procedure (Position : Cursor)) Process : not null access procedure (Position : Cursor))
...@@ -3119,7 +3117,7 @@ package body Ada.Containers.Vectors is ...@@ -3119,7 +3117,7 @@ package body Ada.Containers.Vectors is
Elements := new Elements_Type (Last); Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, others => <>); return Vector'(Controlled with Elements, Last, TC => <>);
end To_Vector; end To_Vector;
function To_Vector function To_Vector
...@@ -3211,7 +3209,7 @@ package body Ada.Containers.Vectors is ...@@ -3211,7 +3209,7 @@ package body Ada.Containers.Vectors is
Elements := new Elements_Type'(Last, EA => (others => New_Item)); Elements := new Elements_Type'(Last, EA => (others => New_Item));
return Vector'(Controlled with Elements, Last, others => <>); return (Controlled with Elements, Last, TC => <>);
end To_Vector; end To_Vector;
-------------------- --------------------
......
gcc/ada/a-convec.ads
...@@ -487,7 +487,7 @@ private ...@@ -487,7 +487,7 @@ private
(Position : Cursor) return not null Element_Access; (Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position. -- Returns a pointer to the element designated by Position.
No_Element : constant Cursor := Cursor'(null, Index_Type'First); No_Element : constant Cursor := Cursor'(null, Index_Type'First);
Empty_Vector : constant Vector := (Controlled with others => <>); Empty_Vector : constant Vector := (Controlled with others => <>);
......
gcc/ada/a-finali.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,48 +29,8 @@ ...@@ -29,48 +29,8 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
package body Ada.Finalization is -- This package does not require a body. We provide a dummy file containing a
-- No_Body pragma so that previous versions of the body (which did exist) will
-- not interfere.
------------ pragma No_Body;
-- Adjust --
------------
procedure Adjust (Object : in out Controlled) is
pragma Warnings (Off, Object);
begin
null;
end Adjust;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Controlled) is
pragma Warnings (Off, Object);
begin
null;
end Finalize;
procedure Finalize (Object : in out Limited_Controlled) is
pragma Warnings (Off, Object);
begin
null;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Object : in out Controlled) is
pragma Warnings (Off, Object);
begin
null;
end Initialize;
procedure Initialize (Object : in out Limited_Controlled) is
pragma Warnings (Off, Object);
begin
null;
end Initialize;
end Ada.Finalization;
gcc/ada/a-finali.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -43,15 +43,15 @@ package Ada.Finalization is ...@@ -43,15 +43,15 @@ package Ada.Finalization is
type Controlled is abstract tagged private; type Controlled is abstract tagged private;
pragma Preelaborable_Initialization (Controlled); pragma Preelaborable_Initialization (Controlled);
procedure Initialize (Object : in out Controlled); procedure Initialize (Object : in out Controlled) is null;
procedure Adjust (Object : in out Controlled); procedure Adjust (Object : in out Controlled) is null;
procedure Finalize (Object : in out Controlled); procedure Finalize (Object : in out Controlled) is null;
type Limited_Controlled is abstract tagged limited private; type Limited_Controlled is abstract tagged limited private;
pragma Preelaborable_Initialization (Limited_Controlled); pragma Preelaborable_Initialization (Limited_Controlled);
procedure Initialize (Object : in out Limited_Controlled); procedure Initialize (Object : in out Limited_Controlled) is null;
procedure Finalize (Object : in out Limited_Controlled); procedure Finalize (Object : in out Limited_Controlled) is null;
private private
package SFR renames System.Finalization_Root; package SFR renames System.Finalization_Root;
......
gcc/ada/sem_ch13.adb
...@@ -2036,8 +2036,8 @@ package body Sem_Ch13 is ...@@ -2036,8 +2036,8 @@ package body Sem_Ch13 is
Analyze_And_Resolve (Expr, Standard_Integer); Analyze_And_Resolve (Expr, Standard_Integer);
-- Interrupt_Priority aspect not allowed for main -- Interrupt_Priority aspect not allowed for main
-- subprograms. ARM D.1 does not forbid this explicitly, -- subprograms. RM D.1 does not forbid this explicitly,
-- but ARM J.15.11 (6/3) does not permit pragma -- but RM J.15.11(6/3) does not permit pragma
-- Interrupt_Priority for subprograms. -- Interrupt_Priority for subprograms.
if A_Id = Aspect_Interrupt_Priority then if A_Id = Aspect_Interrupt_Priority then
...@@ -2060,7 +2060,7 @@ package body Sem_Ch13 is ...@@ -2060,7 +2060,7 @@ package body Sem_Ch13 is
(Specification (N))) (Specification (N)))
or else not Is_Compilation_Unit (Defining_Entity (N)) or else not Is_Compilation_Unit (Defining_Entity (N))
then then
-- See ARM D.1 (14/3) and D.16 (12/3) -- See RM D.1(14/3) and D.16(12/3)
Error_Msg_N Error_Msg_N
("aspect applied to subprogram other than the " ("aspect applied to subprogram other than the "
...@@ -11419,9 +11419,20 @@ package body Sem_Ch13 is ...@@ -11419,9 +11419,20 @@ package body Sem_Ch13 is
declare declare
Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
begin begin
return Id = Attribute_Input
-- List of operational items is given in RM 13.1(8.mm/1).
-- It is clearly incomplete, as it does not include iterator
-- aspects, among others.
return Id = Attribute_Constant_Indexing
or else Id = Attribute_Default_Iterator
or else Id = Attribute_Implicit_Dereference
or else Id = Attribute_Input
or else Id = Attribute_Iterator_Element
or else Id = Attribute_Iterable
or else Id = Attribute_Output or else Id = Attribute_Output
or else Id = Attribute_Read or else Id = Attribute_Read
or else Id = Attribute_Variable_Indexing
or else Id = Attribute_Write or else Id = Attribute_Write
or else Id = Attribute_External_Tag; or else Id = Attribute_External_Tag;
end; end;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment