+2015-10-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_One_Aspect): Avoid
+ analyzing the expression in a 'Disable_Controlled attribute when
+ Expander_Active is False, because otherwise, we get errors about
+ nonstatic expressions in pragma-Preelaborate generic packages.
+ * restrict.ads: minor whitespace cleanup in comment
+
+2015-10-20 Bob Duff <duff@adacore.com>
+
+ * a-conhel.adb: Remove "use SAC;", because otherwise the compiler
+ complains about use clauses in run-time units. Use "use type"
+ instead.
+ * a-btgbso.adb, a-btgbso.ads, a-cbdlli.adb, a-cbdlli.ads,
+ * a-cbhama.adb, a-cbhama.ads, a-cbhase.adb, a-cbhase.ads,
+ * a-cbmutr.adb, a-cbmutr.ads, a-cborma.adb, a-cborma.ads,
+ * a-cborse.adb, a-cborse.ads, a-cdlili.adb, a-cdlili.ads,
+ * a-chtgbk.adb, a-chtgbk.ads, a-chtgbo.adb, a-chtgbo.ads,
+ * a-chtgke.adb, a-chtgke.ads, a-chtgop.adb, a-chtgop.ads,
+ * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads,
+ * a-cihase.adb, a-cihase.ads, a-cimutr.adb, a-cimutr.ads,
+ * a-ciorma.adb, a-ciorma.ads, a-ciormu.adb, a-ciormu.ads,
+ * a-ciorse.adb, a-ciorse.ads, a-cobove.adb, a-cobove.ads,
+ * a-cohama.adb, a-cohama.ads, a-cohase.adb, a-cohase.ads,
+ * a-cohata.ads, a-coinve.adb, a-comutr.adb, a-comutr.ads,
+ * a-convec.adb, a-coorma.adb, a-coorma.ads, a-coormu.adb,
+ * a-coormu.ads, a-coorse.adb, a-coorse.ads, a-crbltr.ads,
+ * a-crbtgk.adb, a-crbtgk.ads, a-crbtgo.adb, a-crbtgo.ads,
+ * a-rbtgbk.adb, a-rbtgbk.ads, a-rbtgbo.adb, a-rbtgbo.ads,
+ * a-rbtgso.adb, a-rbtgso.ads: Change all the predefined containers
+ to share the tampering machinery in Ada.Containers.Helpers. This
+ reduces the amount of duplicated code, and takes advantage of
+ efficiency improvements in Helpers.
+ Protect all run-time checks and supporting machinery with "if
+ Checks" or "if T_Check", so this code can be suppressed with
+ pragma Suppress or -gnatp.
+ Add Pseudo_Reference and Get_Element_Access to remaining
+ containers, so that the compiler can optimize "for ... of" loops.
+
2015-10-20 Bob Duff <duff@adacore.com>
* a-contai.adb, a-coinve.ads, a-contai.ads, a-conhel.adb, a-conhel.ads,
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
----------------
procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt, Src : Count_Type;
TN : Nodes_Type renames Target.Nodes;
begin
if Target'Address = Source'Address then
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
Tree_Operations.Clear_Tree (Target);
return;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
Tgt := Target.First;
Src := Source.First;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (TN (Tgt), SN (Src)) then
Compare := -1;
elsif Is_Less (SN (Src), TN (Tgt)) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Count_Type;
R_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
R_Node := Tree_Operations.Next (Right, R_Node);
end if;
end loop;
-
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
- exception
- when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
- raise;
end;
end return;
end Set_Difference;
(Target : in out Set_Type;
Source : Set_Type)
is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt : Count_Type;
Src : Count_Type;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
if Source.Length = 0 then
Tree_Operations.Clear_Tree (Target);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
Compare := -1;
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Count_Type;
R_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
R_Node := Tree_Operations.Next (Right, R_Node);
end if;
end loop;
-
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
- exception
- when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
- raise;
end;
end return;
end Set_Intersection;
-- element tampering by a generic actual subprogram.
declare
- BL : Natural renames Subset'Unrestricted_Access.Busy;
- LL : Natural renames Subset'Unrestricted_Access.Lock;
-
- BR : Natural renames Of_Set'Unrestricted_Access.Busy;
- LR : Natural renames Of_Set'Unrestricted_Access.Lock;
+ Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access);
+ Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access);
Subset_Node : Count_Type;
Set_Node : Count_Type;
-
- Result : Boolean;
-
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
Subset_Node := Subset.First;
Set_Node := Of_Set.First;
loop
if Set_Node = 0 then
- Result := Subset_Node = 0;
- exit;
+ return Subset_Node = 0;
end if;
if Subset_Node = 0 then
- Result := True;
- exit;
+ return True;
end if;
if Is_Less (Subset.Nodes (Subset_Node),
Of_Set.Nodes (Set_Node))
then
- Result := False;
- exit;
+ return False;
end if;
if Is_Less (Of_Set.Nodes (Set_Node),
Subset_Node := Tree_Operations.Next (Subset, Subset_Node);
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;
end;
end Set_Subset;
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Count_Type;
R_Node : Count_Type;
-
- Result : Boolean;
-
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0
or else R_Node = 0
then
- Result := False;
- exit;
+ return False;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
L_Node := Tree_Operations.Next (Left, L_Node);
-
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
R_Node := Tree_Operations.Next (Right, R_Node);
-
else
- Result := True;
- exit;
+ return True;
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;
end;
end Set_Overlap;
(Target : in out Set_Type;
Source : Set_Type)
is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt : Count_Type;
Src : Count_Type;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
Compare := -1;
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Count_Type;
R_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
R_Node := Tree_Operations.Next (Right, R_Node);
end if;
end loop;
-
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
- exception
- when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
- raise;
end;
end return;
end Set_Symmetric_Difference;
-- element tampering by a generic actual subprogram.
declare
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BS := BS + 1;
- LS := LS + 1;
-
-- Note that there's no way to decide a priori whether the target has
-- enough capacity for the union with source. We cannot simply
-- compare the sum of the existing lengths to the capacity of the
-- the union.
Iterate (Source);
-
- BS := BS - 1;
- LS := LS - 1;
- exception
- when others =>
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
end Set_Union;
return Result : Set_Type (Left.Length + Right.Length) do
declare
- 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;
-
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
Assign (Target => Result, Source => Left);
Insert_Right : declare
begin
Iterate (Right);
end Insert_Right;
-
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
- exception
- when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
- raise;
end;
end return;
end Set_Union;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, 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- --
type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private;
- use Tree_Operations.Tree_Types;
+ use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation;
with procedure Assign (Target : in out Set_Type; Source : Set_Type);
-- --
-- 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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
---------
function "=" (Left, Right : List) return Boolean is
- BL : Natural renames Left'Unrestricted_Access.Busy;
- LL : Natural renames Left'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- BR : Natural renames Right'Unrestricted_Access.Busy;
- LR : Natural renames Right'Unrestricted_Access.Lock;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
LN : Node_Array renames Left.Nodes;
RN : Node_Array renames Right.Nodes;
LI : Count_Type;
RI : Count_Type;
-
- Result : Boolean;
-
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
if Left.Length /= Right.Length 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;
-
LI := Left.First;
RI := Right.First;
- Result := True;
for J in 1 .. Left.Length loop
if LN (LI).Element /= RN (RI).Element then
- Result := False;
- exit;
+ return False;
end if;
LI := LN (LI).Next;
RI := RN (RI).Next;
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 "=";
--------------
Insert (Container, No_Element, New_Item, Count);
end Append;
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error -- ???
with "Target capacity is less than Source length";
end if;
if Container.Length = 0 then
pragma Assert (Container.First = 0);
pragma Assert (Container.Last = 0);
- pragma Assert (Container.Busy = 0);
- pragma Assert (Container.Lock = 0);
+ pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
pragma Assert (N (Container.First).Prev = 0);
pragma Assert (N (Container.Last).Next = 0);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
while Container.Length > 1 loop
X := Container.First;
Position : Cursor) return Constant_Reference_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";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
+ pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
- declare
- N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
- begin
- return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
- end if;
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
--------------
C := Source.Length;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
X : Count_Type;
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for Index in 1 .. Count loop
pragma Assert (Container.Length >= 2);
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.First;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.Last;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Element");
+ pragma Assert (Vet (Position), "bad cursor in Element");
- return Position.Container.Nodes (Position.Node).Element;
- end if;
+ return Position.Container.Nodes (Position.Node).Element;
end Element;
--------------
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
Node := Container.First;
else
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates 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 : Count_Type;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := 0;
while Node /= 0 loop
if Nodes (Node).Element = Item then
- Result := Node;
- exit;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Nodes (Node).Next;
end loop;
- B := B - 1;
- L := L - 1;
-
- if Result = 0 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;
function First_Element (Container : List) return Element_Type is
begin
- if Container.First = 0 then
+ if Checks and then Container.First = 0 then
raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (Container.First).Element;
end if;
+
+ return Container.Nodes (Container.First).Element;
end First_Element;
----------
---------------
function Is_Sorted (Container : List) return Boolean is
- B : Natural renames Container'Unrestricted_Access.Busy;
- L : Natural renames Container'Unrestricted_Access.Lock;
-
- Nodes : Node_Array renames Container.Nodes;
- Node : Count_Type;
-
- Result : Boolean;
-
- 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);
+ Nodes : Node_Array renames Container.Nodes;
+ Node : Count_Type;
+ begin
Node := Container.First;
- Result := True;
for J in 2 .. Container.Length loop
if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
- Result := False;
- exit;
+ return False;
end if;
Node := Nodes (Node).Next;
end loop;
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
- raise;
+ return True;
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;
- if Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length
+ then
raise Constraint_Error with "new length exceeds maximum";
end if;
- if Target.Length + Source.Length > Target.Capacity then
+ if Checks and then Target.Length + Source.Length > Target.Capacity
+ then
raise Capacity_Error with "new length exceeds target capacity";
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
- 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);
LN : Node_Array renames Target.Nodes;
RN : Node_Array renames Source.Nodes;
LI, LJ, RI, RJ : Count_Type;
begin
- TB := TB + 1;
- TL := TL + 1;
-
- SB := SB + 1;
- SL := SL + 1;
-
LI := Target.First;
RI := Source.First;
while RI /= 0 loop
LI := LN (LI).Next;
end if;
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;
pragma Assert (N (Container.First).Prev = 0);
pragma Assert (N (Container.Last).Next = 0);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list 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 (Front => 0, Back => 0);
-
- B := B - 1;
- L := L - 1;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
- raise;
end;
pragma Assert (N (Container.First).Prev = 0);
end Generic_Sorting;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Nodes (Position.Node).Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
begin
if Before.Container /= null then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Before cursor designates wrong list";
end if;
return;
end if;
- if Container.Length > Container.Capacity - Count then
+ if Checks and then Container.Length > Container.Capacity - Count then
raise Capacity_Error with "capacity exceeded";
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
Allocate (Container, New_Item, New_Node);
First_Node := New_Node;
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Count_Type := Container.First;
begin
- B := B + 1;
-
- begin
- while Node /= 0 loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Container.Nodes (Node).Next;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= 0 loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Container.Nodes (Node).Next;
+ end loop;
end Iterate;
function Iterate
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => 0)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong list";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Last_Element (Container : List) return Element_Type is
begin
- if Container.Last = 0 then
+ if Checks and then Container.Last = 0 then
raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (Container.Last).Element;
end if;
+
+ return Container.Nodes (Container.Last).Element;
end Last_Element;
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error with "Source length exceeds Target capacity";
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ TC_Check (Source.TC);
-- Clear target, note that this checks busy bits of Target
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong list";
- else
- return Next (Position);
end if;
+
+ return Next (Position);
end Next;
-------------
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong list";
- else
- return Previous (Position);
end if;
+
+ return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased List'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 --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
declare
+ Lock : With_Lock (Position.Container.TC'Unrestricted_Access);
C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
-
+ N : Node_Type renames C.Nodes (Position.Node);
begin
- B := B + 1;
- L := L + 1;
-
- declare
- N : Node_Type renames C.Nodes (Position.Node);
- begin
- Process (N.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Element);
end;
end Query_Element;
Clear (Item);
Count_Type'Base'Read (Stream, N);
- if N < 0 then
+ if Checks and then N < 0 then
raise Program_Error with "bad list length (corrupt stream)";
+ end if;
- elsif N = 0 then
+ if N = 0 then
return;
+ end if;
- elsif N > Item.Capacity then
+ if Checks and then N > Item.Capacity then
raise Constraint_Error with "length exceeds capacity";
-
- else
- for Idx in 1 .. N loop
- Allocate (Item, Stream, New_Node => X);
- Insert_Internal (Item, Before => 0, New_Node => X);
- end loop;
end if;
+
+ for Idx in 1 .. N loop
+ Allocate (Item, Stream, New_Node => X);
+ Insert_Internal (Item, Before => 0, New_Node => X);
+ end loop;
end Read;
procedure Read
Position : Cursor) return Reference_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";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in function Reference");
+ pragma Assert (Vet (Position), "bad cursor in function Reference");
- declare
- N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
- begin
- return R : constant Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
- end if;
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Type :=
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
---------------------
New_Item : 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";
+ end if;
- elsif Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- elsif Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
+ TE_Check (Container.TC);
- else
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- Container.Nodes (Position.Node).Element := New_Item;
- end if;
+ Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
----------------------
pragma Assert (N (Container.First).Prev = 0);
pragma Assert (N (Container.Last).Next = 0);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
Container.First := J;
Container.Last := I;
Node := Container.Last;
else
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates 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 : Count_Type;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := 0;
while Node /= 0 loop
if Container.Nodes (Node).Element = Item then
- Result := Node;
- exit;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Container.Nodes (Node).Prev;
end loop;
- B := B - 1;
- L := L - 1;
-
- if Result = 0 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;
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Count_Type := Container.Last;
begin
- B := B + 1;
-
- begin
- while Node /= 0 loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Container.Nodes (Node).Prev;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= 0 loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Container.Nodes (Node).Prev;
+ end loop;
end Reverse_Iterate;
------------
is
begin
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
end if;
if Target'Address = Source'Address or else Source.Length = 0 then
return;
+ end if;
- elsif Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum";
+ end if;
- elsif Target.Length + Source.Length > Target.Capacity then
+ if Checks and then Target.Length + Source.Length > Target.Capacity then
raise Capacity_Error with "new length exceeds target capacity";
+ end if;
- elsif Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
-
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
- else
- Splice_Internal (Target, Before.Node, Source);
- end if;
+ Splice_Internal (Target, Before.Node, Source);
end Splice;
procedure Splice
begin
if Before.Container /= null then
- if Before.Container /= Container'Unchecked_Access then
+ if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
"Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Container.Length >= 2);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
if Before.Node = 0 then
pragma Assert (Position.Node /= Container.Last);
end if;
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
- if Target.Length >= Target.Capacity then
+ if Checks and then Target.Length >= Target.Capacity then
raise Capacity_Error with "Target is full";
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
Splice_Internal
(Target => Target,
I, J : Cursor)
is
begin
- if I.Node = 0 then
+ if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = 0 then
+ if Checks and then J.Node = 0 then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unchecked_Access then
+ if Checks and then I.Container /= Container'Unchecked_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unchecked_Access then
+ if Checks and then J.Container /= Container'Unchecked_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
- end if;
+ TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
I, J : Cursor)
is
begin
- if I.Node = 0 then
+ if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = 0 then
+ if Checks and then J.Node = 0 then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
declare
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
+ Lock : With_Lock (Container.TC'Unchecked_Access);
+ N : Node_Type renames Container.Nodes (Position.Node);
begin
- B := B + 1;
- L := L + 1;
-
- declare
- N : Node_Type renames Container.Nodes (Position.Node);
- begin
- Process (N.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Element);
end;
end Update_Element;
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
pragma Inline (Next);
pragma Inline (Previous);
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
use Ada.Streams;
use Ada.Finalization;
First : Count_Type := 0;
Last : Count_Type := 0;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
end record;
procedure Read
for Cursor'Write use Write;
- type Reference_Control_Type is new Controlled with record
- Container : List_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Read use Read;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased List'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_List : constant List := (Capacity => 0, others => <>);
No_Element : constant Cursor := Cursor'(null, 0);
record
Container : List_Access;
Node : Count_Type;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
with System; use type System.Address;
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
return Is_Equal (Left, Right);
end "=";
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Map 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error
with "Target capacity is less than Source length";
end if;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Key_Ops.Find (Container'Unrestricted_Access.all, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
declare
- Cur : Cursor := Find (Container, Key);
- pragma Unmodified (Cur);
-
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Cur.Container.Busy;
- L : Natural renames Cur.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
begin
Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "attempt to delete key not in map";
end if;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "Delete attempted to tamper with cursors (map is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
Key_Ops.Find (Container'Unrestricted_Access.all, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"no element available because key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Map 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
return Object.Container.First;
end First;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Nodes (Position.Node).Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.Lock > 0 then
- raise Program_Error with
- "Include attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Position.Node);
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for a key, given its hash value.
- if Container.Buckets'Length = 0 then
+ if Checks and then Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for a key, given its hash value.
- if Container.Buckets'Length = 0 then
+ if Checks and then Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert key already in map";
end if;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
return It : constant Iterator :=
(Limited_Controlled with
Container => Container'Unrestricted_Access)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Assign (Source);
Source.Clear;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
return Next (Position);
end Next;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Map'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 --
-------------------
procedure (Key : Key_Type; Element : Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
M : Map renames Position.Container.all;
N : Node_Type renames M.Nodes (Position.Node);
- B : Natural renames M.Busy;
- L : Natural renames M.Lock;
-
+ Lock : With_Lock (M.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- declare
-
- begin
- Process (N.Key, N.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Key, N.Element);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
declare
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "Replace attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Node);
-
begin
N.Key := Key;
N.Element := New_Item;
New_Item : Element_Type)
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Position.Container.Lock > 0 then
- raise Program_Error with
- "Replace_Element attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Position.Container.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Capacity : Count_Type)
is
begin
- if Capacity > Container.Capacity then
+ if Checks and then Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
end if;
end Reserve_Capacity;
Element : in out Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (N.Key, N.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Key, N.Element);
end;
end Update_Element;
type Map (Capacity : Count_Type; Modulus : Hash_Type) is
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Streams;
use Ada.Finalization;
for Cursor'Write use Write;
- type Reference_Control_Type is new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Read use Read;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Map : constant Map :=
(Hash_Table_Type with Capacity => 0, Modulus => 0);
Map_Iterator_Interfaces.Forward_Iterator with
record
Container : Map_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
with System; use type System.Address;
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
return Is_Equal (Left, Right);
end "=";
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Set 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error
with "Target capacity is less than Source length";
end if;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
C := Source.Length;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
begin
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
Position : in out Cursor)
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.TC);
if Source.Length < Target.Length then
Src_Node := HT_Ops.First (Source);
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
Right : Element_Type) return Boolean
is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
Right : Cursor) return Boolean
is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Set 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
return Object.Container.First;
end First;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Nodes (Position.Node).Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Container.Nodes (Position.Node).Element := New_Item;
end if;
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for an element, given its hash value.
- if Container.Buckets'Length = 0 then
+ if Checks and then Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.TC);
Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Iterate (Container);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Iterate (Container);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
begin
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
return It : constant Iterator :=
Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access);
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Assign (Source);
Source.Clear;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
return False;
end Overlap;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Set'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 --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
S : Set renames Position.Container.all;
- B : Natural renames S.Busy;
- L : Natural renames S.Lock;
-
+ Lock : With_Lock (S.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (S.Nodes (Position.Node).Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (S.Nodes (Position.Node).Element);
end;
end Query_Element;
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Container.Nodes (Node).Element := New_Item;
end Replace;
New_Item : Element_Type)
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
Capacity : Count_Type)
is
begin
- if Capacity > Container.Capacity then
+ if Checks and then Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
end if;
end Reserve_Capacity;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.TC);
Iterate (Source);
end Symmetric_Difference;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.TC);
-- ??? why is this code commented out ???
-- declare
-- Local Subprograms --
-----------------------
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- B : Natural renames Control.Container.Busy;
- L : Natural renames Control.Container.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Type) return Boolean;
Key_Keys.Find (Container'Unrestricted_Access.all, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
declare
- Cur : Cursor := Find (Container, Key);
- pragma Unmodified (Cur);
-
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Cur.Container.Busy;
- L : Natural renames Cur.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
begin
Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "attempt to delete key not in set";
end if;
Key_Keys.Find (Container'Unrestricted_Access.all, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- B : Natural renames Control.Container.Busy;
- L : Natural renames Control.Container.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
+ Impl.Reference_Control_Type (Control).Finalize;
- if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
+ if Checks and then
+ Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
then
HT_Ops.Delete_Node_At_Index
(Control.Container.all, Control.Index, Control.Old_Pos.Node);
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
begin
return R : constant Reference_Type :=
(Element => N.Element'Unrestricted_Access,
Control =>
(Controlled with
+ Container.TC'Unrestricted_Access,
Container'Unrestricted_Access,
Index => Key_Keys.Index (Container, Key (Position)),
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
- do
- B := B + 1;
- L := L + 1;
+ do
+ Lock (Container.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
declare
P : constant Cursor := Find (Container, Key);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
begin
return R : constant Reference_Type :=
(Element => Container.Nodes (Node).Element'Unrestricted_Access,
Control =>
(Controlled with
+ Container.TC'Unrestricted_Access,
Container'Unrestricted_Access,
Index => Key_Keys.Index (Container, Key),
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (Container.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
N : Nodes_Type renames Container.Nodes;
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
declare
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
-
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- -- Record bucket now, in case key is changed
- Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
-
- Process (E);
-
- Eq := Equivalent_Keys (K, Key (E));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ -- Record bucket now, in case key is changed
+ Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
- L := L - 1;
- B := B - 1;
+ Process (E);
- if Eq then
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
while N (Prev).Next /= Position.Node loop
Prev := N (Prev).Next;
- if Prev = 0 then
+ if Checks and then Prev = 0 then
raise Program_Error with
"Position cursor is bad (node not found)";
end if;
with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
+private with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization; use Ada.Finalization;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Index : Hash_Type;
Old_Hash : Hash_Type;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Set (Capacity : Count_Type; Modulus : Hash_Type) is
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Streams;
procedure Write
for Cursor'Read use Read;
- type Reference_Control_Type is new Controlled with record
- Container : Set_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Constant_Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Set : constant Set :=
(Hash_Table_Type with Capacity => 0, Modulus => 0);
Set_Iterator_Interfaces.Forward_Iterator with
record
Container : Set_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Finalization;
with System; use type System.Address;
package body Ada.Containers.Bounded_Multiway_Trees is
pragma Annotate (CodePeer, Skip_Analysis);
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
+ use Finalization;
+
--------------------
-- Root_Iterator --
--------------------
function "=" (Left, Right : Tree) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
if Left.Count /= Right.Count then
return False;
end if;
Right_Subtree => Root_Node (Right));
end "=";
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Tree 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;
-
-------------------
-- Allocate_Node --
-------------------
R, N : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- search. For now we omit this check, pending a ruling from the ARG.
-- ???
--
- -- if Is_Root (Position) then
+ -- if Checks and then Is_Root (Position) then
-- raise Program_Error with "Position cursor designates root";
-- end if;
First, Last : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Count > Container.Capacity - Count then
+ if Checks and then Container.Count > Container.Capacity - Count then
raise Capacity_Error
with "requested count exceeds available storage";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
return;
end if;
- if Target.Capacity < Source.Count then
+ if Checks and then Target.Capacity < Source.Count then
raise Capacity_Error -- ???
with "Target capacity is less than Source count";
end if;
N : Count_Type'Base;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Child = No_Element then
+ if Checks and then Child = No_Element then
raise Constraint_Error with "Child cursor has no element";
end if;
- if Parent.Container /= Child.Container then
+ if Checks and then Parent.Container /= Child.Container then
raise Program_Error with "Parent and Child in different containers";
end if;
Result := Result + 1;
N := Parent.Container.Nodes (N).Parent;
- if N < 0 then
+ if Checks and then N < 0 then
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
Count : Count_Type;
begin
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container_Count = 0 then
return;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
-- "Position cursor in Constant_Reference is bad");
declare
- C : Tree renames Position.Container.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 (Position.Node)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
C := Source.Count;
elsif Capacity >= Source.Count then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
Target_Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then
+ if Checks and then
+ Before.Container.Nodes (Before.Node).Parent /= Parent.Node
+ then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
return;
end if;
- if Is_Root (Source) then
+ if Checks and then Is_Root (Source) then
raise Constraint_Error with "Source cursor designates root";
end if;
Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container.Count = 0 then
pragma Assert (Is_Root (Parent));
X : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if not Is_Leaf (Position) then
+ if Checks and then not Is_Leaf (Position) then
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
Count : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
function Element (Position : Cursor) return 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";
end if;
- if Position.Node = Root_Node (Position.Container.all) then
+ if Checks and then Position.Node = Root_Node (Position.Container.all)
+ then
raise Program_Error with "Position cursor designates root";
end if;
Right_Position : Cursor) return Boolean
is
begin
- if Left_Position = No_Element then
+ if Checks and then Left_Position = No_Element then
raise Constraint_Error with "Left cursor has no element";
end if;
- if Right_Position = No_Element then
+ if Checks and then Right_Position = No_Element then
raise Constraint_Error with "Right cursor has no element";
end if;
--------------
procedure Finalize (Object : in out Root_Iterator) is
- B : Natural renames Object.Container.Busy;
- begin
- B := B - 1;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
begin
- if Control.Container /= null then
- declare
- C : Tree 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;
----------
Node : Count_Type'Base;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
Result : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Commented-out pending ruling by ARG. ???
- -- if Position.Container /= Container'Unrestricted_Access then
+ -- if Checks and then
+ -- Position.Container /= Container'Unrestricted_Access
+ -- then
-- raise Program_Error with "Position cursor not in container";
-- end if;
return Find_In_Children (Container, Subtree, Item);
end Find_In_Subtree;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Elements (Position.Node)'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Last : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then
+ if Checks and then
+ Before.Container.Nodes (Before.Node).Parent /= Parent.Node
+ then
raise Constraint_Error with "Parent cursor not parent of Before";
end if;
end if;
return;
end if;
- if Container.Count > Container.Capacity - Count then
+ if Checks and then Container.Count > Container.Capacity - Count then
raise Capacity_Error
with "requested count exceeds available storage";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
-- OK to reference, see below
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then
+ if Checks and then
+ Before.Container.Nodes (Before.Node).Parent /= Parent.Node
+ then
raise Constraint_Error with "Parent cursor not parent of Before";
end if;
end if;
return;
end if;
- if Container.Count > Container.Capacity - Count then
+ if Checks and then Container.Count > Container.Capacity - Count then
raise Capacity_Error
with "requested count exceeds available storage";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
(Container : Tree;
Process : not null access procedure (Position : Cursor))
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
begin
if Container.Count = 0 then
return;
end if;
- B := B + 1;
-
Iterate_Children
(Container => Container,
Subtree => Root_Node (Container),
Process => Process);
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end Iterate;
function Iterate (Container : Tree)
Process : not null access procedure (Position : Cursor))
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
end if;
declare
- B : Natural renames Parent.Container.Busy;
C : Count_Type;
NN : Tree_Node_Array renames Parent.Container.Nodes;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
begin
- B := B + 1;
-
C := NN (Parent.Node).Children.First;
while C > 0 loop
Process (Cursor'(Parent.Container, Node => C));
C := NN (C).Next;
end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end;
end Iterate_Children;
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
C : constant Tree_Access := Container'Unrestricted_Access;
- B : Natural renames C.Busy;
-
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= C then
+ if Checks and then Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
Container => C,
Subtree => Parent.Node)
do
- B := B + 1;
+ Busy (C.TC);
end return;
end Iterate_Children;
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ C : constant Tree_Access := Position.Container;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Implement Vet for multiway trees???
-- pragma Assert (Vet (Position), "bad subtree cursor");
- declare
- B : Natural renames Position.Container.Busy;
- begin
- return It : constant Subtree_Iterator :=
- (Limited_Controlled with
- Container => Position.Container,
- Subtree => Position.Node)
- do
- B := B + 1;
- end return;
- end;
+ return It : constant Subtree_Iterator :=
+ (Limited_Controlled with
+ Container => C,
+ Subtree => Position.Node)
+ do
+ Busy (C.TC);
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
Process : not null access procedure (Position : Cursor))
is
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
declare
T : Tree renames Position.Container.all;
- B : Natural renames T.Busy;
-
+ Busy : With_Busy (T.TC'Unrestricted_Access);
begin
- B := B + 1;
-
if Is_Root (Position) then
Iterate_Children (T, Position.Node, Process);
else
Iterate_Subtree (T, Position.Node, Process);
end if;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end;
end Iterate_Subtree;
Node : Count_Type'Base;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors of Source (tree is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Assign (Source);
Source.Clear;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
First, Last : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Count > Container.Capacity - Count then
+ if Checks and then Container.Count > Container.Capacity - Count then
raise Capacity_Error
with "requested count exceeds available storage";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
Position := Previous_Sibling (Position);
end Previous_Sibling;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Tree'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 --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Process (Element => T.Elements (Position.Node));
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
end;
end Query_Element;
begin
Count_Type'Read (Stream, Count);
- if Count < 0 then
+ if Checks and then Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Count_Type'Read (Stream, Total_Count);
- if Total_Count < 0 then
+ if Checks and then Total_Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
return;
end if;
- if Total_Count > Container.Capacity then
+ if Checks and then Total_Count > Container.Capacity then
raise Capacity_Error -- ???
with "node count in stream exceeds container capacity";
end if;
Read_Children (Root_Node (Container));
- if Read_Count /= Total_Count then
+ if Checks and then Read_Count /= Total_Count then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
-- "Position cursor in Constant_Reference is bad");
declare
- C : Tree renames Position.Container.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 (Position.Node)'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
-
end Reference;
--------------------
New_Item : Element_Type)
is
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
Container.Elements (Position.Node) := New_Item;
end Replace_Element;
Process : not null access procedure (Position : Cursor))
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
declare
NN : Tree_Node_Array renames Parent.Container.Nodes;
- B : Natural renames Parent.Container.Busy;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
C : Count_Type;
begin
- B := B + 1;
-
C := NN (Parent.Node).Children.Last;
while C > 0 loop
Process (Cursor'(Parent.Container, Node => C));
C := NN (C).Prev;
end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end;
end Reverse_Iterate_Children;
Source_Parent : Cursor)
is
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error
with "Before cursor not in Target container";
end if;
- if Target.Nodes (Before.Node).Parent /= Target_Parent.Node then
+ if Checks and then
+ Target.Nodes (Before.Node).Parent /= Target_Parent.Node
+ then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Source'Unrestricted_Access then
+ if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in Source container";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (Container => Target,
+ if Checks and then Is_Reachable (Container => Target,
From => Target_Parent.Node,
To => Source_Parent.Node)
then
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
if Target.Count = 0 then
Initialize_Root (Target);
Source_Parent : Cursor)
is
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Target_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Before cursor not in container";
end if;
- if Container.Nodes (Before.Node).Parent /= Target_Parent.Node then
+ if Checks and then
+ Container.Nodes (Before.Node).Parent /= Target_Parent.Node
+ then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Source_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in container";
end if;
pragma Assert (Container.Count > 0);
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (Container => Container,
+ if Checks and then Is_Reachable (Container => Container,
From => Target_Parent.Node,
To => Source_Parent.Node)
then
return;
end if;
- if Target.Count > Target.Capacity - Source_Count then
+ if Checks and then Target.Count > Target.Capacity - Source_Count then
raise Capacity_Error -- ???
with "Source count exceeds available storage on Target";
end if;
Position : in out Cursor)
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in Target container";
end if;
- if Target.Nodes (Before.Node).Parent /= Parent.Node then
+ if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node
+ then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with "Position cursor not in Source container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
end if;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (Container => Target,
+ if Checks and then Is_Reachable (Container => Target,
From => Parent.Node,
To => Position.Node)
then
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
if Target.Count = 0 then
Initialize_Root (Target);
Position : Cursor)
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Container.Nodes (Before.Node).Parent /= Parent.Node then
+ if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node
+ then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
-- Should this be PE instead? Need ARG confirmation. ???
end if;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (Container => Container,
+ if Checks and then Is_Reachable (Container => Container,
From => Parent.Node,
To => Position.Node)
then
-- is a bit of a misnomer here in the case of a bounded tree, because
-- the elements must be copied from the source to the target.
- if Target.Count > Target.Capacity - Source_Count then
+ if Checks and then Target.Count > Target.Capacity - Source_Count then
raise Capacity_Error -- ???
with "Source count exceeds available storage on Target";
end if;
I, J : Cursor)
is
begin
- if I = No_Element then
+ if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor not in container";
end if;
- if Is_Root (I) then
+ if Checks and then Is_Root (I) then
raise Program_Error with "I cursor designates root";
end if;
return;
end if;
- if J = No_Element then
+ if Checks and then J = No_Element then
raise Constraint_Error with "J cursor has no element";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor not in container";
end if;
- if Is_Root (J) then
+ if Checks and then Is_Root (J) then
raise Program_Error with "J cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
declare
EE : Element_Array renames Container.Elements;
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
declare
T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Process (Element => T.Elements (Position.Node));
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
end;
end Update_Element;
------------------------------------------------------------------------------
with Ada.Iterator_Interfaces;
+
+private with Ada.Containers.Helpers;
private with Ada.Streams;
-private with Ada.Finalization;
generic
type Element_Type is private;
Process : not null access procedure (Position : Cursor));
private
+
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
use Ada.Streams;
- use Ada.Finalization;
No_Node : constant Count_Type'Base := -1;
-- Need to document all global declarations such as this ???
Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>);
Elements : Element_Array (1 .. Capacity) := (others => <>);
Free : Count_Type'Base := No_Node;
- Busy : Integer := 0;
- Lock : Integer := 0;
+ TC : aliased Tamper_Counts;
Count : Count_Type := 0;
end record;
Position : Cursor);
for Cursor'Write use Write;
- type Reference_Control_Type is
- new Controlled with record
- Container : Tree_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
Item : out Reference_Type);
for Reference_Type'Read use Read;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Tree'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Tree : constant Tree := (Capacity => 0, others => <>);
No_Element : constant Cursor := Cursor'(others => <>);
-- --
-- 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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
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.Helpers
+
-----------------------------
-- Node Access Subprograms --
-----------------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
end;
end ">";
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Map 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error
with "Target capacity is less than Source length";
end if;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
declare
- Cur : Cursor := Find (Container, Key);
- pragma Unmodified (Cur);
-
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Cur.Container.Busy;
- L : Natural renames Cur.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
X : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
- else
- return Container.Nodes (Node).Element;
end if;
+
+ return Container.Nodes (Node).Element;
end Element;
---------------------
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Map 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
function First_Element (Container : Map) return Element_Type is
begin
- if Container.First = 0 then
+ if Checks and then Container.First = 0 then
raise Constraint_Error with "map is empty";
- else
- return Container.Nodes (Container.First).Element;
end if;
+
+ return Container.Nodes (Container.First).Element;
end First_Element;
---------------
function First_Key (Container : Map) return Key_Type is
begin
- if Container.First = 0 then
+ if Checks and then Container.First = 0 then
raise Constraint_Error with "map is empty";
- else
- return Container.Nodes (Container.First).Key;
end if;
+
+ return Container.Nodes (Container.First).Key;
end First_Key;
-----------
end if;
end Floor;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Nodes (Position.Node).Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Position.Node);
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with "key already in map";
end if;
end Insert;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => 0)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- Iterator was defined to behave the same as for a complete iterator,
-- and iterate over the entire sequence of items. However, those
-- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items.
- if Start = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong map";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
function Last_Element (Container : Map) return Element_Type is
begin
- if Container.Last = 0 then
+ if Checks and then Container.Last = 0 then
raise Constraint_Error with "map is empty";
- else
- return Container.Nodes (Container.Last).Element;
end if;
+
+ return Container.Nodes (Container.Last).Element;
end Last_Element;
--------------
function Last_Key (Container : Map) return Key_Type is
begin
- if Container.Last = 0 then
+ if Checks and then Container.Last = 0 then
raise Constraint_Error with "map is empty";
- else
- return Container.Nodes (Container.Last).Key;
end if;
+
+ return Container.Nodes (Container.Last).Key;
end Last_Key;
----------
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Assign (Source);
Source.Clear;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong map";
end if;
return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Map'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 --
-------------------
Element : Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
M : Map renames Position.Container.all;
N : Node_Type renames M.Nodes (Position.Node);
-
- B : Natural renames M.Busy;
- L : Natural renames M.Lock;
-
+ Lock : With_Lock (M.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (N.Key, N.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Key, N.Element);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
declare
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Node);
New_Item : Element_Type)
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.TC);
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Replace_Element is bad");
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (Container);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (Container);
end Reverse_Iterate;
-----------
Element : in out Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (N.Key, N.Element);
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (N.Key, N.Element);
end;
end Update_Element;
new Tree_Types.Tree_Type (Capacity) with null record;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Streams;
procedure Write
for Cursor'Read use Read;
- type Reference_Control_Type is new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0);
No_Element : constant Cursor := Cursor'(null, 0);
record
Container : Map_Access;
Node : Count_Type;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
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.Helpers
+
------------------------------
-- Access to Fields of Node --
------------------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = 0 then
+ if Checks and then Right.Node = 0 then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = 0 then
+ if Checks and then Left.Node = 0 then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
return Right < Left.Container.Nodes (Left.Node).Element;
end ">";
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Set 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error
with "Target capacity is less than Source length";
end if;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => N.Element'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
C := Source.Length;
elsif Capacity >= Source.Length then
C := Capacity;
- else
+ elsif Checks then
raise Capacity_Error with "Capacity value too small";
end if;
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Delete");
begin
Tree_Operations.Delete_Node_Sans_Free (Container, X);
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Set 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
function First_Element (Container : Set) return Element_Type is
begin
- if Container.First = 0 then
+ if Checks and then Container.First = 0 then
raise Constraint_Error with "set is empty";
end if;
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- B : Natural renames Control.Container.Busy;
- L : Natural renames Control.Container.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
-------------
-- Ceiling --
-------------
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
declare
- Cur : Cursor := Find (Container, Key);
- pragma Unmodified (Cur);
-
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Cur.Container.Busy;
- L : Natural renames Cur.Container.Lock;
-
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if X = 0 then
+ if Checks and then X = 0 then
raise Constraint_Error with "attempt to delete key not in set";
end if;
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- B : Natural renames Control.Container.Busy;
- L : Natural renames Control.Container.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- if not (Key (Control.Pos) = Control.Old_Key.all) then
+ Impl.Reference_Control_Type (Control).Finalize;
+
+ if Checks and then not (Key (Control.Pos) = Control.Old_Key.all)
+ then
Delete (Control.Container.all, Key (Control.Pos));
raise Program_Error;
end if;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control =>
(Controlled with
+ Container.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- B := B + 1;
- L := L + 1;
+ Lock (Container.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with "key not in set";
end if;
declare
N : Node_Type renames Container.Nodes (Node);
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
begin
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control =>
(Controlled with
+ Container.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (Container.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
N : Node_Type renames Container.Nodes (Position.Node);
E : Element_Type renames N.Element;
K : constant Key_Type := Key (E);
-
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (E);
- Eq := Equivalent_Keys (K, Key (E));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
-
- if Eq then
+ Process (E);
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
end Write;
end Generic_Keys;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Container.Nodes (Position.Node).Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Container.Nodes (Position.Node).Element := New_Item;
end if;
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
-- Start of processing for Insert_Sans_Hint
begin
- if Container.Busy > 0 then
- raise Program_Error with
- "attemot to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Container.TC);
Conditional_Insert_Sans_Hint
(Container,
end Process_Node;
S : Set renames Container'Unrestricted_Access.all;
- B : Natural renames S.Busy;
+ Busy : With_Busy (S.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (S);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (S);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => 0)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Iterate (Container : Set; Start : Cursor)
return Set_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong set";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Last_Element (Container : Set) return Element_Type is
begin
- if Container.Last = 0 then
+ if Checks and then Container.Last = 0 then
raise Constraint_Error with "set is empty";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Assign (Source);
Source.Clear;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong set";
end if;
return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Set'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 --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
declare
S : Set renames Position.Container.all;
- B : Natural renames S.Busy;
- L : Natural renames S.Lock;
-
+ Lock : With_Lock (S.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (S.Nodes (Position.Node).Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (S.Nodes (Position.Node).Element);
end;
end Query_Element;
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
- if Node = 0 then
+ if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Container.Nodes (Node).Element := New_Item;
end Replace;
Inserted : Boolean;
Compare : Boolean;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
-- Start of processing for Replace_Element
begin
-- Determine whether Item is equivalent to element on the specified
-- node.
+ declare
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := (if Item < Node.Element then False
elsif Node.Element < Item then False
else True);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Node.Element := Item;
return;
Hint := Element_Keys.Ceiling (Container, Item);
if Hint /= 0 then -- Item <= Nodes (Hint).Element
+ declare
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Item < Nodes (Hint).Element;
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
end;
-- Item is equivalent to Nodes (Hint).Element
- if not Compare then
+ if Checks and then not Compare then
-- Ceiling returns an element that is equivalent or greater than
-- Item. If Item is "not less than" the element, then by
-- because it would only be placed in the exact same position.
if Hint = Index then
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.TC);
Node.Element := Item;
return;
New_Item : Element_Type)
is
begin
- if Position.Node = 0 then
+ if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
end Process_Node;
S : Set renames Container'Unrestricted_Access.all;
- B : Natural renames S.Busy;
+ Busy : With_Busy (S.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (S);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (S);
end Reverse_Iterate;
-----------
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
private with Ada.Finalization;
use Ada.Streams;
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Pos : Cursor;
Old_Key : Key_Access;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Set (Capacity : Count_Type) is
new Tree_Types.Tree_Type (Capacity) with null record;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is new Controlled with record
- Container : Set_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Constant_Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0);
No_Element : constant Cursor := Cursor'(null, 0);
record
Container : Set_Access;
Node : Count_Type;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
---------
function "=" (Left, Right : List) return Boolean is
- BL : Natural renames Left'Unrestricted_Access.Busy;
- LL : Natural renames Left'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- BR : Natural renames Right'Unrestricted_Access.Busy;
- LR : Natural renames Right'Unrestricted_Access.Lock;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L : Node_Access;
R : Node_Access;
- Result : Boolean;
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
if Left.Length /= Right.Length 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;
-
L := Left.First;
R := Right.First;
- Result := True;
for J in 1 .. Left.Length loop
if L.Element /= R.Element then
- Result := False;
- exit;
+ return False;
end if;
L := L.Next;
R := R.Next;
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 "=";
------------
if Src = null then
pragma Assert (Container.Last = null);
pragma Assert (Container.Length = 0);
- pragma Assert (Container.Busy = 0);
- pragma Assert (Container.Lock = 0);
+ pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
Container.First := null;
Container.Last := null;
Container.Length := 0;
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
Container.First := new Node_Type'(Src.Element, null, null);
Container.Last := Container.First;
end loop;
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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 --
------------
if Container.Length = 0 then
pragma Assert (Container.First = null);
pragma Assert (Container.Last = null);
- pragma Assert (Container.Busy = 0);
- pragma Assert (Container.Lock = 0);
+ pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
while Container.Length > 1 loop
X := Container.First;
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
declare
- C : List renames Position.Container.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 => Position.Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
X : Node_Access;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for Index in 1 .. Count loop
X := Position.Node;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.First;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.Last;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
- else
- pragma Assert (Vet (Position), "bad cursor in Element");
-
- return Position.Node.Element;
end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Element");
+
+ return Position.Node.Element;
end Element;
--------------
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
Node := Container.First;
else
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
- else
- pragma Assert (Vet (Position), "bad cursor in Find");
end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Find");
end if;
-- 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 : Node_Access;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- pragma Warnings (Off);
- -- Deal with junk infinite loop warning from below loop
-
- Result := null;
while Node /= null loop
if Node.Element = Item then
- Result := Node;
- exit;
- else
- Node := Node.Next;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
- end loop;
- pragma Warnings (On);
- -- End of section dealing with junk infinite loop warning
-
- B := B - 1;
- L := L - 1;
-
- if Result = null then
- return No_Element;
- else
- return Cursor'(Container'Unrestricted_Access, Result);
- end if;
+ Node := Node.Next;
+ end loop;
- exception
- when others =>
- B := B - 1;
- L := L - 1;
- raise;
+ return No_Element;
end;
end Find;
function First_Element (Container : List) return Element_Type is
begin
- if Container.First = null then
+ if Checks and then Container.First = null then
raise Constraint_Error with "list is empty";
- else
- return Container.First.Element;
end if;
+
+ return Container.First.Element;
end First_Element;
----------
---------------
function Is_Sorted (Container : List) return Boolean is
- B : Natural renames Container'Unrestricted_Access.Busy;
- L : Natural renames Container'Unrestricted_Access.Lock;
-
- Node : Node_Access;
- Result : Boolean;
-
- 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);
+ Node : Node_Access;
+ begin
Node := Container.First;
- Result := True;
for Idx in 2 .. Container.Length loop
if Node.Next.Element < Node.Element then
- Result := False;
- exit;
+ return False;
end if;
Node := Node.Next;
end loop;
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
- raise;
+ return True;
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;
- if Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length
+ then
raise Constraint_Error with "new length exceeds maximum";
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
- 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);
LI, RI, RJ : Node_Access;
begin
- TB := TB + 1;
- TL := TL + 1;
-
- SB := SB + 1;
- SL := SL + 1;
-
LI := Target.First;
RI := Source.First;
while RI /= null loop
LI := LI.Next;
end if;
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;
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list 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 (Front => null, Back => null);
-
- B := B - 1;
- L := L - 1;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
- raise;
end;
pragma Assert (Container.First.Prev = null);
begin
if Before.Container /= null then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Before cursor designates wrong list";
- else
- pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
+
+ pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
Position := Before;
return;
+ end if;
- elsif Container.Length > Count_Type'Last - Count then
+ if Checks and then Container.Length > Count_Type'Last - Count then
raise Constraint_Error with "new length exceeds maximum";
+ end if;
- elsif Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
+ TC_Check (Container.TC);
- else
- New_Node := new Node_Type'(New_Item, null, null);
- First_Node := New_Node;
- Insert_Internal (Container, Before.Node, New_Node);
+ New_Node := new Node_Type'(New_Item, null, null);
+ First_Node := New_Node;
+ Insert_Internal (Container, Before.Node, New_Node);
- for J in 2 .. Count loop
- New_Node := new Node_Type'(New_Item, null, null);
- Insert_Internal (Container, Before.Node, New_Node);
- end loop;
+ for J in 2 .. Count loop
+ New_Node := new Node_Type'(New_Item, null, null);
+ Insert_Internal (Container, Before.Node, New_Node);
+ end loop;
- Position := Cursor'(Container'Unchecked_Access, First_Node);
- end if;
+ Position := Cursor'(Container'Unchecked_Access, First_Node);
end Insert;
procedure Insert
begin
if Before.Container /= null then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Before cursor designates wrong list";
- else
- pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
+
+ pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
return;
end if;
- if Container.Length > Count_Type'Last - Count then
+ if Checks and then Container.Length > Count_Type'Last - Count then
raise Constraint_Error with "new length exceeds maximum";
+ end if;
- elsif Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
+ TC_Check (Container.TC);
- else
- New_Node := new Node_Type;
- First_Node := New_Node;
- Insert_Internal (Container, Before.Node, New_Node);
+ New_Node := new Node_Type;
+ First_Node := New_Node;
+ Insert_Internal (Container, Before.Node, New_Node);
- for J in 2 .. Count loop
- New_Node := new Node_Type;
- Insert_Internal (Container, Before.Node, New_Node);
- end loop;
+ for J in 2 .. Count loop
+ New_Node := new Node_Type;
+ Insert_Internal (Container, Before.Node, New_Node);
+ end loop;
- Position := Cursor'(Container'Unchecked_Access, First_Node);
- end if;
+ Position := Cursor'(Container'Unchecked_Access, First_Node);
end Insert;
---------------------
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Node_Access := Container.First;
begin
- B := B + 1;
-
- begin
- while Node /= null loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Node.Next;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= null loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Node.Next;
+ end loop;
end Iterate;
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => null)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Iterate (Container : List; Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
+ end if;
- elsif Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong list";
-
- else
- pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
-
- -- The value of the Node component influences the behavior of the
- -- First and Last selector functions of the iterator object. When
- -- the Node component is non-null (as is the case here), it means
- -- that this is a partial iteration, over a subset of the complete
- -- sequence of items. The iterator object was constructed with
- -- a start expression, indicating the position from which the
- -- iteration begins. Note that the start position has the same value
- -- irrespective of whether this is a forward or reverse iteration.
-
- return It : constant Iterator :=
- Iterator'(Limited_Controlled with
- Container => Container'Unrestricted_Access,
- Node => Start.Node)
- do
- B := B + 1;
- end return;
end if;
+
+ pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
+
+ -- The value of the Node component influences the behavior of the First
+ -- and Last selector functions of the iterator object. When the Node
+ -- component is non-null (as is the case here), it means that this is a
+ -- partial iteration, over a subset of the complete sequence of items.
+ -- The iterator object was constructed with a start expression,
+ -- indicating the position from which the iteration begins. Note that
+ -- the start position has the same value irrespective of whether this is
+ -- a forward or reverse iteration.
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ Busy (Container.TC'Unrestricted_Access.all);
+ end return;
end Iterate;
----------
function Last_Element (Container : List) return Element_Type is
begin
- if Container.Last = null then
+ if Checks and then Container.Last = null then
raise Constraint_Error with "list is empty";
- else
- return Container.Last.Element;
end if;
+
+ return Container.Last.Element;
end Last_Element;
------------
begin
if Target'Address = Source'Address then
return;
+ end if;
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Source.TC);
- else
- Clear (Target);
+ Clear (Target);
- Target.First := Source.First;
- Source.First := null;
+ Target.First := Source.First;
+ Source.First := null;
- Target.Last := Source.Last;
- Source.Last := null;
+ Target.Last := Source.Last;
+ Source.Last := null;
- Target.Length := Source.Length;
- Source.Length := 0;
- end if;
+ Target.Length := Source.Length;
+ Source.Length := 0;
end Move;
----------
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong list";
- else
- return Next (Position);
end if;
+
+ return Next (Position);
end Next;
-------------
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong list";
- else
- return Previous (Position);
end if;
+
+ return Previous (Position);
end Previous;
----------------------
function Pseudo_Reference
(Container : aliased List'Class) return Reference_Control_Type
is
- C : constant List_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;
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
declare
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
-
+ Lock : With_Lock (Position.Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element);
end;
end Query_Element;
Position : Cursor) return Reference_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";
+ end if;
- elsif Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in function Reference");
+ pragma Assert (Vet (Position), "bad cursor in function Reference");
- declare
- C : List renames Position.Container.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
- begin
- return R : constant Reference_Type :=
- (Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
- end if;
+ declare
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Type :=
+ (Element => Position.Node.Element'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
---------------------
New_Item : 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";
+ end if;
- elsif Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- elsif Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
+ TE_Check (Container.TC);
- else
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- Position.Node.Element := New_Item;
- end if;
+ Position.Node.Element := New_Item;
end Replace_Element;
----------------------
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
Container.First := J;
Container.Last := I;
Node := Container.Last;
else
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
- else
- pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
-- 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 : Node_Access;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := null;
while Node /= null loop
if Node.Element = Item then
- Result := Node;
- exit;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Prev;
end loop;
- B := B - 1;
- L := L - 1;
-
- if Result = null 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;
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Node_Access := Container.Last;
begin
- B := B + 1;
-
- begin
- while Node /= null loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Node.Prev;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= null loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Node.Prev;
+ end loop;
end Reverse_Iterate;
------------
is
begin
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
- else
- pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
+
+ pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
if Target'Address = Source'Address or else Source.Length = 0 then
return;
+ end if;
- elsif Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum";
+ end if;
- elsif Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
-
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
- else
- Splice_Internal (Target, Before.Node, Source);
- end if;
+ Splice_Internal (Target, Before.Node, Source);
end Splice;
procedure Splice
is
begin
if Before.Container /= null then
- if Before.Container /= Container'Unchecked_Access then
+ if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
"Before cursor designates wrong container";
- else
- pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
+
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Container.Length >= 2);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
end if;
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
- else
- pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
+
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
+ end if;
- elsif Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- else
- pragma Assert (Vet (Position), "bad Position cursor in Splice");
-
- if Target.Length = Count_Type'Last then
- raise Constraint_Error with "Target is full";
+ pragma Assert (Vet (Position), "bad Position cursor in Splice");
- elsif Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
+ if Checks and then Target.Length = Count_Type'Last then
+ raise Constraint_Error with "Target is full";
+ end if;
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
- else
- Splice_Internal (Target, Before.Node, Source, Position.Node);
- Position.Container := Target'Unchecked_Access;
- end if;
- end if;
+ Splice_Internal (Target, Before.Node, Source, Position.Node);
+ Position.Container := Target'Unchecked_Access;
end Splice;
---------------------
I, J : Cursor)
is
begin
- if I.Node = null then
+ if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = null then
+ if Checks and then J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unchecked_Access then
+ if Checks and then I.Container /= Container'Unchecked_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unchecked_Access then
+ if Checks and then J.Container /= Container'Unchecked_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
- end if;
+ TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
I, J : Cursor)
is
begin
- if I.Node = null then
+ if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = null then
+ if Checks and then J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
+ end if;
- elsif Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Update_Element");
-
- declare
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
- L := L - 1;
- B := B - 1;
- end;
- end if;
+ declare
+ Lock : With_Lock (Container.TC'Unchecked_Access);
+ begin
+ Process (Position.Node.Element);
+ end;
end Update_Element;
---------
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
pragma Inline (Next);
pragma Inline (Previous);
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
type Node_Type;
type Node_Access is access Node_Type;
type List is
new Controlled with record
- First : Node_Access;
- Last : Node_Access;
+ First : Node_Access := null;
+ Last : Node_Access := null;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
end record;
overriding procedure Adjust (Container : in out List);
for Cursor'Write use Write;
- type Reference_Control_Type is
- new Controlled with record
- Container : List_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
- type Element_Access is access all Element_Type;
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
- Empty_List : constant List := (Controlled with null, null, 0, 0, 0);
+ Empty_List : constant List := (Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : List_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------------
-- Checked_Equivalent_Keys --
-----------------------------
Key : Key_Type;
Node : Count_Type) return Boolean
is
- Result : Boolean;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := Equivalent_Keys (Key, HT.Nodes (Node));
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return Equivalent_Keys (Key, HT.Nodes (Node));
end Checked_Equivalent_Keys;
-------------------
(HT : aliased in out Hash_Table_Type'Class;
Key : Key_Type) return Hash_Type
is
- Result : Hash_Type;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
end Checked_Index;
--------------------------
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Indx := Checked_Index (HT, Key);
X := HT.Buckets (Indx);
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
HT.Buckets (Indx) := Next (HT.Nodes (X));
HT.Length := HT.Length - 1;
return;
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X)));
HT.Length := HT.Length - 1;
return;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Indx := Checked_Index (HT, Key);
Node := HT.Buckets (Indx);
if Node = 0 then
- if HT.Length = HT.Capacity then
+ if Checks and then HT.Length = HT.Capacity then
raise Capacity_Error with "no more capacity for insertion";
end if;
exit when Node = 0;
end loop;
- if HT.Length = HT.Capacity then
+ if Checks and then HT.Length = HT.Capacity then
raise Capacity_Error with "no more capacity for insertion";
end if;
-- the computation of New_Index until after the tampering check. ???
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length;
-
- B := B - 1;
- L := L - 1;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end;
-- Replace_Element is allowed to change a node's key to Key
-- hash table as this one, a key is mapped to exactly one node.)
if Checked_Equivalent_Keys (HT, Key, Node) then
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (container is locked)";
- end if;
+ TE_Check (HT.TC);
-- The new Key value is mapped to this same Node, so Node
-- stays in the same bucket.
N := New_Bucket;
while N /= 0 loop
- if Checked_Equivalent_Keys (HT, Key, N) then
+ if Checks and then Checked_Equivalent_Keys (HT, Key, N) then
pragma Assert (N /= Node);
raise Program_Error with
"attempt to replace existing element";
-- The node is already in the bucket implied by Key. In this case
-- we merely change its value without moving it.
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (container is locked)";
- end if;
+ TE_Check (HT.TC);
Assign (NN (Node), Key);
return;
-- The node is a bucket different from the bucket implied by Key
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
-- Do the assignment first, before moving the node, so that if Assign
-- propagates an exception, then the hash table will not have been
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2013, 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- --
with package HT_Types is
new Generic_Bounded_Hash_Table_Types (<>);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
with function Next (Node : Node_Type) return Count_Type;
-- --
-- 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- --
package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-------------------
-- Checked_Index --
-------------------
(Hash_Table : aliased in out Hash_Table_Type'Class;
Node : Count_Type) return Hash_Type
is
- Result : Hash_Type;
-
- B : Natural renames Hash_Table.Busy;
- L : Natural renames Hash_Table.Lock;
-
+ Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := Index (Hash_Table, Hash_Table.Nodes (Node));
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return Index (Hash_Table, Hash_Table.Nodes (Node));
end Checked_Index;
-----------
procedure Clear (HT : in out Hash_Table_Type'Class) is
begin
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
HT.Length := 0;
-- HT.Busy := 0;
begin
Prev := HT.Buckets (Indx);
- if Prev = 0 then
+ if Checks and then Prev = 0 then
raise Program_Error with
"attempt to delete node from empty hash bucket";
end if;
return;
end if;
- if HT.Length = 1 then
+ if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (HT.Nodes (Prev));
- if Curr = 0 then
+ if Checks and then Curr = 0 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
Curr : Count_Type;
begin
- if HT.Length = 0 then
+ if Checks and then HT.Length = 0 then
raise Program_Error with
"attempt to delete node from empty hashed container";
end if;
Indx := Checked_Index (HT, X);
Prev := HT.Buckets (Indx);
- if Prev = 0 then
+ if Checks and then Prev = 0 then
raise Program_Error with
"attempt to delete node from empty hash bucket";
end if;
return;
end if;
- if HT.Length = 1 then
+ if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (HT.Nodes (Prev));
- if Curr = 0 then
+ if Checks and then Curr = 0 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
function Generic_Equal
(L, R : Hash_Table_Type'Class) return Boolean
is
- BL : Natural renames L'Unrestricted_Access.Busy;
- LL : Natural renames L'Unrestricted_Access.Lock;
-
- BR : Natural renames R'Unrestricted_Access.Busy;
- LR : Natural renames R'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- Result : Boolean;
+ Lock_L : With_Lock (L.TC'Unrestricted_Access);
+ Lock_R : With_Lock (R.TC'Unrestricted_Access);
L_Index : Hash_Type;
L_Node : Count_Type;
L_Index := L_Index + 1;
end loop;
- -- 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;
-
-- For each node of hash table L, search for an equivalent node in hash
-- table R.
N := L.Length;
loop
if not Find (HT => R, Key => L.Nodes (L_Node)) then
- Result := False;
- exit;
+ return False;
end if;
N := N - 1;
-- We have exhausted the nodes in this bucket
if N = 0 then
- Result := True;
- exit;
+ return True;
end if;
-- Find the next bucket
end loop;
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;
end Generic_Equal;
-----------------------
Count_Type'Base'Read (Stream, N);
- if N < 0 then
+ if Checks and then N < 0 then
raise Program_Error with "stream appears to be corrupt";
end if;
return;
end if;
- if N > HT.Capacity then
+ if Checks and then N > HT.Capacity then
raise Capacity_Error with "too many elements in stream";
end if;
-- --
-- S p e c --
-- --
--- 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- --
with package HT_Types is
new Generic_Bounded_Hash_Table_Types (<>);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
with function Hash_Node (Node : Node_Type) return Hash_Type;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Hash_Tables.Generic_Keys is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------------
-- Checked_Equivalent_Keys --
-----------------------------
Key : Key_Type;
Node : Node_Access) return Boolean
is
- Result : Boolean;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := Equivalent_Keys (Key, Node);
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return Equivalent_Keys (Key, Node);
end Checked_Equivalent_Keys;
-------------------
(HT : aliased in out Hash_Table_Type;
Key : Key_Type) return Hash_Type
is
- Result : Hash_Type;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := Hash (Key) mod HT.Buckets'Length;
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return Hash (Key) mod HT.Buckets'Length;
end Checked_Index;
--------------------------
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Indx := Checked_Index (HT, Key);
X := HT.Buckets (Indx);
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
HT.Buckets (Indx) := Next (X);
HT.Length := HT.Length - 1;
return;
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Set_Next (Node => Prev, Next => Next (X));
HT.Length := HT.Length - 1;
return;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Indx := Checked_Index (HT, Key);
Node := HT.Buckets (Indx);
if Node = null then
- if HT.Length = Count_Type'Last then
+ if Checks and then HT.Length = Count_Type'Last then
raise Constraint_Error;
end if;
exit when Node = null;
end loop;
- if HT.Length = Count_Type'Last then
+ if Checks and then HT.Length = Count_Type'Last then
raise Constraint_Error;
end if;
-- element tampering by a generic actual subprogram.
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Old_Indx := Hash (Node) mod HT.Buckets'Length;
-
- B := B - 1;
- L := L - 1;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end;
if Checked_Equivalent_Keys (HT, Key, Node) then
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (container is locked)";
- end if;
+ TE_Check (HT.TC);
-- We can change a node's key to Key (that's what Assign is for), but
-- only if Key is not already in the hash table. (In a unique-key
N := New_Bucket;
while N /= null loop
- if Checked_Equivalent_Keys (HT, Key, N) then
+ if Checks and then Checked_Equivalent_Keys (HT, Key, N) then
pragma Assert (N /= Node);
raise Program_Error with
"attempt to replace existing element";
-- The node is already in the bucket implied by Key. In this case
-- we merely change its value without moving it.
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (container is locked)";
- end if;
+ TE_Check (HT.TC);
Assign (Node, Key);
return;
-- The node is a bucket different from the bucket implied by Key
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
-- Do the assignment first, before moving the node, so that if Assign
-- propagates an exception, then the hash table will not have been
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2013, 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- --
with package HT_Types is
new Generic_Hash_Table_Types (<>);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
with function Next (Node : Node_Access) return Node_Access;
-- --
-- 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- --
package body Ada.Containers.Hash_Tables.Generic_Operations is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
type Buckets_Allocation is access all Buckets_Type;
-- Used for allocation and deallocation (see New_Buckets and Free_Buckets).
-- This is necessary because Buckets_Access has an empty storage pool.
Buckets : Buckets_Type;
Node : Node_Access) return Hash_Type
is
- Result : Hash_Type;
-
- B : Natural renames Hash_Table.Busy;
- L : Natural renames Hash_Table.Lock;
-
+ Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := Index (Buckets, Node);
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return Index (Buckets, Node);
end Checked_Index;
function Checked_Index
Node : Node_Access;
begin
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
while HT.Length > 0 loop
while HT.Buckets (Index) = null loop
return;
end if;
- if HT.Length = 1 then
+ if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (Prev);
- if Curr = null then
+ if Checks and then Curr = null then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
Curr : Node_Access;
begin
- if HT.Length = 0 then
+ if Checks and then HT.Length = 0 then
raise Program_Error with
"attempt to delete node from empty hashed container";
end if;
Indx := Checked_Index (HT, X);
Prev := HT.Buckets (Indx);
- if Prev = null then
+ if Checks and then Prev = null then
raise Program_Error with
"attempt to delete node from empty hash bucket";
end if;
return;
end if;
- if HT.Length = 1 then
+ if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (Prev);
- if Curr = null then
+ if Checks and then Curr = null then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
function Generic_Equal
(L, R : Hash_Table_Type) return Boolean
is
- BL : Natural renames L'Unrestricted_Access.Busy;
- LL : Natural renames L'Unrestricted_Access.Lock;
-
- BR : Natural renames R'Unrestricted_Access.Busy;
- LR : Natural renames R'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- Result : Boolean;
+ Lock_L : With_Lock (L.TC'Unrestricted_Access);
+ Lock_R : With_Lock (R.TC'Unrestricted_Access);
L_Index : Hash_Type;
L_Node : Node_Access;
L_Index := L_Index + 1;
end loop;
- -- 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;
-
-- For each node of hash table L, search for an equivalent node in hash
-- table R.
N := L.Length;
loop
if not Find (HT => R, Key => L_Node) then
- Result := False;
- exit;
+ return False;
end if;
N := N - 1;
-- We have exhausted the nodes in this bucket
if N = 0 then
- Result := True;
- exit;
+ return True;
end if;
-- Find the next bucket
end loop;
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;
end Generic_Equal;
-----------------------
Count_Type'Base'Read (Stream, N);
- if N < 0 then
+ if Checks and then N < 0 then
raise Program_Error with "stream appears to be corrupt";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Clear (Target);
end if;
end if;
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (HT.TC);
Rehash : declare
Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
-- --
-- S p e c --
-- --
--- 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- --
with package HT_Types is
new Generic_Hash_Table_Types (<>);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
with function Hash_Node (Node : Node_Access) return Hash_Type;
-- --
-- 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.Helpers
+
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
---------
function "=" (Left, Right : List) return Boolean is
- BL : Natural renames Left'Unrestricted_Access.Busy;
- LL : Natural renames Left'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- BR : Natural renames Right'Unrestricted_Access.Busy;
- LR : Natural renames Right'Unrestricted_Access.Lock;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L : Node_Access;
R : Node_Access;
- Result : Boolean;
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
if Left.Length /= Right.Length 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;
-
L := Left.First;
R := Right.First;
- Result := True;
for J in 1 .. Left.Length loop
if L.Element.all /= R.Element.all then
- Result := False;
- exit;
+ return False;
end if;
L := L.Next;
R := R.Next;
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 "=";
------------
if Src = null then
pragma Assert (Container.Last = null);
pragma Assert (Container.Length = 0);
- pragma Assert (Container.Busy = 0);
- pragma Assert (Container.Lock = 0);
+ pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
Container.First := null;
Container.Last := null;
Container.Length := 0;
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
declare
Element : Element_Access := new Element_Type'(Src.Element.all);
end loop;
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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 --
------------
if Container.Length = 0 then
pragma Assert (Container.First = null);
pragma Assert (Container.Last = null);
- pragma Assert (Container.Busy = 0);
- pragma Assert (Container.Lock = 0);
+ pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
while Container.Length > 1 loop
X := Container.First;
Position : Cursor) return Constant_Reference_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";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
- elsif Position.Node.Element = null then
+ end if;
+
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
+ pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
- declare
- C : List renames Position.Container.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
- begin
- return R : constant Constant_Reference_Type :=
- (Element => Position.Node.Element.all'Access,
- Control => (Controlled with Position.Container))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
- end if;
+ declare
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => Position.Node.Element,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
--------------
X : Node_Access;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
for Index in 1 .. Count loop
X := Position.Node;
if Count >= Container.Length then
Clear (Container);
return;
+ end if;
- elsif Count = 0 then
+ if Count = 0 then
return;
+ end if;
- elsif Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
+ TC_Check (Container.TC);
- else
- for J in 1 .. Count loop
- X := Container.First;
- pragma Assert (X.Next.Prev = Container.First);
+ for J in 1 .. Count loop
+ X := Container.First;
+ pragma Assert (X.Next.Prev = Container.First);
- Container.First := X.Next;
- Container.First.Prev := null;
+ Container.First := X.Next;
+ Container.First.Prev := null;
- Container.Length := Container.Length - 1;
+ Container.Length := Container.Length - 1;
- Free (X);
- end loop;
- end if;
+ Free (X);
+ end loop;
end Delete_First;
-----------------
if Count >= Container.Length then
Clear (Container);
return;
+ end if;
- elsif Count = 0 then
+ if Count = 0 then
return;
+ end if;
- elsif Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
+ TC_Check (Container.TC);
- else
- for J in 1 .. Count loop
- X := Container.Last;
- pragma Assert (X.Prev.Next = Container.Last);
+ for J in 1 .. Count loop
+ X := Container.Last;
+ pragma Assert (X.Prev.Next = Container.Last);
- Container.Last := X.Prev;
- Container.Last.Next := null;
+ Container.Last := X.Prev;
+ Container.Last.Next := null;
- Container.Length := Container.Length - 1;
+ Container.Length := Container.Length - 1;
- Free (X);
- end loop;
- end if;
+ Free (X);
+ end loop;
end Delete_Last;
-------------
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
+ end if;
- elsif Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Element");
+ pragma Assert (Vet (Position), "bad cursor in Element");
- return Position.Node.Element.all;
- end if;
+ return Position.Node.Element.all;
end Element;
--------------
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : List 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;
+ Unbusy (Object.Container.TC);
end if;
end Finalize;
Node := Container.First;
else
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error;
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
-
- else
- pragma Assert (Vet (Position), "bad cursor in Find");
end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Find");
end if;
-- 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 : Node_Access;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := null;
while Node /= null loop
if Node.Element.all = Item then
- Result := Node;
- exit;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Next;
end loop;
- B := B - 1;
- L := L - 1;
-
- if Result = null 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;
function First_Element (Container : List) return Element_Type is
begin
- if Container.First = null then
+ if Checks and then Container.First = null then
raise Constraint_Error with "list is empty";
- else
- return Container.First.Element.all;
end if;
+
+ return Container.First.Element.all;
end First_Element;
----------
---------------
function Is_Sorted (Container : List) return Boolean is
- B : Natural renames Container'Unrestricted_Access.Busy;
- L : Natural renames Container'Unrestricted_Access.Lock;
-
- Node : Node_Access;
- Result : Boolean;
-
- 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);
+ Node : Node_Access;
+ begin
Node := Container.First;
- Result := True;
for J in 2 .. Container.Length loop
if Node.Next.Element.all < Node.Element.all then
- Result := False;
- exit;
+ return False;
end if;
Node := Node.Next;
end loop;
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
+ return True;
end Is_Sorted;
-----------
if Source.Is_Empty then
return;
+ end if;
- elsif 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;
- elsif Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length
+ then
raise Constraint_Error with "new length exceeds maximum";
-
- elsif Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
-
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
end if;
- declare
- TB : Natural renames Target.Busy;
- TL : Natural renames Target.Lock;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
- SB : Natural renames Source.Busy;
- SL : Natural renames Source.Lock;
+ declare
+ Lock_Target : With_Lock (Target.TC'Unchecked_Access);
+ Lock_Source : With_Lock (Source.TC'Unchecked_Access);
LI, RI, RJ : Node_Access;
begin
- TB := TB + 1;
- TL := TL + 1;
-
- SB := SB + 1;
- SL := SL + 1;
-
LI := Target.First;
RI := Source.First;
while RI /= null loop
LI := LI.Next;
end if;
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;
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list 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 (Front => null, Back => null);
-
- B := B - 1;
- L := L - 1;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end;
pragma Assert (Container.First.Prev = null);
end Generic_Sorting;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
begin
if Before.Container /= null then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
+ "Before cursor designates wrong list";
+ end if;
- elsif Before.Node = null or else Before.Node.Element = null then
+ if Checks and then
+ (Before.Node = null or else Before.Node.Element = null)
+ then
raise Program_Error with
"Before cursor has no element";
-
- else
- pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
+
+ pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
return;
end if;
- if Container.Length > Count_Type'Last - Count then
+ if Checks and then Container.Length > Count_Type'Last - Count then
raise Constraint_Error with "new length exceeds maximum";
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Node_Access := Container.First;
begin
- B := B + 1;
-
- begin
- while Node /= null loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Node.Next;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= null loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Node.Next;
+ end loop;
end Iterate;
function Iterate
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => null)
do
- B := B + 1;
+ Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
+ end if;
- elsif Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong list";
-
- else
- pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
-
- -- The value of the Node component influences the behavior of the
- -- First and Last selector functions of the iterator object. When
- -- the Node component is non-null (as is the case here), it means
- -- that this is a partial iteration, over a subset of the complete
- -- sequence of items. The iterator object was constructed with
- -- a start expression, indicating the position from which the
- -- iteration begins. Note that the start position has the same value
- -- irrespective of whether this is a forward or reverse iteration.
-
- return It : constant Iterator :=
- Iterator'(Limited_Controlled with
- Container => Container'Unrestricted_Access,
- Node => Start.Node)
- do
- B := B + 1;
- end return;
end if;
+
+ pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
+
+ -- The value of the Node component influences the behavior of the
+ -- First and Last selector functions of the iterator object. When
+ -- the Node component is non-null (as is the case here), it means
+ -- that this is a partial iteration, over a subset of the complete
+ -- sequence of items. The iterator object was constructed with
+ -- a start expression, indicating the position from which the
+ -- iteration begins. Note that the start position has the same value
+ -- irrespective of whether this is a forward or reverse iteration.
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ Busy (Container.TC'Unrestricted_Access.all);
+ end return;
end Iterate;
----------
function Last_Element (Container : List) return Element_Type is
begin
- if Container.Last = null then
+ if Checks and then Container.Last = null then
raise Constraint_Error with "list is empty";
- else
- return Container.Last.Element.all;
end if;
+
+ return Container.Last.Element.all;
end Last_Element;
------------
begin
if Target'Address = Source'Address then
return;
+ end if;
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Source.TC);
- else
- Clear (Target);
+ Clear (Target);
- Target.First := Source.First;
- Source.First := null;
+ Target.First := Source.First;
+ Source.First := null;
- Target.Last := Source.Last;
- Source.Last := null;
+ Target.Last := Source.Last;
+ Source.Last := null;
- Target.Length := Source.Length;
- Source.Length := 0;
- end if;
+ Target.Length := Source.Length;
+ Source.Length := 0;
end Move;
----------
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong list";
- else
- return Next (Position);
end if;
+
+ return Next (Position);
end Next;
-------------
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong list";
- else
- return Previous (Position);
end if;
+
+ return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased List'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 --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
+ end if;
- elsif Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Query_Element");
-
- declare
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element.all);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- L := L - 1;
- B := B - 1;
- end;
- end if;
+ declare
+ Lock : With_Lock (Position.Container.TC'Unrestricted_Access);
+ begin
+ Process (Position.Node.Element.all);
+ end;
end Query_Element;
----------
Position : Cursor) return Reference_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";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- elsif Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in function Reference");
+ pragma Assert (Vet (Position), "bad cursor in function Reference");
- declare
- C : List renames Position.Container.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
- begin
- return R : constant Reference_Type :=
- (Element => Position.Node.Element.all'Access,
- Control => (Controlled with Position.Container))
- do
- B := B + 1;
- L := L + 1;
- end return;
- end;
- end if;
+ declare
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Type :=
+ (Element => Position.Node.Element,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
---------------------
New_Item : 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";
+ end if;
- elsif Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
+ end if;
- elsif Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
+ TE_Check (Container.TC);
- elsif Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
+ end if;
- else
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- declare
- -- The element allocator may need an accessibility check in the
- -- case the actual type is class-wide or has access discriminants
- -- (see RM 4.8(10.1) and AI12-0035).
+ declare
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
- pragma Unsuppress (Accessibility_Check);
+ pragma Unsuppress (Accessibility_Check);
- X : Element_Access := Position.Node.Element;
+ X : Element_Access := Position.Node.Element;
- begin
- Position.Node.Element := new Element_Type'(New_Item);
- Free (X);
- end;
- end if;
+ begin
+ Position.Node.Element := new Element_Type'(New_Item);
+ Free (X);
+ end;
end Replace_Element;
----------------------
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
Container.First := J;
Container.Last := I;
Node := Container.Last;
else
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Position cursor has no element";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
-
- else
- pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
-- 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 : Node_Access;
-
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- Result := null;
while Node /= null loop
if Node.Element.all = Item then
- Result := Node;
- exit;
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Prev;
end loop;
- B := B - 1;
- L := L - 1;
-
- if Result = null 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;
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ Busy : With_Busy (Container.TC'Unrestricted_Access);
Node : Node_Access := Container.Last;
begin
- B := B + 1;
-
- begin
- while Node /= null loop
- Process (Cursor'(Container'Unrestricted_Access, Node));
- Node := Node.Prev;
- end loop;
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ while Node /= null loop
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ Node := Node.Prev;
+ end loop;
end Reverse_Iterate;
------------
is
begin
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
+ end if;
- elsif Before.Node = null or else Before.Node.Element = null then
+ if Checks and then
+ (Before.Node = null or else Before.Node.Element = null)
+ then
raise Program_Error with
"Before cursor has no element";
-
- else
- pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
+
+ pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
if Target'Address = Source'Address or else Source.Length = 0 then
return;
+ end if;
- elsif Target.Length > Count_Type'Last - Source.Length then
+ if Checks and then Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum";
+ end if;
- elsif Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
-
- elsif Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
- else
- Splice_Internal (Target, Before.Node, Source);
- end if;
+ Splice_Internal (Target, Before.Node, Source);
end Splice;
procedure Splice
is
begin
if Before.Container /= null then
- if Before.Container /= Container'Unchecked_Access then
+ if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
"Before cursor designates wrong container";
+ end if;
- elsif Before.Node = null or else Before.Node.Element = null then
+ if Checks and then
+ (Before.Node = null or else Before.Node.Element = null)
+ then
raise Program_Error with
"Before cursor has no element";
-
- else
- pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
+
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Container.Length >= 2);
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
end if;
if Before.Container /= null then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
"Before cursor designates wrong container";
end if;
- if Before.Node = null
- or else Before.Node.Element = null
+ if Checks and then
+ (Before.Node = null or else Before.Node.Element = null)
then
raise Program_Error with
"Before cursor has no element";
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
end if;
- if Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
- if Target.Length = Count_Type'Last then
+ if Checks and then Target.Length = Count_Type'Last then
raise Constraint_Error with "Target is full";
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
I, J : Cursor)
is
begin
- if I.Node = null then
+ if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = null then
+ if Checks and then J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unchecked_Access then
+ if Checks and then I.Container /= Container'Unchecked_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unchecked_Access then
+ if Checks and then J.Container /= Container'Unchecked_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is locked)";
- end if;
+ TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
I, J : Cursor)
is
begin
- if I.Node = null then
+ if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Node = null then
+ if Checks and then J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
+ TC_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
end if;
- if Position.Container /= Container'Unchecked_Access then
+ if Checks and then Position.Container /= Container'Unchecked_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
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;
-
- begin
- Process (Position.Node.Element.all);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element.all);
end;
end Update_Element;
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
pragma Inline (Next);
pragma Inline (Previous);
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
type Node_Type;
type Node_Access is access Node_Type;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Node_Type is
limited record
type List is
new Controlled with record
- First : Node_Access;
- Last : Node_Access;
+ First : Node_Access := null;
+ Last : Node_Access := null;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
end record;
overriding procedure Adjust (Container : in out List);
for Cursor'Write use Write;
- type Reference_Control_Type is
- new Controlled with record
- Container : List_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Read use Read;
- Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0);
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased List'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
+ Empty_List : constant List := List'(Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : List_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Unchecked_Deallocation;
with System; use type System.Address;
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.Helpers
+
procedure Free_Key is
new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
HT_Ops.Adjust (Container.HT);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- M : Map renames Control.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "key has no element";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
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;
begin
Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete key not in map";
end if;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
- if Container.HT.Busy > 0 then
- raise Program_Error with
- "Delete attempted to tamper with cursors (map is busy)";
- end if;
+ TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"no element available because key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor of function Element is bad";
end if;
function Equivalent_Keys (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with
"Left cursor of Equivalent_Keys is bad";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with
"Right cursor of Equivalent_Keys is bad";
end if;
Right : Key_Type) return Boolean
is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with
"Left cursor of Equivalent_Keys is bad";
end if;
Right : Cursor) return Boolean
is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with
"Right cursor of Equivalent_Keys is bad";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.HT.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- M : Map renames Control.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.HT.TC);
end if;
end Finalize;
Deallocate (X);
end Free;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "Include attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.HT.TC);
K := Position.Node.Key;
E := Position.Node.Element;
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert key already in map";
end if;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+ Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
-- Start of processing Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container.HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container.HT);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
begin
return It : constant Iterator :=
(Limited_Controlled with Container => Container'Unrestricted_Access)
do
- B := B + 1;
+ Busy (Container.HT.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
- if Position.Node.Key = null then
+ if Checks and then Position.Node.Key = null then
raise Program_Error with
"Position cursor of function Key is bad";
end if;
return No_Element;
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with "Position cursor of Next is bad";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
return Next (Position);
end Next;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type
+ is
+ TC : constant Tamper_Counts_Access :=
+ Container.HT.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
+ end return;
+ end Pseudo_Reference;
+
-------------------
-- Query_Element --
-------------------
Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Query_Element is bad";
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key.all;
- E : Element_Type renames Position.Node.Element.all;
-
- begin
- Process (K, E);
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "key has no element";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
E : Element_Access;
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "Replace attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.HT.TC);
K := Node.Key;
E := Node.Element;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Replace_Element is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Position.Container.HT.Lock > 0 then
- raise Program_Error with
- "Replace_Element attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Position.Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Update_Element is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
HT : Hash_Table_Type renames Container.HT;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key.all;
- E : Element_Type renames Position.Node.Element.all;
-
- begin
- Process (K, E);
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Update_Element;
type Node_Access is access Node_Type;
type Key_Access is access Key_Type;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Node_Type is limited record
Key : Key_Access;
overriding procedure Finalize (Container : in out Map);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Read use Read;
- Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
+ Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
Map_Iterator_Interfaces.Forward_Iterator with
record
Container : Map_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Prime_Numbers;
with System; use type System.Address;
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
HT_Ops.Adjust (Container.HT);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
HT : Hash_Table_Type renames Position.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
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;
begin
Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete element not in set";
end if;
Position : in out Cursor)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
- if Container.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "Position cursor is bad");
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
if Src_HT.Length < Target.HT.Length then
declare
raise;
end Iterate_Left;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Difference;
-------------
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor of equals No_Element";
end if;
- if Position.Node.Element = null then -- handle dangling reference
+ if Checks and then Position.Node.Element = null then
+ -- handle dangling reference
raise Program_Error with "Position cursor is bad";
end if;
function Equivalent_Elements (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with
"Left cursor of Equivalent_Elements is bad";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with
"Right cursor of Equivalent_Elements is bad";
end if;
Right : Element_Type) return Boolean
is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with
"Left cursor of Equivalent_Elements is bad";
end if;
Right : Cursor) return Boolean
is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with
"Right cursor of Equivalent_Elements is bad";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.HT.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.HT.TC);
end if;
end Finalize;
Deallocate (X);
end Free;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.HT.TC);
X := Position.Node.Element;
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop
raise;
end Iterate_Left;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Intersection;
--------------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+ Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Iterate (Container.HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Iterate (Container.HT);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
begin
return It : constant Iterator :=
Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access)
do
- B := B + 1;
+ Busy (Container.HT.TC'Unrestricted_Access.all);
end return;
end Iterate;
return No_Element;
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "bad cursor in Next";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
return False;
end Overlap;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type
+ is
+ TC : constant Tamper_Counts_Access :=
+ Container.HT.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
+ end return;
+ end Pseudo_Reference;
+
-------------------
-- Query_Element --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "bad cursor in Query_Element";
end if;
declare
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element.all);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element.all);
end;
end Query_Element;
pragma Warnings (Off, X);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.HT.TC);
X := Node.Element;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "bad cursor in Replace_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
is
Tgt_HT : Hash_Table_Type renames Target.HT;
Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
-
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- TB : Natural renames Tgt_HT.Busy;
- TL : Natural renames Tgt_HT.Lock;
-
- SB : Natural renames Src_HT.Busy;
- SL : Natural renames Src_HT.Lock;
-
begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- if TB > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Tgt_HT.TC);
declare
N : constant Count_Type := Target.Length + Source.Length;
N := N + 1;
end Process;
- -- Start of processing for Iterate_Source_When_Empty_Target
+ -- Per AI05-0022, the container implementation is required to
+ -- detect element tampering by a generic actual subprogram.
- begin
- TB := TB + 1;
- TL := TL + 1;
+ Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
+ Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
- SB := SB + 1;
- SL := SL + 1;
+ -- Start of processing for Iterate_Source_When_Empty_Target
+ begin
Iterate (Src_HT);
-
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- exception
- when others =>
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- raise;
end Iterate_Source_When_Empty_Target;
else
end if;
end Process;
- -- Start of processing for Iterate_Source
+ -- Per AI05-0022, the container implementation is required to
+ -- detect element tampering by a generic actual subprogram.
- begin
- TB := TB + 1;
- TL := TL + 1;
+ Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
+ Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
- SB := SB + 1;
- SL := SL + 1;
+ -- Start of processing for Iterate_Source
+ begin
Iterate (Src_HT);
-
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- exception
- when others =>
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- raise;
end Iterate_Source;
end if;
end Symmetric_Difference;
raise;
end Iterate_Right;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Symmetric_Difference;
------------
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
declare
N : constant Count_Type := Target.Length + Source.Length;
-- Checked_Index instead of a simple invocation of generic formal
-- Hash.
- B : Integer renames Left_HT.Busy;
- L : Integer renames Left_HT.Lock;
+ Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
-- Start of processing for Iterate_Left
begin
- B := B + 1;
- L := L + 1;
-
- Iterate (Left.HT);
-
- L := L - 1;
- B := B - 1;
-
+ Iterate (Left_HT);
exception
when others =>
- L := L - 1;
- B := B - 1;
-
HT_Ops.Free_Hash_Table (Buckets);
raise;
end Iterate_Left;
-- Checked_Index instead of a simple invocation of generic formal
-- Hash.
- LB : Integer renames Left_HT.Busy;
- LL : Integer renames Left_HT.Lock;
-
- RB : Integer renames Right_HT.Busy;
- RL : Integer renames Right_HT.Lock;
+ Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access);
-- Start of processing for Iterate_Right
begin
- LB := LB + 1;
- LL := LL + 1;
-
- RB := RB + 1;
- RL := RL + 1;
-
Iterate (Right.HT);
-
- RL := RL - 1;
- RB := RB - 1;
-
- LL := LL - 1;
- LB := LB - 1;
-
exception
when others =>
- RL := RL - 1;
- RB := RB - 1;
-
- LL := LL - 1;
- LB := LB - 1;
-
HT_Ops.Free_Hash_Table (Buckets);
raise;
end Iterate_Right;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Union;
---------
Hash => Hash,
Equivalent_Keys => Equivalent_Key_Node);
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------------------
-- Constant_Reference --
------------------------
Node : constant Node_Access := Key_Keys.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "Key not in set";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
begin
Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "key not in set";
end if;
Node : constant Node_Access := Key_Keys.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
end if;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
+ Impl.Reference_Control_Type (Control).Finalize;
- if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
+ if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash
+ then
HT_Ops.Delete_Node_At_Index
(Control.Container.HT, Control.Index, Control.Old_Pos.Node);
raise Program_Error;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with
+ HT.TC'Unrestricted_Access,
Container => Container'Access,
Index => HT_Ops.Index (HT, Position.Node),
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
- do
- B := B + 1;
- L := L + 1;
+ do
+ Lock (HT.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "Key not in set";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
P : constant Cursor := Find (Container, Key);
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with
+ HT.TC'Unrestricted_Access,
Container => Container'Access,
Index => HT_Ops.Index (HT, P.Node),
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (HT.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Indx : Hash_Type;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Node.Element = null
- or else Position.Node.Next = Position.Node
+ if Checks and then
+ (Position.Node.Element = null
+ or else Position.Node.Next = Position.Node)
then
raise Program_Error with "Position cursor is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
- if HT.Buckets = null
- or else HT.Buckets'Length = 0
- or else HT.Length = 0
+ if Checks and then
+ (HT.Buckets = null
+ or else HT.Buckets'Length = 0
+ or else HT.Length = 0)
then
raise Program_Error with "Position cursor is bad (set is empty)";
end if;
declare
E : Element_Type renames Position.Node.Element.all;
K : constant Key_Type := Key (E);
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Indx := HT_Ops.Index (HT, Position.Node);
- Process (E);
- Eq := Equivalent_Keys (K, Key (E));
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Indx := HT_Ops.Index (HT, Position.Node);
+ Process (E);
- if Eq then
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
- if Prev = null then
+ if Checks and then Prev = null then
raise Program_Error with
"Position cursor is bad (node not found)";
end if;
with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
+private with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Index : Hash_Type;
Old_Hash : Hash_Type;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Node_Type;
type Node_Access is access Node_Type;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Node_Type is limited record
Element : Element_Access;
overriding procedure Finalize (Container : in out Set);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Set_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Constant_Reference_Type'Write use Write;
- Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0));
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
+ Empty_Set : constant Set := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
Set_Iterator_Interfaces.Forward_Iterator with
record
Container : Set_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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.Helpers
+
--------------------
-- Root_Iterator --
--------------------
function "=" (Left, Right : Tree) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Equal_Children (Root_Node (Left), Root_Node (Right));
end "=";
-- are preserved in the event that the allocation fails.
Container.Root.Children := Children_Type'(others => null);
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
Container.Count := 0;
-- Copy_Children returns a count of the number of nodes that it
Container.Count := Source_Count;
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Tree 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;
-
-------------------
-- Ancestor_Find --
-------------------
R, N : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Commented-out pending ARG ruling. ???
- -- if Position.Container /= Container'Unrestricted_Access then
+ -- if Checks and then
+ -- Position.Container /= Container'Unrestricted_Access
+ -- then
-- raise Program_Error with "Position cursor not in container";
-- end if;
-- not seem correct, as this value is just the limiting condition of the
-- search. For now we omit this check pending a ruling from the ARG.???
- -- if Is_Root (Position) then
+ -- if Checks and then Is_Root (Position) then
-- raise Program_Error with "Position cursor designates root";
-- end if;
Element : Element_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
N : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Child = No_Element then
+ if Checks and then Child = No_Element then
raise Constraint_Error with "Child cursor has no element";
end if;
- if Parent.Container /= Child.Container then
+ if Checks and then Parent.Container /= Child.Container then
raise Program_Error with "Parent and Child in different containers";
end if;
Result := Result + 1;
N := N.Parent;
- if N = null then
+ if Checks and then N = null then
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
Children_Count : Count_Type;
begin
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
-- We first set the container count to 0, in order to preserve
-- invariants in case the deallocation fails. (This works because
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
-- "Position cursor in Constant_Reference is bad");
declare
- C : Tree renames Position.Container.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 => Position.Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Target_Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
return;
end if;
- if Is_Root (Source) then
+ if Checks and then Is_Root (Source) then
raise Constraint_Error with "Source cursor designates root";
end if;
Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
-- Deallocate_Children returns a count of the number of nodes
-- that it deallocates, but it works by incrementing the
X : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if not Is_Leaf (Position) then
+ if Checks and then not Is_Leaf (Position) then
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
Count : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
function Element (Position : Cursor) return 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";
end if;
- if Position.Node = Root_Node (Position.Container.all) then
+ if Checks and then Position.Node = Root_Node (Position.Container.all)
+ then
raise Program_Error with "Position cursor designates root";
end if;
Right_Position : Cursor) return Boolean
is
begin
- if Left_Position = No_Element then
+ if Checks and then Left_Position = No_Element then
raise Constraint_Error with "Left cursor has no element";
end if;
- if Right_Position = No_Element then
+ if Checks and then Right_Position = No_Element then
raise Constraint_Error with "Right cursor has no element";
end if;
--------------
procedure Finalize (Object : in out Root_Iterator) is
- B : Natural renames Object.Container.Busy;
- begin
- B := B - 1;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
begin
- if Control.Container /= null then
- declare
- C : Tree 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;
----------
Node : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
Result : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Commented-out pending ruling from ARG. ???
- -- if Position.Container /= Container'Unrestricted_Access then
+ -- if Checks and then
+ -- Position.Container /= Container'Unrestricted_Access
+ -- then
-- raise Program_Error with "Position cursor not in container";
-- end if;
return Find_In_Children (Subtree, Item);
end Find_In_Subtree;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Element : Element_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Parent cursor not parent of Before";
end if;
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
(Container : Tree;
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;
-
Iterate_Children
(Container => Container'Unrestricted_Access,
Subtree => Root_Node (Container),
Process => Process);
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end Iterate;
function Iterate (Container : Tree)
(Parent : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ C : Tree_Node_Access;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- declare
- B : Natural renames Parent.Container.Busy;
- C : Tree_Node_Access;
-
- begin
- B := B + 1;
-
- C := Parent.Node.Children.First;
- while C /= null loop
- Process (Position => Cursor'(Parent.Container, Node => C));
- C := C.Next;
- end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ C := Parent.Node.Children.First;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Next;
+ end loop;
end Iterate_Children;
procedure Iterate_Children
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
C : constant Tree_Access := Container'Unrestricted_Access;
- B : Natural renames C.Busy;
-
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= C then
+ if Checks and then Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
Container => C,
Subtree => Parent.Node)
do
- B := B + 1;
+ Busy (C.TC);
end return;
end Iterate_Children;
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ C : constant Tree_Access := Position.Container;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Implement Vet for multiway trees???
-- pragma Assert (Vet (Position), "bad subtree cursor");
- declare
- B : Natural renames Position.Container.Busy;
- begin
- return It : constant Subtree_Iterator :=
- (Limited_Controlled with
- Container => Position.Container,
- Subtree => Position.Node)
- do
- B := B + 1;
- end return;
- end;
+ return It : constant Subtree_Iterator :=
+ (Limited_Controlled with
+ Container => Position.Container,
+ Subtree => Position.Node)
+ do
+ Busy (C.TC);
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
(Position : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- declare
- B : Natural renames Position.Container.Busy;
-
- begin
- B := B + 1;
-
- if Is_Root (Position) then
- Iterate_Children (Position.Container, Position.Node, Process);
- else
- Iterate_Subtree (Position.Container, Position.Node, Process);
- end if;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ if Is_Root (Position) then
+ Iterate_Children (Position.Container, Position.Node, Process);
+ else
+ Iterate_Subtree (Position.Container, Position.Node, Process);
+ end if;
end Iterate_Subtree;
procedure Iterate_Subtree
Node : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors of Source (tree is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Clear; -- checks busy bit
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
Element : Element_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
Position := Previous_Sibling (Position);
end Previous_Sibling;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Tree'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 --
-------------------
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- declare
- T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- Process (Position.Node.Element.all);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ Process (Position.Node.Element.all);
end Query_Element;
----------
begin
Count_Type'Read (Stream, Count);
- if Count < 0 then
+ if Checks and then Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Count_Type'Read (Stream, Total_Count);
- if Total_Count < 0 then
+ if Checks and then Total_Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Read_Children (Root_Node (Container));
- if Read_Count /= Total_Count then
+ if Checks and then Read_Count /= Total_Count then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
-- "Position cursor in Constant_Reference is bad");
declare
- C : Tree renames Position.Container.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 => Position.Node.Element.all'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
E, X : Element_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
(Parent : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ C : Tree_Node_Access;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- declare
- B : Natural renames Parent.Container.Busy;
- C : Tree_Node_Access;
-
- begin
- B := B + 1;
-
- C := Parent.Node.Children.Last;
- while C /= null loop
- Process (Position => Cursor'(Parent.Container, Node => C));
- C := C.Prev;
- end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ C := Parent.Node.Children.Last;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Prev;
+ end loop;
end Reverse_Iterate_Children;
----------
Count : Count_Type;
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error
with "Before cursor not in Target container";
end if;
- if Before.Node.Parent /= Target_Parent.Node then
+ if Checks and then Before.Node.Parent /= Target_Parent.Node then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Source'Unrestricted_Access then
+ if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in Source container";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (From => Target_Parent.Node,
+ if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
raise Constraint_Error
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
Source_Parent : Cursor)
is
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Target_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Target_Parent.Node then
+ if Checks and then Before.Node.Parent /= Target_Parent.Node then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Source_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (From => Target_Parent.Node,
+ if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
raise Constraint_Error
Subtree_Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in Target container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with "Position cursor not in Source container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
end if;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ if Checks and then
+ Is_Reachable (From => Parent.Node, To => Position.Node)
+ then
raise Constraint_Error with "Position is ancestor of Parent";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
Position : Cursor)
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
-- Should this be PE instead? Need ARG confirmation. ???
end if;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ if Checks and then
+ Is_Reachable (From => Parent.Node, To => Position.Node)
+ then
raise Constraint_Error with "Position is ancestor of Parent";
end if;
I, J : Cursor)
is
begin
- if I = No_Element then
+ if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor not in container";
end if;
- if Is_Root (I) then
+ if Checks and then Is_Root (I) then
raise Program_Error with "I cursor designates root";
end if;
return;
end if;
- if J = No_Element then
+ if Checks and then J = No_Element then
raise Constraint_Error with "J cursor has no element";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor not in container";
end if;
- if Is_Root (J) then
+ if Checks and then Is_Root (J) then
raise Program_Error with "J cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
declare
EI : constant Element_Access := I.Node.Element;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- declare
- T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- Process (Position.Node.Element.all);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
- end;
+ Process (Position.Node.Element.all);
end Update_Element;
-----------
------------------------------------------------------------------------------
with Ada.Iterator_Interfaces;
+
+private with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
private
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
type Tree_Node_Type;
type Tree_Node_Access is access all Tree_Node_Type;
Last : Tree_Node_Access;
end record;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Tree_Node_Type is record
Parent : Tree_Node_Access;
type Tree is new Controlled with record
Root : aliased Tree_Node_Type;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
Count : Count_Type := 0;
end record;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Tree_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Tree'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Tree : constant Tree := (Controlled with others => <>);
No_Element : constant Cursor := (others => <>);
-- --
-- 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- --
with Ada.Unchecked_Deallocation;
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
pragma Annotate (CodePeer, Skip_Analysis);
pragma Suppress (All_Checks);
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------------
-- Node Access Subprograms --
-----------------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with "Left cursor in ""<"" is bad";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with "Right cursor in ""<"" is bad";
end if;
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with "Left cursor in ""<"" is bad";
end if;
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with "Right cursor in ""<"" is bad";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with "Left cursor in ""<"" is bad";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with "Right cursor in ""<"" is bad";
end if;
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
- if Left.Node.Key = null then
+ if Checks and then Left.Node.Key = null then
raise Program_Error with "Left cursor in ""<"" is bad";
end if;
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
- if Right.Node.Key = null then
+ if Checks and then Right.Node.Key = null then
raise Program_Error with "Right cursor in ""<"" is bad";
end if;
Adjust (Container.Tree);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- T : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
"Position cursor in Constant_Reference is bad");
declare
- T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
- T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Position : in out Cursor)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with "Position cursor of Delete is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor of function Element is bad";
end if;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Tree.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- T : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.Tree.TC);
end if;
end Finalize;
function First_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.First = null then
+ if Checks and then T.First = null then
raise Constraint_Error with "map is empty";
- else
- return T.First.Element.all;
end if;
+
+ return T.First.Element.all;
end First_Element;
---------------
function First_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.First = null then
+ if Checks and then T.First = null then
raise Constraint_Error with "map is empty";
- else
- return T.First.Key.all;
end if;
+
+ return T.First.Key.all;
end First_Key;
-----------
Deallocate (X);
end Free;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
K := Position.Node.Key;
E := Position.Node.Element;
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with "key already in map";
end if;
end Insert;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+ Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container.Tree);
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container.Tree);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => null)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong map";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
- if Position.Node.Key = null then
+ if Checks and then Position.Node.Key = null then
raise Program_Error with
"Position cursor of function Key is bad";
end if;
T : Tree_Type renames Container.Tree;
begin
- if T.Last = null then
+ if Checks and then T.Last = null then
raise Constraint_Error with "map is empty";
end if;
T : Tree_Type renames Container.Tree;
begin
- if T.Last = null then
+ if Checks and then T.Last = null then
raise Constraint_Error with "map is empty";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong map";
end if;
return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type
+ is
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
+ end return;
+ end Pseudo_Reference;
+
-------------------
-- Query_Element --
-------------------
Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Query_Element is bad";
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key.all;
- E : Element_Type renames Position.Node.Element.all;
- begin
- Process (K, E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
"Position cursor in function Reference is bad");
declare
- T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
- T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
E : Element_Access;
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
K := Node.Key;
E := Node.Element;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Replace_Element is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (Container.Tree);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (Container.Tree);
end Reverse_Iterate;
-----------
Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Node.Key = null
- or else Position.Node.Element = null
+ if Checks and then
+ (Position.Node.Key = null or else Position.Node.Element = null)
then
raise Program_Error with
"Position cursor of Update_Element is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key.all;
- E : Element_Type renames Position.Node.Element.all;
- begin
- Process (K, E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Update_Element;
type Node_Access is access Node_Type;
type Key_Access is access Key_Type;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Node_Type is limited record
Parent : Node_Access;
overriding procedure Finalize (Container : in out Map) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Write use Write;
- Empty_Map : constant Map :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Map'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
+ Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : Map_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
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.Helpers
+
-----------------------------
-- Node Access Subprograms --
-----------------------------
--------------
procedure Finalize (Object : in out Iterator) is
- B : Natural renames Object.Container.Tree.Busy;
- pragma Assert (B > 0);
begin
- B := B - 1;
+ Unbusy (Object.Container.Tree.TC);
end Finalize;
-----------
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T, Key);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T, Key);
end Iterate;
---------
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T, Key);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T, Key);
end Reverse_Iterate;
--------------------
declare
E : Element_Type renames Node.Element.all;
K : constant Key_Type := Key (E);
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (E);
if Equivalent_Keys (Left => K, Right => Key (E)) then
return;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T, Item);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T, Item);
end Iterate;
procedure Iterate
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
S : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames S.Tree.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator := (Limited_Controlled with S, null) do
- B := B + 1;
+ Busy (S.Tree.TC);
end return;
end Iterate;
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
S : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames S.Tree.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,
return It : constant Iterator :=
(Limited_Controlled with S, Start.Node)
do
- B := B + 1;
+ Busy (S.Tree.TC);
end return;
end Iterate;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element.all);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element.all);
end;
end Query_Element;
then
null;
else
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
declare
X : Element_Access := Node.Element;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T, Item);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T, Item);
end Reverse_Iterate;
procedure Reverse_Iterate
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T);
end Reverse_Iterate;
-----------
overriding procedure Finalize (Container : in out Set) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Constant_Reference_Type'Write use Write;
- Empty_Set : constant Set :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ Empty_Set : constant Set := (Controlled with others => <>);
type Iterator is new Limited_Controlled and
Set_Iterator_Interfaces.Reversible_Iterator with
record
Container : Set_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with "Left cursor is bad";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with "Right cursor is bad";
end if;
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with "Left cursor is bad";
end if;
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with "Right cursor is bad";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with "Left cursor is bad";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with "Right cursor is bad";
end if;
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null then
+ if Checks and then Left.Node.Element = null then
raise Program_Error with "Left cursor is bad";
end if;
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
- if Right.Node.Element = null then
+ if Checks and then Right.Node.Element = null then
raise Program_Error with "Right cursor is bad";
end if;
Adjust (Container.Tree);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
Tree : Tree_Type renames Position.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
procedure Delete (Container : in out Set; Item : Element_Type) is
X : Node_Access := Element_Keys.Find (Container.Tree, Item);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete element not in set";
- else
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
- Free (X);
end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
end Delete;
------------------
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Tree.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.Tree.TC);
end if;
end Finalize;
function First_Element (Container : Set) return Element_Type is
begin
- if Container.Tree.First = null then
+ if Checks and then Container.Tree.First = null then
raise Constraint_Error with "set is empty";
- else
- return Container.Tree.First.Element.all;
end if;
+
+ return Container.Tree.First.Element.all;
end First_Element;
-----------
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
-------------
-- Ceiling --
-------------
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "Key not in set";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
X : Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete key not in set";
end if;
function Element (Container : Set; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
- else
- return Node.Element.all;
end if;
+
+ return Node.Element.all;
end Element;
---------------------
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
+ Impl.Reference_Control_Type (Control).Finalize;
- if not (Key (Control.Pos) = Control.Old_Key.all) then
+ if Checks and then not (Key (Control.Pos) = Control.Old_Key.all)
+ then
Delete (Control.Container.all, Key (Control.Pos));
raise Program_Error;
end if;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor is bad";
end if;
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
Tree : Tree_Type renames Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Unchecked_Access,
Control =>
(Controlled with
+ Tree.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- B := B + 1;
- L := L + 1;
+ Lock (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "Key not in set";
end if;
- if Node.Element = null then
+ if Checks and then Node.Element = null then
raise Program_Error with "Node has no element";
end if;
declare
Tree : Tree_Type renames Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Unchecked_Access,
Control =>
(Controlled with
+ Tree.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
Tree : Tree_Type renames Container.Tree;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
declare
E : Element_Type renames Position.Node.Element.all;
K : constant Key_Type := Key (E);
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (E);
- Eq := Equivalent_Keys (K, Key (E));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
-
- if Eq then
+ Process (E);
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
end Generic_Keys;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
-- Include --
-------------
- procedure Include (Container : in out Set; New_Item : Element_Type) is
+ procedure Include (Container : in out Set; New_Item : Element_Type) is
Position : Cursor;
Inserted : Boolean;
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
declare
-- The element allocator may need an accessibility check in the
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
end Process_Node;
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T);
end Iterate;
function Iterate
(Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => null)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
Start : Cursor)
return Set_Iterator_Interfaces.Reversible_Iterator'class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong set";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Last_Element (Container : Set) return Element_Type is
begin
- if Container.Tree.Last = null then
+ if Checks and then Container.Tree.Last = null then
raise Constraint_Error with "set is empty";
- else
- return Container.Tree.Last.Element.all;
end if;
+
+ return Container.Tree.Last.Element.all;
end Last_Element;
----------
return No_Element;
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
return No_Element;
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong set";
end if;
return Previous (Position);
end Previous;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type
+ is
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
+ end return;
+ end Pseudo_Reference;
+
-------------------
-- Query_Element --
-------------------
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element.all);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element.all);
end;
end Query_Element;
pragma Warnings (Off, X);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "attempt to replace element not in set";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
declare
-- The element allocator may need an accessibility check in the case
X : Element_Access := Node.Element;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
-- Start of processing for Replace_Element
begin
-- Determine whether Item is equivalent to element on the specified
-- node.
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := (if Item < Node.Element.all then False
elsif Node.Element.all < Item then False
else True);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
declare
-- The element allocator may need an accessibility check in the
Hint := Element_Keys.Ceiling (Tree, Item);
if Hint /= null then
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Item < Hint.Element.all;
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
-- Item >= Hint.Element
- if not Compare then
+ if Checks and then not Compare then
-- Ceiling returns an element that is equivalent or greater
-- than Item. If Item is "not less than" the element, then
-- because it would only be placed in the exact same position.
if Hint = Node then
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
declare
-- The element allocator may need an accessibility check in the
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
+ if Checks and then Position.Node.Element = null then
raise Program_Error with "Position cursor is bad";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T);
end Reverse_Iterate;
-----------
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
type Key_Access is access all Key_Type;
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Pos : Cursor;
Old_Key : Key_Access;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Node_Type;
type Node_Access is access Node_Type;
- type Element_Access is access Element_Type;
+ type Element_Access is access all Element_Type;
type Node_Type is limited record
Parent : Node_Access;
overriding procedure Finalize (Container : in out Set) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Set_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Constant_Reference_Type'Write use Write;
- Empty_Set : constant Set :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Set'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
+ Empty_Set : constant Set := (Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : Set_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- 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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
-- 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
+ if Checks and then LN > Count_Type'Last - RN then
raise Constraint_Error with "new length is out of range";
end if;
-- Which can rewrite as:
-- No_Index <= Last - Length
- if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
+ if Checks and then
+ Index_Type'Base'Last - Index_Type'Base (N) < No_Index
+ then
raise Constraint_Error with "new 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 "new length is out of range";
end if;
J := Count_Type'Base (No_Index) + N; -- Last
- if J > Count_Type'Base (Index_Type'Last) then
+ if Checks and then J > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
- if J < Count_Type'Base (No_Index) then
+ if Checks and then J < Count_Type'Base (No_Index) then
raise Constraint_Error with "new length is out of range";
end if;
-- constraints: the new length cannot exceed Count_Type'Last, and the
-- new Last index cannot exceed Index_Type'Last.
- if LN = Count_Type'Last then
+ if Checks and then LN = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
- if Left.Last >= Index_Type'Last then
+ if Checks and then Left.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
-- the new length cannot exceed Count_Type'Last, and the new Last index
-- cannot exceed Index_Type'Last.
- if RN = Count_Type'Last then
+ if Checks and then RN = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
- if Right.Last >= Index_Type'Last then
+ if Checks and then Right.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
-- know that that condition is satisfied), and the new Last index cannot
-- exceed Index_Type'Last.
- if Index_Type'First >= Index_Type'Last then
+ if Checks and then Index_Type'First >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
---------
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 Count_Type range 1 .. Left.Length loop
if Left.Elements (J) /= Right.Elements (J) 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 "=";
- ------------
- -- 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;
-
------------
-- Assign --
------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error -- ???
with "Target capacity is less than Source length";
end if;
return;
end if;
- 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;
return;
end if;
- 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;
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)";
- 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
+ if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
end if;
- if Position.Index > Position.Container.Last then
+ if Checks and then Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
declare
A : Elements_Array renames Container.Elements;
- I : constant Count_Type := To_Array_Index (Position.Index);
- B : Natural renames Position.Container.Busy;
- L : Natural renames Position.Container.Lock;
+ J : constant Count_Type := To_Array_Index (Position.Index);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => A (I)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => A (J)'Access,
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end 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";
end if;
declare
A : Elements_Array renames Container.Elements;
- I : constant Count_Type := To_Array_Index (Index);
+ J : constant Count_Type := To_Array_Index (Index);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => A (I)'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ (Element => A (J)'Access,
+ Control => (Controlled with TC))
do
- R.Control.Container.Busy := R.Control.Container.Busy + 1;
- R.Control.Container.Lock := R.Control.Container.Lock + 1;
+ Lock (TC.all);
end return;
end;
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)";
end if;
-- 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
pragma Warnings (Off, Position);
begin
- if Position.Container = null then
+ if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
end if;
- if Position.Index > Container.Last then
+ if Checks and then Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
-- 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 (To_Array_Index (Index));
function Element (Position : Cursor) return 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
return Position.Container.Element (Position.Index);
--------------
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
- 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;
----------
is
begin
if Position.Container /= null then
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
end if;
- if Position.Index > Container.Last then
+ if Checks and then Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
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 (To_Array_Index (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 (To_Array_Index (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 (To_Array_Index (Index_Type'First));
end if;
+
+ return Container.Elements (To_Array_Index (Index_Type'First));
end First_Element;
-----------------
-- element tampering by a generic actual subprogram.
declare
+ Lock : With_Lock (Container.TC'Unrestricted_Access);
EA : Elements_Array renames Container.Elements;
-
- 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 J in 1 .. Container.Length - 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);
I := Target.Length;
Target.Set_Length (I + Source.Length);
TA : Elements_Array renames Target.Elements;
SA : Elements_Array renames Source.Elements;
- 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.Length;
while not Source.Is_Empty loop
pragma Assert (Source.Length <= 1
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 (1 .. Container.Length));
-
- 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
+ (To_Array_Index (Position.Index))'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
- if Before < Index_Type'First then
+ if Checks and then Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
- if Before > Container.Last
+ if Checks and then Before > Container.Last
and then Before > Container.Last + 1
then
raise Constraint_Error with
-- count. Note that 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);
- if New_Length > Container.Capacity then
+ if Checks and then New_Length > Container.Capacity then
raise Capacity_Error with "New length is larger than capacity";
end if;
Index : Index_Type'Base;
begin
- if Before.Container /= null
+ if Checks and then Before.Container /= null
and then Before.Container /= Container'Unchecked_Access
then
raise Program_Error with "Before cursor denotes wrong container";
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'Unchecked_Access
then
raise Program_Error with "Before cursor denotes wrong container";
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'Unchecked_Access
then
raise Program_Error with "Before cursor denotes wrong container";
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'Unchecked_Access
then
raise Program_Error with "Before cursor denotes wrong container";
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;
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
- if Before < Index_Type'First then
+ if Checks and then Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
- if Before > Container.Last
+ if Checks and then Before > Container.Last
and then Before > Container.Last + 1
then
raise Constraint_Error with
-- Note that 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 need to check
-- whether there is enough unused storage for the new items.
- if New_Length > Container.Capacity then
+ if Checks and then New_Length > Container.Capacity then
raise Capacity_Error with "New length is larger than capacity";
end if;
Index : Index_Type'Base;
begin
- if Before.Container /= null
+ if Checks and then Before.Container /= null
and then Before.Container /= Container'Unchecked_Access
then
raise Program_Error with "Before cursor denotes wrong container";
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;
(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
+ if Checks and then Start.Container = null then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= V then
+ if Checks and then Start.Container /= V then
raise Program_Error with
"Start cursor of Iterate designates wrong vector";
end if;
- if Start.Index > V.Last then
+ if Checks and then Start.Index > V.Last then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
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 (Container.Length);
end if;
+
+ return Container.Elements (Container.Length);
end Last_Element;
----------------
return;
end if;
- if Target.Capacity < Source.Length then
+ if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error -- ???
with "Target capacity is less than Source length";
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);
-- Clear Target now, in case element assignment fails
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
- else
- return Next (Position);
end if;
+
+ return Next (Position);
end Next;
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return No_Element;
- elsif Position.Container /= Object.Container then
+ end if;
+
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
- else
- return Previous (Position);
end if;
+
+ return Previous (Position);
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;
- B := B + 1;
- L := L + 1;
-
- begin
- Process (V.Elements (To_Array_Index (Index)));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (V.Elements (To_Array_Index (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);
end if;
+
+ Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
end if;
- if Position.Index > Position.Container.Last then
+ if Checks and then Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
declare
A : Elements_Array renames Container.Elements;
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
J : constant Count_Type := To_Array_Index (Position.Index);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
- B := B + 1;
- L := L + 1;
- return (Element => A (J)'Access,
- Control => (Controlled with Container'Unrestricted_Access));
+ return R : constant Reference_Type :=
+ (Element => A (J)'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
end;
end 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;
declare
A : Elements_Array renames Container.Elements;
- B : Natural renames Container.Busy;
- L : Natural renames Container.Lock;
J : constant Count_Type := To_Array_Index (Index);
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
begin
- B := B + 1;
- L := L + 1;
- return (Element => A (J)'Access,
- Control => (Controlled with Container'Unrestricted_Access));
+ return R : constant Reference_Type :=
+ (Element => A (J)'Access,
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
end;
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 (To_Array_Index (Index)) := New_Item;
end if;
+
+ TE_Check (Container.TC);
+
+ Container.Elements (To_Array_Index (Index)) := New_Item;
end Replace_Element;
procedure Replace_Element
New_Item : 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";
+ end if;
- elsif Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
+ end if;
- elsif Position.Index > Container.Last then
+ if Checks and then Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
+ end if;
- elsif Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (vector is locked)";
+ TE_Check (Container.TC);
- else
- Container.Elements (To_Array_Index (Position.Index)) := New_Item;
- end if;
+ Container.Elements (To_Array_Index (Position.Index)) := New_Item;
end Replace_Element;
----------------------
Capacity : Count_Type)
is
begin
- if Capacity > Container.Capacity then
+ if Checks and then Capacity > Container.Capacity then
raise Capacity_Error with "Capacity is out of range";
end if;
end Reserve_Capacity;
-- 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);
Idx := 1;
Jdx := Container.Length;
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 (To_Array_Index (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 (To_Array_Index (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;
---------------------
(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
+ end if;
+
+ if Checks and then Container.Last >= Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
- else
- Container.Insert_Space (Container.Last + 1, -Count);
end if;
+
+ Container.Insert_Space (Container.Last + 1, -Count);
end Set_Length;
----------
E : Elements_Array renames Container.Elements;
begin
- if I > Container.Last then
+ if Checks and then I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
- if J > Container.Last then
+ if Checks and then J > Container.Last then
raise Constraint_Error with "J index is out of range";
end if;
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 := E (To_Array_Index (I));
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
- if I.Container = null then
+ if Checks and then I.Container = null then
raise Constraint_Error with "I cursor has no element";
end if;
- if J.Container = null then
+ if Checks and then J.Container = null then
raise Constraint_Error with "J cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
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; -- 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 (To_Array_Index (Index)));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Container.Elements (To_Array_Index (Index)));
end Update_Element;
procedure Update_Element
Process : not null access procedure (Element : in out 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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor denotes wrong container";
end if;
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
pragma Inline (Next);
pragma Inline (Previous);
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
use Ada.Streams;
use Ada.Finalization;
type Vector (Capacity : Count_Type) is tagged record
Elements : Elements_Array (1 .. Capacity) := (others => <>);
Last : Extended_Index := No_Index;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
end record;
procedure Write
for Cursor'Read use Read;
- type Reference_Control_Type is new Controlled with record
- Container : Vector_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Vector'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Vector : constant Vector := (Capacity => 0, others => <>);
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
record
Container : Vector_Access;
Index : Index_Type'Base;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with System; use type System.Address;
package body Ada.Containers.Hashed_Maps is
pragma Annotate (CodePeer, Skip_Analysis);
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
HT_Ops.Adjust (Container.HT);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
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;
begin
Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete key not in map";
end if;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
- if Container.HT.Busy > 0 then
- raise Program_Error with
- "Delete attempted to tamper with cursors (map is busy)";
- end if;
+ TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"no element available because key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.HT.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.HT.TC);
end if;
end Finalize;
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "Include attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.HT.TC);
Position.Node.Key := Key;
Position.Node.Element := New_Item;
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert key already in map";
end if;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
+ Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container.HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container.HT);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
begin
return It : constant Iterator :=
(Limited_Controlled with Container => Container'Unrestricted_Access)
do
- B := B + 1;
+ Busy (Container.HT.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
function Pseudo_Reference
(Container : aliased Map'Class) return Reference_Control_Type
is
- C : constant Map_Access := Container'Unrestricted_Access;
- B : Natural renames C.HT.Busy;
- L : Natural renames C.HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.HT.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;
procedure (Key : Key_Type; Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key;
- E : Element_Type renames Position.Node.Element;
- begin
- Process (K, E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "Replace attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.HT.TC);
Node.Key := Key;
Node.Element := New_Item;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Position.Container.HT.Lock > 0 then
- raise Program_Error with
- "Replace_Element attempted to tamper with elements (map is locked)";
- end if;
+ TE_Check (Position.Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key;
- E : Element_Type renames Position.Node.Element;
- begin
- Process (K, E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Update_Element;
overriding procedure Finalize (Container : in out Map);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Write use Write;
- type Reference_Control_Type is
- new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
- type Element_Access is access all Element_Type;
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
- Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
+ Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
Map_Iterator_Interfaces.Forward_Iterator with
record
Container : Map_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Prime_Numbers;
with System; use type System.Address;
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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
HT_Ops.Adjust (Container.HT);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
HT : Hash_Table_Type renames Position.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
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;
begin
Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete element not in set";
end if;
Position : in out Cursor)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
- if Container.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
if Src_HT.Length < Target.HT.Length then
declare
raise;
end Iterate_Left;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Difference;
-------------
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Elements equals No_Element";
end if;
function Equivalent_Elements (Left : Element_Type; Right : Cursor)
return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Elements equals No_Element";
end if;
HT_Ops.Finalize (Container.HT);
end Finalize;
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
- end if;
- end Finalize;
-
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.HT.Busy;
- begin
- B := B - 1;
- end;
+ Unbusy (Object.Container.HT.TC);
end if;
end Finalize;
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.HT.TC);
Position.Node.Element := New_Item;
end if;
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
HT_Ops.Reserve_Capacity (HT, 1);
end if;
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (HT.TC);
Local_Insert (HT, New_Item, Node, Inserted);
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop
raise;
end Iterate_Left;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Intersection;
--------------
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Iterate (Container.HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Iterate (Container.HT);
end Iterate;
function Iterate
(Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
begin
- B := B + 1;
+ Busy (Container.HT.TC'Unrestricted_Access.all);
return It : constant Iterator :=
Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access);
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
function Pseudo_Reference
(Container : aliased Set'Class) return Reference_Control_Type
is
- C : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames C.HT.Busy;
- L : Natural renames C.HT.Lock;
- begin
- return R : constant Reference_Control_Type :=
- (Controlled with C)
- do
- B := B + 1;
- L := L + 1;
+ TC : constant Tamper_Counts_Access :=
+ Container.HT.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
end return;
end Pseudo_Reference;
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element);
end;
end Query_Element;
Element_Keys.Find (Container.HT, New_Item);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.HT.TC);
Node.Element := New_Item;
end Replace;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
is
Tgt_HT : Hash_Table_Type renames Target.HT;
Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
-
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- TB : Natural renames Tgt_HT.Busy;
- TL : Natural renames Tgt_HT.Lock;
-
- SB : Natural renames Src_HT.Busy;
- SL : Natural renames Src_HT.Lock;
-
begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- if TB > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Tgt_HT.TC);
declare
N : constant Count_Type := Target.Length + Source.Length;
Iterate_Source_When_Empty_Target : declare
procedure Process (Src_Node : Node_Access);
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ procedure Iterate is new HT_Ops.Generic_Iteration (Process);
-------------
-- Process --
N := N + 1;
end Process;
- -- Start of processing for Iterate_Source_When_Empty_Target
+ -- Per AI05-0022, the container implementation is required to
+ -- detect element tampering by a generic actual subprogram.
- begin
- TB := TB + 1;
- TL := TL + 1;
+ Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
+ Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
- SB := SB + 1;
- SL := SL + 1;
+ -- Start of processing for Iterate_Source_When_Empty_Target
+ begin
Iterate (Src_HT);
-
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- exception
- when others =>
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- raise;
end Iterate_Source_When_Empty_Target;
else
end if;
end Process;
- -- Start of processing for Iterate_Source
+ -- Per AI05-0022, the container implementation is required to
+ -- detect element tampering by a generic actual subprogram.
- begin
- TB := TB + 1;
- TL := TL + 1;
+ Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
+ Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
- SB := SB + 1;
- SL := SL + 1;
+ -- Start of processing for Iterate_Source
+ begin
Iterate (Src_HT);
-
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- exception
- when others =>
- SL := SL - 1;
- SB := SB - 1;
-
- TL := TL - 1;
- TB := TB - 1;
-
- raise;
end Iterate_Source;
end if;
end Symmetric_Difference;
raise;
end Iterate_Right;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Symmetric_Difference;
------------
return;
end if;
- if Target.HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is busy)";
- end if;
+ TC_Check (Target.HT.TC);
declare
N : constant Count_Type := Target.Length + Source.Length;
-- Checked_Index instead of a simple invocation of generic formal
-- Hash.
- B : Integer renames Left_HT.Busy;
- L : Integer renames Left_HT.Lock;
+ Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
-- Start of processing for Iterate_Left
begin
- B := B + 1;
- L := L + 1;
-
Iterate (Left_HT);
-
- L := L - 1;
- B := B - 1;
-
exception
when others =>
- L := L - 1;
- B := B - 1;
-
HT_Ops.Free_Hash_Table (Buckets);
raise;
end Iterate_Left;
-- Checked_Index instead of a simple invocation of generic formal
-- Hash.
- LB : Integer renames Left_HT.Busy;
- LL : Integer renames Left_HT.Lock;
-
- RB : Integer renames Right_HT.Busy;
- RL : Integer renames Right_HT.Lock;
+ Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access);
-- Start of processing for Iterate_Right
begin
- LB := LB + 1;
- LL := LL + 1;
-
- RB := RB + 1;
- RL := RL + 1;
-
Iterate (Right_HT);
-
- RL := RL - 1;
- RB := RB - 1;
-
- LL := LL - 1;
- LB := LB - 1;
-
exception
when others =>
- RL := RL - 1;
- RB := RB - 1;
-
- LL := LL - 1;
- LB := LB - 1;
-
HT_Ops.Free_Hash_Table (Buckets);
raise;
end Iterate_Right;
- return (Controlled with HT => (Buckets, Length, 0, 0));
+ return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
end Union;
---------
-- Local Subprograms --
-----------------------
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
Node : constant Node_Access := Key_Keys.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "Key not in set";
end if;
declare
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ TC : constant Tamper_Counts_Access :=
+ HT.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
begin
Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete key not in set";
end if;
Node : constant Node_Access := Key_Keys.Find (HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
end if;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- HT : Hash_Table_Type renames Control.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
+ Impl.Reference_Control_Type (Control).Finalize;
- if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
+ if Checks and then
+ Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
then
HT_Ops.Delete_Node_At_Index
(Control.Container.HT, Control.Index, Control.Old_Pos.Node);
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
HT : Hash_Table_Type renames Position.Container.all.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with
+ HT.TC'Unrestricted_Access,
Container'Unrestricted_Access,
Index => HT_Ops.Index (HT, Position.Node),
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
do
- B := B + 1;
- L := L + 1;
+ Lock (HT.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
end if;
declare
HT : Hash_Table_Type renames Container.HT;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
P : constant Cursor := Find (Container, Key);
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with
+ HT.TC'Unrestricted_Access,
Container'Unrestricted_Access,
Index => HT_Ops.Index (HT, P.Node),
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (HT.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Indx : Hash_Type;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
- if HT.Buckets = null
- or else HT.Buckets'Length = 0
- or else HT.Length = 0
- or else Position.Node.Next = Position.Node
+ if Checks and then
+ (HT.Buckets = null
+ or else HT.Buckets'Length = 0
+ or else HT.Length = 0
+ or else Position.Node.Next = Position.Node)
then
raise Program_Error with "Position cursor is bad (set is empty)";
end if;
declare
E : Element_Type renames Position.Node.Element;
K : constant Key_Type := Key (E);
-
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (HT.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Indx := HT_Ops.Index (HT, Position.Node);
- Process (E);
- Eq := Equivalent_Keys (K, Key (E));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Indx := HT_Ops.Index (HT, Position.Node);
+ Process (E);
- if Eq then
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
- if Prev = null then
+ if Checks and then Prev = null then
raise Program_Error with
"Position cursor is bad (node not found)";
end if;
with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
+private with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-- in that case the check that buckets have not changed is performed
-- at the time of the update, not when the reference is finalized.
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Index : Hash_Type;
Old_Hash : Hash_Type;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
overriding procedure Finalize (Container : in out Set);
- use HT_Types;
+ use HT_Types, HT_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
Node : Node_Access;
end record;
- type Reference_Control_Type is new Ada.Finalization.Controlled with record
- Container : Set_Access;
- end record;
-
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Read use Read;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
- type Element_Access is access all Element_Type;
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
- Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0));
+ Empty_Set : constant Set := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
- type Iterator is new Limited_Controlled
- and Set_Iterator_Interfaces.Forward_Iterator with
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Forward_Iterator with
record
Container : Set_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding function First (Object : Iterator) return Cursor;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2011, 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- --
-- This package declares the hash-table type used to implement hashed
-- containers.
+with Ada.Containers.Helpers;
+
package Ada.Containers.Hash_Tables is
pragma Pure;
-- Declare Pure so this can be imported by Remote_Types packages
type Node_Access is access Node_Type;
package Generic_Hash_Table_Types is
+
type Buckets_Type is array (Hash_Type range <>) of Node_Access;
type Buckets_Access is access all Buckets_Type;
-- Storage_Size of zero so this package can be Pure
type Hash_Table_Type is tagged record
- Buckets : Buckets_Access;
+ Buckets : Buckets_Access := null;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Helpers.Tamper_Counts;
end record;
+
+ package Implementation is new Helpers.Generic_Implementation;
end Generic_Hash_Table_Types;
generic
type Node_Type is private;
package Generic_Bounded_Hash_Table_Types is
+
type Nodes_Type is array (Count_Type range <>) of Node_Type;
type Buckets_Type is array (Hash_Type range <>) of Count_Type;
Modulus : Hash_Type) is
tagged record
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Helpers.Tamper_Counts;
Free : Count_Type'Base := -1;
Nodes : Nodes_Type (1 .. Capacity) := (others => <>);
Buckets : Buckets_Type (1 .. Modulus) := (others => 0);
end record;
+
+ package Implementation is new Helpers.Generic_Implementation;
end Generic_Bounded_Hash_Table_Types;
end Ada.Containers.Hash_Tables;
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
- -- See comment in Ada.Containers
+ -- See comment in Ada.Containers.Helpers
procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
end if;
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
function Constant_Reference
raise Constraint_Error with "Index is out of range";
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
--------------
end if;
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
function Reference
raise Constraint_Error with "Index is out of range";
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
---------------------
-- --
-- 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.Helpers
+
--------------------
-- Root_Iterator --
--------------------
function "=" (Left, Right : Tree) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Equal_Children (Root_Node (Left), Root_Node (Right));
end "=";
-- are preserved in the event that the allocation fails.
Container.Root.Children := Children_Type'(others => null);
- Container.Busy := 0;
- Container.Lock := 0;
+ Zero_Counts (Container.TC);
Container.Count := 0;
-- Copy_Children returns a count of the number of nodes that it
Container.Count := Source_Count;
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Tree 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;
-
-------------------
-- Ancestor_Find --
-------------------
R, N : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- not seem correct, as this value is just the limiting condition of the
-- search. For now we omit this check, pending a ruling from the ARG.???
- -- if Is_Root (Position) then
+ -- if Checks and then Is_Root (Position) then
-- raise Program_Error with "Position cursor designates root";
-- end if;
Last : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
N : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Child = No_Element then
+ if Checks and then Child = No_Element then
raise Constraint_Error with "Child cursor has no element";
end if;
- if Parent.Container /= Child.Container then
+ if Checks and then Parent.Container /= Child.Container then
raise Program_Error with "Parent and Child in different containers";
end if;
Result := Result + 1;
N := N.Parent;
- if N = null then
+ if Checks and then N = null then
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
Container_Count, Children_Count : Count_Type;
begin
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
-- We first set the container count to 0, in order to preserve
-- invariants in case the deallocation fails. (This works because
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
declare
C : Tree renames Position.Container.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ TC : constant Tamper_Counts_Access :=
+ C.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Target_Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
return;
end if;
- if Is_Root (Source) then
+ if Checks and then Is_Root (Source) then
raise Constraint_Error with "Source cursor designates root";
end if;
Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
-- Deallocate_Children returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
X : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if not Is_Leaf (Position) then
+ if Checks and then not Is_Leaf (Position) then
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
Count : Count_Type;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
function Element (Position : Cursor) return 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";
end if;
- if Position.Node = Root_Node (Position.Container.all) then
+ if Checks and then Position.Node = Root_Node (Position.Container.all)
+ then
raise Program_Error with "Position cursor designates root";
end if;
Right_Position : Cursor) return Boolean
is
begin
- if Left_Position = No_Element then
+ if Checks and then Left_Position = No_Element then
raise Constraint_Error with "Left cursor has no element";
end if;
- if Right_Position = No_Element then
+ if Checks and then Right_Position = No_Element then
raise Constraint_Error with "Right cursor has no element";
end if;
--------------
procedure Finalize (Object : in out Root_Iterator) is
- B : Natural renames Object.Container.Busy;
begin
- B := B - 1;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- C : Tree 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;
----------
Node : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
Result : Tree_Node_Access;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Commented out pending official ruling by ARG. ???
- -- if Position.Container /= Container'Unrestricted_Access then
+ -- if Checks and then
+ -- Position.Container /= Container'Unrestricted_Access
+ -- then
-- raise Program_Error with "Position cursor not in container";
-- end if;
return Find_In_Children (Subtree, Item);
end Find_In_Subtree;
+ ------------------------
+ -- Get_Element_Access --
+ ------------------------
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access is
+ begin
+ return Position.Node.Element'Access;
+ end Get_Element_Access;
+
-----------------
-- Has_Element --
-----------------
Last : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Parent cursor not parent of Before";
end if;
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
Last : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Parent cursor not parent of Before";
end if;
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => <>,
(Container : Tree;
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;
-
Iterate_Children
(Container => Container'Unrestricted_Access,
Subtree => Root_Node (Container),
Process => Process);
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
end Iterate;
function Iterate (Container : Tree)
(Parent : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ C : Tree_Node_Access;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- declare
- B : Natural renames Parent.Container.Busy;
- C : Tree_Node_Access;
-
- begin
- B := B + 1;
-
- C := Parent.Node.Children.First;
- while C /= null loop
- Process (Position => Cursor'(Parent.Container, Node => C));
- C := C.Next;
- end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ C := Parent.Node.Children.First;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Next;
+ end loop;
end Iterate_Children;
procedure Iterate_Children
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
C : constant Tree_Access := Container'Unrestricted_Access;
- B : Natural renames C.Busy;
-
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= C then
+ if Checks and then Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
Container => C,
Subtree => Parent.Node)
do
- B := B + 1;
+ Busy (C.TC);
end return;
end Iterate_Children;
(Position : Cursor)
return Tree_Iterator_Interfaces.Forward_Iterator'Class
is
+ C : constant Tree_Access := Position.Container;
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
-- Implement Vet for multiway trees???
-- pragma Assert (Vet (Position), "bad subtree cursor");
- declare
- B : Natural renames Position.Container.Busy;
- begin
- return It : constant Subtree_Iterator :=
- (Limited_Controlled with
- Container => Position.Container,
- Subtree => Position.Node)
- do
- B := B + 1;
- end return;
- end;
+ return It : constant Subtree_Iterator :=
+ (Limited_Controlled with
+ Container => C,
+ Subtree => Position.Node)
+ do
+ Busy (C.TC);
+ end return;
end Iterate_Subtree;
procedure Iterate_Subtree
(Position : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- declare
- B : Natural renames Position.Container.Busy;
-
- begin
- B := B + 1;
-
- if Is_Root (Position) then
- Iterate_Children (Position.Container, Position.Node, Process);
- else
- Iterate_Subtree (Position.Container, Position.Node, Process);
- end if;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ if Is_Root (Position) then
+ Iterate_Children (Position.Container, Position.Node, Process);
+ else
+ Iterate_Subtree (Position.Container, Position.Node, Process);
+ end if;
end Iterate_Subtree;
procedure Iterate_Subtree
Node : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors of Source (tree is busy)";
- end if;
+ TC_Check (Source.TC);
Target.Clear; -- checks busy bit
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
First, Last : Tree_Node_Access;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
Position := Previous_Sibling (Position);
end Previous_Sibling;
+ ----------------------
+ -- Pseudo_Reference --
+ ----------------------
+
+ function Pseudo_Reference
+ (Container : aliased Tree'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 --
-------------------
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- declare
- T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- Process (Position.Node.Element);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
- end;
+ Process (Position.Node.Element);
end Query_Element;
----------
begin
Count_Type'Read (Stream, Count);
- if Count < 0 then
+ if Checks and then Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Count_Type'Read (Stream, Total_Count);
- if Total_Count < 0 then
+ if Checks and then Total_Count < 0 then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Read_Children (Root_Node (Container));
- if Read_Count /= Total_Count then
+ if Checks and then Read_Count /= Total_Count then
raise Program_Error with "attempt to read from corrupt stream";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
- if Position.Node = Root_Node (Container) then
+ if Checks and then Position.Node = Root_Node (Container) then
raise Program_Error with "Position cursor designates root";
end if;
declare
C : Tree renames Position.Container.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ TC : constant Tamper_Counts_Access :=
+ C.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
New_Item : Element_Type)
is
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
Position.Node.Element := New_Item;
end Replace_Element;
(Parent : Cursor;
Process : not null access procedure (Position : Cursor))
is
+ C : Tree_Node_Access;
+ Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- declare
- B : Natural renames Parent.Container.Busy;
- C : Tree_Node_Access;
-
- begin
- B := B + 1;
-
- C := Parent.Node.Children.Last;
- while C /= null loop
- Process (Position => Cursor'(Parent.Container, Node => C));
- C := C.Prev;
- end loop;
-
- B := B - 1;
-
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ C := Parent.Node.Children.Last;
+ while C /= null loop
+ Process (Position => Cursor'(Parent.Container, Node => C));
+ C := C.Prev;
+ end loop;
end Reverse_Iterate_Children;
----------
Count : Count_Type;
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error
with "Before cursor not in Target container";
end if;
- if Before.Node.Parent /= Target_Parent.Node then
+ if Checks and then Before.Node.Parent /= Target_Parent.Node then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Source'Unrestricted_Access then
+ if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in Source container";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (From => Target_Parent.Node,
+ if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
raise Constraint_Error
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
Source_Parent : Cursor)
is
begin
- if Target_Parent = No_Element then
+ if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
- if Target_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Target_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Target_Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Target_Parent.Node then
+ if Checks and then Before.Node.Parent /= Target_Parent.Node then
raise Constraint_Error
with "Before cursor not child of Target_Parent";
end if;
end if;
- if Source_Parent = No_Element then
+ if Checks and then Source_Parent = No_Element then
raise Constraint_Error with "Source_Parent cursor has no element";
end if;
- if Source_Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then
+ Source_Parent.Container /= Container'Unrestricted_Access
+ then
raise Program_Error
with "Source_Parent cursor not in container";
end if;
return;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (From => Target_Parent.Node,
+ if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
raise Constraint_Error
Subtree_Count : Count_Type;
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Target'Unrestricted_Access then
+ if Checks and then Parent.Container /= Target'Unrestricted_Access then
raise Program_Error with "Parent cursor not in Target container";
end if;
if Before /= No_Element then
- if Before.Container /= Target'Unrestricted_Access then
+ if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with "Before cursor not in Target container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Source'Unrestricted_Access then
+ if Checks and then Position.Container /= Source'Unrestricted_Access then
raise Program_Error with "Position cursor not in Source container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
end if;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
+ TC_Check (Target.TC);
- if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ if Checks and then
+ Is_Reachable (From => Parent.Node, To => Position.Node)
+ then
raise Constraint_Error with "Position is ancestor of Parent";
end if;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Target tree is busy)";
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (Source tree is busy)";
- end if;
+ TC_Check (Target.TC);
+ TC_Check (Source.TC);
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
Position : Cursor)
is
begin
- if Parent = No_Element then
+ if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
- if Parent.Container /= Container'Unrestricted_Access then
+ if Checks and then Parent.Container /= Container'Unrestricted_Access then
raise Program_Error with "Parent cursor not in container";
end if;
if Before /= No_Element then
- if Before.Container /= Container'Unrestricted_Access then
+ if Checks and then Before.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Before cursor not in container";
end if;
- if Before.Node.Parent /= Parent.Node then
+ if Checks and then Before.Node.Parent /= Parent.Node then
raise Constraint_Error with "Before cursor not child of Parent";
end if;
end if;
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
-- Should this be PE instead? Need ARG confirmation. ???
end if;
end if;
- if Container.Busy > 0 then
- raise Program_Error
- with "attempt to tamper with cursors (tree is busy)";
- end if;
+ TC_Check (Container.TC);
- if Is_Reachable (From => Parent.Node, To => Position.Node) then
+ if Checks and then
+ Is_Reachable (From => Parent.Node, To => Position.Node)
+ then
raise Constraint_Error with "Position is ancestor of Parent";
end if;
I, J : Cursor)
is
begin
- if I = No_Element then
+ if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access then
+ if Checks and then I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor not in container";
end if;
- if Is_Root (I) then
+ if Checks and then Is_Root (I) then
raise Program_Error with "I cursor designates root";
end if;
return;
end if;
- if J = No_Element then
+ if Checks and then J = No_Element then
raise Constraint_Error with "J cursor has no element";
end if;
- if J.Container /= Container'Unrestricted_Access then
+ if Checks and then J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor not in container";
end if;
- if Is_Root (J) then
+ if Checks and then Is_Root (J) then
raise Program_Error with "J cursor designates root";
end if;
- if Container.Lock > 0 then
- raise Program_Error
- with "attempt to tamper with elements (tree is locked)";
- end if;
+ TE_Check (Container.TC);
declare
EI : constant Element_Type := I.Node.Element;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
+ T : Tree renames Position.Container.all'Unrestricted_Access.all;
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- if Position = No_Element then
+ if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor not in container";
end if;
- if Is_Root (Position) then
+ if Checks and then Is_Root (Position) then
raise Program_Error with "Position cursor designates root";
end if;
- declare
- T : Tree renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
- begin
- B := B + 1;
- L := L + 1;
-
- Process (Position.Node.Element);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
- end;
+ Process (Position.Node.Element);
end Update_Element;
-----------
------------------------------------------------------------------------------
with Ada.Iterator_Interfaces;
+
+private with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-- thus guaranteeing that (unchecked) conversions between access types
-- designating each kind of node type is a meaningful conversion.
+ use Ada.Containers.Helpers;
+ package Implementation is new Generic_Implementation;
+ use Implementation;
+
type Tree_Node_Type;
type Tree_Node_Access is access all Tree_Node_Type;
pragma Convention (C, Tree_Node_Access);
type Tree is new Controlled with record
Root : aliased Root_Node_Type;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Tamper_Counts;
Count : Count_Type := 0;
end record;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Tree_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
for Reference_Type'Write use Write;
+ -- Three operations are used to optimize in the expansion of "for ... of"
+ -- loops: the Next(Cursor) procedure in the visible part, and the following
+ -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
+ -- details.
+
+ function Pseudo_Reference
+ (Container : aliased Tree'Class) return Reference_Control_Type;
+ pragma Inline (Pseudo_Reference);
+ -- Creates an object of type Reference_Control_Type pointing to the
+ -- container, and increments the Lock. Finalization of this object will
+ -- decrement the Lock.
+
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
+
+ function Get_Element_Access
+ (Position : Cursor) return not null Element_Access;
+ -- Returns a pointer to the element designated by Position.
+
Empty_Tree : constant Tree := (Controlled with others => <>);
No_Element : constant Cursor := (others => <>);
package body Generic_Implementation is
- use SAC;
+ use type SAC.Atomic_Unsigned;
------------
-- Adjust --
procedure Busy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- Increment (T_Counts.Busy);
+ SAC.Increment (T_Counts.Busy);
end if;
end Busy;
procedure Lock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- Increment (T_Counts.Lock);
- Increment (T_Counts.Busy);
+ SAC.Increment (T_Counts.Lock);
+ SAC.Increment (T_Counts.Busy);
end if;
end Lock;
raise Program_Error with
"attempt to tamper with cursors";
end if;
+
+ -- The lock status (which monitors "element tampering") always
+ -- implies that the busy status (which monitors "cursor tampering")
+ -- is set too; this is a representation invariant. Thus if the busy
+ -- bit is not set, then the lock bit must not be set either.
+
+ pragma Assert (T_Counts.Lock = 0);
end TC_Check;
--------------
procedure Unbusy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- Decrement (T_Counts.Busy);
+ SAC.Decrement (T_Counts.Busy);
end if;
end Unbusy;
procedure Unlock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- Decrement (T_Counts.Lock);
- Decrement (T_Counts.Busy);
+ SAC.Decrement (T_Counts.Lock);
+ SAC.Decrement (T_Counts.Busy);
end if;
end Unlock;
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
- -- See comment in Ada.Containers
+ -- See comment in Ada.Containers.Helpers
procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
end if;
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
function Constant_Reference
raise Constraint_Error with "Index is out of range";
end if;
- 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 (Index)'Access,
- Control => (Controlled with TC))
- do
- Lock (TC.all);
- end return;
- end;
- else
+ declare
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Constant_Reference;
--------------
end if;
end if;
- 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
+ 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 null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
function Reference
raise Constraint_Error with "Index is out of range";
end if;
- if T_Check then
- declare
- TC : constant Tamper_Counts_Access :=
- Container.TC'Unrestricted_Access;
- begin
- return R : constant Reference_Type :=
- (Element => Container.Elements.EA (Index)'Access,
- Control => (Controlled with TC))
- do
- Lock (TC.all);
- end return;
- end;
- else
+ declare
+ TC : constant Tamper_Counts_Access :=
+ Container.TC'Unrestricted_Access;
+ begin
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
- Control => (Controlled with null));
- end if;
+ Control => (Controlled with TC))
+ do
+ Lock (TC.all);
+ end return;
+ end;
end Reference;
---------------------
with Ada.Unchecked_Deallocation;
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
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.Helpers
+
-----------------------------
-- Node Access Subprograms --
-----------------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
end if;
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor of "">"" equals No_Element";
end if;
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor of "">"" equals No_Element";
end if;
Adjust (Container.Tree);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- T : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
T : Tree_Type renames Position.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ T.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ T.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
Tree : Tree_Type renames Container.Tree;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "key not in map";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Tree.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- T : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.Tree.TC);
end if;
end Finalize;
function First_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.First = null then
+ if Checks and then T.First = null then
raise Constraint_Error with "map is empty";
- else
- return T.First.Element;
end if;
+
+ return T.First.Element;
end First_Element;
---------------
function First_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.First = null then
+ if Checks and then T.First = null then
raise Constraint_Error with "map is empty";
- else
- return T.First.Key;
end if;
+
+ return T.First.Key;
end First_Key;
-----------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
Position.Node.Key := Key;
Position.Node.Element := New_Item;
begin
Insert (Container, Key, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with "key already in map";
end if;
end Insert;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (Container.Tree);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (Container.Tree);
end Iterate;
function Iterate
(Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
Container => Container'Unrestricted_Access,
Node => null)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Iterate (Container : Map; Start : Cursor)
return Map_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container.Tree'Unrestricted_Access.all.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong map";
end if;
Container => Container'Unrestricted_Access,
Node => Start.Node)
do
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
end return;
end Iterate;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
function Last_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.Last = null then
+ if Checks and then T.Last = null then
raise Constraint_Error with "map is empty";
- else
- return T.Last.Element;
end if;
+
+ return T.Last.Element;
end Last_Element;
--------------
function Last_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
- if T.Last = null then
+ if Checks and then T.Last = null then
raise Constraint_Error with "map is empty";
- else
- return T.Last.Key;
end if;
+
+ return T.Last.Key;
end Last_Key;
----------
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong map";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong map";
end if;
function Pseudo_Reference
(Container : aliased Map'Class) return Reference_Control_Type
is
- C : constant Map_Access := Container'Unrestricted_Access;
- B : Natural renames C.Tree.Busy;
- L : Natural renames C.Tree.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.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;
Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key;
- E : Element_Type renames Position.Node.Element;
-
- begin
- Process (K, E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Query_Element;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong map";
end if;
declare
T : Tree_Type renames Position.Container.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ T.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Position.Container))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ TC : constant Tamper_Counts_Access :=
+ T.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Reference;
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
Node.Key := Key;
Node.Element := New_Item;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (map is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+ Busy : With_Busy (Container.Tree.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (Container.Tree);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (Container.Tree);
end Reverse_Iterate;
-----------
Element : in out Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
declare
T : Tree_Type renames Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
begin
- B := B + 1;
- L := L + 1;
-
- declare
- K : Key_Type renames Position.Node.Key;
- E : Element_Type renames Position.Node.Element;
-
- begin
- Process (K, E);
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (K, E);
end;
end Update_Element;
overriding procedure Finalize (Container : in out Map) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Map_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
- type Element_Access is access all Element_Type;
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
- Empty_Map : constant Map :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : Map_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
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.Helpers
+
-----------------------------
-- Node Access Subprograms --
-----------------------------
--------------
procedure Finalize (Object : in out Iterator) is
- B : Natural renames Object.Container.Tree.Busy;
- pragma Assert (B > 0);
begin
- B := B - 1;
+ Unbusy (Object.Container.Tree.TC);
end Finalize;
----------
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T, Key);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T, Key);
end Iterate;
---------
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T, Key);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T, Key);
end Reverse_Iterate;
--------------------
declare
E : Element_Type renames Node.Element;
K : constant Key_Type := Key (E);
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (E);
if Equivalent_Keys (Left => K, Right => Key (E)) then
return;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T);
end Iterate;
procedure Iterate
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T, Item);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T, Item);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
S : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames S.Tree.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator := (Limited_Controlled with S, null) do
- B := B + 1;
+ Busy (S.Tree.TC);
end return;
end Iterate;
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
S : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames S.Tree.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,
return It : constant Iterator :=
(Limited_Controlled with S, Start.Node)
do
- B := B + 1;
+ Busy (S.Tree.TC);
end return;
end Iterate;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element);
end;
end Query_Element;
then
null;
else
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
Node.Element := Item;
return;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T);
end Reverse_Iterate;
procedure Reverse_Iterate
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T, Item);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T, Item);
end Reverse_Iterate;
-----------
overriding procedure Finalize (Container : in out Set) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Constant_Reference_Type'Write use Write;
- Empty_Set : constant Set :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ Empty_Set : constant Set := (Controlled with others => <>);
type Iterator is new Limited_Controlled and
Set_Iterator_Interfaces.Reversible_Iterator with
record
Container : Set_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
with Ada.Unchecked_Deallocation;
+with Ada.Containers.Helpers; use Ada.Containers.Helpers;
+
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
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.Helpers
+
------------------------------
-- Access to Fields of Node --
------------------------------
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
- if Right.Node = null then
+ if Checks and then Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
- if Left.Node = null then
+ if Checks and then Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
Adjust (Container.Tree);
end Adjust;
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
------------
-- Assign --
------------
Position : Cursor) return Constant_Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
Tree : Tree_Type renames Position.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with "Position cursor designates wrong set";
end if;
X : Node_Access := Element_Keys.Find (Container.Tree, Item);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete element not in set";
end if;
function Element (Position : Cursor) return Element_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
procedure Finalize (Object : in out Iterator) is
begin
if Object.Container /= null then
- declare
- B : Natural renames Object.Container.all.Tree.Busy;
- begin
- B := B - 1;
- end;
- end if;
- end Finalize;
-
- procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- Control.Container := null;
+ Unbusy (Object.Container.Tree.TC);
end if;
end Finalize;
function First_Element (Container : Set) return Element_Type is
begin
- if Container.Tree.First = null then
+ if Checks and then Container.Tree.First = null then
raise Constraint_Error with "set is empty";
end if;
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B + 1;
- L := L + 1;
- end;
- end if;
- end Adjust;
-
-------------
-- Ceiling --
-------------
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
end if;
declare
Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
+ TC : constant Tamper_Counts_Access :=
+ Tree.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
- Control => (Controlled with Container'Unrestricted_Access))
+ Control => (Controlled with TC))
do
- B := B + 1;
- L := L + 1;
+ Lock (TC.all);
end return;
end;
end Constant_Reference;
X : Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if X = null then
+ if Checks and then X = null then
raise Constraint_Error with "attempt to delete key not in set";
end if;
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with "key not in set";
end if;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
- declare
- Tree : Tree_Type renames Control.Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
- begin
- B := B - 1;
- L := L - 1;
- end;
-
- if not (Key (Control.Pos) = Control.Old_Key.all) then
+ Impl.Reference_Control_Type (Control).Finalize;
+
+ if Checks and then not (Key (Control.Pos) = Control.Old_Key.all)
+ then
Delete (Control.Container.all, Key (Control.Pos));
raise Program_Error;
end if;
function Key (Position : Cursor) return Key_Type is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
Position : Cursor) return Reference_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";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong container";
end if;
declare
Tree : Tree_Type renames Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with
+ Tree.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- B := B + 1;
- L := L + 1;
+ Lock (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
- raise Constraint_Error with "key not in set";
+ if Checks and then Node = null then
+ raise Constraint_Error with "Key not in set";
end if;
declare
Tree : Tree_Type renames Container.Tree;
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with
+ Tree.TC'Unrestricted_Access,
Container => Container'Access,
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- B := B + 1;
- L := L + 1;
+ Lock (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Tree : Tree_Type renames Container.Tree;
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
declare
E : Element_Type renames Position.Node.Element;
K : constant Key_Type := Key (E);
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
- Eq : Boolean;
-
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (E);
- Eq := Equivalent_Keys (K, Key (E));
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
-
- if Eq then
+ Process (E);
+ if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
Position.Node.Element := New_Item;
end if;
begin
Insert (Container, New_Item, Position, Inserted);
- if not Inserted then
+ if Checks and then not Inserted then
raise Constraint_Error with
"attempt to insert element already in set";
end if;
end Process_Node;
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Iterate
begin
- B := B + 1;
-
- begin
- Local_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Iterate (T);
end Iterate;
function Iterate (Container : Set)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
-
begin
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node
-- Note: For a forward iterator, Container.First is the beginning, and
-- for a reverse iterator, Container.Last is the beginning.
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
return It : constant Iterator :=
Iterator'(Limited_Controlled with
function Iterate (Container : Set; Start : Cursor)
return Set_Iterator_Interfaces.Reversible_Iterator'Class
is
- B : Natural renames Container'Unrestricted_Access.all.Tree.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 = No_Element then
+ if Checks and then Start = No_Element then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
- if Start.Container /= Container'Unrestricted_Access then
+ if Checks and then Start.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Start cursor of Iterate designates wrong set";
end if;
-- the start position has the same value irrespective of whether this is
-- a forward or reverse iteration.
- B := B + 1;
+ Busy (Container.Tree.TC'Unrestricted_Access.all);
return It : constant Iterator :=
Iterator'(Limited_Controlled with
function Last_Element (Container : Set) return Element_Type is
begin
- if Container.Tree.Last = null then
+ if Checks and then Container.Tree.Last = null then
raise Constraint_Error with "set is empty";
- else
- return Container.Tree.Last.Element;
end if;
+
+ return Container.Tree.Last.Element;
end Last_Element;
----------
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong set";
end if;
return No_Element;
end if;
- if Position.Container /= Object.Container then
+ if Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong set";
end if;
function Pseudo_Reference
(Container : aliased Set'Class) return Reference_Control_Type
is
- C : constant Set_Access := Container'Unrestricted_Access;
- B : Natural renames C.Tree.Busy;
- L : Natural renames C.Tree.Lock;
- begin
- return R : constant Reference_Control_Type :=
- (Controlled with C)
- do
- B := B + 1;
- L := L + 1;
+ TC : constant Tamper_Counts_Access :=
+ Container.Tree.TC'Unrestricted_Access;
+ begin
+ return R : constant Reference_Control_Type := (Controlled with TC) do
+ Lock (TC.all);
end return;
end Pseudo_Reference;
Process : not null access procedure (Element : Element_Type))
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
declare
T : Tree_Type renames Position.Container.Tree;
-
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
-
+ Lock : With_Lock (T.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
- begin
- Process (Position.Node.Element);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
-
- L := L - 1;
- B := B - 1;
+ Process (Position.Node.Element);
end;
end Query_Element;
Element_Keys.Find (Container.Tree, New_Item);
begin
- if Node = null then
+ if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Container.Tree.TC);
Node.Element := New_Item;
end Replace;
Inserted : Boolean;
Compare : Boolean;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
-- Start of processing for Replace_Element
begin
-- Determine whether Item is equivalent to element on the specified
-- node.
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := (if Item < Node.Element then False
elsif Node.Element < Item then False
else True);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
Node.Element := Item;
return;
Hint := Element_Keys.Ceiling (Tree, Item);
if Hint /= null then
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Item < Hint.Element;
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
-- Item >= Hint.Element
- if not Compare then
+ if Checks and then not Compare then
-- Ceiling returns an element that is equivalent or greater
-- than Item. If Item is "not less than" the element, then
-- because it would only be placed in the exact same position.
if Hint = Node then
- if Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is locked)";
- end if;
+ TE_Check (Tree.TC);
Node.Element := Item;
return;
New_Item : Element_Type)
is
begin
- if Position.Node = null then
+ if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- if Position.Container /= Container'Unrestricted_Access then
+ if Checks and then Position.Container /= Container'Unrestricted_Access
+ then
raise Program_Error with
"Position cursor designates wrong set";
end if;
end Process_Node;
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
- B : Natural renames T.Busy;
+ Busy : With_Busy (T.TC'Unrestricted_Access);
-- Start of processing for Reverse_Iterate
begin
- B := B + 1;
-
- begin
- Local_Reverse_Iterate (T);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
+ Local_Reverse_Iterate (T);
end Reverse_Iterate;
-----------
with Ada.Iterator_Interfaces;
+private with Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
type Key_Access is access all Key_Type;
+ package Impl is new Helpers.Generic_Implementation;
+
type Reference_Control_Type is
- new Ada.Finalization.Controlled with
+ new Impl.Reference_Control_Type with
record
Container : Set_Access;
Pos : Cursor;
Old_Key : Key_Access;
end record;
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
overriding procedure Finalize (Container : in out Set) renames Clear;
use Red_Black_Trees;
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
use Ada.Streams;
for Cursor'Read use Read;
- type Reference_Control_Type is
- new Controlled with record
- Container : Set_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
+ subtype Reference_Control_Type is Implementation.Reference_Control_Type;
+ -- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
-- container, and increments the Lock. Finalization of this object will
-- decrement the Lock.
- type Element_Access is access all Element_Type;
+ type Element_Access is access all Element_Type with
+ Storage_Size => 0;
function Get_Element_Access
(Position : Cursor) return not null Element_Access;
-- Returns a pointer to the element designated by Position.
- Empty_Set : constant Set :=
- (Controlled with Tree => (First => null,
- Last => null,
- Root => null,
- Length => 0,
- Busy => 0,
- Lock => 0));
+ Empty_Set : constant Set := (Controlled with others => <>);
No_Element : constant Cursor := Cursor'(null, null);
record
Container : Set_Access;
Node : Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2011, 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- --
-- This package declares the tree type used to implement ordered containers
+with Ada.Containers.Helpers;
+
package Ada.Containers.Red_Black_Trees is
pragma Pure;
type Node_Type (<>) is limited private;
type Node_Access is access Node_Type;
package Generic_Tree_Types is
+
type Tree_Type is tagged record
- First : Node_Access;
- Last : Node_Access;
- Root : Node_Access;
+ First : Node_Access := null;
+ Last : Node_Access := null;
+ Root : Node_Access := null;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Helpers.Tamper_Counts;
end record;
+
+ package Implementation is new Helpers.Generic_Implementation;
end Generic_Tree_Types;
generic
Last : Count_Type := 0;
Root : Count_Type := 0;
Length : Count_Type := 0;
- Busy : Natural := 0;
- Lock : Natural := 0;
+ TC : aliased Helpers.Tamper_Counts;
Free : Count_Type'Base := -1;
Nodes : Nodes_Type (1 .. Capacity) := (others => <>);
end record;
+
+ package Implementation is new Helpers.Generic_Implementation;
end Generic_Bounded_Tree_Types;
end Ada.Containers.Red_Black_Trees;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Red_Black_Trees.Generic_Keys is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
package Ops renames Tree_Operations;
-------------
-- AKA Lower_Bound
function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
- B : Natural renames Tree'Unrestricted_Access.Busy;
- L : Natural renames Tree'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
Y : Node_Access;
X : Node_Access;
return null;
end if;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B := B + 1;
- L := L + 1;
-
X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
end if;
end loop;
- B := B - 1;
- L := L - 1;
-
return Y;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end Ceiling;
----------
----------
function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
- B : Natural renames Tree'Unrestricted_Access.Busy;
- L : Natural renames Tree'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
Y : Node_Access;
X : Node_Access;
- Result : Node_Access;
-
begin
-- If the container is empty, return a result immediately, so that we do
-- not manipulate the tamper bits unnecessarily.
return null;
end if;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B := B + 1;
- L := L + 1;
-
X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
end if;
end loop;
- if Y = null then
- Result := null;
-
- elsif Is_Less_Key_Node (Key, Y) then
- Result := null;
-
+ if Y = null or else Is_Less_Key_Node (Key, Y) then
+ return null;
else
- Result := Y;
+ return Y;
end if;
-
- B := B - 1;
- L := L - 1;
-
- return Result;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end Find;
-----------
-----------
function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
- B : Natural renames Tree'Unrestricted_Access.Busy;
- L : Natural renames Tree'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
Y : Node_Access;
X : Node_Access;
return null;
end if;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B := B + 1;
- L := L + 1;
-
X := Tree.Root;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
end if;
end loop;
- B := B - 1;
- L := L - 1;
-
return Y;
-
- exception
- when others =>
- B := B - 1;
- L := L - 1;
-
- raise;
end Floor;
--------------------------------
X : Node_Access;
Y : Node_Access;
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
Compare : Boolean;
begin
-- either the smallest node greater than Key (Inserted is True), or the
-- largest node less or equivalent to Key (Inserted is False).
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
X := Tree.Root;
Y := null;
Inserted := True;
Inserted := Is_Less_Key_Node (Key, X);
X := (if Inserted then Ops.Left (X) else Ops.Right (X));
end loop;
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Inserted then
-- Key is equivalent to or greater than Node. We must resolve which is
-- the case, to determine whether the conditional insertion succeeds.
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Greater_Key_Node (Key, Node);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
Node : out Node_Access;
Inserted : out Boolean)
is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
-
Test : Node_Access;
Compare : Boolean;
-- we must search.
if Position = null then -- largest
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Greater_Key_Node (Key, Tree.Last);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
-- then its neighbor must be anterior and so we insert before the
-- hint.
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Less_Key_Node (Key, Position);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
return;
end if;
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Greater_Key_Node (Key, Test);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
-- less than the hint's next neighbor, then we're done; otherwise we
-- must search.
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Greater_Key_Node (Key, Position);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
return;
end if;
+ declare
+ Lock : With_Lock (Tree.TC'Unrestricted_Access);
begin
- B := B + 1;
- L := L + 1;
-
Compare := Is_Less_Key_Node (Key, Test);
-
- L := L - 1;
- B := B - 1;
-
- exception
- when others =>
- L := L - 1;
- B := B - 1;
-
- raise;
end;
if Compare then
Z : out Node_Access)
is
begin
- if Tree.Length = Count_Type'Last then
+ if Checks and then Tree.Length = Count_Type'Last then
raise Constraint_Error with "too many elements";
end if;
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Tree.TC);
Z := New_Node;
pragma Assert (Z /= null);
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2009, 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- --
generic
with package Tree_Operations is new Generic_Operations (<>);
- use Tree_Operations.Tree_Types;
+ use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation;
type Key_Type (<>) is limited private;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Red_Black_Trees.Generic_Operations is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
pragma Assert (Z /= null);
begin
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Tree.TC);
-- Why are these all commented out ???
procedure Generic_Adjust (Tree : in out Tree_Type) is
N : constant Count_Type := Tree.Length;
Root : constant Node_Access := Tree.Root;
-
+ use type Helpers.Tamper_Counts;
begin
if N = 0 then
pragma Assert (Root = null);
- pragma Assert (Tree.Busy = 0);
- pragma Assert (Tree.Lock = 0);
+ pragma Assert (Tree.TC = (Busy => 0, Lock => 0));
return;
end if;
procedure Generic_Clear (Tree : in out Tree_Type) is
Root : Node_Access := Tree.Root;
begin
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Tree.TC);
Tree := (First => null,
Last => null,
Root => null,
Length => 0,
- Busy => 0,
- Lock => 0);
+ TC => <>);
Delete_Tree (Root);
end Generic_Clear;
-------------------
function Generic_Equal (Left, Right : Tree_Type) 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Node_Access;
R_Node : Node_Access;
-
- Result : Boolean;
-
begin
if Left'Address = Right'Address then
return True;
return True;
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;
-
L_Node := Left.First;
R_Node := Right.First;
- Result := True;
while L_Node /= null loop
if not Is_Equal (L_Node, R_Node) then
- Result := False;
- exit;
+ return False;
end if;
L_Node := Next (L_Node);
R_Node := Next (R_Node);
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 Generic_Equal;
-----------------------
return;
end if;
- if Source.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Source.TC);
Clear (Target);
Last => null,
Root => null,
Length => 0,
- Busy => 0,
- Lock => 0);
+ TC => <>);
end Generic_Move;
------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2009, 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- --
generic
with package Tree_Types is new Generic_Tree_Types (<>);
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
with function Parent (Node : Node_Access) return Node_Access is <>;
with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>;
-- --
-- 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- --
N : Nodes_Type renames Tree.Nodes;
begin
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Tree.TC);
- if Tree.Length >= Tree.Capacity then
+ if Checks and then Tree.Length >= Tree.Capacity then
raise Capacity_Error with "not enough capacity to insert new item";
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, 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- --
generic
with package Tree_Operations is new Generic_Bounded_Operations (<>);
- use Tree_Operations.Tree_Types;
+ use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation;
type Key_Type (<>) is limited private;
-- --
-- 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.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Clear_Tree (Tree : in out Tree_Type'Class) is
begin
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- -- The lock status (which monitors "element tampering") always implies
- -- that the busy status (which monitors "cursor tampering") is set too;
- -- this is a representation invariant. Thus if the busy bit is not set,
- -- then the lock bit must not be set either.
-
- pragma Assert (Tree.Lock = 0);
+ TC_Check (Tree.TC);
Tree.First := 0;
Tree.Last := 0;
N : Nodes_Type renames Tree.Nodes;
begin
- if Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Tree.TC);
-- If node is not present, return (exception will be raised in caller)
-------------------
function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
- BL : Natural renames Left'Unrestricted_Access.Busy;
- LL : Natural renames Left'Unrestricted_Access.Lock;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- BR : Natural renames Right'Unrestricted_Access.Busy;
- LR : Natural renames Right'Unrestricted_Access.Lock;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Count_Type;
R_Node : Count_Type;
- Result : Boolean;
-
begin
if Left'Address = Right'Address then
return True;
return True;
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;
-
L_Node := Left.First;
R_Node := Right.First;
- Result := True;
while L_Node /= 0 loop
if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
- Result := False;
- exit;
+ return False;
end if;
L_Node := Next (Left, L_Node);
R_Node := Next (Right, R_Node);
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 Generic_Equal;
-----------------------
Clear_Tree (Tree);
Count_Type'Base'Read (Stream, Len);
- if Len < 0 then
+ if Checks and then Len < 0 then
raise Program_Error with "bad container length (corrupt stream)";
end if;
return;
end if;
- if Len > Tree.Capacity then
+ if Checks and then Len > Tree.Capacity then
raise Constraint_Error with "length exceeds capacity";
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, 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- --
generic
with package Tree_Types is new Generic_Bounded_Tree_Types (<>);
- use Tree_Types;
+ use Tree_Types, Tree_Types.Implementation;
with function Parent (Node : Node_Type) return Count_Type is <>;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, 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- --
package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
+ pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+ pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+ -- See comment in Ada.Containers.Helpers
+
-----------------------
-- Local Subprograms --
-----------------------
-----------
procedure Clear (Tree : in out Tree_Type) is
- pragma Assert (Tree.Busy = 0);
- pragma Assert (Tree.Lock = 0);
+ use type Helpers.Tamper_Counts;
+ pragma Assert (Tree.TC = (Busy => 0, Lock => 0));
Root : Node_Access := Tree.Root;
pragma Warnings (Off, Root);
----------------
procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt : Node_Access;
Src : Node_Access;
begin
if Target'Address = Source'Address then
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
Clear (Target);
return;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
Tgt := Target.First;
Src := Source.First;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
Tree : Tree_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
end if;
end loop;
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
return Tree;
exception
when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
Delete_Tree (Tree.Root);
raise;
end;
(Target : in out Tree_Type;
Source : Tree_Type)
is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt : Node_Access;
Src : Node_Access;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ TC_Check (Target.TC);
if Source.Length = 0 then
Clear (Target);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
Tree : Tree_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
end if;
end loop;
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
return Tree;
exception
when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
Delete_Tree (Tree.Root);
raise;
end;
-- element tampering by a generic actual subprogram.
declare
- BL : Natural renames Subset'Unrestricted_Access.Busy;
- LL : Natural renames Subset'Unrestricted_Access.Lock;
-
- BR : Natural renames Of_Set'Unrestricted_Access.Busy;
- LR : Natural renames Of_Set'Unrestricted_Access.Lock;
+ Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access);
+ Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access);
Subset_Node : Node_Access;
Set_Node : Node_Access;
- Result : Boolean;
-
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
Subset_Node := Subset.First;
Set_Node := Of_Set.First;
loop
if Set_Node = null then
- Result := Subset_Node = null;
- exit;
+ return Subset_Node = null;
end if;
if Subset_Node = null then
- Result := True;
- exit;
+ return True;
end if;
if Is_Less (Subset_Node, Set_Node) then
- Result := False;
- exit;
+ return False;
end if;
if Is_Less (Set_Node, Subset_Node) then
Subset_Node := Tree_Operations.Next (Subset_Node);
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;
end;
end Is_Subset;
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
L_Node : Node_Access;
R_Node : Node_Access;
-
- Result : Boolean;
-
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = null
or else R_Node = null
then
- Result := False;
- exit;
+ return False;
end if;
if Is_Less (L_Node, R_Node) then
R_Node := Tree_Operations.Next (R_Node);
else
- Result := True;
- exit;
+ return True;
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;
end;
end Overlap;
(Target : in out Tree_Type;
Source : Tree_Type)
is
- BT : Natural renames Target.Busy;
- LT : Natural renames Target.Lock;
-
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
Tgt : Node_Access;
Src : Node_Access;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
+ declare
+ Lock_Target : With_Lock (Target.TC'Unrestricted_Access);
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BT := BT + 1;
- LT := LT + 1;
-
- BS := BS + 1;
- LS := LS + 1;
-
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
else
Compare := 0;
end if;
-
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- exception
- when others =>
- BT := BT - 1;
- LT := LT - 1;
-
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
if Compare < 0 then
-- element tampering by a generic actual subprogram.
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
Tree : Tree_Type;
pragma Warnings (Off, Dst_Node);
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
L_Node := Left.First;
R_Node := Right.First;
loop
end if;
end loop;
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
return Tree;
exception
when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
Delete_Tree (Tree.Root);
raise;
end;
-- element tampering by a generic actual subprogram.
declare
- BS : Natural renames Source'Unrestricted_Access.Busy;
- LS : Natural renames Source'Unrestricted_Access.Lock;
-
+ Lock_Source : With_Lock (Source.TC'Unrestricted_Access);
begin
- BS := BS + 1;
- LS := LS + 1;
-
Iterate (Source);
-
- BS := BS - 1;
- LS := LS - 1;
-
- exception
- when others =>
- BS := BS - 1;
- LS := LS - 1;
-
- raise;
end;
end Union;
end if;
declare
- 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;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
Tree : Tree_Type := Copy (Left);
-- Start of processing for Union
begin
- BL := BL + 1;
- LL := LL + 1;
-
- BR := BR + 1;
- LR := LR + 1;
-
Iterate (Right);
-
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
return Tree;
exception
when others =>
- BL := BL - 1;
- LL := LL - 1;
-
- BR := BR - 1;
- LR := LR - 1;
-
Delete_Tree (Tree.Root);
raise;
end;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2009, 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- --
generic
with package Tree_Operations is new Generic_Operations (<>);
- use Tree_Operations.Tree_Types;
+ use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation;
with procedure Insert_With_Hint
(Dst_Tree : in out Tree_Type;
-- and this flag is not set. Profile is set to a non-default value if the
-- No_Dependence restriction comes from a Profile pragma. This procedure
-- also takes care of setting the Boolean2 flag of the simple name for
- -- the entity (to optimize table searches).
+ -- the entity (to optimize table searches).
procedure Set_Restriction_No_Use_Of_Pragma
(N : Node_Id;
goto Continue;
end if;
- Analyze_And_Resolve (Expr, Standard_Boolean);
-
-- If we're in a generic template, we don't want to try
-- to disable controlled types, because typical usage is
-- "Disable_Controlled => not <some_check>'Enabled", and
-- particular instance.
if Expander_Active then
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+
if not Present (Expr)
or else Is_True (Static_Boolean (Expr))
then
projects / gcc.git / commitdiff