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>
* sem_prag.adb (Check_Usage): Update the calls to Usage_Error.
......
gcc/ada/a-coinve.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -36,457 +36,66 @@ package body Ada.Containers.Indefinite_Vectors is
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
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
procedure Free is
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
LN : constant Count_Type := Length (Left);
RN : constant Count_Type := Length (Right);
N : Count_Type'Base; -- length of result
J : Count_Type'Base; -- for computing intermediate values
Last : Index_Type'Base; -- Last index of result
-- We decide that the capacity of the result of "&" is the minimum needed
-- -- the sum of the lengths of the vector parameters. We could decide to
-- make it larger, but we have no basis for knowing how much larger, so we
-- just allocate the minimum amount of storage.
function "&" (Left, Right : Vector) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the vector parameters. We could decide to make it larger, but we
-- have no basis for knowing how much larger, so we just allocate the
-- minimum amount of storage.
-- Here we handle the easy cases first, when one of the vector
-- parameters is empty. (We say "easy" because there's nothing to
-- compute, that can potentially overflow.)
if LN = 0 then
if RN = 0 then
return Empty_Vector;
end if;
declare
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access := new Elements_Type (Right.Last);
begin
-- Elements of an indefinite vector are allocated, so we cannot
-- use simple slice assignment to give a value to our result.
-- Hence we must walk the array of the Right vector, and copy
-- each source element individually.
for I in Elements.EA'Range loop
begin
if RE (I) /= null then
Elements.EA (I) := new Element_Type'(RE (I).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
return (Controlled with Elements, Right.Last, 0, 0);
end;
end if;
if RN = 0 then
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : Elements_Access := new Elements_Type (Left.Last);
begin
-- Elements of an indefinite vector are allocated, so we cannot
-- use simple slice assignment to give a value to our result.
-- Hence we must walk the array of the Left vector, and copy
-- each source element individually.
for I in Elements.EA'Range loop
begin
if LE (I) /= null then
Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
return (Controlled with Elements, Left.Last, 0, 0);
end;
end if;
-- Neither of the vector parameters is empty, so we must compute the
-- length of the result vector and its last index. (This is the harder
-- case, because our computations must avoid overflow.)
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the combined lengths. Note that we cannot
-- simply add the lengths, because of the possibility of overflow.
if LN > Count_Type'Last - RN then
raise Constraint_Error with "new length is out of range";
end if;
-- It is now safe compute the length of the new vector.
N := LN + RN;
-- The second constraint is that the new Last index value cannot
-- exceed Index_Type'Last. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
-- Last must satisfy this relation:
-- First + Length - 1 <= Last
-- We regroup terms:
-- First - 1 <= Last - Length
-- Which can rewrite as:
-- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
raise Constraint_Error with "new length is out of range";
end if;
-- We now know that the computed value of Last is within the base
-- range of the type, so it is safe to compute its value:
Last := No_Index + Index_Type'Base (N);
-- Finally we test whether the value is within the range of the
-- generic actual index subtype:
if Last > Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of length.
J := Count_Type'Base (No_Index) + N; -- Last
if J > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
-- We know that the computed value (having type Count_Type) of Last
-- is within the range of the generic actual index subtype, so it is
-- safe to convert to Index_Type:
Last := Index_Type'Base (J);
else
-- Here Index_Type'First (and Index_Type'Last) is positive, so we
-- must test the length indirectly (by working backwards from the
-- largest possible value of Last), in order to prevent overflow.
J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
if J < Count_Type'Base (No_Index) then
raise Constraint_Error with "new length is out of range";
end if;
-- We have determined that the result length would not create a Last
-- index value outside of the range of Index_Type, so we can now
-- safely compute its value.
Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
end if;
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access := new Elements_Type (Last);
I : Index_Type'Base := No_Index;
begin
-- Elements of an indefinite vector are allocated, so we cannot use
-- simple slice assignment to give a value to our result. Hence we
-- must walk the array of each vector parameter, and copy each source
-- element individually.
for LI in LE'Range loop
I := I + 1;
begin
if LE (LI) /= null then
Elements.EA (I) := new Element_Type'(LE (LI).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
for RI in RE'Range loop
I := I + 1;
begin
if RE (RI) /= null then
Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
return (Controlled with Elements, Last, 0, 0);
end;
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + Length (Right));
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is
function "&" (Left : Vector; Right : Element_Type) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- Here we handle the easy case first, when the vector parameter (Left)
-- is empty.
if Left.Is_Empty then
declare
Elements : Elements_Access := new Elements_Type (Index_Type'First);
begin
begin
Elements.EA (Index_Type'First) := new Element_Type'(Right);
exception
when others =>
Free (Elements);
raise;
end;
return (Controlled with Elements, Index_Type'First, 0, 0);
end;
end if;
-- The vector parameter is not empty, so we must compute the length of
-- the result vector and its last index, but in such a way that overflow
-- is avoided. We must satisfy two constraints: the new length cannot
-- exceed Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
if Left.Length = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
if Left.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
Last : constant Index_Type := Left.Last + 1;
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : Elements_Access := new Elements_Type (Last);
begin
for I in LE'Range loop
begin
if LE (I) /= null then
Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
begin
Elements.EA (Last) := new Element_Type'(Right);
exception
when others =>
for J in Index_Type'First .. Last - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
return (Controlled with Elements, Last, 0, 0);
end;
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + 1);
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is
function "&" (Left : Element_Type; Right : Vector) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- Here we handle the easy case first, when the vector parameter (Right)
-- is empty.
if Right.Is_Empty then
declare
Elements : Elements_Access := new Elements_Type (Index_Type'First);
begin
begin
Elements.EA (Index_Type'First) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
raise;
end;
return (Controlled with Elements, Index_Type'First, 0, 0);
end;
end if;
-- The vector parameter is not empty, so we must compute the length of
-- the result vector and its last index, but in such a way that overflow
-- is avoided. We must satisfy two constraints: the new length cannot
-- exceed Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
if Right.Length = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
if Right.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
Last : constant Index_Type := Right.Last + 1;
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access := new Elements_Type (Last);
I : Index_Type'Base := Index_Type'First;
begin
begin
Elements.EA (I) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
raise;
end;
for RI in RE'Range loop
I := I + 1;
begin
if RE (RI) /= null then
Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
return (Controlled with Elements, Last, 0, 0);
end;
return Result : Vector do
Reserve_Capacity (Result, 1 + Length (Right));
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left, Right : Element_Type) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- We must compute the length of the result vector and its last index,
-- but in such a way that overflow is avoided. We must satisfy two
-- constraints: the new length cannot exceed Count_Type'Last (here, we
-- know that that condition is satisfied), and the new Last index cannot
-- exceed Index_Type'Last.
if Index_Type'First >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
Last : constant Index_Type := Index_Type'First + 1;
Elements : Elements_Access := new Elements_Type (Last);
begin
begin
Elements.EA (Index_Type'First) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
raise;
end;
begin
Elements.EA (Last) := new Element_Type'(Right);
exception
when others =>
Free (Elements.EA (Index_Type'First));
Free (Elements);
raise;
end;
return (Controlled with Elements, Last, 0, 0);
end;
return Result : Vector do
Reserve_Capacity (Result, 1 + 1);
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
---------
......@@ -494,67 +103,31 @@ package body Ada.Containers.Indefinite_Vectors is
---------
overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin
if Left'Address = Right'Address then
return True;
end if;
if Left.Last /= Right.Last then
return False;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- 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
for J in Index_Type range Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) = null then
if Right.Elements.EA (J) /= null then
Result := False;
exit;
return False;
end if;
elsif Right.Elements.EA (J) = null then
Result := False;
exit;
return False;
elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
Result := False;
exit;
return False;
end if;
end loop;
BL := BL - 1;
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;
return True;
end "=";
------------
......@@ -576,8 +149,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
Container.Elements := null;
Container.Last := No_Index;
Container.Busy := 0;
Container.Lock := 0;
Zero_Counts (Container.TC);
Container.Elements := new Elements_Type (L);
......@@ -591,20 +163,6 @@ package body Ada.Containers.Indefinite_Vectors is
end;
end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------
-- Append --
------------
......@@ -613,7 +171,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Is_Empty (New_Item) then
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";
else
Insert (Container, Container.Last + 1, New_Item);
......@@ -626,14 +184,56 @@ package body Ada.Containers.Indefinite_Vectors is
Count : Count_Type := 1)
is
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
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";
else
Insert (Container, Container.Last + 1, New_Item, Count);
end if;
end Append;
end Append_Slow_Path;
------------
-- Assign --
......@@ -668,21 +268,17 @@ package body Ada.Containers.Indefinite_Vectors is
procedure Clear (Container : in out Vector) is
begin
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
TC_Check (Container.TC);
else
while Container.Last >= Index_Type'First loop
declare
X : Element_Access := Container.Elements.EA (Container.Last);
begin
Container.Elements.EA (Container.Last) := null;
Container.Last := Container.Last - 1;
Free (X);
end;
end loop;
end if;
while Container.Last >= Index_Type'First loop
declare
X : Element_Access := Container.Elements.EA (Container.Last);
begin
Container.Elements.EA (Container.Last) := null;
Container.Last := Container.Last - 1;
Free (X);
end;
end loop;
end Clear;
------------------------
......@@ -693,72 +289,70 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : aliased Vector;
Position : Cursor) return Constant_Reference_Type
is
E : Element_Access;
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
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
raise Constraint_Error with "element at Position is empty";
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
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 :=
(Element => E.all'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with null));
end if;
end Constant_Reference;
function Constant_Reference
(Container : aliased Vector;
Index : Index_Type) return Constant_Reference_Type
is
E : Element_Access;
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
E := Container.Elements.EA (Index);
if E = null then
raise Constraint_Error with "element at Index is empty";
end if;
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
-- The following will raise Constraint_Error if Element is null
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index),
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Constant_Reference_Type :=
(Element => E.all'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
(Element => Container.Elements.EA (Index),
Control => (Controlled with null));
end if;
end Constant_Reference;
--------------
......@@ -790,9 +384,9 @@ package body Ada.Containers.Indefinite_Vectors is
elsif Capacity >= Source.Length then
C := Capacity;
else
raise Capacity_Error
with "Requested capacity is less than Source length";
elsif Checks then
raise Capacity_Error with
"Requested capacity is less than Source length";
end if;
return Target : Vector do
......@@ -833,7 +427,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- in the base range that immediately precede and immediately follow the
-- 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)";
end if;
......@@ -845,7 +439,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- algorithm, so that case is treated as a proper error.)
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)";
else
return;
......@@ -874,10 +468,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
......@@ -886,7 +477,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else
Count2 := Count_Type'Base (Old_Last - Index + 1);
end if;
......@@ -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 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);
J := Index + Index_Type'Base (Count);
else
......@@ -988,22 +578,21 @@ package body Ada.Containers.Indefinite_Vectors is
Position : in out Cursor;
Count : Count_Type := 1)
is
pragma Warnings (Off, Position);
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
else
Delete (Container, Position.Index, Count);
Position := No_Element;
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
end if;
Delete (Container, Position.Index, Count);
Position := No_Element;
end Delete;
------------------
......@@ -1062,10 +651,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- it is being called while the associated callback procedure is
-- executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- Elements in an indefinite vector are allocated, so we must iterate
-- over the loop and deallocate elements one-at-a-time. We work from
......@@ -1108,14 +694,14 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type) return Element_Type
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
declare
EA : constant Element_Access := Container.Elements.EA (Index);
begin
if EA = null then
if Checks and then EA = null then
raise Constraint_Error with "element is empty";
else
return EA.all;
......@@ -1125,19 +711,21 @@ package body Ada.Containers.Indefinite_Vectors is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
declare
EA : constant Element_Access :=
Position.Container.Elements.EA (Position.Index);
begin
if EA = null then
if Checks and then EA = null then
raise Constraint_Error with "element is empty";
else
return EA.all;
......@@ -1162,25 +750,9 @@ package body Ada.Containers.Indefinite_Vectors is
end Finalize;
procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy;
begin
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
pragma Assert (T_Check); -- not called if check suppressed
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
Unbusy (Object.Container.TC);
end Finalize;
----------
......@@ -1193,7 +765,7 @@ package body Ada.Containers.Indefinite_Vectors is
Position : Cursor := No_Element) return Cursor
is
begin
if Position.Container /= null then
if Checks and then Position.Container /= null then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
......@@ -1207,39 +779,15 @@ package body Ada.Containers.Indefinite_Vectors is
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) /= null
and then Container.Elements.EA (J).all = Item
then
Result := J;
exit;
if Container.Elements.EA (J).all = Item then
return Cursor'(Container'Unrestricted_Access, J);
end if;
end loop;
B := B - 1;
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;
return No_Element;
end;
end Find;
......@@ -1252,39 +800,18 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
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
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
Result := Indx;
exit;
if Container.Elements.EA (Indx).all = Item then
return Indx;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Index;
end Find_Index;
-----------
......@@ -1329,7 +856,7 @@ package body Ada.Containers.Indefinite_Vectors is
function First_Element (Container : Vector) return Element_Type is
begin
if Container.Last = No_Index then
if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
end if;
......@@ -1337,7 +864,7 @@ package body Ada.Containers.Indefinite_Vectors is
EA : constant Element_Access :=
Container.Elements.EA (Index_Type'First);
begin
if EA = null then
if Checks and then EA = null then
raise Constraint_Error with "first element is empty";
else
return EA.all;
......@@ -1397,36 +924,16 @@ package body Ada.Containers.Indefinite_Vectors is
-- element tampering by a generic actual subprogram.
declare
Lock : With_Lock (Container.TC'Unrestricted_Access);
E : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin
B := B + 1;
L := L + 1;
Result := True;
for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then
Result := False;
exit;
for J in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (J + 1), E (J)) then
return False;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return True;
end;
end Is_Sorted;
......@@ -1450,7 +957,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Target'Address = Source'Address then
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
end if;
......@@ -1460,10 +967,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Source.TC);
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
......@@ -1475,19 +979,9 @@ package body Ada.Containers.Indefinite_Vectors is
TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
Lock_Target : With_Lock (Target.TC'Unchecked_Access);
Lock_Source : With_Lock (Source.TC'Unchecked_Access);
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop
pragma Assert
......@@ -1531,22 +1025,6 @@ package body Ada.Containers.Indefinite_Vectors is
J := J - 1;
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 Merge;
......@@ -1579,38 +1057,30 @@ package body Ada.Containers.Indefinite_Vectors is
-- an artifact of our array-based implementation. Logically Sort
-- requires a check for cursor tampering.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
Lock : With_Lock (Container.TC'Unchecked_Access);
begin
B := B + 1;
L := L + 1;
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 Sort;
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 --
-----------------
......@@ -1648,33 +1118,33 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
-- not allow that as the value for Index when specifying where the new
-- items should be inserted, so we must manually check. (That the user
-- is allowed to specify the value at all here is a consequence of the
-- declaration of the Extended_Index subtype, which includes the values
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we
-- do not allow that as the value for Index when specifying where the
-- new items should be inserted, so we must manually check. (That the
-- user is allowed to specify the value at all here is a consequence
-- of the declaration of the Extended_Index subtype, which includes
-- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for the
-- case of appending items to the back end of the vector. (It is assumed
-- that specifying an index value greater than Last + 1 indicates some
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
if Before > Container.Last
and then Before > Container.Last + 1
then
raise Constraint_Error with
"Before index is out of range (too large)";
-- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for
-- the case of appending items to the back end of the vector. (It is
-- assumed that specifying an index value greater than Last + 1
-- indicates some deeper flaw in the caller's algorithm, so that case
-- is treated as a proper error.)
if Before > Container.Last + 1 then
raise Constraint_Error with
"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
......@@ -1687,10 +1157,10 @@ package body Ada.Containers.Indefinite_Vectors 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
-- we must check the sum of the current length and the insertion count.
-- Note that we cannot simply add these values, because of the
-- possibility of overflow.
-- Note: we cannot simply add these values, because of the possibility
-- 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";
end if;
......@@ -1705,7 +1175,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- compare the new length to the maximum length. If the new length is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
......@@ -1740,9 +1210,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- worry about if No_Index were less than 0, but that case is
-- handled above).
if Index_Type'Last - No_Index >=
Count_Type'Pos (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
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -1799,7 +1267,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then
if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range";
end if;
......@@ -1807,7 +1275,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
-- compute its value from the New_Length.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
......@@ -1863,10 +1331,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
if New_Length <= Container.Elements.EA'Length then
......@@ -1916,7 +1381,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
......@@ -2002,7 +1467,7 @@ package body Ada.Containers.Indefinite_Vectors 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.
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);
else
Dst_Last :=
......@@ -2069,7 +1534,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being inserted before some existing elements,
-- so we must slide the existing elements up to their new home.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
......@@ -2219,7 +1684,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- after copying the first slice of the source, and determining that
-- this second slice of the source is empty.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
J := Before + Index_Type'Base (N);
else
J := Index_Type'Base (Count_Type'Base (Before) + N);
......@@ -2242,7 +1707,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- destination that receives this slice of the source. (For the
-- reasons given above, this slice is guaranteed to be non-empty.)
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
Dst_Index := J - Index_Type'Base (Src'Length);
else
Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
......@@ -2266,7 +1731,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -2277,7 +1742,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -2300,9 +1765,8 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
and then Before.Container /=
Vector_Access'(Container'Unrestricted_Access)
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
......@@ -2318,7 +1782,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -2331,7 +1795,7 @@ package body Ada.Containers.Indefinite_Vectors is
Insert (Container, Index, New_Item);
Position := Cursor'(Container'Unrestricted_Access, Index);
Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
......@@ -2343,7 +1807,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -2354,7 +1818,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -2378,16 +1842,14 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
end if;
if Count = 0 then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -2397,7 +1859,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -2436,31 +1898,33 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
-- not allow that as the value for Index when specifying where the new
-- items should be inserted, so we must manually check. (That the user
-- is allowed to specify the value at all here is a consequence of the
-- declaration of the Extended_Index subtype, which includes the values
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we
-- do not allow that as the value for Index when specifying where the
-- new items should be inserted, so we must manually check. (That the
-- user is allowed to specify the value at all here is a consequence
-- of the declaration of the Extended_Index subtype, which includes
-- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for the
-- case of appending items to the back end of the vector. (It is assumed
-- that specifying an index value greater than Last + 1 indicates some
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
-- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for
-- the case of appending items to the back end of the vector. (It is
-- assumed that specifying an index value greater than Last + 1
-- indicates some deeper flaw in the caller's algorithm, so that case
-- is treated as a proper error.)
if Before > Container.Last + 1 then
raise Constraint_Error with
"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
......@@ -2472,11 +1936,11 @@ package body Ada.Containers.Indefinite_Vectors 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
-- we must check the sum of the current length and the insertion
-- count. Note that we cannot simply add these values, because of the
-- possibility of overflow.
-- we must check the sum of the current length and the insertion count.
-- Note: we cannot simply add these values, because of the possibility
-- of overflow.
if Old_Length > Count_Type'Last - Count then
if Checks and then Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range";
end if;
......@@ -2491,7 +1955,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- compare the new length to the maximum length. If the new length is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
......@@ -2525,9 +1989,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- worry about if No_Index were less than 0, but that case is
-- handled above).
if Index_Type'Last - No_Index >=
Count_Type'Pos (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
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -2584,7 +2046,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then
if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range";
end if;
......@@ -2592,7 +2054,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
-- compute its value from the New_Length.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
......@@ -2624,10 +2086,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Insert checks the count to determine whether it is being called while
-- the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
if New_Length <= Container.Elements.EA'Length then
......@@ -2646,7 +2105,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- their new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
......@@ -2692,7 +2151,7 @@ package body Ada.Containers.Indefinite_Vectors 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.
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);
else
Dst_Last :=
......@@ -2722,7 +2181,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being inserted before some existing elements,
-- so we must slide the existing elements up to their new home.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= Count_Type_Last then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
......@@ -2750,7 +2209,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -2766,10 +2225,8 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then
if Before.Container = null or else Before.Index > Container.Last then
if Checks and then Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
......@@ -2782,7 +2239,7 @@ package body Ada.Containers.Indefinite_Vectors is
Insert_Space (Container, Index, Count);
Position := Cursor'(Container'Unrestricted_Access, Index);
Position := (Container'Unrestricted_Access, Index);
end Insert_Space;
--------------
......@@ -2802,30 +2259,18 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
Busy : With_Busy (Container.TC'Unrestricted_Access);
begin
B := B + 1;
begin
for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
end Iterate;
function Iterate (Container : Vector)
function Iterate
(Container : Vector)
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin
-- The value of its Index component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Index
......@@ -2842,7 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is
Container => V,
Index => No_Index)
do
B := B + 1;
Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
......@@ -2852,8 +2297,6 @@ package body Ada.Containers.Indefinite_Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
......@@ -2866,19 +2309,21 @@ package body Ada.Containers.Indefinite_Vectors is
-- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items.
if Start.Container = null then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
if Checks then
if Start.Container = null then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
if Start.Container /= V then
raise Program_Error with
"Start cursor of Iterate designates wrong vector";
end if;
if Start.Container /= V then
raise Program_Error with
"Start cursor of Iterate designates wrong vector";
end if;
if Start.Index > V.Last then
raise Constraint_Error with
"Start position for iterator equals No_Element";
if Start.Index > V.Last then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
end if;
-- The value of its Index component influences the behavior of the First
......@@ -2895,7 +2340,7 @@ package body Ada.Containers.Indefinite_Vectors is
Container => V,
Index => Start.Index)
do
B := B + 1;
Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
......@@ -2934,13 +2379,13 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end Last;
-----------------
------------------
-- Last_Element --
------------------
function Last_Element (Container : Vector) return Element_Type is
begin
if Container.Last = No_Index then
if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
end if;
......@@ -2948,7 +2393,7 @@ package body Ada.Containers.Indefinite_Vectors is
EA : constant Element_Access :=
Container.Elements.EA (Container.Last);
begin
if EA = null then
if Checks and then EA = null then
raise Constraint_Error with "last element is empty";
else
return EA.all;
......@@ -3012,10 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (Source is busy)";
end if;
TC_Check (Source.TC);
Clear (Target); -- Checks busy-bit
......@@ -3049,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
elsif Position.Container /= Object.Container then
elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
else
......@@ -3090,17 +2532,6 @@ package body Ada.Containers.Indefinite_Vectors is
-- 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
begin
if Position.Container = null then
......@@ -3116,7 +2547,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
elsif Position.Container /= Object.Container then
elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
else
......@@ -3124,6 +2555,31 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end Previous;
procedure Previous (Position : in out Cursor) is
begin
if Position.Container = null then
return;
elsif Position.Index > Index_Type'First then
Position.Index := Position.Index - 1;
else
Position := No_Element;
end if;
end Previous;
----------------------
-- 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 --
-------------------
......@@ -3133,33 +2589,19 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type;
Process : not null access procedure (Element : Element_Type))
is
Lock : With_Lock (Container.TC'Unrestricted_Access);
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
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";
end if;
B := B + 1;
L := L + 1;
begin
Process (V.Elements.EA (Index).all);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
Process (V.Elements.EA (Index).all);
end Query_Element;
procedure Query_Element
......@@ -3167,7 +2609,7 @@ package body Ada.Containers.Indefinite_Vectors is
Process : not null access procedure (Element : Element_Type))
is
begin
if Position.Container = null then
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
else
Query_Element (Position.Container.all, Position.Index, Process);
......@@ -3241,72 +2683,70 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : aliased in out Vector;
Position : Cursor) return Reference_Type
is
E : Element_Access;
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
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
raise Constraint_Error with "element at Position is empty";
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
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 :=
(Element => E.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with null));
end if;
end Reference;
function Reference
(Container : aliased in out Vector;
Index : Index_Type) return Reference_Type
is
E : Element_Access;
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
E := Container.Elements.EA (Index);
if E = null then
raise Constraint_Error with "element at Index is empty";
end if;
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
-- The following will raise Constraint_Error if Element is null
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index),
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Reference_Type :=
(Element => E.all'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
(Element => Container.Elements.EA (Index),
Control => (Controlled with null));
end if;
end Reference;
---------------------
......@@ -3319,14 +2759,11 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
TE_Check (Container.TC);
declare
X : Element_Access := Container.Elements.EA (Index);
......@@ -3349,22 +2786,21 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
if Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
TE_Check (Container.TC);
declare
X : Element_Access := Container.Elements.EA (Position.Index);
......@@ -3442,10 +2878,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- so this is the best we can do with respect to minimizing
-- storage).
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
subtype Array_Index_Subtype is Index_Type'Base range
......@@ -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
-- 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
-- computed Last value lies in the base range of the type, and then
......@@ -3498,7 +2931,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -3510,7 +2945,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -3522,7 +2957,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -3539,7 +2974,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -3578,10 +3013,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- internal array having a length that exactly matches the number
-- of items in the container.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
subtype Array_Index_Subtype is Index_Type'Base range
......@@ -3634,10 +3066,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- number of active elements in the container.) We must check whether
-- the container is busy before doing anything else.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- We now allocate a new internal array, having a length different from
-- its current value.
......@@ -3689,10 +3118,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
I : Index_Type;
......@@ -3729,55 +3155,32 @@ package body Ada.Containers.Indefinite_Vectors is
Last : Index_Type'Base;
begin
if Position.Container /= null
if Checks and then Position.Container /= null
and then Position.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Container = null or else Position.Index > Container.Last then
Last := Container.Last;
else
Last := Position.Index;
end if;
Last :=
(if Position.Container = null or else Position.Index > Container.Last
then Container.Last
else Position.Index);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
Result := Indx;
exit;
return Cursor'(Container'Unrestricted_Access, Indx);
end if;
end loop;
B := B - 1;
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;
return No_Element;
end;
end Reverse_Find;
......@@ -3790,41 +3193,24 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
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
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Lock : With_Lock (Container.TC'Unrestricted_Access);
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
Result := No_Index;
begin
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
Result := Indx;
exit;
return Indx;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Index;
end Reverse_Find_Index;
---------------------
......@@ -3835,33 +3221,18 @@ package body Ada.Containers.Indefinite_Vectors is
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
Busy : With_Busy (Container.TC'Unrestricted_Access);
begin
B := B + 1;
begin
for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
end Reverse_Iterate;
----------------
-- Set_Length --
----------------
procedure Set_Length
(Container : in out Vector;
Length : Count_Type)
is
procedure Set_Length (Container : in out Vector; Length : Count_Type) is
Count : constant Count_Type'Base := Container.Length - Length;
begin
......@@ -3875,7 +3246,7 @@ package body Ada.Containers.Indefinite_Vectors is
if Count >= 0 then
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";
else
......@@ -3887,27 +3258,23 @@ package body Ada.Containers.Indefinite_Vectors is
-- Swap --
----------
procedure Swap
(Container : in out Vector;
I, J : Index_Type)
is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
if J > Container.Last then
raise Constraint_Error with "J index is out of range";
if J > Container.Last then
raise Constraint_Error with "J index is out of range";
end if;
end if;
if I = J then
return;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
TE_Check (Container.TC);
declare
EI : Element_Access renames Container.Elements.EA (I);
......@@ -3926,20 +3293,22 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Cursor)
is
begin
if I.Container = null then
raise Constraint_Error with "I cursor has no element";
end if;
if Checks then
if I.Container = null then
raise Constraint_Error with "I cursor has no element";
end if;
if J.Container = null then
raise Constraint_Error with "J cursor has no element";
end if;
if J.Container = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
end if;
if I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
end if;
if J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
if J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
end if;
end if;
Swap (Container, I.Index, J.Index);
......@@ -3997,7 +3366,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= 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
......@@ -4010,7 +3379,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -4022,7 +3393,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -4034,7 +3405,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -4051,7 +3422,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -4064,7 +3435,7 @@ package body Ada.Containers.Indefinite_Vectors is
Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, 0, 0);
return Vector'(Controlled with Elements, Last, TC => <>);
end To_Vector;
function To_Vector
......@@ -4087,7 +3458,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
if Index_Type'Base'Last >= 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
......@@ -4100,7 +3471,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -4112,7 +3485,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -4124,7 +3497,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -4141,7 +3514,7 @@ package body Ada.Containers.Indefinite_Vectors is
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";
end if;
......@@ -4191,7 +3564,7 @@ package body Ada.Containers.Indefinite_Vectors is
raise;
end;
return (Controlled with Elements, Last, 0, 0);
return (Controlled with Elements, Last, TC => <>);
end To_Vector;
--------------------
......@@ -4203,32 +3576,17 @@ package body Ada.Containers.Indefinite_Vectors is
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
Lock : With_Lock (Container.TC'Unchecked_Access);
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
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";
end if;
B := B + 1;
L := L + 1;
begin
Process (Container.Elements.EA (Index).all);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
Process (Container.Elements.EA (Index).all);
end Update_Element;
procedure Update_Element
......@@ -4237,15 +3595,15 @@ package body Ada.Containers.Indefinite_Vectors is
Process : not null access procedure (Element : in out Element_Type))
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
else
Update_Element (Container, Position.Index, Process);
if Checks then
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";
end if;
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------
......
gcc/ada/a-coinve.ads
......@@ -343,6 +343,7 @@ package Ada.Containers.Indefinite_Vectors is
private
pragma Inline (Append);
pragma Inline (First_Index);
pragma Inline (Last_Index);
pragma Inline (Element);
......@@ -351,35 +352,37 @@ private
pragma Inline (Query_Element);
pragma Inline (Update_Element);
pragma Inline (Replace_Element);
pragma Inline (Is_Empty);
pragma Inline (Contains);
pragma Inline (Next);
pragma Inline (Previous);
package Implementation is new Generic_Implementation;
use Implementation;
type Element_Access is access Element_Type;
type Elements_Array is array (Index_Type range <>) of Element_Access;
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);
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
Elements : Elements_Access;
type Vector is new Controlled with record
Elements : Elements_Access := null;
Last : Extended_Index := No_Index;
Busy : Natural := 0;
Lock : Natural := 0;
TC : aliased Tamper_Counts;
end record;
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
use Ada.Finalization;
use Ada.Streams;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Vector);
......@@ -412,16 +415,8 @@ private
for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
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);
subtype Reference_Control_Type is Implementation.Reference_Control_Type;
-- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
......@@ -467,16 +462,33 @@ private
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);
Empty_Vector : constant Vector := (Controlled with others => <>);
type Iterator is new Limited_Controlled and
Vector_Iterator_Interfaces.Reversible_Iterator with
record
Container : Vector_Access;
Index : Index_Type'Base;
end record;
end record
with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
......
gcc/ada/a-convec.adb
......@@ -450,9 +450,9 @@ package body Ada.Containers.Vectors is
return;
end if;
-- There are some elements aren't being deleted (the requested count was
-- less than the available count), so we must slide them down to
-- Index. We first calculate the index values of the respective array
-- There are some elements that aren't being deleted (the requested
-- count was less than the available count), so we must slide them down
-- to Index. We first calculate the index values of the respective array
-- slices, using the wider of Index_Type'Base and Count_Type'Base as the
-- type for intermediate calculations. For the elements that slide down,
-- index value New_Last is the last index value of their new home, and
......@@ -583,9 +583,9 @@ package body Ada.Containers.Vectors is
begin
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
else
return Container.Elements.EA (Index);
end if;
return Container.Elements.EA (Index);
end Element;
function Element (Position : Cursor) return Element_Type is
......@@ -692,9 +692,9 @@ package body Ada.Containers.Vectors is
begin
if Is_Empty (Container) then
return No_Element;
else
return (Container'Unrestricted_Access, Index_Type'First);
end if;
return (Container'Unrestricted_Access, Index_Type'First);
end First;
function First (Object : Iterator) return Cursor is
......@@ -1030,7 +1030,6 @@ package body Ada.Containers.Vectors is
-- handled above).
if Index_Type'Last - No_Index >= Count_Type_Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -1655,7 +1654,6 @@ package body Ada.Containers.Vectors is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type_Last then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
......@@ -1690,7 +1688,6 @@ package body Ada.Containers.Vectors is
-- handled above).
if Index_Type'Last - No_Index >= Count_Type_Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -1965,7 +1962,7 @@ package body Ada.Containers.Vectors is
Index := Before.Index;
end if;
Insert_Space (Container, Index, Count => Count);
Insert_Space (Container, Index, Count);
Position := (Container'Unrestricted_Access, Index);
end Insert_Space;
......@@ -2022,7 +2019,7 @@ package body Ada.Containers.Vectors is
function Iterate
(Container : Vector;
Start : Cursor)
return Vector_Iterator_Interfaces.Reversible_Iterator'class
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
V : constant Vector_Access := Container'Unrestricted_Access;
begin
......@@ -2911,6 +2908,7 @@ package body Ada.Containers.Vectors is
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Vector;
Process : not null access procedure (Position : Cursor))
......@@ -3119,7 +3117,7 @@ package body Ada.Containers.Vectors is
Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, others => <>);
return Vector'(Controlled with Elements, Last, TC => <>);
end To_Vector;
function To_Vector
......@@ -3211,7 +3209,7 @@ package body Ada.Containers.Vectors is
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;
--------------------
......
gcc/ada/a-convec.ads
......@@ -487,7 +487,7 @@ private
(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 => <>);
......
gcc/ada/a-finali.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -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.
------------
-- 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;
pragma No_Body;
gcc/ada/a-finali.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -43,15 +43,15 @@ package Ada.Finalization is
type Controlled is abstract tagged private;
pragma Preelaborable_Initialization (Controlled);
procedure Initialize (Object : in out Controlled);
procedure Adjust (Object : in out Controlled);
procedure Finalize (Object : in out Controlled);
procedure Initialize (Object : in out Controlled) is null;
procedure Adjust (Object : in out Controlled) is null;
procedure Finalize (Object : in out Controlled) is null;
type Limited_Controlled is abstract tagged limited private;
pragma Preelaborable_Initialization (Limited_Controlled);
procedure Initialize (Object : in out Limited_Controlled);
procedure Finalize (Object : in out Limited_Controlled);
procedure Initialize (Object : in out Limited_Controlled) is null;
procedure Finalize (Object : in out Limited_Controlled) is null;
private
package SFR renames System.Finalization_Root;
......
gcc/ada/sem_ch13.adb
......@@ -2036,8 +2036,8 @@ package body Sem_Ch13 is
Analyze_And_Resolve (Expr, Standard_Integer);
-- Interrupt_Priority aspect not allowed for main
-- subprograms. ARM D.1 does not forbid this explicitly,
-- but ARM J.15.11 (6/3) does not permit pragma
-- subprograms. RM D.1 does not forbid this explicitly,
-- but RM J.15.11(6/3) does not permit pragma
-- Interrupt_Priority for subprograms.
if A_Id = Aspect_Interrupt_Priority then
......@@ -2060,7 +2060,7 @@ package body Sem_Ch13 is
(Specification (N)))
or else not Is_Compilation_Unit (Defining_Entity (N))
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
("aspect applied to subprogram other than the "
......@@ -11419,9 +11419,20 @@ package body Sem_Ch13 is
declare
Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
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_Read
or else Id = Attribute_Variable_Indexing
or else Id = Attribute_Write
or else Id = Attribute_External_Tag;
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