From 47fb6ca83f9443beb6d113c93436748d42da08da Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 19 Feb 2014 15:59:32 +0100 Subject: [PATCH] [multiple changes] 2014-02-19 Matthew Heaney * a-chtgop.ads (Checked_Index): New operation. (Next): Changed mode of hash table. * a-chtgop.adb (Adjust, Delete_Node_Sans_Free): Detect tampering (Generic_Read, Reserve_Capacity): Ditto. (Generic_Equal): Detect tampering. (Next): Changed mode of hash table, detect tampering. * a-chtgke.ads (Checked_Index, Checked_Equivalent_Keys): New operation. (Find): Changed mode of hash table. * a-chtgke.adb (Checked_Equivalent_Keys): New operation (Delete_Key_Sans_Free, Generic_Conditional_Insert): Detect tampering. (Find): Changed mode of hash table, check for tampering. (Generic_Replace_Element): Check for tampering. * a-chtgbk.ads (Checked_Index, Checked_Equivalent_Keys): New operation. * a-chtgbk.adb (Checked_Index, Checked_Equivalent_Keys): New operation (Delete_Key_Sans_Free, Generic_Conditional_Insert): Detect tampering. (Find, Generic_Replace_Element): Check for tampering. * a-chtgbo.ads (Checked_Index): New operation. * a-chtgbo.adb (Checked_Index): New operation (Delete_Node_Sans_Free, Generic_Equal): Detect tampering. (Generic_Read, Next): Ditto. * a-cohase.adb, a-cihase.adb (Is_In): Changed mode of hash table (Difference, Intersection): Use variable view of source, detect tampering (Find, Is_Subset, Overlap): Use variable view of container (Symmetric_Difference, Union): Detect tampering (Vet): Use Checked_Index to detect tampering (Constant_Reference, Element, Find): Use variable view of container. (Update_Element_Preserving_Key): Detect tampering. * a-cbhase.adb (Difference, Find, Is_In): Use variable view of container. (Is_Subset): Ditto. (Equivalent_Sets, Overlap): Use Node's Next component. (Vet): Use Checked_Index to detect tampering. (Constant_Reference, Element, Find): Use variable view of container. (Update_Element_Preserving_Key): Detect tampering. * a-cohama.adb, a-cihama.adb, a-cbhama.adb (Constant_Reference, Element, Find): Use variable view of container. (Reference): Rename hash table component. (Vet): Use Checked_Index to detect tampering. 2014-02-19 Arnaud Charlet * adabkend.adb (Scan_Compiler_Arguments): Add missing handling of -nostdinc. 2014-02-19 Thomas Quinot * tbuild.adb (New_Occurrence_Of, New_Rerefence_To): Guard against calls without Def_Id. 2014-02-19 Claire Dross * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, a-cforse.ads, a-cofove.ads: Add global annotations to subprograms. 2014-02-19 Hristian Kirtchev * sem_prag.adb (Analyze_Initial_Condition_In_Decl_Part): Remove constants Errors, Pack_Id and Pack_Init. Remove variable Vars. Initial_Condition no longer requires the presence of pragma Initialized. Do not try to diagnose whether all variables mentioned in pragma Initializes also appear in Initial_Condition. (Collect_Variables): Removed. (Match_Variable): Removed. (Match_Variables): Removed. (Report_Unused_Variables): Removed. 2014-02-19 Thomas Quinot * gnat_rm.texi (pragma Stream_Convert): Minor rewording. From-SVN: r207905 --- gcc/ada/ChangeLog | 76 ++++++++++++ gcc/ada/a-cbhama.adb | 12 +- gcc/ada/a-cbhase.adb | 59 ++++++--- gcc/ada/a-cfdlli.ads | 155 +++++++++++++++--------- gcc/ada/a-cfhama.ads | 108 +++++++++++------ gcc/ada/a-cfhase.ads | 167 +++++++++++++++++-------- gcc/ada/a-cforma.ads | 123 ++++++++++++------- gcc/ada/a-cforse.ads | 180 ++++++++++++++++++--------- gcc/ada/a-chtgbk.adb | 181 +++++++++++++++++++-------- gcc/ada/a-chtgbk.ads | 16 ++- gcc/ada/a-chtgbo.adb | 85 +++++++++++-- gcc/ada/a-chtgbo.ads | 8 +- gcc/ada/a-chtgke.adb | 184 ++++++++++++++++++++-------- gcc/ada/a-chtgke.ads | 20 ++- gcc/ada/a-chtgop.adb | 102 ++++++++++++++-- gcc/ada/a-chtgop.ads | 16 ++- gcc/ada/a-cihama.adb | 18 +-- gcc/ada/a-cihase.adb | 282 ++++++++++++++++++++++++++++++++++--------- gcc/ada/a-cofove.ads | 227 ++++++++++++++++++++++------------ gcc/ada/a-cohama.adb | 16 +-- gcc/ada/a-cohase.adb | 280 +++++++++++++++++++++++++++++++++--------- gcc/ada/adabkend.adb | 6 + gcc/ada/gnat_rm.texi | 10 +- gcc/ada/sem_prag.adb | 174 +------------------------- gcc/ada/tbuild.adb | 3 +- 25 files changed, 1740 insertions(+), 768 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a97d87985d9..09ad3eaf4f6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,79 @@ +2014-02-19 Matthew Heaney + + * a-chtgop.ads (Checked_Index): New operation. + (Next): Changed mode of hash table. + * a-chtgop.adb (Adjust, Delete_Node_Sans_Free): Detect tampering + (Generic_Read, Reserve_Capacity): Ditto. + (Generic_Equal): Detect tampering. + (Next): Changed mode of hash table, detect tampering. + * a-chtgke.ads (Checked_Index, Checked_Equivalent_Keys): New + operation. + (Find): Changed mode of hash table. + * a-chtgke.adb (Checked_Equivalent_Keys): New operation + (Delete_Key_Sans_Free, Generic_Conditional_Insert): Detect + tampering. + (Find): Changed mode of hash table, check for tampering. + (Generic_Replace_Element): Check for tampering. + * a-chtgbk.ads (Checked_Index, Checked_Equivalent_Keys): New operation. + * a-chtgbk.adb (Checked_Index, Checked_Equivalent_Keys): New + operation (Delete_Key_Sans_Free, Generic_Conditional_Insert): + Detect tampering. + (Find, Generic_Replace_Element): Check for tampering. + * a-chtgbo.ads (Checked_Index): New operation. + * a-chtgbo.adb (Checked_Index): New operation + (Delete_Node_Sans_Free, Generic_Equal): Detect tampering. + (Generic_Read, Next): Ditto. + * a-cohase.adb, a-cihase.adb (Is_In): Changed mode of hash + table (Difference, Intersection): Use variable view of + source, detect tampering (Find, Is_Subset, Overlap): Use + variable view of container (Symmetric_Difference, Union): + Detect tampering (Vet): Use Checked_Index to detect tampering + (Constant_Reference, Element, Find): Use variable view of + container. + (Update_Element_Preserving_Key): Detect tampering. + * a-cbhase.adb (Difference, Find, Is_In): Use variable view + of container. + (Is_Subset): Ditto. + (Equivalent_Sets, Overlap): Use Node's Next component. + (Vet): Use Checked_Index to detect tampering. + (Constant_Reference, Element, Find): Use variable view of container. + (Update_Element_Preserving_Key): Detect tampering. + * a-cohama.adb, a-cihama.adb, a-cbhama.adb (Constant_Reference, + Element, Find): Use variable view of container. + (Reference): Rename hash table component. + (Vet): Use Checked_Index to detect tampering. + +2014-02-19 Arnaud Charlet + + * adabkend.adb (Scan_Compiler_Arguments): Add missing handling + of -nostdinc. + +2014-02-19 Thomas Quinot + + * tbuild.adb (New_Occurrence_Of, New_Rerefence_To): Guard + against calls without Def_Id. + +2014-02-19 Claire Dross + + * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, a-cforse.ads, + a-cofove.ads: Add global annotations to subprograms. + +2014-02-19 Hristian Kirtchev + + * sem_prag.adb (Analyze_Initial_Condition_In_Decl_Part): Remove + constants Errors, Pack_Id and Pack_Init. Remove variable Vars. + Initial_Condition no longer requires the presence of pragma + Initialized. Do not try to diagnose whether all variables mentioned in + pragma Initializes also appear in Initial_Condition. + (Collect_Variables): Removed. + (Match_Variable): Removed. + (Match_Variables): Removed. + (Report_Unused_Variables): Removed. + +2014-02-19 Thomas Quinot + + * gnat_rm.texi (pragma Stream_Convert): Minor rewording. + 2014-02-19 Robert Dewar * sem_util.adb, sem_util.ads, prj-conf.adb, s-os_lib.adb: Minor diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index f4a953c1401..3549f993935 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -208,7 +208,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type is - Node : constant Count_Type := Key_Ops.Find (Container, Key); + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin if Node = 0 then @@ -321,7 +322,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is ------------- function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Ops.Find (Container, Key); + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin if Node = 0 then @@ -449,7 +451,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container, Key); + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin if Node = 0 then return No_Element; @@ -1160,7 +1163,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is return False; end if; - X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key)); + X := M.Buckets (Key_Ops.Checked_Index + (M, M.Nodes (Position.Node).Key)); for J in 1 .. M.Length loop if X = Position.Node then diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 99efc1dcf79..640fb8e6136 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -328,6 +328,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is is Tgt_Node, Src_Node : Count_Type; + Src : Set renames Source'Unrestricted_Access.all; + TN : Nodes_Type renames Target.Nodes; SN : Nodes_Type renames Source.Nodes; @@ -356,7 +358,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Free (Target, Tgt_Node); end if; - Src_Node := HT_Ops.Next (Source, Src_Node); + Src_Node := HT_Ops.Next (Src, Src_Node); end loop; else @@ -481,7 +483,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return True; end if; - R_Node := HT_Ops.Next (R_HT, R_Node); + R_Node := Next (R_HT.Nodes (R_Node)); end loop; end Find_Equivalent_Key; @@ -512,6 +514,20 @@ package body Ada.Containers.Bounded_Hashed_Sets is pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + declare LN : Node_Type renames Left.Container.Nodes (Left.Node); RN : Node_Type renames Right.Container.Nodes (Right.Node); @@ -609,7 +625,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := Element_Keys.Find (Container, Item); + Node : constant Count_Type := + Element_Keys.Find (Container'Unrestricted_Access.all, Item); begin return (if Node = 0 then No_Element else Cursor'(Container'Unrestricted_Access, Node)); @@ -865,7 +882,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Is_In (HT : Set; Key : Node_Type) return Boolean is begin - return Element_Keys.Find (HT, Key.Element) /= 0; + return Element_Keys.Find (HT'Unrestricted_Access.all, Key.Element) /= 0; end Is_In; --------------- @@ -890,7 +907,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is if not Is_In (Of_Set, SN (Subset_Node)) then return False; end if; - Subset_Node := HT_Ops.Next (Subset, Subset_Node); + Subset_Node := HT_Ops.Next + (Subset'Unrestricted_Access.all, Subset_Node); end loop; return True; @@ -1049,7 +1067,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is if Is_In (Right, Left.Nodes (Left_Node)) then return True; end if; - Left_Node := HT_Ops.Next (Left, Left_Node); + Left_Node := HT_Ops.Next (Left'Unrestricted_Access.all, Left_Node); end loop; return False; @@ -1481,7 +1499,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is return False; end if; - X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); + X := S.Buckets (Element_Keys.Checked_Index + (S, N (Position.Node).Element)); for J in 1 .. S.Length loop if X = Position.Node then @@ -1585,7 +1604,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type is - Node : constant Count_Type := Key_Keys.Find (Container, Key); + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin if Node = 0 then @@ -1639,11 +1659,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Keys.Find (Container, Key); + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin if Node = 0 then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in set"; end if; return Container.Nodes (Node).Element; @@ -1683,7 +1704,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Find (Container, Key); + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin return (if Node = 0 then No_Element else Cursor'(Container'Unrestricted_Access, Node)); @@ -1825,9 +1847,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Vet (Position), "bad cursor in Update_Element_Preserving_Key"); - -- Record bucket now, in case key is changed - - Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. declare E : Element_Type renames N (Position.Node).Element; @@ -1836,12 +1857,19 @@ package body Ada.Containers.Bounded_Hashed_Sets is B : Natural renames Container.Busy; L : Natural renames Container.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin + -- Record bucket now, in case key is changed + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); + Process (E); + + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1852,8 +1880,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); + if Eq then return; end if; end; diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 7b19f1dd2e3..8b169e46cc7 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -77,35 +77,44 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is No_Element : constant Cursor; - function "=" (Left, Right : List) return Boolean; + function "=" (Left, Right : List) return Boolean with + Global => null; - function Length (Container : List) return Count_Type; + function Length (Container : List) return Count_Type with + Global => null; - function Is_Empty (Container : List) return Boolean; + function Is_Empty (Container : List) return Boolean with + Global => null; - procedure Clear (Container : in out List); + procedure Clear (Container : in out List) with + Global => null; procedure Assign (Target : in out List; Source : List) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); function Copy (Source : List; Capacity : Count_Type := 0) return List with - Pre => Capacity = 0 or else Capacity >= Source.Capacity; + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity; function Element (Container : List; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out List; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out List; Source : in out List) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); procedure Insert (Container : in out List; @@ -113,9 +122,10 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) + Count <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Insert (Container : in out List; @@ -124,9 +134,10 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is Position : out Cursor; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) + Count <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Insert (Container : in out List; @@ -134,61 +145,73 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is Position : out Cursor; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) + Count <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Prepend (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity; + Global => null, + Pre => Length (Container) + Count <= Container.Capacity; procedure Append (Container : in out List; New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity; + Global => null, + Pre => Length (Container) + Count <= Container.Capacity; procedure Delete (Container : in out List; Position : in out Cursor; Count : Count_Type := 1) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Delete_First (Container : in out List; - Count : Count_Type := 1); + Count : Count_Type := 1) + with + Global => null; procedure Delete_Last (Container : in out List; - Count : Count_Type := 1); + Count : Count_Type := 1) + with + Global => null; - procedure Reverse_Elements (Container : in out List); + procedure Reverse_Elements (Container : in out List) with + Global => null; procedure Swap (Container : in out List; I, J : Cursor) with - Pre => Has_Element (Container, I) and then Has_Element (Container, J); + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J); procedure Swap_Links (Container : in out List; I, J : Cursor) with - Pre => Has_Element (Container, I) and then Has_Element (Container, J); + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J); procedure Splice (Target : in out List; Before : Cursor; Source : in out List) with - Pre => Length (Source) + Length (Target) <= Target.Capacity - and then (Has_Element (Target, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Source) + Length (Target) <= Target.Capacity + and then (Has_Element (Target, Before) + or else Before = No_Element); procedure Splice (Target : in out List; @@ -196,84 +219,106 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is Source : in out List; Position : in out Cursor) with - Pre => Length (Source) + Length (Target) <= Target.Capacity - and then (Has_Element (Target, Before) - or else Before = No_Element) - and then Has_Element (Source, Position); + Global => null, + Pre => Length (Source) + Length (Target) <= Target.Capacity + and then (Has_Element (Target, Before) + or else Before = No_Element) + and then Has_Element (Source, Position); procedure Splice (Container : in out List; Before : Cursor; Position : Cursor) with - Pre => 2 * Length (Container) <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element) - and then Has_Element (Container, Position); + Global => null, + Pre => 2 * Length (Container) <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element) + and then Has_Element (Container, Position); - function First (Container : List) return Cursor; + function First (Container : List) return Cursor with + Global => null; function First_Element (Container : List) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); - function Last (Container : List) return Cursor; + function Last (Container : List) return Cursor with + Global => null; function Last_Element (Container : List) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Next (Container : List; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : List; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Previous (Container : List; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Previous (Container : List; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Reverse_Find (Container : List; Item : Element_Type; Position : Cursor := No_Element) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Contains (Container : List; - Item : Element_Type) return Boolean; + Item : Element_Type) return Boolean + with + Global => null; - function Has_Element (Container : List; Position : Cursor) return Boolean; + function Has_Element (Container : List; Position : Cursor) return Boolean + with + Global => null; generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is - function Is_Sorted (Container : List) return Boolean; + function Is_Sorted (Container : List) return Boolean with + Global => null; - procedure Sort (Container : in out List); + procedure Sort (Container : in out List) with + Global => null; - procedure Merge (Target, Source : in out List); + procedure Merge (Target, Source : in out List) with + Global => null; end Generic_Sorting; - function Strict_Equal (Left, Right : List) return Boolean; + function Strict_Equal (Left, Right : List) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : List; Position : Cursor) return List with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : List; Position : Cursor) return List with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 16a95052422..7880ea0fe7f 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -81,53 +81,65 @@ package Ada.Containers.Formal_Hashed_Maps is No_Element : constant Cursor; - function "=" (Left, Right : Map) return Boolean; + function "=" (Left, Right : Map) return Boolean with + Global => null; - function Capacity (Container : Map) return Count_Type; + function Capacity (Container : Map) return Count_Type with + Global => null; procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type) with - Pre => Capacity <= Container.Capacity; + Global => null, + Pre => Capacity <= Container.Capacity; - function Length (Container : Map) return Count_Type; + function Length (Container : Map) return Count_Type with + Global => null; - function Is_Empty (Container : Map) return Boolean; + function Is_Empty (Container : Map) return Boolean with + Global => null; - procedure Clear (Container : in out Map); + procedure Clear (Container : in out Map) with + Global => null; procedure Assign (Target : in out Map; Source : Map) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); function Copy (Source : Map; Capacity : Count_Type := 0) return Map with - Pre => Capacity = 0 or else Capacity >= Source.Capacity; + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity; -- Copy returns a container stricty equal to Source. It must have -- the same cursors associated with each element. Therefore: -- - capacity=0 means use container.capacity as capacity of target -- - the modulus cannot be changed. function Key (Container : Map; Position : Cursor) return Key_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); function Element (Container : Map; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out Map; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out Map; Source : in out Map) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); procedure Insert (Container : in out Map; @@ -136,82 +148,107 @@ package Ada.Containers.Formal_Hashed_Maps is Position : out Cursor; Inserted : out Boolean) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Insert (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, Key)); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (not Contains (Container, Key)); procedure Include (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Replace (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); - procedure Exclude (Container : in out Map; Key : Key_Type); + procedure Exclude (Container : in out Map; Key : Key_Type) with + Global => null; procedure Delete (Container : in out Map; Key : Key_Type) with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); procedure Delete (Container : in out Map; Position : in out Cursor) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); - function First (Container : Map) return Cursor; + function First (Container : Map) return Cursor with + Global => null; function Next (Container : Map; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : Map; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; - function Find (Container : Map; Key : Key_Type) return Cursor; + function Find (Container : Map; Key : Key_Type) return Cursor with + Global => null; - function Contains (Container : Map; Key : Key_Type) return Boolean; + function Contains (Container : Map; Key : Key_Type) return Boolean with + Global => null; function Element (Container : Map; Key : Key_Type) return Element_Type with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); - function Has_Element (Container : Map; Position : Cursor) return Boolean; + function Has_Element (Container : Map; Position : Cursor) return Boolean + with + Global => null; function Equivalent_Keys (Left : Map; CLeft : Cursor; Right : Map; - CRight : Cursor) return Boolean; + CRight : Cursor) return Boolean + with + Global => null; function Equivalent_Keys (Left : Map; CLeft : Cursor; - Right : Key_Type) return Boolean; + Right : Key_Type) return Boolean + with + Global => null; function Equivalent_Keys (Left : Key_Type; Right : Map; - CRight : Cursor) return Boolean; + CRight : Cursor) return Boolean + with + Global => null; - function Default_Modulus (Capacity : Count_Type) return Hash_Type; + function Default_Modulus (Capacity : Count_Type) return Hash_Type with + Global => null; - function Strict_Equal (Left, Right : Map) return Boolean; + function Strict_Equal (Left, Right : Map) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : Map; Position : Cursor) return Map with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : Map; Position : Cursor) return Map with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new @@ -219,7 +256,8 @@ package Ada.Containers.Formal_Hashed_Maps is -- iterate over containers. Left returns the part of the container already -- scanned and Right the part not scanned yet. - function Overlap (Left, Right : Map) return Boolean; + function Overlap (Left, Right : Map) return Boolean with + Global => null; -- Overlap returns True if the containers have common keys private diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index fc02e04403d..058d4503e1d 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -83,50 +83,63 @@ package Ada.Containers.Formal_Hashed_Sets is No_Element : constant Cursor; - function "=" (Left, Right : Set) return Boolean; + function "=" (Left, Right : Set) return Boolean with + Global => null; - function Equivalent_Sets (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean with + Global => null; - function To_Set (New_Item : Element_Type) return Set; + function To_Set (New_Item : Element_Type) return Set with + Global => null; - function Capacity (Container : Set) return Count_Type; + function Capacity (Container : Set) return Count_Type with + Global => null; procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type) with - Pre => Capacity <= Container.Capacity; + Global => null, + Pre => Capacity <= Container.Capacity; - function Length (Container : Set) return Count_Type; + function Length (Container : Set) return Count_Type with + Global => null; - function Is_Empty (Container : Set) return Boolean; + function Is_Empty (Container : Set) return Boolean with + Global => null; - procedure Clear (Container : in out Set); + procedure Clear (Container : in out Set) with + Global => null; procedure Assign (Target : in out Set; Source : Set) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); function Copy (Source : Set; Capacity : Count_Type := 0) return Set with - Pre => Capacity = 0 or else Capacity >= Source.Capacity; + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity; function Element (Container : Set; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out Set; Source : in out Set) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); procedure Insert (Container : in out Set; @@ -134,85 +147,123 @@ package Ada.Containers.Formal_Hashed_Sets is Position : out Cursor; Inserted : out Boolean) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Insert (Container : in out Set; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (not Contains (Container, New_Item)); procedure Include (Container : in out Set; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Replace (Container : in out Set; New_Item : Element_Type) with - Pre => Contains (Container, New_Item); + Global => null, + Pre => Contains (Container, New_Item); - procedure Exclude (Container : in out Set; Item : Element_Type); + procedure Exclude (Container : in out Set; Item : Element_Type) with + Global => null; procedure Delete (Container : in out Set; Item : Element_Type) with - Pre => Contains (Container, Item); + Global => null, + Pre => Contains (Container, Item); procedure Delete (Container : in out Set; Position : in out Cursor) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Union (Target : in out Set; Source : Set) with - Pre => Length (Target) + Length (Source) - - Length (Intersection (Target, Source)) <= Target.Capacity; + Global => null, + Pre => Length (Target) + Length (Source) - + Length (Intersection (Target, Source)) <= Target.Capacity; - function Union (Left, Right : Set) return Set; + function Union (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) + Length (Right) - + Length (Intersection (Left, Right)) <= Count_Type'Last; function "or" (Left, Right : Set) return Set renames Union; - procedure Intersection (Target : in out Set; Source : Set); + procedure Intersection (Target : in out Set; Source : Set) with + Global => null; - function Intersection (Left, Right : Set) return Set; + function Intersection (Left, Right : Set) return Set with + Global => null; function "and" (Left, Right : Set) return Set renames Intersection; - procedure Difference (Target : in out Set; Source : Set); + procedure Difference (Target : in out Set; Source : Set) with + Global => null; - function Difference (Left, Right : Set) return Set; + function Difference (Left, Right : Set) return Set with + Global => null; function "-" (Left, Right : Set) return Set renames Difference; - procedure Symmetric_Difference (Target : in out Set; Source : Set); + procedure Symmetric_Difference (Target : in out Set; Source : Set) with + Global => null, + Pre => Length (Target) + Length (Source) - + 2 * Length (Intersection (Target, Source)) <= Target.Capacity; - function Symmetric_Difference (Left, Right : Set) return Set; + function Symmetric_Difference (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) + Length (Right) - + 2 * Length (Intersection (Left, Right)) <= Count_Type'Last; function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - function Overlap (Left, Right : Set) return Boolean; + function Overlap (Left, Right : Set) return Boolean with + Global => null; - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with + Global => null; - function First (Container : Set) return Cursor; + function First (Container : Set) return Cursor with + Global => null; function Next (Container : Set; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : Set; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Find (Container : Set; - Item : Element_Type) return Cursor; + Item : Element_Type) return Cursor + with + Global => null; - function Contains (Container : Set; Item : Element_Type) return Boolean; + function Contains (Container : Set; Item : Element_Type) return Boolean with + Global => null; - function Has_Element (Container : Set; Position : Cursor) return Boolean; + function Has_Element (Container : Set; Position : Cursor) return Boolean + with + Global => null; function Equivalent_Elements (Left : Set; CLeft : Cursor; - Right : Set; CRight : Cursor) return Boolean; + Right : Set; CRight : Cursor) return Boolean + with + Global => null; function Equivalent_Elements (Left : Set; CLeft : Cursor; - Right : Element_Type) return Boolean; + Right : Element_Type) return Boolean + with + Global => null; function Equivalent_Elements (Left : Element_Type; - Right : Set; CRight : Cursor) return Boolean; + Right : Set; CRight : Cursor) return Boolean + with + Global => null; - function Default_Modulus (Capacity : Count_Type) return Hash_Type; + function Default_Modulus (Capacity : Count_Type) return Hash_Type with + Global => null; generic type Key_Type (<>) is private; @@ -225,34 +276,46 @@ package Ada.Containers.Formal_Hashed_Sets is package Generic_Keys is - function Key (Container : Set; Position : Cursor) return Key_Type; + function Key (Container : Set; Position : Cursor) return Key_Type with + Global => null; - function Element (Container : Set; Key : Key_Type) return Element_Type; + function Element (Container : Set; Key : Key_Type) return Element_Type + with + Global => null; procedure Replace (Container : in out Set; Key : Key_Type; - New_Item : Element_Type); + New_Item : Element_Type) + with + Global => null; - procedure Exclude (Container : in out Set; Key : Key_Type); + procedure Exclude (Container : in out Set; Key : Key_Type) with + Global => null; - procedure Delete (Container : in out Set; Key : Key_Type); + procedure Delete (Container : in out Set; Key : Key_Type) with + Global => null; - function Find (Container : Set; Key : Key_Type) return Cursor; + function Find (Container : Set; Key : Key_Type) return Cursor with + Global => null; - function Contains (Container : Set; Key : Key_Type) return Boolean; + function Contains (Container : Set; Key : Key_Type) return Boolean with + Global => null; end Generic_Keys; - function Strict_Equal (Left, Right : Set) return Boolean; + function Strict_Equal (Left, Right : Set) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : Set; Position : Cursor) return Set with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : Set; Position : Cursor) return Set with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 08dabf5541f..f927cf86da3 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -68,7 +68,8 @@ package Ada.Containers.Formal_Ordered_Maps is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean with + Global => null; type Map (Capacity : Count_Type) is private with Iterable => (First => First, @@ -84,38 +85,48 @@ package Ada.Containers.Formal_Ordered_Maps is No_Element : constant Cursor; - function "=" (Left, Right : Map) return Boolean; + function "=" (Left, Right : Map) return Boolean with + Global => null; - function Length (Container : Map) return Count_Type; + function Length (Container : Map) return Count_Type with + Global => null; - function Is_Empty (Container : Map) return Boolean; + function Is_Empty (Container : Map) return Boolean with + Global => null; - procedure Clear (Container : in out Map); + procedure Clear (Container : in out Map) with + Global => null; procedure Assign (Target : in out Map; Source : Map) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); function Copy (Source : Map; Capacity : Count_Type := 0) return Map with - Pre => Capacity = 0 or else Capacity >= Source.Capacity; + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity; function Key (Container : Map; Position : Cursor) return Key_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); function Element (Container : Map; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out Map; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out Map; Source : in out Map) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); procedure Insert (Container : in out Map; @@ -124,92 +135,121 @@ package Ada.Containers.Formal_Ordered_Maps is Position : out Cursor; Inserted : out Boolean) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Insert (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, Key)); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (not Contains (Container, Key)); procedure Include (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Replace (Container : in out Map; Key : Key_Type; New_Item : Element_Type) with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); - procedure Exclude (Container : in out Map; Key : Key_Type); + procedure Exclude (Container : in out Map; Key : Key_Type) with + Global => null; procedure Delete (Container : in out Map; Key : Key_Type) with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); procedure Delete (Container : in out Map; Position : in out Cursor) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); - procedure Delete_First (Container : in out Map); + procedure Delete_First (Container : in out Map) with + Global => null; - procedure Delete_Last (Container : in out Map); + procedure Delete_Last (Container : in out Map) with + Global => null; - function First (Container : Map) return Cursor; + function First (Container : Map) return Cursor with + Global => null; function First_Element (Container : Map) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function First_Key (Container : Map) return Key_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); - function Last (Container : Map) return Cursor; + function Last (Container : Map) return Cursor with + Global => null; function Last_Element (Container : Map) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Last_Key (Container : Map) return Key_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Next (Container : Map; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : Map; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Previous (Container : Map; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Previous (Container : Map; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; - function Find (Container : Map; Key : Key_Type) return Cursor; + function Find (Container : Map; Key : Key_Type) return Cursor with + Global => null; function Element (Container : Map; Key : Key_Type) return Element_Type with - Pre => Contains (Container, Key); + Global => null, + Pre => Contains (Container, Key); - function Floor (Container : Map; Key : Key_Type) return Cursor; + function Floor (Container : Map; Key : Key_Type) return Cursor with + Global => null; - function Ceiling (Container : Map; Key : Key_Type) return Cursor; + function Ceiling (Container : Map; Key : Key_Type) return Cursor with + Global => null; - function Contains (Container : Map; Key : Key_Type) return Boolean; + function Contains (Container : Map; Key : Key_Type) return Boolean with + Global => null; - function Has_Element (Container : Map; Position : Cursor) return Boolean; + function Has_Element (Container : Map; Position : Cursor) return Boolean + with + Global => null; - function Strict_Equal (Left, Right : Map) return Boolean; + function Strict_Equal (Left, Right : Map) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : Map; Position : Cursor) return Map with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : Map; Position : Cursor) return Map with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new @@ -217,7 +257,8 @@ package Ada.Containers.Formal_Ordered_Maps is -- iterate over containers. Left returns the part of the container already -- scanned and Right the part not scanned yet. - function Overlap (Left, Right : Map) return Boolean; + function Overlap (Left, Right : Map) return Boolean with + Global => null; -- Overlap returns True if the containers have common keys private diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index bc69c1b1bf6..5035e1c85a7 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -66,7 +66,9 @@ package Ada.Containers.Formal_Ordered_Sets is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + function Equivalent_Elements (Left, Right : Element_Type) return Boolean + with + Global => null; type Set (Capacity : Count_Type) is private with Iterable => (First => First, @@ -82,39 +84,49 @@ package Ada.Containers.Formal_Ordered_Sets is No_Element : constant Cursor; - function "=" (Left, Right : Set) return Boolean; + function "=" (Left, Right : Set) return Boolean with + Global => null; - function Equivalent_Sets (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean with + Global => null; - function To_Set (New_Item : Element_Type) return Set; + function To_Set (New_Item : Element_Type) return Set with + Global => null; - function Length (Container : Set) return Count_Type; + function Length (Container : Set) return Count_Type with + Global => null; - function Is_Empty (Container : Set) return Boolean; + function Is_Empty (Container : Set) return Boolean with + Global => null; - procedure Clear (Container : in out Set); + procedure Clear (Container : in out Set) with + Global => null; procedure Assign (Target : in out Set; Source : Set) with Pre => Target.Capacity >= Length (Source); function Copy (Source : Set; Capacity : Count_Type := 0) return Set with - Pre => Capacity = 0 or else Capacity >= Source.Capacity; + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity; function Element (Container : Set; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out Set; Source : in out Set) with - Pre => Target.Capacity >= Length (Source); + Global => null, + Pre => Target.Capacity >= Length (Source); procedure Insert (Container : in out Set; @@ -122,108 +134,147 @@ package Ada.Containers.Formal_Ordered_Sets is Position : out Cursor; Inserted : out Boolean) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Insert (Container : in out Set; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (not Contains (Container, New_Item)); procedure Include (Container : in out Set; New_Item : Element_Type) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Replace (Container : in out Set; New_Item : Element_Type) with - Pre => Contains (Container, New_Item); + Global => null, + Pre => Contains (Container, New_Item); procedure Exclude (Container : in out Set; - Item : Element_Type); + Item : Element_Type) + with + Global => null; procedure Delete (Container : in out Set; Item : Element_Type) with - Pre => Contains (Container, Item); + Global => null, + Pre => Contains (Container, Item); procedure Delete (Container : in out Set; Position : in out Cursor) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); - procedure Delete_First (Container : in out Set); + procedure Delete_First (Container : in out Set) with + Global => null; - procedure Delete_Last (Container : in out Set); + procedure Delete_Last (Container : in out Set) with + Global => null; procedure Union (Target : in out Set; Source : Set) with - Pre => Length (Target) + Length (Source) - - Length (Intersection (Target, Source)) <= Target.Capacity; + Global => null, + Pre => Length (Target) + Length (Source) - + Length (Intersection (Target, Source)) <= Target.Capacity; - function Union (Left, Right : Set) return Set; + function Union (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) + Length (Right) - + Length (Intersection (Left, Right)) <= Count_Type'Last; function "or" (Left, Right : Set) return Set renames Union; - procedure Intersection (Target : in out Set; Source : Set); + procedure Intersection (Target : in out Set; Source : Set) with + Global => null; - function Intersection (Left, Right : Set) return Set; + function Intersection (Left, Right : Set) return Set with + Global => null; function "and" (Left, Right : Set) return Set renames Intersection; - procedure Difference (Target : in out Set; Source : Set); + procedure Difference (Target : in out Set; Source : Set) with + Global => null; - function Difference (Left, Right : Set) return Set; + function Difference (Left, Right : Set) return Set with + Global => null; function "-" (Left, Right : Set) return Set renames Difference; - procedure Symmetric_Difference (Target : in out Set; Source : Set); + procedure Symmetric_Difference (Target : in out Set; Source : Set) with + Global => null, + Pre => Length (Target) + Length (Source) - + 2 * Length (Intersection (Target, Source)) <= Target.Capacity; - function Symmetric_Difference (Left, Right : Set) return Set; + function Symmetric_Difference (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) + Length (Right) - + 2 * Length (Intersection (Left, Right)) <= Count_Type'Last; function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - function Overlap (Left, Right : Set) return Boolean; + function Overlap (Left, Right : Set) return Boolean with + Global => null; - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with + Global => null; - function First (Container : Set) return Cursor; + function First (Container : Set) return Cursor with + Global => null; function First_Element (Container : Set) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Last (Container : Set) return Cursor; function Last_Element (Container : Set) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Next (Container : Set; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : Set; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Previous (Container : Set; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Previous (Container : Set; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; - function Find (Container : Set; Item : Element_Type) return Cursor; + function Find (Container : Set; Item : Element_Type) return Cursor with + Global => null; - function Floor (Container : Set; Item : Element_Type) return Cursor; + function Floor (Container : Set; Item : Element_Type) return Cursor with + Global => null; - function Ceiling (Container : Set; Item : Element_Type) return Cursor; + function Ceiling (Container : Set; Item : Element_Type) return Cursor with + Global => null; - function Contains (Container : Set; Item : Element_Type) return Boolean; + function Contains (Container : Set; Item : Element_Type) return Boolean with + Global => null; - function Has_Element (Container : Set; Position : Cursor) return Boolean; + function Has_Element (Container : Set; Position : Cursor) return Boolean + with + Global => null; generic type Key_Type (<>) is private; @@ -234,40 +285,55 @@ package Ada.Containers.Formal_Ordered_Sets is package Generic_Keys is - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean with + Global => null; - function Key (Container : Set; Position : Cursor) return Key_Type; + function Key (Container : Set; Position : Cursor) return Key_Type with + Global => null; - function Element (Container : Set; Key : Key_Type) return Element_Type; + function Element (Container : Set; Key : Key_Type) return Element_Type + with + Global => null; procedure Replace (Container : in out Set; Key : Key_Type; - New_Item : Element_Type); + New_Item : Element_Type) + with + Global => null; - procedure Exclude (Container : in out Set; Key : Key_Type); + procedure Exclude (Container : in out Set; Key : Key_Type) with + Global => null; - procedure Delete (Container : in out Set; Key : Key_Type); + procedure Delete (Container : in out Set; Key : Key_Type) with + Global => null; - function Find (Container : Set; Key : Key_Type) return Cursor; + function Find (Container : Set; Key : Key_Type) return Cursor with + Global => null; - function Floor (Container : Set; Key : Key_Type) return Cursor; + function Floor (Container : Set; Key : Key_Type) return Cursor with + Global => null; - function Ceiling (Container : Set; Key : Key_Type) return Cursor; + function Ceiling (Container : Set; Key : Key_Type) return Cursor with + Global => null; - function Contains (Container : Set; Key : Key_Type) return Boolean; + function Contains (Container : Set; Key : Key_Type) return Boolean with + Global => null; end Generic_Keys; - function Strict_Equal (Left, Right : Set) return Boolean; + function Strict_Equal (Left, Right : Set) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : Set; Position : Cursor) return Set with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : Set; Position : Cursor) return Set with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new diff --git a/gcc/ada/a-chtgbk.adb b/gcc/ada/a-chtgbk.adb index 211e921c6c5..13082c9c25b 100644 --- a/gcc/ada/a-chtgbk.adb +++ b/gcc/ada/a-chtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,69 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + ----------------------------- + -- Checked_Equivalent_Keys -- + ----------------------------- + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean + is + Result : Boolean; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := Equivalent_Keys (Key, HT.Nodes (Node)); + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Equivalent_Keys; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type + is + Result : Hash_Type; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Index; + -------------------------- -- Delete_Key_Sans_Free -- -------------------------- @@ -47,14 +110,22 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is return; end if; - Indx := Index (HT, Key); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); if X = 0 then return; end if; - if Equivalent_Keys (Key, HT.Nodes (X)) then + if Checked_Equivalent_Keys (HT, Key, X) then if HT.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; @@ -72,7 +143,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is return; end if; - if Equivalent_Keys (Key, HT.Nodes (X)) then + if Checked_Equivalent_Keys (HT, Key, X) then if HT.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; @@ -100,11 +171,13 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is return 0; end if; - Indx := Index (HT, Key); + Indx := Checked_Index (HT'Unrestricted_Access.all, Key); Node := HT.Buckets (Indx); while Node /= 0 loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then + if Checked_Equivalent_Keys + (HT'Unrestricted_Access.all, Key, Node) + then return Node; end if; Node := Next (HT.Nodes (Node)); @@ -123,16 +196,21 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is Node : out Count_Type; Inserted : out Boolean) is - Indx : constant Hash_Type := Index (HT, Key); - B : Count_Type renames HT.Buckets (Indx); + Indx : Hash_Type; begin - if B = 0 then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Indx := Checked_Index (HT, Key); + Node := HT.Buckets (Indx); + if Node = 0 then if HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; @@ -142,15 +220,14 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is Inserted := True; - B := Node; + HT.Buckets (Indx) := Node; HT.Length := HT.Length + 1; return; end if; - Node := B; loop - if Equivalent_Keys (Key, HT.Nodes (Node)) then + if Checked_Equivalent_Keys (HT, Key, Node) then Inserted := False; return; end if; @@ -160,35 +237,19 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is exit when Node = 0; end loop; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - if HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; Node := New_Node; - Set_Next (HT.Nodes (Node), Next => B); + Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); Inserted := True; - B := Node; + HT.Buckets (Indx) := Node; HT.Length := HT.Length + 1; end Generic_Conditional_Insert; - ----------- - -- Index -- - ----------- - - function Index - (HT : Hash_Table_Type'Class; - Key : Key_Type) return Hash_Type is - begin - return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - end Index; - ----------------------------- -- Generic_Replace_Element -- ----------------------------- @@ -204,24 +265,41 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is BB : Buckets_Type renames HT.Buckets; NN : Nodes_Type renames HT.Nodes; - Old_Hash : constant Hash_Type := Hash (NN (Node)); - Old_Indx : constant Hash_Type := BB'First + Old_Hash mod BB'Length; - - New_Hash : constant Hash_Type := Hash (Key); - New_Indx : constant Hash_Type := BB'First + New_Hash mod BB'Length; + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Checked_Index (HT, Key); New_Bucket : Count_Type renames BB (New_Indx); N, M : Count_Type; begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + + Old_Indx := Hash (NN (Node)) mod HT.Buckets'Length; + + B := B - 1; + L := L - 1; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end; + -- Replace_Element is allowed to change a node's key to Key -- (generic formal operation Assign provides the mechanism), but -- only if Key is not already in the hash table. (In a unique-key -- hash table as this one, a key is mapped to exactly one node.) - if Equivalent_Keys (Key, NN (Node)) then - pragma Assert (New_Hash = Old_Hash); - + if Checked_Equivalent_Keys (HT, Key, Node) then if HT.Lock > 0 then raise Program_Error with "attempt to tamper with elements (container is locked)"; @@ -231,8 +309,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- stays in the same bucket. Assign (NN (Node), Key); - pragma Assert (Hash (NN (Node)) = New_Hash); - pragma Assert (Equivalent_Keys (Key, NN (Node))); return; end if; @@ -243,7 +319,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is N := New_Bucket; while N /= 0 loop - if Equivalent_Keys (Key, NN (N)) then + if Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -269,8 +345,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is end if; Assign (NN (Node), Key); - pragma Assert (Hash (NN (Node)) = New_Hash); - pragma Assert (Equivalent_Keys (Key, NN (Node))); return; end if; @@ -286,8 +360,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- modified (except for any possible side-effect Assign had on Node). Assign (NN (Node), Key); - pragma Assert (Hash (NN (Node)) = New_Hash); - pragma Assert (Equivalent_Keys (Key, NN (Node))); -- Now we can safely remove the node from its current bucket @@ -319,4 +391,15 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is New_Bucket := Node; end Generic_Replace_Element; + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type is + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Index; + end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/a-chtgbk.ads b/gcc/ada/a-chtgbk.ads index 4257c251e8d..d6d207780f6 100644 --- a/gcc/ada/a-chtgbk.ads +++ b/gcc/ada/a-chtgbk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,6 +59,20 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Keys is pragma Inline (Index); -- Returns the bucket number (array index value) for the given key + function Checked_Index + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type; + pragma Inline (Checked_Index); + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean; + -- Calls Equivalent_Keys, but locks and unlocks the container, per + -- AI05-0022, in order to detect element tampering by that generic actual. + procedure Delete_Key_Sans_Free (HT : in out Hash_Table_Type'Class; Key : Key_Type; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index 1a395d3b34e..f3376cad1df 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,37 @@ with System; use type System.Address; package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type + is + Result : Hash_Type; + + B : Natural renames Hash_Table.Busy; + L : Natural renames Hash_Table.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := Index (Hash_Table, Hash_Table.Nodes (Node)); + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Index; + ----------- -- Clear -- ----------- @@ -69,7 +100,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is "attempt to delete node from empty hashed container"; end if; - Indx := Index (HT, HT.Nodes (X)); + Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); if Prev = 0 then @@ -288,6 +319,14 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean is + BL : Natural renames L'Unrestricted_Access.Busy; + LL : Natural renames L'Unrestricted_Access.Lock; + + BR : Natural renames R'Unrestricted_Access.Busy; + LR : Natural renames R'Unrestricted_Access.Lock; + + Result : Boolean; + L_Index : Hash_Type; L_Node : Count_Type; @@ -315,13 +354,23 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is L_Index := L_Index + 1; end loop; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + -- For each node of hash table L, search for an equivalent node in hash -- table R. N := L.Length; loop if not Find (HT => R, Key => L.Nodes (L_Node)) then - return False; + Result := False; + exit; end if; N := N - 1; @@ -332,7 +381,8 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- We have exhausted the nodes in this bucket if N = 0 then - return True; + Result := True; + exit; end if; -- Find the next bucket @@ -344,6 +394,23 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end loop; end if; end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end Generic_Equal; ----------------------- @@ -397,7 +464,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is for J in 1 .. N loop declare Node : constant Count_Type := New_Node (Stream); - Indx : constant Hash_Type := Index (HT, HT.Nodes (Node)); + Indx : constant Hash_Type := Checked_Index (HT, Node); B : Count_Type renames HT.Buckets (Indx); begin Set_Next (HT.Nodes (Node), Next => B); @@ -461,9 +528,12 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is (HT : Hash_Table_Type'Class; Node : Count_Type) return Count_Type is - Result : Count_Type := Next (HT.Nodes (Node)); + Result : Count_Type; + First : Hash_Type; begin + Result := Next (HT.Nodes (Node)); + if Result /= 0 then -- another node in same bucket return Result; end if; @@ -471,7 +541,8 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- This was the last node in the bucket, so move to the next -- bucket, and start searching for next node from there. - for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop + First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1; + for Indx in First .. HT.Buckets'Last loop Result := HT.Buckets (Indx); if Result /= 0 then -- bucket is not empty diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads index 8eca9e6a53e..0e9e9284018 100644 --- a/gcc/ada/a-chtgbo.ads +++ b/gcc/ada/a-chtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -62,6 +62,12 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- Uses the hash value of Node to compute its Hash_Table buckets array -- index. + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type; + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + generic with function Find (HT : Hash_Table_Type'Class; diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index 89649f33a5d..e4de7712e7a 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,69 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is + ----------------------------- + -- Checked_Equivalent_Keys -- + ----------------------------- + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type; + Key : Key_Type; + Node : Node_Access) return Boolean + is + Result : Boolean; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := Equivalent_Keys (Key, Node); + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Equivalent_Keys; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Hash_Type + is + Result : Hash_Type; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := Hash (Key) mod HT.Buckets'Length; + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Index; + -------------------------- -- Delete_Key_Sans_Free -- -------------------------- @@ -47,14 +110,22 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is return; end if; - Indx := Index (HT, Key); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); if X = null then return; end if; - if Equivalent_Keys (Key, X) then + if Checked_Equivalent_Keys (HT, Key, X) then if HT.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; @@ -72,7 +143,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is return; end if; - if Equivalent_Keys (Key, X) then + if Checked_Equivalent_Keys (HT, Key, X) then if HT.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; @@ -89,9 +160,9 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ---------- function Find - (HT : Hash_Table_Type; - Key : Key_Type) return Node_Access is - + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Node_Access + is Indx : Hash_Type; Node : Node_Access; @@ -100,11 +171,11 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is return null; end if; - Indx := Index (HT, Key); + Indx := Checked_Index (HT, Key); Node := HT.Buckets (Indx); while Node /= null loop - if Equivalent_Keys (Key, Node) then + if Checked_Equivalent_Keys (HT, Key, Node) then return Node; end if; Node := Next (Node); @@ -123,16 +194,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is - Indx : constant Hash_Type := Index (HT, Key); - B : Node_Access renames HT.Buckets (Indx); + Indx : Hash_Type; begin - if B = null then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Indx := Checked_Index (HT, Key); + Node := HT.Buckets (Indx); + if Node = null then if HT.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -140,15 +216,14 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Node := New_Node (Next => null); Inserted := True; - B := Node; + HT.Buckets (Indx) := Node; HT.Length := HT.Length + 1; return; end if; - Node := B; loop - if Equivalent_Keys (Key, Node) then + if Checked_Equivalent_Keys (HT, Key, Node) then Inserted := False; return; end if; @@ -158,33 +233,17 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is exit when Node = null; end loop; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - if HT.Length = Count_Type'Last then raise Constraint_Error; end if; - Node := New_Node (Next => B); + Node := New_Node (Next => HT.Buckets (Indx)); Inserted := True; - B := Node; + HT.Buckets (Indx) := Node; HT.Length := HT.Length + 1; end Generic_Conditional_Insert; - ----------- - -- Index -- - ----------- - - function Index - (HT : Hash_Table_Type; - Key : Key_Type) return Hash_Type is - begin - return Hash (Key) mod HT.Buckets'Length; - end Index; - ----------------------------- -- Generic_Replace_Element -- ----------------------------- @@ -197,19 +256,36 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is pragma Assert (HT.Length > 0); pragma Assert (Node /= null); - Old_Hash : constant Hash_Type := Hash (Node); - Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length; - - New_Hash : constant Hash_Type := Hash (Key); - New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length; + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Checked_Index (HT, Key); New_Bucket : Node_Access renames HT.Buckets (New_Indx); N, M : Node_Access; begin - if Equivalent_Keys (Key, Node) then - pragma Assert (New_Hash = Old_Hash); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + + Old_Indx := Hash (Node) mod HT.Buckets'Length; + B := B - 1; + L := L - 1; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end; + + if Checked_Equivalent_Keys (HT, Key, Node) then if HT.Lock > 0 then raise Program_Error with "attempt to tamper with elements (container is locked)"; @@ -222,8 +298,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- change is allowed. Assign (Node, Key); - pragma Assert (Hash (Node) = New_Hash); - pragma Assert (Equivalent_Keys (Key, Node)); return; end if; @@ -234,7 +308,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is N := New_Bucket; while N /= null loop - if Equivalent_Keys (Key, N) then + if Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -260,8 +334,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is end if; Assign (Node, Key); - pragma Assert (Hash (Node) = New_Hash); - pragma Assert (Equivalent_Keys (Key, Node)); return; end if; @@ -277,8 +349,6 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- modified (except for any possible side-effect Assign had on Node). Assign (Node, Key); - pragma Assert (Hash (Node) = New_Hash); - pragma Assert (Equivalent_Keys (Key, Node)); -- Now we can safely remove the node from its current bucket @@ -310,4 +380,16 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is New_Bucket := Node; end Generic_Replace_Element; + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type + is + begin + return Hash (Key) mod HT.Buckets'Length; + end Index; + end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads index ccdee2f6bad..37256e2eb59 100644 --- a/gcc/ada/a-chtgke.ads +++ b/gcc/ada/a-chtgke.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,6 +59,20 @@ package Ada.Containers.Hash_Tables.Generic_Keys is pragma Inline (Index); -- Returns the bucket number (array index value) for the given key + function Checked_Index + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Hash_Type; + pragma Inline (Checked_Index); + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type; + Key : Key_Type; + Node : Node_Access) return Boolean; + -- Calls Equivalent_Keys, but locks and unlocks the container, per + -- AI05-0022, in order to detect element tampering by that generic actual. + procedure Delete_Key_Sans_Free (HT : in out Hash_Table_Type; Key : Key_Type; @@ -67,7 +81,9 @@ package Ada.Containers.Hash_Tables.Generic_Keys is -- without deallocating it. Program_Error is raised if the hash -- table is busy. - function Find (HT : Hash_Table_Type; Key : Key_Type) return Node_Access; + function Find + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Node_Access; -- Returns the node (if any) corresponding to the given key generic diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index d014dc17c09..a0e0af16493 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -75,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- See note above - pragma Assert (Index (HT, Dst_Node) = Src_Index); + pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); begin HT.Buckets (Src_Index) := Dst_Node; @@ -91,7 +91,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- See note above - pragma Assert (Index (HT, Dst_Node) = Src_Index); + pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); begin Set_Next (Node => Dst_Prev, Next => Dst_Node); @@ -121,6 +121,46 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return HT.Buckets'Length; end Capacity; + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type + is + Result : Hash_Type; + + B : Natural renames Hash_Table.Busy; + L : Natural renames Hash_Table.Lock; + + begin + B := B + 1; + L := L + 1; + + Result := Index (Buckets, Node); + + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + + raise; + end Checked_Index; + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Node : Node_Access) return Hash_Type + is + begin + return Checked_Index (Hash_Table, Hash_Table.Buckets.all, Node); + end Checked_Index; + ----------- -- Clear -- ----------- @@ -174,7 +214,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is "attempt to delete node from empty hashed container"; end if; - Indx := Index (HT, X); + Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); if Prev = null then @@ -288,6 +328,14 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is function Generic_Equal (L, R : Hash_Table_Type) return Boolean is + BL : Natural renames L'Unrestricted_Access.Busy; + LL : Natural renames L'Unrestricted_Access.Lock; + + BR : Natural renames R'Unrestricted_Access.Busy; + LR : Natural renames R'Unrestricted_Access.Lock; + + Result : Boolean; + L_Index : Hash_Type; L_Node : Node_Access; @@ -315,13 +363,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is L_Index := L_Index + 1; end loop; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + -- For each node of hash table L, search for an equivalent node in hash -- table R. N := L.Length; loop if not Find (HT => R, Key => L_Node) then - return False; + Result := False; + exit; end if; N := N - 1; @@ -332,7 +390,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- We have exhausted the nodes in this bucket if N = 0 then - return True; + Result := True; + exit; end if; -- Find the next bucket @@ -344,6 +403,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end loop; end if; end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end Generic_Equal; ----------------------- @@ -407,7 +483,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is for J in 1 .. N loop declare Node : constant Node_Access := New_Node (Stream); - Indx : constant Hash_Type := Index (HT, Node); + Indx : constant Hash_Type := Checked_Index (HT, Node); B : Node_Access renames HT.Buckets (Indx); begin Set_Next (Node => Node, Next => B); @@ -513,17 +589,21 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ---------- function Next - (HT : Hash_Table_Type; + (HT : aliased in out Hash_Table_Type; Node : Node_Access) return Node_Access is - Result : Node_Access := Next (Node); + Result : Node_Access; + First : Hash_Type; begin + Result := Next (Node); + if Result /= null then return Result; end if; - for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop + First := Checked_Index (HT, Node) + 1; + for Indx in First .. HT.Buckets'Last loop Result := HT.Buckets (Indx); if Result /= null then @@ -643,7 +723,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Src_Node : constant Node_Access := Src_Bucket; Dst_Index : constant Hash_Type := - Index (Dst_Buckets.all, Src_Node); + Checked_Index (HT, Dst_Buckets.all, Src_Node); Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index b6ffd070984..c8e22c30ca5 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -71,6 +71,18 @@ package Ada.Containers.Hash_Tables.Generic_Operations is -- Uses the hash value of Node to compute its Hash_Table buckets array -- index. + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type; + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Node : Node_Access) return Hash_Type; + -- Calls Checked_Index using Hash_Table's buckets array. + procedure Adjust (HT : in out Hash_Table_Type); -- Used to implement controlled Adjust. It is assumed that HT has the value -- of the bit-wise copy that immediately follows controlled Finalize. @@ -126,7 +138,7 @@ package Ada.Containers.Hash_Tables.Generic_Operations is -- bucket. function Next - (HT : Hash_Table_Type; + (HT : aliased in out Hash_Table_Type; Node : Node_Access) return Node_Access; -- Returns the node that immediately follows Node. This corresponds to -- either the next node in the same bucket, or (if Node is the last node in diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 4e4d240e394..41a5eb1ef53 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -238,7 +238,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -250,8 +251,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is end if; declare - M : Map renames Container'Unrestricted_Access.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -368,7 +367,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ------------- function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -533,7 +533,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -1106,7 +1107,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is (Container : aliased in out Map; Key : Key_Type) return Reference_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -1118,8 +1120,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is end if; declare - M : Map renames Container'Unrestricted_Access.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -1353,7 +1353,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return False; end if; - X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all)); + X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all)); for J in 1 .. HT.Length loop if X = Position.Node then diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 7a70bf65a87..bbd29e552ec 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -75,7 +75,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : out Node_Access; Inserted : out Boolean); - function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean; pragma Inline (Is_In); function Next (Node : Node_Access) return Node_Access; @@ -359,6 +361,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Target : in out Set; Source : Set) is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; Tgt_Node : Node_Access; begin @@ -367,7 +370,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Source.HT.Length = 0 then + if Src_HT.Length = 0 then return; end if; @@ -376,12 +379,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is "attempt to tamper with cursors (set is busy)"; end if; - if Source.HT.Length < Target.HT.Length then + if Src_HT.Length < Target.HT.Length then declare Src_Node : Node_Access; begin - Src_Node := HT_Ops.First (Source.HT); + Src_Node := HT_Ops.First (Src_HT); while Src_Node /= null loop Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); @@ -390,14 +393,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Free (Tgt_Node); end if; - Src_Node := HT_Ops.Next (Source.HT, Src_Node); + Src_Node := HT_Ops.Next (Src_HT, Src_Node); end loop; end; else Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop - if Is_In (Source.HT, Tgt_Node) then + if Is_In (Src_HT, Tgt_Node) then declare X : Node_Access := Tgt_Node; begin @@ -414,8 +417,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Difference; function Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -450,12 +455,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right.HT, L_Node) then + if not Is_In (Right_HT, L_Node) then declare - Src : Element_Type renames L_Node.Element.all; - Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + Indx : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + Bucket : Node_Access renames Buckets (Indx); + Src : Element_Type renames L_Node.Element.all; Tgt : Element_Access := new Element_Type'(Src); + begin Bucket := new Node_Type'(Tgt, Bucket); exception @@ -538,6 +551,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + return Equivalent_Elements (Left.Node.Element.all, Right.Node.Element.all); @@ -653,7 +680,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Element_Keys.Find (HT, Item); begin return (if Node = null then No_Element else Cursor'(Container'Unrestricted_Access, Node)); @@ -904,6 +932,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Target : in out Set; Source : Set) is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; Tgt_Node : Node_Access; begin @@ -923,7 +952,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop - if Is_In (Source.HT, Tgt_Node) then + if Is_In (Src_HT, Tgt_Node) then Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); else @@ -939,8 +968,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Intersection; function Intersection (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -973,14 +1004,19 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if Is_In (Right.HT, L_Node) then + if Is_In (Right_HT, L_Node) then declare - Src : Element_Type renames L_Node.Element.all; + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. - Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; + Indx : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); Bucket : Node_Access renames Buckets (Indx); + Src : Element_Type renames L_Node.Element.all; Tgt : Element_Access := new Element_Type'(Src); begin @@ -1021,7 +1057,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Is_In -- ----------- - function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean + is begin return Element_Keys.Find (HT, Key.Element.all) /= null; end Is_In; @@ -1034,6 +1073,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Subset : Set; Of_Set : Set) return Boolean is + Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; + Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; Subset_Node : Node_Access; begin @@ -1045,13 +1086,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end if; - Subset_Node := HT_Ops.First (Subset.HT); + Subset_Node := HT_Ops.First (Subset_HT); while Subset_Node /= null loop - if not Is_In (Of_Set.HT, Subset_Node) then + if not Is_In (Of_Set_HT, Subset_Node) then return False; end if; - Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); + Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); end loop; return True; @@ -1186,6 +1227,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ------------- function Overlap (Left, Right : Set) return Boolean is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; Left_Node : Node_Access; begin @@ -1197,13 +1240,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return True; end if; - Left_Node := HT_Ops.First (Left.HT); + Left_Node := HT_Ops.First (Left_HT); while Left_Node /= null loop - if Is_In (Right.HT, Left_Node) then + if Is_In (Right_HT, Left_Node) then return True; end if; - Left_Node := HT_Ops.Next (Left.HT, Left_Node); + Left_Node := HT_Ops.Next (Left_HT, Left_Node); end loop; return False; @@ -1396,13 +1439,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Target : in out Set; Source : Set) is + Tgt_HT : Hash_Table_Type renames Target.HT; + Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TB : Natural renames Tgt_HT.Busy; + TL : Natural renames Tgt_HT.Lock; + + SB : Natural renames Src_HT.Busy; + SL : Natural renames Src_HT.Lock; + begin if Target'Address = Source'Address then Clear (Target); return; end if; - if Target.HT.Busy > 0 then + if TB > 0 then raise Program_Error with "attempt to tamper with cursors (set is busy)"; end if; @@ -1410,8 +1465,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare N : constant Count_Type := Target.Length + Source.Length; begin - if N > HT_Ops.Capacity (Target.HT) then - HT_Ops.Reserve_Capacity (Target.HT, N); + if N > HT_Ops.Capacity (Tgt_HT) then + HT_Ops.Reserve_Capacity (Tgt_HT, N); end if; end; @@ -1427,9 +1482,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Target.HT.Buckets.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.HT.Length; + N : Count_Type renames Tgt_HT.Length; begin declare @@ -1448,7 +1503,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Start of processing for Iterate_Source_When_Empty_Target begin - Iterate (Source.HT); + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + Iterate (Src_HT); + + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + exception + when others => + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + raise; end Iterate_Source_When_Empty_Target; else @@ -1464,9 +1541,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Target.HT.Buckets.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.HT.Length; + N : Count_Type renames Tgt_HT.Length; begin if B (J) = null then @@ -1527,14 +1604,38 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Start of processing for Iterate_Source begin - Iterate (Source.HT); + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + Iterate (Src_HT); + + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + exception + when others => + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + raise; end Iterate_Source; end if; end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -1570,10 +1671,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right.HT, L_Node) then + if not Is_In (Right_HT, L_Node) then declare E : Element_Type renames L_Node.Element.all; - J : constant Hash_Type := Hash (E) mod Buckets'Length; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); begin declare @@ -1594,7 +1702,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Start of processing for Iterate_Left begin - Iterate (Left.HT); + Iterate (Left_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -1613,10 +1721,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Process (R_Node : Node_Access) is begin - if not Is_In (Left.HT, R_Node) then + if not Is_In (Left_HT, R_Node) then declare E : Element_Type renames R_Node.Element.all; - J : constant Hash_Type := Hash (E) mod Buckets'Length; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); begin declare @@ -1637,7 +1752,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Start of processing for Iterate_Right begin - Iterate (Right.HT); + Iterate (Right_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -1735,8 +1850,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Union; function Union (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; + Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -1781,12 +1898,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Process; - -- Start of processing for Process + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + B : Integer renames Left_HT.Busy; + L : Integer renames Left_HT.Lock; + + -- Start of processing for Iterate_Left begin + B := B + 1; + L := L + 1; + Iterate (Left.HT); + + L := L - 1; + B := B - 1; exception when others => + L := L - 1; + B := B - 1; + HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1830,12 +1964,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Length := Length + 1; end Process; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + LB : Integer renames Left_HT.Busy; + LL : Integer renames Left_HT.Lock; + + RB : Integer renames Right_HT.Busy; + RL : Integer renames Right_HT.Lock; + -- Start of processing for Iterate_Right begin + LB := LB + 1; + LL := LL + 1; + + RB := RB + 1; + RL := RL + 1; + Iterate (Right.HT); + + RL := RL - 1; + RB := RB - 1; + + LL := LL - 1; + LB := LB - 1; exception when others => + RL := RL - 1; + RB := RB - 1; + + LL := LL - 1; + LB := LB - 1; + HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; @@ -1880,7 +2043,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end if; - X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all)); + X := HT.Buckets (Element_Keys.Checked_Index + (HT, + Position.Node.Element.all)); for J in 1 .. HT.Length loop if X = Position.Node then @@ -1974,8 +2139,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type is - Node : constant Node_Access := - Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin if Node = null then @@ -1987,7 +2152,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -2027,7 +2191,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in set"; end if; Free (X); @@ -2041,11 +2205,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin if Node = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in set"; end if; return Node.Element.all; @@ -2084,7 +2249,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin return (if Node = null then No_Element else Cursor'(Container'Unrestricted_Access, Node)); @@ -2240,7 +2406,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Vet (Position), "bad cursor in Update_Element_Preserving_Key"); - Indx := HT_Ops.Index (HT, Position.Node); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. declare E : Element_Type renames Position.Node.Element.all; @@ -2249,12 +2416,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is B : Natural renames HT.Busy; L : Natural renames HT.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin + Indx := HT_Ops.Index (HT, Position.Node); Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -2265,8 +2436,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); + if Eq then return; end if; end; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 17a3522d026..727941f2258 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -88,103 +88,132 @@ package Ada.Containers.Formal_Vectors is No_Element : constant Cursor; - function "=" (Left, Right : Vector) return Boolean; + function "=" (Left, Right : Vector) return Boolean with + Global => null; function To_Vector (New_Item : Element_Type; - Length : Count_Type) return Vector; + Length : Count_Type) return Vector + with + Global => null; - function "&" (Left, Right : Vector) return Vector; + function "&" (Left, Right : Vector) return Vector with + Global => null, + Pre => Capacity_Range'Last - Length (Left) >= Length (Right); - function "&" (Left : Vector; Right : Element_Type) return Vector; + function "&" (Left : Vector; Right : Element_Type) return Vector with + Global => null, + Pre => Length (Left) < Capacity_Range'Last; - function "&" (Left : Element_Type; Right : Vector) return Vector; + function "&" (Left : Element_Type; Right : Vector) return Vector with + Global => null, + Pre => Length (Right) < Capacity_Range'Last; - function "&" (Left, Right : Element_Type) return Vector; + function "&" (Left, Right : Element_Type) return Vector with + Global => null, + Pre => Capacity_Range'Last >= 2; - function Capacity (Container : Vector) return Count_Type; + function Capacity (Container : Vector) return Count_Type with + Global => null; procedure Reserve_Capacity (Container : in out Vector; Capacity : Count_Type) with - Pre => Capacity <= Container.Capacity; + Global => null, + Pre => Capacity <= Container.Capacity; - function Length (Container : Vector) return Count_Type; + function Length (Container : Vector) return Count_Type with + Global => null; procedure Set_Length (Container : in out Vector; New_Length : Count_Type) with - Pre => New_Length <= Length (Container); + Global => null, + Pre => New_Length <= Length (Container); - function Is_Empty (Container : Vector) return Boolean; + function Is_Empty (Container : Vector) return Boolean with + Global => null; - procedure Clear (Container : in out Vector); + procedure Clear (Container : in out Vector) with + Global => null; procedure Assign (Target : in out Vector; Source : Vector) with - Pre => Length (Source) <= Target.Capacity; + Global => null, + Pre => Length (Source) <= Target.Capacity; function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector with - Pre => Length (Source) <= Capacity and then Capacity in Capacity_Range; + Global => null, + Pre => Length (Source) <= Capacity and then Capacity in Capacity_Range; function To_Cursor (Container : Vector; - Index : Extended_Index) return Cursor; + Index : Extended_Index) return Cursor + with + Global => null; - function To_Index (Position : Cursor) return Extended_Index; + function To_Index (Position : Cursor) return Extended_Index with + Global => null; function Element (Container : Vector; Index : Index_Type) return Element_Type with - Pre => First_Index (Container) <= Index - and then Index <= Last_Index (Container); + Global => null, + Pre => First_Index (Container) <= Index + and then Index <= Last_Index (Container); function Element (Container : Vector; Position : Cursor) return Element_Type with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Replace_Element (Container : in out Vector; Index : Index_Type; New_Item : Element_Type) with - Pre => First_Index (Container) <= Index - and then Index <= Last_Index (Container); + Global => null, + Pre => First_Index (Container) <= Index + and then Index <= Last_Index (Container); procedure Replace_Element (Container : in out Vector; Position : Cursor; New_Item : Element_Type) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Move (Target : in out Vector; Source : in out Vector) with - Pre => Length (Source) <= Target.Capacity; + Global => null, + Pre => Length (Source) <= Target.Capacity; procedure Insert (Container : in out Vector; Before : Extended_Index; New_Item : Vector) with - Pre => First_Index (Container) <= Before - and then Before <= Last_Index (Container) + 1 - and then Length (Container) < Container.Capacity; + Global => null, + Pre => First_Index (Container) <= Before + and then Before <= Last_Index (Container) + 1 + and then Length (Container) < Container.Capacity; procedure Insert (Container : in out Vector; Before : Cursor; New_Item : Vector) with - Pre => Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Insert (Container : in out Vector; @@ -192,9 +221,10 @@ package Ada.Containers.Formal_Vectors is New_Item : Vector; Position : out Cursor) with - Pre => Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) < Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Insert (Container : in out Vector; @@ -202,9 +232,10 @@ package Ada.Containers.Formal_Vectors is New_Item : Element_Type; Count : Count_Type := 1) with - Pre => First_Index (Container) <= Before - and then Before <= Last_Index (Container) + 1 - and then Length (Container) + Count <= Container.Capacity; + Global => null, + Pre => First_Index (Container) <= Before + and then Before <= Last_Index (Container) + 1 + and then Length (Container) + Count <= Container.Capacity; procedure Insert (Container : in out Vector; @@ -212,9 +243,10 @@ package Ada.Containers.Formal_Vectors is New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) + Count <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Insert (Container : in out Vector; @@ -223,146 +255,187 @@ package Ada.Containers.Formal_Vectors is Position : out Cursor; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element); + Global => null, + Pre => Length (Container) + Count <= Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element); procedure Prepend (Container : in out Vector; New_Item : Vector) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Prepend (Container : in out Vector; New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity; + Global => null, + Pre => Length (Container) + Count <= Container.Capacity; procedure Append (Container : in out Vector; New_Item : Vector) with - Pre => Length (Container) < Container.Capacity; + Global => null, + Pre => Length (Container) < Container.Capacity; procedure Append (Container : in out Vector; New_Item : Element_Type; Count : Count_Type := 1) with - Pre => Length (Container) + Count <= Container.Capacity; + Global => null, + Pre => Length (Container) + Count <= Container.Capacity; procedure Delete (Container : in out Vector; Index : Extended_Index; Count : Count_Type := 1) with - Pre => First_Index (Container) <= Index - and then Index <= Last_Index (Container) + 1; + Global => null, + Pre => First_Index (Container) <= Index + and then Index <= Last_Index (Container) + 1; procedure Delete (Container : in out Vector; Position : in out Cursor; Count : Count_Type := 1) with - Pre => Has_Element (Container, Position); + Global => null, + Pre => Has_Element (Container, Position); procedure Delete_First (Container : in out Vector; - Count : Count_Type := 1); + Count : Count_Type := 1) + with + Global => null; procedure Delete_Last (Container : in out Vector; - Count : Count_Type := 1); + Count : Count_Type := 1) + with + Global => null; - procedure Reverse_Elements (Container : in out Vector); + procedure Reverse_Elements (Container : in out Vector) with + Global => null; procedure Swap (Container : in out Vector; I, J : Index_Type) with - Pre => First_Index (Container) <= I and then I <= Last_Index (Container) - and then First_Index (Container) <= J - and then J <= Last_Index (Container); + Global => null, + Pre => First_Index (Container) <= I + and then I <= Last_Index (Container) + and then First_Index (Container) <= J + and then J <= Last_Index (Container); procedure Swap (Container : in out Vector; I, J : Cursor) with - Pre => Has_Element (Container, I) and then Has_Element (Container, J); + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J); - function First_Index (Container : Vector) return Index_Type; + function First_Index (Container : Vector) return Index_Type with + Global => null; - function First (Container : Vector) return Cursor; + function First (Container : Vector) return Cursor with + Global => null; function First_Element (Container : Vector) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); - function Last_Index (Container : Vector) return Extended_Index; + function Last_Index (Container : Vector) return Extended_Index with + Global => null; - function Last (Container : Vector) return Cursor; + function Last (Container : Vector) return Cursor with + Global => null; function Last_Element (Container : Vector) return Element_Type with - Pre => not Is_Empty (Container); + Global => null, + Pre => not Is_Empty (Container); function Next (Container : Vector; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Next (Container : Vector; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Previous (Container : Vector; Position : Cursor) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; procedure Previous (Container : Vector; Position : in out Cursor) with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Find_Index (Container : Vector; Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index; + Index : Index_Type := Index_Type'First) return Extended_Index + with + Global => null; function Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Reverse_Find_Index (Container : Vector; Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index; + Index : Index_Type := Index_Type'Last) return Extended_Index + with + Global => null; function Reverse_Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Contains (Container : Vector; - Item : Element_Type) return Boolean; + Item : Element_Type) return Boolean + with + Global => null; - function Has_Element (Container : Vector; Position : Cursor) return Boolean; + function Has_Element (Container : Vector; Position : Cursor) return Boolean + with + Global => null; generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is - function Is_Sorted (Container : Vector) return Boolean; + function Is_Sorted (Container : Vector) return Boolean with + Global => null; - procedure Sort (Container : in out Vector); + procedure Sort (Container : in out Vector) with + Global => null; - procedure Merge (Target : in out Vector; Source : in out Vector); + procedure Merge (Target : in out Vector; Source : in out Vector) with + Global => null; end Generic_Sorting; - function Strict_Equal (Left, Right : Vector) return Boolean; + function Strict_Equal (Left, Right : Vector) return Boolean with + Global => null; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they -- have the same set of cursors. function Left (Container : Vector; Position : Cursor) return Vector with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; function Right (Container : Vector; Position : Cursor) return Vector with - Pre => Has_Element (Container, Position) or else Position = No_Element; + Global => null, + Pre => Has_Element (Container, Position) or else Position = No_Element; -- Left returns a container containing all elements preceding Position -- (excluded) in Container. Right returns a container containing all -- elements following Position (included) in Container. These two new diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 0616f4373ba..541e95a14e6 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -230,7 +230,8 @@ package body Ada.Containers.Hashed_Maps is (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -238,7 +239,6 @@ package body Ada.Containers.Hashed_Maps is end if; declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -351,7 +351,8 @@ package body Ada.Containers.Hashed_Maps is ------------- function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -484,7 +485,8 @@ package body Ada.Containers.Hashed_Maps is ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -978,7 +980,8 @@ package body Ada.Containers.Hashed_Maps is (Container : aliased in out Map; Key : Key_Type) return Reference_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); begin if Node = null then @@ -986,7 +989,6 @@ package body Ada.Containers.Hashed_Maps is end if; declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -1181,7 +1183,7 @@ package body Ada.Containers.Hashed_Maps is return False; end if; - X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key)); + X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key)); for J in 1 .. HT.Length loop if X = Position.Node then diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index f9e1b2aa8c0..6126db3a794 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -76,7 +76,7 @@ package body Ada.Containers.Hashed_Sets is Inserted : out Boolean); function Is_In - (HT : Hash_Table_Type; + (HT : aliased in out Hash_Table_Type; Key : Node_Access) return Boolean; pragma Inline (Is_In); @@ -337,6 +337,7 @@ package body Ada.Containers.Hashed_Sets is Source : Set) is Tgt_Node : Node_Access; + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; begin if Target'Address = Source'Address then @@ -344,7 +345,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Source.HT.Length = 0 then + if Src_HT.Length = 0 then return; end if; @@ -353,12 +354,12 @@ package body Ada.Containers.Hashed_Sets is "attempt to tamper with cursors (set is busy)"; end if; - if Source.HT.Length < Target.HT.Length then + if Src_HT.Length < Target.HT.Length then declare Src_Node : Node_Access; begin - Src_Node := HT_Ops.First (Source.HT); + Src_Node := HT_Ops.First (Src_HT); while Src_Node /= null loop Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); @@ -367,14 +368,14 @@ package body Ada.Containers.Hashed_Sets is Free (Tgt_Node); end if; - Src_Node := HT_Ops.Next (Source.HT, Src_Node); + Src_Node := HT_Ops.Next (Src_HT, Src_Node); end loop; end; else Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop - if Is_In (Source.HT, Tgt_Node) then + if Is_In (Src_HT, Tgt_Node) then declare X : Node_Access := Tgt_Node; begin @@ -391,19 +392,21 @@ package body Ada.Containers.Hashed_Sets is end Difference; function Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then return Empty_Set; end if; - if Left.HT.Length = 0 then + if Left_HT.Length = 0 then return Empty_Set; end if; - if Right.HT.Length = 0 then + if Right_HT.Length = 0 then return Left; end if; @@ -427,10 +430,15 @@ package body Ada.Containers.Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right.HT, L_Node) then + if not Is_In (Right_HT, L_Node) then declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + J : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); Bucket : Node_Access renames Buckets (J); @@ -445,7 +453,7 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Left begin - Iterate (Left.HT); + Iterate (Left_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -499,6 +507,20 @@ package body Ada.Containers.Hashed_Sets is pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + return Equivalent_Elements (Left.Node.Element, Right.Node.Element); end Equivalent_Elements; @@ -587,7 +609,8 @@ package body Ada.Containers.Hashed_Sets is (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Element_Keys.Find (HT, Item); begin if Node = null then @@ -807,6 +830,7 @@ package body Ada.Containers.Hashed_Sets is (Target : in out Set; Source : Set) is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; Tgt_Node : Node_Access; begin @@ -826,7 +850,7 @@ package body Ada.Containers.Hashed_Sets is Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop - if Is_In (Source.HT, Tgt_Node) then + if Is_In (Src_HT, Tgt_Node) then Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); else @@ -842,8 +866,10 @@ package body Ada.Containers.Hashed_Sets is end Intersection; function Intersection (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -876,10 +902,15 @@ package body Ada.Containers.Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if Is_In (Right.HT, L_Node) then + if Is_In (Right_HT, L_Node) then declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + J : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); Bucket : Node_Access renames Buckets (J); @@ -894,7 +925,7 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Left begin - Iterate (Left.HT); + Iterate (Left_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -917,7 +948,10 @@ package body Ada.Containers.Hashed_Sets is -- Is_In -- ----------- - function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean + is begin return Element_Keys.Find (HT, Key.Element) /= null; end Is_In; @@ -927,6 +961,8 @@ package body Ada.Containers.Hashed_Sets is --------------- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; + Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; Subset_Node : Node_Access; begin @@ -938,12 +974,12 @@ package body Ada.Containers.Hashed_Sets is return False; end if; - Subset_Node := HT_Ops.First (Subset.HT); + Subset_Node := HT_Ops.First (Subset_HT); while Subset_Node /= null loop - if not Is_In (Of_Set.HT, Subset_Node) then + if not Is_In (Of_Set_HT, Subset_Node) then return False; end if; - Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); + Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); end loop; return True; @@ -1072,6 +1108,8 @@ package body Ada.Containers.Hashed_Sets is ------------- function Overlap (Left, Right : Set) return Boolean is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; Left_Node : Node_Access; begin @@ -1083,12 +1121,12 @@ package body Ada.Containers.Hashed_Sets is return True; end if; - Left_Node := HT_Ops.First (Left.HT); + Left_Node := HT_Ops.First (Left_HT); while Left_Node /= null loop - if Is_In (Right.HT, Left_Node) then + if Is_In (Right_HT, Left_Node) then return True; end if; - Left_Node := HT_Ops.Next (Left.HT, Left_Node); + Left_Node := HT_Ops.Next (Left_HT, Left_Node); end loop; return False; @@ -1255,13 +1293,25 @@ package body Ada.Containers.Hashed_Sets is (Target : in out Set; Source : Set) is + Tgt_HT : Hash_Table_Type renames Target.HT; + Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TB : Natural renames Tgt_HT.Busy; + TL : Natural renames Tgt_HT.Lock; + + SB : Natural renames Src_HT.Busy; + SL : Natural renames Src_HT.Lock; + begin if Target'Address = Source'Address then Clear (Target); return; end if; - if Target.HT.Busy > 0 then + if TB > 0 then raise Program_Error with "attempt to tamper with cursors (set is busy)"; end if; @@ -1269,8 +1319,8 @@ package body Ada.Containers.Hashed_Sets is declare N : constant Count_Type := Target.Length + Source.Length; begin - if N > HT_Ops.Capacity (Target.HT) then - HT_Ops.Reserve_Capacity (Target.HT, N); + if N > HT_Ops.Capacity (Tgt_HT) then + HT_Ops.Reserve_Capacity (Tgt_HT, N); end if; end; @@ -1287,9 +1337,9 @@ package body Ada.Containers.Hashed_Sets is procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Target.HT.Buckets.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.HT.Length; + N : Count_Type renames Tgt_HT.Length; begin B (J) := new Node_Type'(E, B (J)); @@ -1299,7 +1349,29 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Source_When_Empty_Target begin - Iterate (Source.HT); + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + Iterate (Src_HT); + + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + exception + when others => + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + raise; end Iterate_Source_When_Empty_Target; else @@ -1315,9 +1387,9 @@ package body Ada.Containers.Hashed_Sets is procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Target.HT.Buckets.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.HT.Length; + N : Count_Type renames Tgt_HT.Length; begin if B (J) = null then @@ -1360,14 +1432,38 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Source begin - Iterate (Source.HT); + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + Iterate (Src_HT); + + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + exception + when others => + SL := SL - 1; + SB := SB - 1; + + TL := TL - 1; + TB := TB - 1; + + raise; end Iterate_Source; end if; end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -1403,10 +1499,17 @@ package body Ada.Containers.Hashed_Sets is procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right.HT, L_Node) then + if not Is_In (Right_HT, L_Node) then declare E : Element_Type renames L_Node.Element; - J : constant Hash_Type := Hash (E) mod Buckets'Length; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); begin Buckets (J) := new Node_Type'(E, Buckets (J)); @@ -1418,7 +1521,7 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Left begin - Iterate (Left.HT); + Iterate (Left_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -1437,10 +1540,17 @@ package body Ada.Containers.Hashed_Sets is procedure Process (R_Node : Node_Access) is begin - if not Is_In (Left.HT, R_Node) then + if not Is_In (Left_HT, R_Node) then declare E : Element_Type renames R_Node.Element; - J : constant Hash_Type := Hash (E) mod Buckets'Length; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); begin Buckets (J) := new Node_Type'(E, Buckets (J)); @@ -1452,7 +1562,7 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Iterate_Right begin - Iterate (Right.HT); + Iterate (Right_HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); @@ -1547,8 +1657,10 @@ package body Ada.Containers.Hashed_Sets is end Union; function Union (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; + Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin if Left'Address = Right'Address then @@ -1588,12 +1700,29 @@ package body Ada.Containers.Hashed_Sets is Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); end Process; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + B : Integer renames Left_HT.Busy; + L : Integer renames Left_HT.Lock; + -- Start of processing for Iterate_Left begin - Iterate (Left.HT); + B := B + 1; + L := L + 1; + + Iterate (Left_HT); + + L := L - 1; + B := B - 1; exception when others => + L := L - 1; + B := B - 1; + HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1629,12 +1758,41 @@ package body Ada.Containers.Hashed_Sets is Length := Length + 1; end Process; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + LB : Integer renames Left_HT.Busy; + LL : Integer renames Left_HT.Lock; + + RB : Integer renames Right_HT.Busy; + RL : Integer renames Right_HT.Lock; + -- Start of processing for Iterate_Right begin - Iterate (Right.HT); + LB := LB + 1; + LL := LL + 1; + + RB := RB + 1; + RL := RL + 1; + + Iterate (Right_HT); + + RL := RL - 1; + RB := RB - 1; + + LL := LL - 1; + LB := LB - 1; exception when others => + RL := RL - 1; + RB := RB - 1; + + LL := LL - 1; + LB := LB - 1; + HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; @@ -1675,7 +1833,9 @@ package body Ada.Containers.Hashed_Sets is return False; end if; - X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element)); + X := HT.Buckets (Element_Keys.Checked_Index + (HT, + Position.Node.Element)); for J in 1 .. HT.Length loop if X = Position.Node then @@ -1769,7 +1929,8 @@ package body Ada.Containers.Hashed_Sets is (Container : aliased Set; Key : Key_Type) return Constant_Reference_Type is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin if Node = null then @@ -1777,7 +1938,6 @@ package body Ada.Containers.Hashed_Sets is end if; declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; B : Natural renames HT.Busy; L : Natural renames HT.Lock; begin @@ -1831,11 +1991,12 @@ package body Ada.Containers.Hashed_Sets is (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin if Node = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in set"; end if; return Node.Element; @@ -1875,7 +2036,8 @@ package body Ada.Containers.Hashed_Sets is (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); begin if Node = null then @@ -2016,7 +2178,8 @@ package body Ada.Containers.Hashed_Sets is (Vet (Position), "bad cursor in Update_Element_Preserving_Key"); - Indx := HT_Ops.Index (HT, Position.Node); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. declare E : Element_Type renames Position.Node.Element; @@ -2025,12 +2188,16 @@ package body Ada.Containers.Hashed_Sets is B : Natural renames HT.Busy; L : Natural renames HT.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin + Indx := HT_Ops.Index (HT, Position.Node); Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -2041,8 +2208,7 @@ package body Ada.Containers.Hashed_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); + if Eq then return; end if; end; diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb index 4c70a560d8f..1e1a2d9b2c9 100644 --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -272,6 +272,12 @@ package body Adabkend is elsif not Is_Switch (Argv) then Add_File (Argv); + -- We must recognize -nostdinc to suppress visibility on the + -- standard GNAT RTL sources. + + elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + -- Front end switch elsif Is_Front_End_Switch (Argv) then diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b93d220f4db..cd850889821 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -6454,11 +6454,11 @@ pragma Stream_Convert ( @end smallexample @noindent -This pragma provides an efficient way of providing stream functions for -types defined in packages. Not only is it simpler to use than declaring -the necessary functions with attribute representation clauses, but more -significantly, it allows the declaration to made in such a way that the -stream packages are not loaded unless they are needed. The use of +This pragma provides an efficient way of providing user-defined stream +attributes. Not only is it simpler to use than specifying the attributes +directly, but more importantly, it allows the specification to be made in such +a way that the predefined unit Ada.Streams is not loaded unless it is actually +needed (i.e. unless the stream attributes are actually used); the use of the Stream_Convert pragma adds no overhead at all, unless the stream attributes are actually used on the designated type. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1b102b43a9a..42cb142a84a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2333,187 +2333,17 @@ package body Sem_Prag is -------------------------------------------- procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is - Pack_Id : constant Entity_Id := Defining_Entity (Parent (Parent (N))); - Prag_Init : constant Node_Id := - Get_Pragma (Pack_Id, Pragma_Initializes); - -- The related pragma Initializes - - Vars : Elist_Id := No_Elist; - -- A list of all variables declared in pragma Initializes - - procedure Collect_Variables; - -- Inspect the initialization list of pragma Initializes and collect the - -- entities of all variables declared within the related package. - - function Match_Variable (N : Node_Id) return Traverse_Result; - -- Determine whether arbitrary node N denotes a variable declared in the - -- visible declarations of the related package. - - procedure Report_Unused_Variables; - -- Emit errors for all variables found in list Vars - - ----------------------- - -- Collect_Variables -- - ----------------------- - - procedure Collect_Variables is - procedure Collect_Variable (Item : Node_Id); - -- Determine whether Item denotes a variable that appears in the - -- related package and if it does, add it to list Vars. - - ---------------------- - -- Collect_Variable -- - ---------------------- - - procedure Collect_Variable (Item : Node_Id) is - Item_Id : Entity_Id; - - begin - if Is_Entity_Name (Item) and then Present (Entity (Item)) then - Item_Id := Entity (Item); - - -- The item is a variable declared in the related package - - if Ekind (Item_Id) = E_Variable - and then Scope (Item_Id) = Pack_Id - then - Add_Item (Item_Id, Vars); - end if; - end if; - end Collect_Variable; - - -- Local variables - - Inits : constant Node_Id := - Get_Pragma_Arg - (First (Pragma_Argument_Associations (Prag_Init))); - Init : Node_Id; - - -- Start of processing for Collect_Variables - - begin - -- Multiple initialization items appear as an aggregate - - if Nkind (Inits) = N_Aggregate - and then Present (Expressions (Inits)) - then - Init := First (Expressions (Inits)); - while Present (Init) loop - Collect_Variable (Init); - - Next (Init); - end loop; - - -- Single initialization item - - else - Collect_Variable (Inits); - end if; - end Collect_Variables; - - -------------------- - -- Match_Variable -- - -------------------- - - function Match_Variable (N : Node_Id) return Traverse_Result is - Var_Id : Entity_Id; - - begin - -- Find a variable declared within the related package and try to - -- remove it from the list of collected variables found in pragma - -- Initializes. - - if Is_Entity_Name (N) - and then Present (Entity (N)) - then - Var_Id := Entity (N); - - if Ekind (Var_Id) = E_Variable - and then Scope (Var_Id) = Pack_Id - then - Remove (Vars, Var_Id); - end if; - end if; - - return OK; - end Match_Variable; - - procedure Match_Variables is new Traverse_Proc (Match_Variable); - - ----------------------------- - -- Report_Unused_Variables -- - ----------------------------- - - procedure Report_Unused_Variables is - Posted : Boolean := False; - Var_Elmt : Elmt_Id; - Var_Id : Entity_Id; - - begin - if Present (Vars) then - Var_Elmt := First_Elmt (Vars); - while Present (Var_Elmt) loop - Var_Id := Node (Var_Elmt); - - if not Posted then - Posted := True; - Error_Msg_Name_1 := Name_Initial_Condition; - Error_Msg_N - ("expression of % must mention the following variables", - N); - end if; - - Error_Msg_Sloc := Sloc (Var_Id); - Error_Msg_NE ("\ & declared #", N, Var_Id); - - Next_Elmt (Var_Elmt); - end loop; - end if; - end Report_Unused_Variables; - - Expr : constant Node_Id := - Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); - Errors : constant Nat := Serious_Errors_Detected; - - -- Start of processing for Analyze_Initial_Condition_In_Decl_Part + Expr : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); begin Set_Analyzed (N); - -- Pragma Initial_Condition depends on the names enumerated in pragma - -- Initializes. Without those, the analysis cannot take place. - - if No (Prag_Init) then - Error_Msg_Name_1 := Name_Initial_Condition; - Error_Msg_Name_2 := Name_Initializes; - - Error_Msg_N ("% requires the presence of aspect or pragma %", N); - return; - end if; - -- The expression is preanalyzed because it has not been moved to its -- final place yet. A direct analysis may generate side effects and this -- is not desired at this point. Preanalyze_And_Resolve (Expr, Standard_Boolean); - - -- Perform variable matching only when the expression is legal - - if Serious_Errors_Detected = Errors then - Collect_Variables; - - -- Verify that all variables mentioned in pragma Initializes are used - -- in the expression of pragma Initial_Condition. - - Match_Variables (Expr); - end if; - - -- Emit errors for all variables that should participate in the - -- expression of pragma Initial_Condition. - - if Serious_Errors_Detected = Errors then - Report_Unused_Variables; - end if; end Analyze_Initial_Condition_In_Decl_Part; -------------------------------------- diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 01ea5d56cbd..352ac0783a7 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -649,6 +649,7 @@ package body Tbuild is (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is + pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity); Occurrence : Node_Id; begin @@ -725,7 +726,7 @@ package body Tbuild is (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is - pragma Assert (Nkind (Def_Id) in N_Entity); + pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity); Occurrence : Node_Id; begin Occurrence := New_Node (N_Identifier, Loc); -- 2.30.2