-- --
-- 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- --
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 "&";
---------
---------
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 "=";
------------
begin
Container.Elements := null;
Container.Last := No_Index;
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
Container.Elements := new Elements_Type (L);
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);
New_Item : Element_Type;
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 --
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;
------------------------
(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;
--------------
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
-- 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
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;
-- 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
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);
-- Elements in an indefinite vector are allocated, so we must iterate
-- over the loop and deallocate elements one-at-a-time. We work from
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;
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;
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) /= 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;
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;
-----------
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;
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;
-- 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;
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);
I := Target.Last; -- original value (before Set_Length)
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; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop
pragma Assert
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;
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 --
-----------------
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
-- 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;
-- 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.
-- 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.
-- 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;
-- 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);
-- 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
-- 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);
-- 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 :=
-- 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);
-- 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);
-- 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);
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
- 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;
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;
Insert (Container, Index, New_Item);
- Position := Cursor'(Container'Unrestricted_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert;
procedure Insert
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 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);
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.)
-
- 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
-- 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;
-- 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.
-- 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.
-- 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;
-- 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);
-- 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
-- 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);
-- 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 :=
-- 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);
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";
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;
Insert_Space (Container, Index, Count);
- Position := Cursor'(Container'Unrestricted_Access, Index);
+ Position := (Container'Unrestricted_Access, Index);
end Insert_Space;
--------------
(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
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;
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;
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;
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
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
-- 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
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
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 --
-------------------
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
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);
(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;
---------------------
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);
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);
-- 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
-- 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
-- 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;
-- 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
-- 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
I : 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";
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;
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;
---------------------
(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
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
-- 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);
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);
-- 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
-- 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;
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
-- 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
-- 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;
raise;
end;
- return (Controlled with Elements, Last, 0, 0);
+ return (Controlled with Elements, Last, TC => <>);
end To_Vector;
--------------------
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
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