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);
- type Iterator is new Limited_Controlled and
- Vector_Iterator_Interfaces.Reversible_Iterator with
- record
- Container : Vector_Access;
- Index : Index_Type'Base;
- end record;
-
- overriding procedure Finalize (Object : in out Iterator);
-
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- overriding function Previous
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
procedure Append_Slow_Path
(Container : in out Vector;
New_Item : Element_Type;
-- "&" --
---------
- 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 index 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 : constant Elements_Access :=
- new Elements_Type'(Right.Last, RE);
- begin
- return (Controlled with Elements, Right.Last, others => <>);
- end;
- end if;
-
- if RN = 0 then
- declare
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
- Elements : constant Elements_Access :=
- new Elements_Type'(Left.Last, LE);
- begin
- return (Controlled with Elements, Left.Last, others => <>);
- end;
-
- end if;
-
- -- Neither of the vector parameters is empty, so 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, without fear of
- -- overflow.
-
- 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_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 : constant Elements_Access :=
- new Elements_Type'(Last, LE & RE);
- begin
- return (Controlled with Elements, Last, others => <>);
- 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
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.
-
- -- Handle easy case first, when the vector parameter (Left) is empty
-
- if Left.Is_Empty then
- declare
- Elements : constant Elements_Access :=
- new Elements_Type'
- (Last => Index_Type'First,
- EA => (others => Right));
-
- begin
- return (Controlled with Elements, Index_Type'First, others => <>);
- 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 : constant Elements_Access :=
- new Elements_Type'(Last => Last, EA => LE & Right);
- begin
- return (Controlled with Elements, Last, others => <>);
- 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
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.
-
- -- Handle easy case first, when the vector parameter (Right) is empty
-
- if Right.Is_Empty then
- declare
- Elements : constant Elements_Access :=
- new Elements_Type'
- (Last => Index_Type'First,
- EA => (others => Left));
- begin
- return (Controlled with Elements, Index_Type'First, others => <>);
- 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 : constant Elements_Access :=
- new Elements_Type'
- (Last => Last,
- EA => Left & RE);
-
- begin
- return (Controlled with Elements, Last, others => <>);
- 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 : constant Elements_Access :=
- new Elements_Type'
- (Last => Last,
- EA => (Left, Right));
-
- begin
- return (Controlled with Elements, Last, others => <>);
- end;
+ return Result : Vector do
+ Reserve_Capacity (Result, 1 + 1);
+ Append (Result, Left);
+ Append (Result, Right);
+ end return;
end "&";
---------
---------
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;
-
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 range Index_Type'First .. Left.Last loop
- if Left.Elements.EA (J) /= Right.Elements.EA (J) then
- Result := False;
- exit;
- 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;
+ declare
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+ Left_Valid : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
+ Right_Valid : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
+ begin
+ return Left_Valid = Right_Valid;
+ end;
end "=";
------------
begin
Container.Elements := null;
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
-- Note: it may seem that the following assignment to Container.Last
-- is useless, since we assign it to L below. However this code 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 --
------------
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);
and then Container.Elements /= null
and then Container.Last /= Container.Elements.Last
then
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (vector is busy)";
- end if;
+ TC_Check (Container.TC);
-- Increment Container.Last after assigning the New_Item, so we
-- leave the Container unmodified in case Finalize/Adjust raises
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);
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)";
- else
- Container.Last := No_Index;
- end if;
+ TC_Check (Container.TC);
+ Container.Last := No_Index;
end Clear;
------------------------
Position : Cursor) return Constant_Reference_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 > 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
- C : Vector renames Position.Container.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
+ return R : constant Constant_Reference_Type :=
+ (Element => Container.Elements.EA (Position.Index)'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
+ else
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
+ Control => (Controlled with null));
+ end if;
end Constant_Reference;
function Constant_Reference
Index : Index_Type) return Constant_Reference_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";
- else
+ end if;
+
+ if T_Check then
declare
- C : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
+ else
+ return R : constant Constant_Reference_Type :=
+ (Element => Container.Elements.EA (Index)'Access,
+ Control => (Controlled with null));
end if;
end Constant_Reference;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with
"Requested capacity is less than Source length";
end if;
-- 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;
-- 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;
-- 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
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;
------------------
-- 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);
-- There is no restriction on how large Count can be when deleting
-- items. If it is equal or greater than the current length, then this
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";
else
return Container.Elements.EA (Index);
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Container = null then
- raise Constraint_Error with "Position cursor has no element";
- elsif Position.Index > Position.Container.Last then
- raise Constraint_Error with "Position cursor is out of range";
- else
- return Position.Container.Elements.EA (Position.Index);
+ if Checks then
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ elsif Position.Index > Position.Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
end if;
+
+ return Position.Container.Elements.EA (Position.Index);
end Element;
--------------
Free (X);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (vector is busy)";
- end if;
+ TC_Check (Container.TC);
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;
----------
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;
-- 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) = Item then
- Result := J;
- exit;
+ 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;
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) = 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 Find_Index;
-----------
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";
else
return Container.Elements.EA (Index_Type'First);
-- element tampering by a generic actual subprogram.
declare
- EA : Elements_Array renames Container.Elements.EA;
-
- B : Natural renames Container'Unrestricted_Access.Busy;
- L : Natural renames Container'Unrestricted_Access.Lock;
-
- Result : Boolean;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
+ EA : Elements_Array renames Container.Elements.EA;
begin
- B := B + 1;
- L := L + 1;
-
- Result := True;
for J in Index_Type'First .. Container.Last - 1 loop
if EA (J + 1) < EA (J) then
- Result := False;
- exit;
+ 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;
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;
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);
Target.Set_Length (Length (Target) + Length (Source));
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;
while Source.Last >= Index_Type'First loop
pragma Assert (Source.Last <= Index_Type'First
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;
-- 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;
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.)
+ -- 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)";
+ 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
-- 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;
-- 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;
-- 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);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
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 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;
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 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;
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 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";
else
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 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;
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.)
+ -- 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)";
+ 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
-- 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;
-- 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;
-- 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);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
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 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";
else
(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
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
Container => V,
Index => No_Index)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
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,
-- 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
Container => V,
Index => Start.Index)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
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";
else
return Container.Elements.EA (Container.Last);
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (Target is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (Source is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
declare
Target_Elements : constant Elements_Access := Target.Elements;
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
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
function Pseudo_Reference
(Container : aliased Vector'Class) return Reference_Control_Type
is
- C : constant Vector_Access := Container'Unrestricted_Access;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
- return R : constant Reference_Control_Type :=
- (Controlled with C)
- do
- B := B + 1;
- L := L + 1;
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
end return;
end Pseudo_Reference;
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;
- B := B + 1;
- L := L + 1;
-
- begin
- Process (V.Elements.EA (Index));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (V.Elements.EA (Index));
end Query_Element;
procedure Query_Element
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);
Position : Cursor) return Reference_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 > 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
- C : Vector renames Position.Container.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
+ return R : constant Reference_Type :=
+ (Element => Container.Elements.EA (Position.Index)'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
+ else
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access,
- Control => (Controlled with Position.Container))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
+ Control => (Controlled with null));
+ end if;
end Reference;
function Reference
Index : Index_Type) return Reference_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;
- else
+ if T_Check then
declare
- C : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
+ else
+ return R : constant Reference_Type :=
+ (Element => Container.Elements.EA (Index)'Access,
+ Control => (Controlled with null));
end if;
end Reference;
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";
- elsif Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (vector is locked)";
- else
- Container.Elements.EA (Index) := New_Item;
end if;
+
+ TE_Check (Container.TC);
+ Container.Elements.EA (Index) := New_Item;
end Replace_Element;
procedure Replace_Element
New_Item : Element_Type)
is
begin
- if Position.Container = null then
- raise Constraint_Error with "Position cursor has no element";
+ 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";
-
- elsif Position.Index > Container.Last then
- raise Constraint_Error with "Position cursor is out of range";
+ elsif Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor denotes wrong container";
- else
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (vector is locked)";
+ elsif Position.Index > Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
end if;
-
- Container.Elements.EA (Position.Index) := New_Item;
end if;
+
+ TE_Check (Container.TC);
+ Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element;
----------------------
-- 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 Src_Index_Subtype is Index_Type'Base range
-- 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;
-- 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;
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;
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;
-- new internal array having a length that exactly matches the
-- number of items in the container.
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (vector is busy)";
- end if;
+ TC_Check (Container.TC);
declare
subtype Src_Index_Subtype is Index_Type'Base range
-- 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.
-- 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
K : Index_Type;
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";
-- 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) = 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;
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;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, 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;
-
- Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = 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;
---------------------
-- Reverse_Iterate --
---------------------
-
procedure Reverse_Iterate
(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;
----------------
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
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_Copy : constant Element_Type := Container.Elements.EA (I);
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
- if I.Container = null then
- raise Constraint_Error with "I cursor has no element";
+ if Checks then
+ if I.Container = null then
+ raise Constraint_Error with "I cursor has no element";
- elsif J.Container = null then
- raise Constraint_Error with "J cursor has no element";
+ elsif J.Container = null then
+ raise Constraint_Error with "J cursor has no element";
- elsif I.Container /= Container'Unrestricted_Access then
- raise Program_Error with "I cursor denotes wrong container";
+ elsif I.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "I cursor denotes wrong container";
- elsif J.Container /= Container'Unrestricted_Access then
- raise Program_Error with "J cursor denotes wrong container";
-
- else
- Swap (Container, I.Index, J.Index);
+ elsif 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);
end Swap;
---------------
-- 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;
-- 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;
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;
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;
-- 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;
-- 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;
Index := Count_Type'Base (No_Index) + Length; -- same value as V.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;
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;
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;
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Container.Elements.EA (Index));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Container.Elements.EA (Index));
end Update_Element;
procedure Update_Element
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;
-----------
projects / gcc.git / commitdiff