diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/a-cbhase.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/a-cbhase.adb | 1919 |
1 files changed, 0 insertions, 1919 deletions
diff --git a/gcc-4.8/gcc/ada/a-cbhase.adb b/gcc-4.8/gcc/ada/a-cbhase.adb deleted file mode 100644 index cc60762ed..000000000 --- a/gcc-4.8/gcc/ada/a-cbhase.adb +++ /dev/null @@ -1,1919 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2012, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); - -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; -with Ada.Finalization; use Ada.Finalization; - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Hashed_Sets is - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - function Is_In (HT : Set; Key : Node_Type) return Boolean; - pragma Inline (Is_In); - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type); - pragma Inline (Set_Element); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Element_Keys is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equal_Key); - - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Count_Type := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = 0 then - return False; - end if; - - if L_Node.Element = R_HT.Nodes (R_Node).Element then - return True; - end if; - - R_Node := Next (R_HT.Nodes (R_Node)); - end loop; - end Find_Equal_Key; - - -- Start of processing for "=" - - begin - return Is_Equal (Left, Right); - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - B : Boolean; - begin - Insert (Target, N.Element, X, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Capacity_Error - with "Target capacity is less than Source length"; - end if; - - HT_Ops.Clear (Target); - Insert_Elements (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return Container.Capacity; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return (Element => N.Element'Access); - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0; - Modulus : Hash_Type := 0) return Set - is - C : Count_Type; - M : Hash_Type; - - begin - if Capacity = 0 then - C := Source.Length; - elsif Capacity >= Source.Length then - C := Capacity; - else - raise Capacity_Error with "Capacity value too small"; - end if; - - if Modulus = 0 then - M := Default_Modulus (C); - else - M := Modulus; - end if; - - return Target : Set (Capacity => C, Modulus => M) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Item : Element_Type) - is - X : Count_Type; - - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - HT_Ops.Free (Container, X); - end Delete; - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - is - begin - if Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - HT_Ops.Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Target : in out Set; - Source : Set) - is - Tgt_Node, Src_Node : Count_Type; - - TN : Nodes_Type renames Target.Nodes; - SN : Nodes_Type renames Source.Nodes; - - begin - if Target'Address = Source'Address then - HT_Ops.Clear (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; - - if Source.Length < Target.Length then - Src_Node := HT_Ops.First (Source); - while Src_Node /= 0 loop - Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); - - if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); - HT_Ops.Free (Target, Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Source, Src_Node); - end loop; - - else - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Is_In (Source, TN (Tgt_Node)) then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - HT_Ops.Free (Target, X); - end; - - else - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - end if; - end loop; - end if; - end Difference; - - function Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Left.Length = 0 then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - return Result : Set (Left.Length, To_Prime (Left.Length)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Right, N) then - Insert (Result, N.Element, X, B); -- optimize this ??? - pragma Assert (B); - pragma Assert (X > 0); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - declare - S : Set renames Position.Container.all; - N : Node_Type renames S.Nodes (Position.Node); - begin - return N.Element; - end; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Count_Type := R_HT.Buckets (R_Index); - - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then - return True; - end if; - - R_Node := HT_Ops.Next (R_HT, R_Node); - end loop; - end Find_Equivalent_Key; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left, Right); - end Equivalent_Sets; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Cursor) - return Boolean is - - begin - if Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - if Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - RN : Node_Type renames Right.Container.Nodes (Right.Node); - begin - return Equivalent_Elements (LN.Element, RN.Element); - end; - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean - is - begin - if Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - begin - return Equivalent_Elements (LN.Element, Right); - end; - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean - is - begin - if Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert - (Vet (Right), - "Right cursor of Equivalent_Elements is bad"); - - declare - RN : Node_Type renames Right.Container.Nodes (Right.Node); - begin - return Equivalent_Elements (Left, RN.Element); - end; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - is - X : Count_Type; - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - HT_Ops.Free (Container, X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - Node : constant Count_Type := Element_Keys.Find (Container, Item); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end First; - - overriding function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= 0; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; - - Container.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Allocate_Set_Element (Node : in out Node_Type); - pragma Inline (Allocate_Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Allocate_Set_Element); - - --------------------------- - -- Allocate_Set_Element -- - --------------------------- - - procedure Allocate_Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Allocate_Set_Element; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - -- The buckets array length is specified by the user as a discriminant - -- of the container type, so it is possible for the buckets array to - -- have a length of zero. We must check for this case specifically, in - -- order to prevent divide-by-zero errors later, when we compute the - -- buckets array index value for an element, given its hash value. - - if Container.Buckets'Length = 0 then - raise Capacity_Error with "No capacity for insertion"; - end if; - - Local_Insert (Container, New_Item, Node, Inserted); - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Set; - Source : Set) - is - Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.Nodes; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Length = 0 then - HT_Ops.Clear (Target); - return; - end if; - - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; - - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Is_In (Source, TN (Tgt_Node)) then - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - - else - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - HT_Ops.Free (Target, X); - end; - end if; - end loop; - end Intersection; - - function Intersection (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - C := Count_Type'Min (Left.Length, Right.Length); - - if C = 0 then - return Empty_Set; - end if; - - return Result : Set (C, To_Prime (C)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - - begin - if Is_In (Right, N) then - Insert (Result, N.Element, X, B); -- optimize ??? - pragma Assert (B); - pragma Assert (X > 0); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In (HT : Set; Key : Node_Type) return Boolean is - begin - return Element_Keys.Find (HT, Key.Element) /= 0; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_Node : Count_Type; - SN : Nodes_Type renames Subset.Nodes; - - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - Subset_Node := HT_Ops.First (Subset); - while Subset_Node /= 0 loop - if not Is_In (Of_Set, SN (Subset_Node)) then - return False; - end if; - Subset_Node := HT_Ops.Next (Subset, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.all.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class - is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin - B := B + 1; - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access); - end Iterate; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - HT : Set renames Position.Container.all; - Node : constant Count_Type := HT_Ops.Next (HT, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_Node : Count_Type; - - begin - if Right.Length = 0 then - return False; - end if; - - if Left'Address = Right'Address then - return True; - end if; - - Left_Node := HT_Ops.First (Left); - while Left_Node /= 0 loop - if Is_In (Right, Left.Nodes (Left_Node)) then - return True; - end if; - Left_Node := HT_Ops.Next (Left, Left_Node); - end loop; - - return False; - end Overlap; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - S : Set renames Position.Container.all; - B : Natural renames S.Busy; - L : Natural renames S.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (S.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Read_Element); - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - is - Node : constant Count_Type := Element_Keys.Find (Container, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; - - Container.Nodes (Node).Element := New_Item; - end Replace; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - ------------------ - -- Set_Element -- - ------------------ - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is - begin - Node.Element := Item; - end Set_Element; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Set; - Source : Set) - is - procedure Process (Source_Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - B : Boolean; - - begin - if Is_In (Target, N) then - Delete (Target, N.Element); - else - Insert (Target, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Symmetric_Difference - - begin - if Target'Address = Source'Address then - HT_Ops.Clear (Target); - return; - end if; - - if Target.Length = 0 then - Assign (Target => Target, Source => Source); - return; - end if; - - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; - - Iterate (Source); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - C := Left.Length + Right.Length; - - return Result : Set (C, To_Prime (C)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Right, N) then - Insert (Result, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - - Iterate_Right : declare - procedure Process (R_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (R_Node : Count_Type) is - N : Node_Type renames Right.Nodes (R_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Left, N) then - Insert (Result, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Iterate_Right - - begin - Iterate (Right); - end Iterate_Right; - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - X : Count_Type; - B : Boolean; - begin - return Result : Set (1, 1) do - Insert (Result, New_Item, X, B); - pragma Assert (B); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union - (Target : in out Set; - Source : Set) - is - procedure Process (Src_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Src_Node); - X : Count_Type; - B : Boolean; - begin - Insert (Target, N.Element, X, B); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; - - -- ??? why is this code commented out ??? - -- 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); - -- end if; - -- end; - - Iterate (Source); - end Union; - - function Union (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - C := Left.Length + Right.Length; - - return Result : Set (C, To_Prime (C)) do - Assign (Target => Result, Source => Left); - Union (Target => Result, Source => Right); - end return; - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - declare - S : Set renames Position.Container.all; - N : Nodes_Type renames S.Nodes; - X : Count_Type; - - begin - if S.Length = 0 then - return False; - end if; - - if Position.Node > N'Last then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); - - for J in 1 .. S.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = N (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := N (X).Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - begin - return (Element => N.Element'Access); - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Key : Key_Type) - is - X : Count_Type; - - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - HT_Ops.Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; -- ??? "set" - end if; - - return Container.Nodes (Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Key : Key_Type) - is - X : Count_Type; - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - HT_Ops.Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - return Key (Position.Container.Nodes (Position.Node).Element); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in function Reference_Preserving_Key"); - - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return (Element => N.Element'Access); - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - begin - return (Element => N.Element'Access); - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - Indx : Hash_Type; - N : Nodes_Type renames Container.Nodes; - - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - -- ??? why is this code commented out ??? - -- if HT.Buckets = null - -- or else HT.Buckets'Length = 0 - -- or else HT.Length = 0 - -- or else Position.Node.Next = Position.Node - -- then - -- raise Program_Error with - -- "Position cursor is bad (set is empty)"; - -- end if; - - pragma Assert - (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)); - - declare - E : Element_Type renames N (Position.Node).Element; - K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); - return; - end if; - end; - - -- Key was modified, so remove this node from set. - - if Container.Buckets (Indx) = Position.Node then - Container.Buckets (Indx) := N (Position.Node).Next; - - else - declare - Prev : Count_Type := Container.Buckets (Indx); - - begin - while N (Prev).Next /= Position.Node loop - Prev := N (Prev).Next; - - if Prev = 0 then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - N (Prev).Next := N (Position.Node).Next; - end; - end if; - - Container.Length := Container.Length - 1; - HT_Ops.Free (Container, Position.Node); - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - -end Ada.Containers.Bounded_Hashed_Sets; |