diff options
Diffstat (limited to 'gcc/ada/a-cihase.adb')
| -rw-r--r-- | gcc/ada/a-cihase.adb | 282 |
1 files changed, 226 insertions, 56 deletions
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; |