path: root/gcc/ada/s-htable.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                        S Y S T E M . H T A B L E                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 1995-2011, 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 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/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

pragma Compiler_Unit;

with Ada.Unchecked_Deallocation;
with System.String_Hash;

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;

      -------------
      -- Present --
      -------------

      function Present (K : Key) return Boolean is
      begin
         return Get (K) /= Null_Ptr;
      end Present;

      ------------
      -- 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;

      ------------------------
      -- Set_If_Not_Present --
      ------------------------

      function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
         K : Key renames Get_Key (E);
         --  Note that it is important to use a renaming here rather than
         --  define a constant initialized by the call, because the latter
         --  construct runs into bootstrap problems with earlier versions
         --  of the GNAT compiler.

         Index : constant Header_Num := Hash (K);
         Elmt  : Elmt_Ptr;

      begin
         Elmt := Table (Index);
         loop
            if Elmt = Null_Ptr then
               Set_Next (E, Table (Index));
               Table (Index) := E;
               return True;

            elsif Equal (Get_Key (Elmt), K) then
               return False;

            else
               Elmt := Next (Elmt);
            end if;
         end loop;
      end Set_If_Not_Present;

   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;

      procedure Get_First (K : in out Key; E : out Element) is
         Tmp : constant Elmt_Ptr := Tab.Get_First;
      begin
         if Tmp = null then
            E := No_Element;
         else
            K := Tmp.K;
            E := 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;

      procedure Get_Next (K : in out Key; E : out Element) is
         Tmp : constant Elmt_Ptr := Tab.Get_Next;
      begin
         if Tmp = null then
            E := No_Element;
         else
            K := Tmp.K;
            E := 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 Hash_Fun is
         new System.String_Hash.Hash (Character, String, Uns);

   begin
      return Header_Num'First +
        Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);
   end Hash;

end System.HTable;