OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Ada2020: AI12-0110 Tampering checks are performed first

Browse Source 
2020-06-17  Bob Duff  <duff@adacore.com>

gcc/ada/

	* libgnat/a-cbdlli.adb, libgnat/a-cbhama.adb,
	libgnat/a-cbhase.adb, libgnat/a-cbmutr.adb,
	libgnat/a-cborma.adb, libgnat/a-cborse.adb,
	libgnat/a-cdlili.adb, libgnat/a-chtgbk.adb,
	libgnat/a-chtgke.adb, libgnat/a-cidlli.adb,
	libgnat/a-cihama.adb, libgnat/a-cihase.adb,
	libgnat/a-cimutr.adb, libgnat/a-ciorma.adb,
	libgnat/a-ciorse.adb, libgnat/a-cobove.adb,
	libgnat/a-cohama.adb, libgnat/a-cohase.adb,
	libgnat/a-coinve.adb, libgnat/a-comutr.adb,
	libgnat/a-convec.adb, libgnat/a-coorma.adb,
	libgnat/a-coorse.adb, libgnat/a-crbtgk.adb,
	libgnat/a-crbtgo.adb, libgnat/a-rbtgso.adb: Move tampering
	checks earlier.
This commit is contained in:
Bob Duff 2020-04-10 18:23:15 -04:00 committed by Pierre-Marie de Rodat
parent 4ea4df3af8
commit c602003b6a
26 changed files with 313 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
gcc/ada/libgnat/a-cbdlli.adb
View File

@ -358,6 +358,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor has no element";
@ -386,8 +388,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
TC_Check (Container.TC);
for Index in 1 .. Count loop
pragma Assert (Container.Length >= 2);
@ -427,6 +427,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
TC_Check (Container.TC);
if Count >= Container.Length then
Clear (Container);
return;
@ -436,8 +438,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First);
@ -463,6 +463,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
TC_Check (Container.TC);
if Count >= Container.Length then
Clear (Container);
return;
@ -472,8 +474,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
TC_Check (Container.TC);
for J in 1 .. Count loop
X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last);
@ -759,6 +759,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Source : in out List)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@ -786,9 +789,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "new length exceeds target capacity";
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.
@ -964,6 +964,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
New_Node : Count_Type;
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@ -983,8 +985,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "capacity exceeded";
end if;
TC_Check (Container.TC);
Allocate (Container, New_Item, New_Node);
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@ -1261,6 +1261,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
X : Count_Type;
begin
TC_Check (Source.TC);
if Target'Address = Source'Address then
return;
end if;
@ -1269,8 +1271,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "Source length exceeds Target capacity";
end if;
TC_Check (Source.TC);
-- Clear target, note that this checks busy bits of Target
Clear (Target);
@ -1579,6 +1579,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1588,8 +1590,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
TE_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Container.Nodes (Position.Node).Element := New_Item;
@ -1751,6 +1751,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Source : in out List)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1772,9 +1775,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "new length exceeds target capacity";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source);
end Splice;
@ -1786,6 +1786,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
N : Node_Array renames Container.Nodes;
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@ -1815,8 +1817,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
TC_Check (Container.TC);
if Before.Node = 0 then
pragma Assert (Position.Node /= Container.Last);
@ -1894,6 +1894,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1918,9 +1921,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Capacity_Error with "Target is full";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal
(Target => Target,
Before => Before.Node,
@ -2063,6 +2063,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@ -2083,8 +2085,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
end if;
TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@ -2109,6 +2109,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@ -2129,8 +2131,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return;
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");

12
gcc/ada/libgnat/a-cbhama.adb
View File

@ -311,6 +311,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
TC_Check (Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@ -322,8 +324,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
TC_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
@ -1029,13 +1029,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
TE_Check (Container.TC);
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Node);
begin
@ -1054,6 +1054,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Position.Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1065,8 +1067,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Position.Container.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Container.Nodes (Position.Node).Element := New_Item;

8
gcc/ada/libgnat/a-cbhase.adb
View File

@ -309,6 +309,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Position : in out Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@ -318,8 +320,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
TC_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
@ -1179,13 +1179,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
TE_Check (Container.TC);
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
TE_Check (Container.TC);
Container.Nodes (Node).Element := New_Item;
end Replace;

60
gcc/ada/libgnat/a-cbmutr.adb
View File

@ -366,6 +366,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
First, Last : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -383,8 +385,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@ -985,6 +985,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -993,8 +995,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
end if;
TC_Check (Container.TC);
if Container.Count = 0 then
pragma Assert (Is_Root (Parent));
return;
@ -1024,6 +1024,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
X : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1041,8 +1043,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -1064,6 +1064,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1077,8 +1079,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -1506,6 +1506,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Last : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1537,8 +1539,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@ -1584,6 +1584,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
-- OK to reference, see below
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1615,8 +1617,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@ -2181,6 +2181,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
First, Last : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2198,8 +2200,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
with "requested count exceeds available storage";
end if;
TC_Check (Container.TC);
if Container.Count = 0 then
Initialize_Root (Container);
end if;
@ -2545,6 +2545,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -2558,8 +2560,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TE_Check (Container.TC);
Container.Elements (Position.Node) := New_Item;
end Replace_Element;
@ -2627,6 +2627,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Source_Parent : Cursor)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2671,8 +2674,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
TC_Check (Target.TC);
if Checks and then Is_Reachable (Container => Target,
From => Target_Parent.Node,
To => Source_Parent.Node)
@ -2690,9 +2691,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Target.Count = 0 then
Initialize_Root (Target);
end if;
@ -2712,6 +2710,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Source_Parent : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2755,8 +2755,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
pragma Assert (Container.Count > 0);
TC_Check (Container.TC);
if Checks and then Is_Reachable (Container => Container,
From => Target_Parent.Node,
To => Source_Parent.Node)
@ -2911,6 +2909,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Position : in out Cursor)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2957,8 +2958,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end if;
end if;
TC_Check (Target.TC);
if Checks and then Is_Reachable (Container => Target,
From => Parent.Node,
To => Position.Node)
@ -2974,9 +2973,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Target.Count = 0 then
Initialize_Root (Target);
end if;
@ -2998,6 +2994,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Position : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -3048,8 +3046,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end if;
end if;
TC_Check (Container.TC);
if Checks and then Is_Reachable (Container => Container,
From => Parent.Node,
To => Position.Node)
@ -3176,6 +3172,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@ -3204,8 +3202,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
TE_Check (Container.TC);
declare
EE : Element_Array renames Container.Elements;
EI : constant Element_Type := EE (I.Node);

8
gcc/ada/libgnat/a-cborma.adb
View File

@ -1418,12 +1418,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
TE_Check (Container.TC);
if Checks and then Node = 0 then
raise Constraint_Error with "key not in map";
end if;
TE_Check (Container.TC);
declare
N : Node_Type renames Container.Nodes (Node);
@ -1443,6 +1443,8 @@ package body Ada.Containers.Bounded_Ordered_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1454,8 +1456,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Container.TC);
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Replace_Element is bad");

8
gcc/ada/libgnat/a-cborse.adb
View File

@ -461,6 +461,8 @@ package body Ada.Containers.Bounded_Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
TC_Check (Container.TC);
if Checks and then Position.Node = 0 then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@ -470,8 +472,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
TC_Check (Container.TC);
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Delete");
@ -1682,13 +1682,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
TE_Check (Container.TC);
if Checks and then Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
TE_Check (Container.TC);
Container.Nodes (Node).Element := New_Item;
end Replace;

46
gcc/ada/libgnat/a-cdlili.adb
View File

@ -295,6 +295,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
X : Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
@ -319,8 +321,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
TC_Check (Container.TC);
for Index in 1 .. Count loop
X := Position.Node;
Container.Length := Container.Length - 1;
@ -604,6 +604,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@ -626,9 +629,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
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.
@ -796,6 +796,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@ -815,8 +817,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Container.TC);
New_Node := new Node_Type'(New_Item, null, null);
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@ -851,6 +851,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@ -870,8 +872,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Container.TC);
New_Node := new Node_Type;
First_Node := New_Node;
Insert_Internal (Container, Before.Node, New_Node);
@ -1372,6 +1372,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1381,8 +1383,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
TE_Check (Container.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item;
@ -1543,6 +1543,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1560,9 +1563,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source);
end Splice;
@ -1572,6 +1572,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
Position : Cursor)
is
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@ -1601,8 +1603,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
TC_Check (Container.TC);
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
@ -1678,6 +1678,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1702,9 +1705,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Constraint_Error with "Target is full";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
end Splice;
@ -1862,6 +1862,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@ -1882,8 +1884,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@ -1908,6 +1908,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@ -1928,8 +1930,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
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");

9
gcc/ada/libgnat/a-chtgbk.adb
View File

@ -228,6 +228,8 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
N, M : Count_Type;
begin
TC_Check (HT.TC);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@ -250,8 +252,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
-- hash table as this one, a key is mapped to exactly one node.)
if Checked_Equivalent_Keys (HT, Key, Node) then
TE_Check (HT.TC);
-- The new Key value is mapped to this same Node, so Node
-- stays in the same bucket.
@ -292,10 +292,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
return;
end if;
-- The node is a bucket different from the bucket implied by Key
TC_Check (HT.TC);
-- The node is in a bucket different from the bucket implied by Key.
-- Do the assignment first, before moving the node, so that if Assign
-- propagates an exception, then the hash table will not have been
-- modified (except for any possible side-effect Assign had on Node).

2
gcc/ada/libgnat/a-chtgke.adb
View File

@ -91,7 +91,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
TC_Check (HT.TC);
HT.Buckets (Indx) := Next (X);
HT.Length := HT.Length - 1;
return;
@ -106,7 +105,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
end if;
if Checked_Equivalent_Keys (HT, Key, X) then
TC_Check (HT.TC);
Set_Next (Node => Prev, Next => Next (X));
HT.Length := HT.Length - 1;
return;

42
gcc/ada/libgnat/a-cidlli.adb
View File

@ -320,6 +320,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
X : Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor has no element";
@ -349,8 +351,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
TC_Check (Container.TC);
for Index in 1 .. Count loop
X := Position.Node;
Container.Length := Container.Length - 1;
@ -667,6 +667,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
@ -677,9 +680,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
declare
Lock_Target : With_Lock (Target.TC'Unchecked_Access);
Lock_Source : With_Lock (Source.TC'Unchecked_Access);
@ -847,6 +847,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Node : Node_Access;
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unrestricted_Access
then
@ -873,8 +875,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@ -1420,6 +1420,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1429,8 +1431,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
"Position cursor designates wrong container";
end if;
TE_Check (Container.TC);
if Checks and then Position.Node.Element = null then
raise Program_Error with
"Position cursor has no element";
@ -1612,6 +1612,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Source : in out List)
is
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1636,9 +1639,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "new length exceeds maximum";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source);
end Splice;
@ -1648,6 +1648,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Position : Cursor)
is
begin
TC_Check (Container.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Container'Unchecked_Access then
raise Program_Error with
@ -1688,8 +1690,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
TC_Check (Container.TC);
if Before.Node = null then
pragma Assert (Position.Node /= Container.Last);
@ -1765,6 +1765,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Before.Container /= null then
if Checks and then Before.Container /= Target'Unrestricted_Access then
raise Program_Error with
@ -1801,9 +1804,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Constraint_Error with "Target is full";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
end Splice;
@ -1960,6 +1960,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@ -1980,8 +1982,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
TE_Check (Container.TC);
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
@ -2003,6 +2003,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
@ -2023,8 +2025,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
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");

12
gcc/ada/libgnat/a-cihama.adb
View File

@ -327,6 +327,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
TC_Check (Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@ -338,8 +340,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@ -1106,13 +1106,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
E : Element_Access;
begin
TE_Check (Container.HT.TC);
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
TE_Check (Container.HT.TC);
K := Node.Key;
E := Node.Element;
@ -1148,6 +1148,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Position.Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1166,8 +1168,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Position.Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
declare

8
gcc/ada/libgnat/a-cihase.adb
View File

@ -320,6 +320,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Position : in out Cursor)
is
begin
TC_Check (Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@ -333,8 +335,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "Position cursor is bad");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@ -1321,13 +1321,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Warnings (Off, X);
begin
TE_Check (Container.HT.TC);
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
TE_Check (Container.HT.TC);
X := Node.Element;
declare

56
gcc/ada/libgnat/a-cimutr.adb
View File

@ -261,6 +261,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -273,8 +275,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@ -738,6 +738,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -746,8 +748,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
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 in. We must therefore initialize
@ -772,6 +772,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
X : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -789,8 +791,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -819,6 +819,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -832,8 +834,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -1191,6 +1191,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1215,8 +1217,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@ -1735,6 +1735,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Element : Element_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1747,8 +1749,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@ -2096,6 +2096,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
E, X : Element_Access;
begin
TE_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -2109,8 +2111,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TE_Check (Container.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see
@ -2182,6 +2182,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2219,8 +2222,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
TC_Check (Target.TC);
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@ -2236,9 +2237,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
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
-- nodes in the subtree we remove from Source and insert into Target, in
@ -2265,6 +2263,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Source_Parent : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2304,8 +2304,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@ -2363,6 +2361,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Subtree_Count : Count_Type;
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2404,8 +2405,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end if;
end if;
TC_Check (Target.TC);
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@ -2420,9 +2419,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
return;
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)
-- operation. It would have been better if the Tree container did not
@ -2455,6 +2451,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Position : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2500,8 +2498,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end if;
end if;
TC_Check (Container.TC);
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@ -2553,6 +2549,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@ -2581,8 +2579,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
TE_Check (Container.TC);
declare
EI : constant Element_Access := I.Node.Element;

8
gcc/ada/libgnat/a-ciorma.adb
View File

@ -1435,12 +1435,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
E : Element_Access;
begin
TE_Check (Container.Tree.TC);
if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
TE_Check (Container.Tree.TC);
K := Node.Key;
E := Node.Element;
@ -1476,6 +1476,8 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Container.Tree.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1494,8 +1496,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Container.Tree.TC);
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");

4
gcc/ada/libgnat/a-ciorse.adb
View File

@ -1788,12 +1788,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
pragma Warnings (Off, X);
begin
TE_Check (Container.Tree.TC);
if Checks and then Node = null then
raise Constraint_Error with "attempt to replace element not in set";
end if;
TE_Check (Container.Tree.TC);
declare
-- The element allocator may need an accessibility check in the case
-- the actual type is class-wide or has access discriminants (see

71
gcc/ada/libgnat/a-cobove.adb
View File

@ -483,6 +483,8 @@ package body Ada.Containers.Bounded_Vectors is
Off : Count_Type'Base; -- Index expressed as offset from IT'First
begin
TC_Check (Container.TC);
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@ -532,8 +534,6 @@ package body Ada.Containers.Bounded_Vectors is
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
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
-- Count_Type'Base as the type for intermediate values. (See function
@ -636,15 +636,6 @@ package body Ada.Containers.Bounded_Vectors is
Count : Count_Type := 1)
is
begin
-- It is not permitted to delete items while the container is busy (for
-- example, we're in the middle of a passive iteration). However, we
-- always treat deleting 0 items as a no-op, even when we're busy, so we
-- simply return without checking.
if Count = 0 then
return;
end if;
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
@ -654,6 +645,10 @@ package body Ada.Containers.Bounded_Vectors is
TC_Check (Container.TC);
if Count = 0 then
return;
end if;
-- 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
-- is equivalent to clearing the vector. (In particular, there's no need
@ -882,6 +877,8 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
TC_Check (Source.TC);
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
@ -892,8 +889,6 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
TC_Check (Source.TC);
I := Target.Length;
Target.Set_Length (I + Source.Length);
@ -1021,6 +1016,14 @@ package body Ada.Containers.Bounded_Vectors is
J : Count_Type'Base; -- scratch
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
@ -1176,14 +1179,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Count is out of range";
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
if Checks and then New_Length > Container.Capacity then
raise Capacity_Error with "New length is larger than capacity";
end if;
@ -1491,6 +1486,14 @@ package body Ada.Containers.Bounded_Vectors is
J : Count_Type'Base; -- scratch
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
@ -1646,14 +1649,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Count is out of range";
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
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.
@ -1937,14 +1932,14 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Target.Capacity < Source.Length then
raise Capacity_Error -- ???
with "Target capacity is less than Source length";
end if;
TC_Check (Target.TC);
TC_Check (Source.TC);
-- Clear Target now, in case element assignment fails
Target.Last := No_Index;
@ -2222,12 +2217,12 @@ package body Ada.Containers.Bounded_Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
TE_Check (Container.TC);
Container.Elements (To_Array_Index (Index)) := New_Item;
end Replace_Element;
@ -2237,6 +2232,8 @@ package body Ada.Containers.Bounded_Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -2250,8 +2247,6 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "Position cursor is out of range";
end if;
TE_Check (Container.TC);
Container.Elements (To_Array_Index (Position.Index)) := New_Item;
end Replace_Element;
@ -2425,6 +2420,8 @@ package body Ada.Containers.Bounded_Vectors is
E : Elements_Array renames Container.Elements;
begin
TE_Check (Container.TC);
if Checks and then I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
@ -2437,8 +2434,6 @@ package body Ada.Containers.Bounded_Vectors is
return;
end if;
TE_Check (Container.TC);
declare
EI_Copy : constant Element_Type := E (To_Array_Index (I));
begin

12
gcc/ada/libgnat/a-cohama.adb
View File

@ -314,6 +314,8 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
TC_Check (Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
@ -325,8 +327,6 @@ package body Ada.Containers.Hashed_Maps is
"Position cursor of Delete designates wrong map";
end if;
TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@ -999,13 +999,13 @@ package body Ada.Containers.Hashed_Maps is
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
TE_Check (Container.HT.TC);
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
TE_Check (Container.HT.TC);
Node.Key := Key;
Node.Element := New_Item;
end Replace;
@ -1020,6 +1020,8 @@ package body Ada.Containers.Hashed_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Position.Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1031,8 +1033,6 @@ package body Ada.Containers.Hashed_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Position.Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item;

8
gcc/ada/libgnat/a-cohase.adb
View File

@ -299,6 +299,8 @@ package body Ada.Containers.Hashed_Sets is
Position : in out Cursor)
is
begin
TC_Check (Container.HT.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with "Position cursor equals No_Element";
end if;
@ -308,8 +310,6 @@ package body Ada.Containers.Hashed_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
TC_Check (Container.HT.TC);
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
@ -1204,13 +1204,13 @@ package body Ada.Containers.Hashed_Sets is
Element_Keys.Find (Container.HT, New_Item);
begin
TE_Check (Container.HT.TC);
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
TE_Check (Container.HT.TC);
Node.Element := New_Item;
end Replace;

64
gcc/ada/libgnat/a-coinve.adb
View File

@ -408,6 +408,14 @@ package body Ada.Containers.Indefinite_Vectors is
J : Index_Type'Base; -- first index of items that slide down
begin
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
TC_Check (Container.TC);
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@ -460,14 +468,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
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
-- Count_Type'Base as the type for intermediate values. (See function
@ -942,6 +942,8 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Index_Type'Base;
begin
TC_Check (Source.TC);
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@ -964,8 +966,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
TC_Check (Source.TC);
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
@ -1128,6 +1128,14 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@ -1335,14 +1343,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
if New_Length <= Container.Elements.EA'Length then
-- In this case, we're inserting elements into a vector that has
@ -1908,6 +1908,14 @@ package body Ada.Containers.Indefinite_Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on exit.
-- Insert checks the count to determine whether it is being called while
-- the associated callback procedure is executing.
TC_Check (Container.TC);
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@ -2090,14 +2098,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on exit.
-- Insert checks the count to determine whether it is being called while
-- the associated callback procedure is executing.
TC_Check (Container.TC);
if New_Length <= Container.Elements.EA'Length then
-- In this case, we are inserting elements into a vector that has
@ -2757,12 +2757,12 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
TE_Check (Container.TC);
declare
X : Element_Access := Container.Elements.EA (Index);
@ -2784,6 +2784,8 @@ package body Ada.Containers.Indefinite_Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
@ -2798,8 +2800,6 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end if;
TE_Check (Container.TC);
declare
X : Element_Access := Container.Elements.EA (Position.Index);
@ -3258,6 +3258,8 @@ package body Ada.Containers.Indefinite_Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
TE_Check (Container.TC);
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
@ -3272,8 +3274,6 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
TE_Check (Container.TC);
declare
EI : Element_Access renames Container.Elements.EA (I);
EJ : Element_Access renames Container.Elements.EA (J);

60
gcc/ada/libgnat/a-comutr.adb
View File

@ -263,6 +263,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -275,8 +277,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@ -699,6 +699,8 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -707,8 +709,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Parent cursor not in container";
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
-- in. We must therefore initialize the count value before calling
@ -733,6 +733,8 @@ package body Ada.Containers.Multiway_Trees is
X : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -750,8 +752,6 @@ package body Ada.Containers.Multiway_Trees is
raise Constraint_Error with "Position cursor does not designate leaf";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -780,6 +780,8 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -793,8 +795,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TC_Check (Container.TC);
X := Position.Node;
Position := No_Element;
@ -1145,6 +1145,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1169,8 +1171,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@ -1214,6 +1214,8 @@ package body Ada.Containers.Multiway_Trees is
Last : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1238,8 +1240,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => <>,
others => <>);
@ -1737,6 +1737,8 @@ package body Ada.Containers.Multiway_Trees is
First, Last : Tree_Node_Access;
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -1749,8 +1751,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => New_Item,
others => <>);
@ -2073,6 +2073,8 @@ package body Ada.Containers.Multiway_Trees is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Position = No_Element then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -2086,8 +2088,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Position cursor designates root";
end if;
TE_Check (Container.TC);
Position.Node.Element := New_Item;
end Replace_Element;
@ -2160,6 +2160,9 @@ package body Ada.Containers.Multiway_Trees is
Count : Count_Type;
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2197,8 +2200,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Target.TC);
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@ -2214,9 +2215,6 @@ package body Ada.Containers.Multiway_Trees is
return;
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
-- nodes in the subtree we remove from Source and insert into Target, in
@ -2243,6 +2241,8 @@ package body Ada.Containers.Multiway_Trees is
Source_Parent : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Target_Parent = No_Element then
raise Constraint_Error with "Target_Parent cursor has no element";
end if;
@ -2282,8 +2282,6 @@ package body Ada.Containers.Multiway_Trees is
return;
end if;
TC_Check (Container.TC);
if Checks and then Is_Reachable (From => Target_Parent.Node,
To => Source_Parent.Node)
then
@ -2341,6 +2339,9 @@ package body Ada.Containers.Multiway_Trees is
Subtree_Count : Count_Type;
begin
TC_Check (Target.TC);
TC_Check (Source.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2382,8 +2383,6 @@ package body Ada.Containers.Multiway_Trees is
end if;
end if;
TC_Check (Target.TC);
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@ -2398,9 +2397,6 @@ package body Ada.Containers.Multiway_Trees is
return;
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)
-- operation. It would have been better if the Tree container did not
@ -2433,6 +2429,8 @@ package body Ada.Containers.Multiway_Trees is
Position : Cursor)
is
begin
TC_Check (Container.TC);
if Checks and then Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
@ -2478,8 +2476,6 @@ package body Ada.Containers.Multiway_Trees is
end if;
end if;
TC_Check (Container.TC);
if Checks and then
Is_Reachable (From => Parent.Node, To => Position.Node)
then
@ -2531,6 +2527,8 @@ package body Ada.Containers.Multiway_Trees is
I, J : Cursor)
is
begin
TE_Check (Container.TC);
if Checks and then I = No_Element then
raise Constraint_Error with "I cursor has no element";
end if;
@ -2559,8 +2557,6 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "J cursor designates root";
end if;
TE_Check (Container.TC);
declare
EI : constant Element_Type := I.Node.Element;

70
gcc/ada/libgnat/a-convec.adb
View File

@ -377,6 +377,14 @@ package body Ada.Containers.Vectors is
J : Index_Type'Base; -- first index of items that slide down
begin
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
TC_Check (Container.TC);
-- Delete removes items from the vector, the number of which is the
-- minimum of the specified Count and the items (if any) that exist from
-- Index to Container.Last. There are no constraints on the specified
@ -420,14 +428,6 @@ package body Ada.Containers.Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being deleted (or
-- otherwise harmfully manipulated) while it is being visited. Query,
-- Update, and Iterate increment the busy count on entry, and decrement
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
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
-- Count_Type'Base as the type for intermediate values. (See function
@ -781,6 +781,8 @@ package body Ada.Containers.Vectors is
J : Index_Type'Base;
begin
TC_Check (Source.TC);
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@ -803,8 +805,6 @@ package body Ada.Containers.Vectors is
return;
end if;
TC_Check (Source.TC);
Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
@ -861,10 +861,6 @@ package body Ada.Containers.Vectors is
"<" => "<");
begin
if Container.Last <= Index_Type'First then
return;
end if;
-- The exception behavior for the vector container must match that
-- for the list container, so we check for cursor tampering here
-- (which will catch more things) instead of for element tampering
@ -878,6 +874,10 @@ package body Ada.Containers.Vectors is
TC_Check (Container.TC);
if Container.Last <= Index_Type'First then
return;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
@ -933,6 +933,14 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@ -1124,14 +1132,6 @@ package body Ada.Containers.Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
@ -1595,6 +1595,14 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
@ -1784,14 +1792,6 @@ package body Ada.Containers.Vectors is
return;
end if;
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
TC_Check (Container.TC);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
@ -2446,11 +2446,12 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
TE_Check (Container.TC);
Container.Elements.EA (Index) := New_Item;
end Replace_Element;
@ -2460,6 +2461,8 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
TE_Check (Container.TC);
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
@ -2472,7 +2475,6 @@ package body Ada.Containers.Vectors is
end if;
end if;
TE_Check (Container.TC);
Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element;
@ -2940,6 +2942,8 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
TE_Check (Container.TC);
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
@ -2954,8 +2958,6 @@ package body Ada.Containers.Vectors is
return;
end if;
TE_Check (Container.TC);
declare
EI_Copy : constant Element_Type := Container.Elements.EA (I);
begin

8
gcc/ada/libgnat/a-coorma.adb
View File

@ -1349,12 +1349,12 @@ package body Ada.Containers.Ordered_Maps is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
TE_Check (Container.Tree.TC);
if Checks and then Node = null then
raise Constraint_Error with "key not in map";
end if;
TE_Check (Container.Tree.TC);
Node.Key := Key;
Node.Element := New_Item;
end Replace;
@ -1369,6 +1369,8 @@ package body Ada.Containers.Ordered_Maps is
New_Item : Element_Type)
is
begin
TE_Check (Container.Tree.TC);
if Checks and then Position.Node = null then
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
@ -1380,8 +1382,6 @@ package body Ada.Containers.Ordered_Maps is
"Position cursor of Replace_Element designates wrong map";
end if;
TE_Check (Container.Tree.TC);
pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor of Replace_Element is bad");

4
gcc/ada/libgnat/a-coorse.adb
View File

@ -1641,13 +1641,13 @@ package body Ada.Containers.Ordered_Sets is
Element_Keys.Find (Container.Tree, New_Item);
begin
TE_Check (Container.Tree.TC);
if Checks and then Node = null then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
TE_Check (Container.Tree.TC);
Node.Element := New_Item;
end Replace;

4
gcc/ada/libgnat/a-crbtgk.adb
View File

@ -422,12 +422,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Z : out Node_Access)
is
begin
TC_Check (Tree.TC);
if Checks and then Tree.Length = Count_Type'Last then
raise Constraint_Error with "too many elements";
end if;
TC_Check (Tree.TC);
Z := New_Node;
pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);

4
gcc/ada/libgnat/a-crbtgo.adb
View File

@ -693,12 +693,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Move (Target, Source : in out Tree_Type) is
begin
TC_Check (Source.TC);
if Target'Address = Source'Address then
return;
end if;
TC_Check (Source.TC);
Clear (Target);
Target := Source;

4
gcc/ada/libgnat/a-rbtgso.adb
View File

@ -94,9 +94,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
Compare : Integer;
begin
if Target'Address = Source'Address then
TC_Check (Target.TC);
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
@ -105,8 +105,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return;
end if;
TC_Check (Target.TC);
Tgt := Target.First;
Src := Source.First;
loop