diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/a-cihama.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/a-cihama.adb | 1082 |
1 files changed, 0 insertions, 1082 deletions
diff --git a/gcc-4.4.3/gcc/ada/a-cihama.adb b/gcc-4.4.3/gcc/ada/a-cihama.adb deleted file mode 100644 index ab8660ba8..000000000 --- a/gcc-4.4.3/gcc/ada/a-cihama.adb +++ /dev/null @@ -1,1082 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, 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_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); - -with Ada.Containers.Hash_Tables.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); - -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Indefinite_Hashed_Maps is - - procedure Free_Key is - new Ada.Unchecked_Deallocation (Key_Type, Key_Access); - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Node : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Key_Node); - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - procedure Free (X : in out Node_Access); - -- pragma Inline (Free); - - function Hash_Node (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Access) return Node_Access; - pragma Inline (Next); - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - - procedure Set_Next (Node : Node_Access; Next : Node_Access); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is - new Ada.Containers.Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Key_Ops is - new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - --------- - -- "=" -- - --------- - - function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); - - function "=" (Left, Right : Map) return Boolean is - begin - return Is_Equal (Left.HT, Right.HT); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Map) is - begin - HT_Ops.Adjust (Container.HT); - end Adjust; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return HT_Ops.Capacity (Container.HT); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container.HT); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Node : Node_Access) return Node_Access is - K : Key_Access := new Key_Type'(Node.Key.all); - E : Element_Access; - - begin - E := new Element_Type'(Node.Element.all); - return new Node_Type'(K, E, null); - - exception - when others => - Free_Key (K); - Free_Element (E); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Node_Access; - - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - - if X = null then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - if Container.HT.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with elements (map is busy)"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); - - Free (Position.Node); - Position.Container := null; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); - - begin - if Node = null then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Node.Element.all; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with - "Position cursor of function Element is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Node.Element.all; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean - is - begin - return Equivalent_Keys (Key, Node.Key.all); - end Equivalent_Key_Node; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Cursor) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - if Left.Node.Key = null then - raise Program_Error with - "Left cursor of Equivalent_Keys is bad"; - end if; - - if Right.Node.Key = null then - raise Program_Error with - "Right cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean - is - begin - if Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Left.Node.Key = null then - raise Program_Error with - "Left cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left.Node.Key.all, Right); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean - is - begin - if Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - if Right.Node.Key = null then - raise Program_Error with - "Right cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left, Right.Node.Key.all); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Node_Access; - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Map) is - begin - HT_Ops.Finalize (Container.HT); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unchecked_Access, Node); - end Find; - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all); - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - while R_Node /= null loop - if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then - return L_Node.Element.all = R_Node.Element.all; - end if; - - R_Node := R_Node.Next; - end loop; - - return False; - end Find_Equal_Key; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container.HT); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unchecked_Access, Node); - end First; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - begin - if X = null then - return; - end if; - - X.Next := X; -- detect mischief (in Vet) - - begin - Free_Key (X.Key); - exception - when others => - X.Key := null; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - end; - - Deallocate (X); - raise; - end; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Key.all); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - K : Key_Access; - E : Element_Access; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with cursors (map is locked)"; - end if; - - K := Position.Node.Key; - E := Position.Node.Element; - - Position.Node.Key := new Key_Type'(Key); - - begin - Position.Node.Element := new Element_Type'(New_Item); - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - K : Key_Access := new Key_Type'(Key); - E : Element_Access; - - begin - E := new Element_Type'(New_Item); - return new Node_Type'(K, E, Next); - exception - when others => - Free_Key (K); - Free_Element (E); - raise; - end New_Node; - - HT : Hash_Table_Type renames Container.HT; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - Local_Insert (HT, Key, Position.Node, Inserted); - - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.HT.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unchecked_Access, Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.HT.Busy; - - -- Start of processing Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - if Position.Node.Key = null then - raise Program_Error with - "Position cursor of function Key is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Position.Node.Key.all; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.HT.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - begin - HT_Ops.Move (Target => Target.HT, Source => Source.HT); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - end if; - - if Position.Node.Key = null - or else Position.Node.Element = null - then - raise Program_Error with "Position cursor of Next is bad"; - end if; - - pragma Assert (Vet (Position), "Position cursor of Next is bad"); - - declare - HT : Hash_Table_Type renames Position.Container.HT; - Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - if Position.Node.Key = null - or else Position.Node.Element = null - then - raise Program_Error with - "Position cursor of Query_Element is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - begin - Read_Nodes (Stream, Container.HT); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - - begin - begin - Node.Key := new Key_Type'(Key_Type'Input (Stream)); - exception - when others => - Free (Node); - raise; - end; - - begin - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - exception - when others => - Free_Key (Node.Key); - Free (Node); - raise; - end; - - return Node; - end Read_Node; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); - - K : Key_Access; - E : Element_Access; - - begin - if Node = null then - raise Constraint_Error with - "attempt to replace key not in map"; - end if; - - if Container.HT.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with cursors (map is locked)"; - end if; - - K := Node.Key; - E := Node.Element; - - Node.Key := new Key_Type'(Key); - - begin - Node.Element := new Element_Type'(New_Item); - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Position.Node.Key = null - or else Position.Node.Element = null - then - raise Program_Error with - "Position cursor of Replace_Element is bad"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - if Position.Container.HT.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with cursors (map is locked)"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - declare - X : Element_Access := Position.Node.Element; - - begin - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - HT_Ops.Reserve_Capacity (Container.HT, Capacity); - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : Node_Access; Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Position.Node.Key = null - or else Position.Node.Element = null - then - raise Program_Error with - "Position cursor of Update_Element is bad"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - HT : Hash_Table_Type renames Container.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - if Position.Node.Next = Position.Node then - return False; - end if; - - if Position.Node.Key = null then - return False; - end if; - - if Position.Node.Element = null then - return False; - end if; - - declare - HT : Hash_Table_Type renames Position.Container.HT; - X : Node_Access; - - begin - if HT.Length = 0 then - return False; - end if; - - if HT.Buckets = null - or else HT.Buckets'Length = 0 - then - return False; - end if; - - X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all)); - - for J in 1 .. HT.Length loop - if X = Position.Node then - return True; - end if; - - if X = null then - return False; - end if; - - if X = X.Next then -- to prevent endless loop - return False; - end if; - - X := X.Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - begin - Write_Nodes (Stream, Container.HT); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Key_Type'Output (Stream, Node.Key.all); - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - -end Ada.Containers.Indefinite_Hashed_Maps; |