diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-htable.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/s-htable.adb | 363 |
1 files changed, 0 insertions, 363 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-htable.adb b/gcc-4.4.0/gcc/ada/s-htable.adb deleted file mode 100644 index 9dbb7f984..000000000 --- a/gcc-4.4.0/gcc/ada/s-htable.adb +++ /dev/null @@ -1,363 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . H T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2007, AdaCore -- --- -- --- 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 2, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); -pragma Compiler_Unit; -pragma Warnings (On); - -with Ada.Unchecked_Deallocation; - -package body System.HTable is - - ------------------- - -- Static_HTable -- - ------------------- - - package body Static_HTable is - - Table : array (Header_Num) of Elmt_Ptr; - - Iterator_Index : Header_Num; - Iterator_Ptr : Elmt_Ptr; - Iterator_Started : Boolean := False; - - function Get_Non_Null return Elmt_Ptr; - -- Returns Null_Ptr if Iterator_Started is false or the Table is empty. - -- Returns Iterator_Ptr if non null, or the next non null element in - -- table if any. - - --------- - -- Get -- - --------- - - function Get (K : Key) return Elmt_Ptr is - Elmt : Elmt_Ptr; - - begin - Elmt := Table (Hash (K)); - - loop - if Elmt = Null_Ptr then - return Null_Ptr; - - elsif Equal (Get_Key (Elmt), K) then - return Elmt; - - else - Elmt := Next (Elmt); - end if; - end loop; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First return Elmt_Ptr is - begin - Iterator_Started := True; - Iterator_Index := Table'First; - Iterator_Ptr := Table (Iterator_Index); - return Get_Non_Null; - end Get_First; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next return Elmt_Ptr is - begin - if not Iterator_Started then - return Null_Ptr; - end if; - - Iterator_Ptr := Next (Iterator_Ptr); - return Get_Non_Null; - end Get_Next; - - ------------------ - -- Get_Non_Null -- - ------------------ - - function Get_Non_Null return Elmt_Ptr is - begin - while Iterator_Ptr = Null_Ptr loop - if Iterator_Index = Table'Last then - Iterator_Started := False; - return Null_Ptr; - end if; - - Iterator_Index := Iterator_Index + 1; - Iterator_Ptr := Table (Iterator_Index); - end loop; - - return Iterator_Ptr; - end Get_Non_Null; - - ------------ - -- Remove -- - ------------ - - procedure Remove (K : Key) is - Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr; - Next_Elmt : Elmt_Ptr; - - begin - Elmt := Table (Index); - - if Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Elmt), K) then - Table (Index) := Next (Elmt); - - else - loop - Next_Elmt := Next (Elmt); - - if Next_Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Next_Elmt), K) then - Set_Next (Elmt, Next (Next_Elmt)); - return; - - else - Elmt := Next_Elmt; - end if; - end loop; - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - for J in Table'Range loop - Table (J) := Null_Ptr; - end loop; - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (E : Elmt_Ptr) is - Index : Header_Num; - - begin - Index := Hash (Get_Key (E)); - Set_Next (E, Table (Index)); - Table (Index) := E; - end Set; - - end Static_HTable; - - ------------------- - -- Simple_HTable -- - ------------------- - - package body Simple_HTable is - - type Element_Wrapper; - type Elmt_Ptr is access all Element_Wrapper; - type Element_Wrapper is record - K : Key; - E : Element; - Next : Elmt_Ptr; - end record; - - procedure Free is new - Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - function Next (E : Elmt_Ptr) return Elmt_Ptr; - function Get_Key (E : Elmt_Ptr) return Key; - - package Tab is new Static_HTable ( - Header_Num => Header_Num, - Element => Element_Wrapper, - Elmt_Ptr => Elmt_Ptr, - Null_Ptr => null, - Set_Next => Set_Next, - Next => Next, - Key => Key, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); - - --------- - -- Get -- - --------- - - function Get (K : Key) return Element is - Tmp : constant Elmt_Ptr := Tab.Get (K); - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First return Element is - Tmp : constant Elmt_Ptr := Tab.Get_First; - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_First; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (E : Elmt_Ptr) return Key is - begin - return E.K; - end Get_Key; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next return Element is - Tmp : constant Elmt_Ptr := Tab.Get_Next; - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_Next; - - ---------- - -- Next -- - ---------- - - function Next (E : Elmt_Ptr) return Elmt_Ptr is - begin - return E.Next; - end Next; - - ------------ - -- Remove -- - ------------ - - procedure Remove (K : Key) is - Tmp : Elmt_Ptr; - - begin - Tmp := Tab.Get (K); - - if Tmp /= null then - Tab.Remove (K); - Free (Tmp); - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - E1, E2 : Elmt_Ptr; - - begin - E1 := Tab.Get_First; - while E1 /= null loop - E2 := Tab.Get_Next; - Free (E1); - E1 := E2; - end loop; - - Tab.Reset; - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (K : Key; E : Element) is - Tmp : constant Elmt_Ptr := Tab.Get (K); - begin - if Tmp = null then - Tab.Set (new Element_Wrapper'(K, E, null)); - else - Tmp.E := E; - end if; - end Set; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is - begin - E.Next := Next; - end Set_Next; - end Simple_HTable; - - ---------- - -- Hash -- - ---------- - - function Hash (Key : String) return Header_Num is - - type Uns is mod 2 ** 32; - - function Rotate_Left (Value : Uns; Amount : Natural) return Uns; - pragma Import (Intrinsic, Rotate_Left); - - Hash_Value : Uns; - - begin - Hash_Value := 0; - for J in Key'Range loop - Hash_Value := Rotate_Left (Hash_Value, 3) + Character'Pos (Key (J)); - end loop; - - return Header_Num'First + - Header_Num'Base (Hash_Value mod Header_Num'Range_Length); - end Hash; - -end System.HTable; |