diff options
Diffstat (limited to 'gcc/ada/libgnat')
26 files changed, 313 insertions, 335 deletions
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index d16bc5b..1b3a88c 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 dad7abb0..b76bd62 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 e399e50..8a786f1 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 7137a13..f9048b0 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 cf92b29..1e384d7 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 649b6c1..af5efc1 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 2940b1d..73c7980 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 e87517c..89358e4 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 900af0c..fdd62b7 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 ec3b585..a086935 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 37d6b3f..7c4d427c 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 1c51799..3d5af6a 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 951097b..ac7e534 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 6965cc1..25cf674 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 349a59d..f9647a2 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 d8ed1f8..fe94ea5 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 1df66d1..f542462 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 5249941..45a1b2e 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 5ae3ffe..85c30fa 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 48aae25..6468839 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 0dc1d30..197271b 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 ea34877..9bad901 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 7291e0a..8c37d11 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 7a947b8..a41fcbb 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 1338f03..35727b0 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 58d6138..fcb254d 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 |