[gcc(refs/users/giulianob/heads/autopar_rebase2)] [Ada] Ada2020: AI12-0110 Tampering checks are performed first
Giuliano Belinassi
giulianob@gcc.gnu.org
Mon Aug 17 23:52:52 GMT 2020
https://gcc.gnu.org/g:2649da0eade749734446e47a9c3317f018ae647e
commit 2649da0eade749734446e47a9c3317f018ae647e
Author: Bob Duff <duff@adacore.com>
Date: Fri Apr 10 18:23:15 2020 -0400
[Ada] Ada2020: AI12-0110 Tampering checks are performed first
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.
Diff:
---
gcc/ada/libgnat/a-cbdlli.adb | 54 ++++++++++++++++-----------------
gcc/ada/libgnat/a-cbhama.adb | 12 ++++----
gcc/ada/libgnat/a-cbhase.adb | 8 ++---
gcc/ada/libgnat/a-cbmutr.adb | 60 +++++++++++++++++--------------------
gcc/ada/libgnat/a-cborma.adb | 8 ++---
gcc/ada/libgnat/a-cborse.adb | 8 ++---
gcc/ada/libgnat/a-cdlili.adb | 46 ++++++++++++++--------------
gcc/ada/libgnat/a-chtgbk.adb | 9 ++----
gcc/ada/libgnat/a-chtgke.adb | 2 --
gcc/ada/libgnat/a-cidlli.adb | 42 +++++++++++++-------------
gcc/ada/libgnat/a-cihama.adb | 12 ++++----
gcc/ada/libgnat/a-cihase.adb | 8 ++---
gcc/ada/libgnat/a-cimutr.adb | 56 ++++++++++++++++------------------
gcc/ada/libgnat/a-ciorma.adb | 8 ++---
gcc/ada/libgnat/a-ciorse.adb | 4 +--
gcc/ada/libgnat/a-cobove.adb | 71 ++++++++++++++++++++------------------------
gcc/ada/libgnat/a-cohama.adb | 12 ++++----
gcc/ada/libgnat/a-cohase.adb | 8 ++---
gcc/ada/libgnat/a-coinve.adb | 64 +++++++++++++++++++--------------------
gcc/ada/libgnat/a-comutr.adb | 60 +++++++++++++++++--------------------
gcc/ada/libgnat/a-convec.adb | 70 ++++++++++++++++++++++---------------------
gcc/ada/libgnat/a-coorma.adb | 8 ++---
gcc/ada/libgnat/a-coorse.adb | 4 +--
gcc/ada/libgnat/a-crbtgk.adb | 4 +--
gcc/ada/libgnat/a-crbtgo.adb | 4 +--
gcc/ada/libgnat/a-rbtgso.adb | 6 ++--
26 files changed, 313 insertions(+), 335 deletions(-)
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb
index d16bc5ba33d..1b3a88cd60e 100644
--- a/gcc/ada/libgnat/a-cbdlli.adb
+++ b/gcc/ada/libgnat/a-cbdlli.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb
index dad7abb0f48..b76bd623cd7 100644
--- a/gcc/ada/libgnat/a-cbhama.adb
+++ b/gcc/ada/libgnat/a-cbhama.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
index e399e50e51f..8a786f1f68e 100644
--- a/gcc/ada/libgnat/a-cbhase.adb
+++ b/gcc/ada/libgnat/a-cbhase.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb
index 7137a137596..f9048b09c2f 100644
--- a/gcc/ada/libgnat/a-cbmutr.adb
+++ b/gcc/ada/libgnat/a-cbmutr.adb
@@ -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);
diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb
index cf92b29be9c..1e384d777e0 100644
--- a/gcc/ada/libgnat/a-cborma.adb
+++ b/gcc/ada/libgnat/a-cborma.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index 649b6c1827d..af5efc1f5ca 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 2940b1d262e..73c7980a157 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-chtgbk.adb b/gcc/ada/libgnat/a-chtgbk.adb
index e87517c109e..89358e4f46a 100644
--- a/gcc/ada/libgnat/a-chtgbk.adb
+++ b/gcc/ada/libgnat/a-chtgbk.adb
@@ -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).
diff --git a/gcc/ada/libgnat/a-chtgke.adb b/gcc/ada/libgnat/a-chtgke.adb
index 900af0c5075..fdd62b743b0 100644
--- a/gcc/ada/libgnat/a-chtgke.adb
+++ b/gcc/ada/libgnat/a-chtgke.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb
index ec3b5850573..a086935dd3a 100644
--- a/gcc/ada/libgnat/a-cidlli.adb
+++ b/gcc/ada/libgnat/a-cidlli.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb
index 37d6b3f70d7..7c4d427ca24 100644
--- a/gcc/ada/libgnat/a-cihama.adb
+++ b/gcc/ada/libgnat/a-cihama.adb
@@ -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
diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb
index 1c5179936b9..3d5af6a1769 100644
--- a/gcc/ada/libgnat/a-cihase.adb
+++ b/gcc/ada/libgnat/a-cihase.adb
@@ -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
diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb
index 951097ba7c3..ac7e534380a 100644
--- a/gcc/ada/libgnat/a-cimutr.adb
+++ b/gcc/ada/libgnat/a-cimutr.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb
index 6965cc1d0ec..25cf67445f1 100644
--- a/gcc/ada/libgnat/a-ciorma.adb
+++ b/gcc/ada/libgnat/a-ciorma.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index 349a59d69ac..f9647a2cf40 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -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
diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb
index d8ed1f8b4f1..fe94ea58364 100644
--- a/gcc/ada/libgnat/a-cobove.adb
+++ b/gcc/ada/libgnat/a-cobove.adb
@@ -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
diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb
index 1df66d1e856..f5424623cf7 100644
--- a/gcc/ada/libgnat/a-cohama.adb
+++ b/gcc/ada/libgnat/a-cohama.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb
index 52499418c9c..45a1b2e0294 100644
--- a/gcc/ada/libgnat/a-cohase.adb
+++ b/gcc/ada/libgnat/a-cohase.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb
index 5ae3ffeb035..85c30fa1832 100644
--- a/gcc/ada/libgnat/a-coinve.adb
+++ b/gcc/ada/libgnat/a-coinve.adb
@@ -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);
diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb
index 48aae25204f..6468839e294 100644
--- a/gcc/ada/libgnat/a-comutr.adb
+++ b/gcc/ada/libgnat/a-comutr.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb
index 0dc1d30fb2d..197271b87c7 100644
--- a/gcc/ada/libgnat/a-convec.adb
+++ b/gcc/ada/libgnat/a-convec.adb
@@ -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
diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb
index ea3487712c2..9bad901259a 100644
--- a/gcc/ada/libgnat/a-coorma.adb
+++ b/gcc/ada/libgnat/a-coorma.adb
@@ -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");
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index 7291e0aa6d2..8c37d11248a 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-crbtgk.adb b/gcc/ada/libgnat/a-crbtgk.adb
index 7a947b8c80a..a41fcbbc02d 100644
--- a/gcc/ada/libgnat/a-crbtgk.adb
+++ b/gcc/ada/libgnat/a-crbtgk.adb
@@ -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);
diff --git a/gcc/ada/libgnat/a-crbtgo.adb b/gcc/ada/libgnat/a-crbtgo.adb
index 1338f03a901..35727b0d7dd 100644
--- a/gcc/ada/libgnat/a-crbtgo.adb
+++ b/gcc/ada/libgnat/a-crbtgo.adb
@@ -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;
diff --git a/gcc/ada/libgnat/a-rbtgso.adb b/gcc/ada/libgnat/a-rbtgso.adb
index 58d61384c2e..fcb254d8fe4 100644
--- a/gcc/ada/libgnat/a-rbtgso.adb
+++ b/gcc/ada/libgnat/a-rbtgso.adb
@@ -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);
+ 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
More information about the Gcc-cvs
mailing list