gcc/ada/a-chtgke.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      A D A . C O N T A I N E R S .                       --
   6 --             H A S H _ T A B L E S . G E N E R I C _ K E Y S              --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- This specification is derived from the Ada Reference Manual for use with --
  13 -- GNAT. The copyright notice above, and the license provisions that follow --
  14 -- apply solely to the  contents of the part following the private keyword. --
  15 --                                                                          --
  16 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  17 -- terms of the  GNU General Public License as published  by the Free Soft- --
  18 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  19 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  20 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  21 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  22 -- for  more details.  You should have  received  a copy of the GNU General --
  23 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  24 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  25 -- Boston, MA 02110-1301, USA.                                              --
  26 --                                                                          --
  27 -- As a special exception,  if other files  instantiate  generics from this --
  28 -- unit, or you link  this unit with other files  to produce an executable, --
  29 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  30 -- covered  by the  GNU  General  Public  License.  This exception does not --
  31 -- however invalidate  any other reasons why  the executable file  might be --
  32 -- covered by the  GNU Public License.                                      --
  33 --                                                                          --
  34 -- This unit was originally developed by Matthew J Heaney.                  --
  35 ------------------------------------------------------------------------------
  36
  37 package body Ada.Containers.Hash_Tables.Generic_Keys is
  38
  39    --------------------------
  40    -- Delete_Key_Sans_Free --
  41    --------------------------
  42
  43    procedure Delete_Key_Sans_Free
  44      (HT   : in out Hash_Table_Type;
  45       Key  : Key_Type;
  46       X    : out Node_Access)
  47    is
  48       Indx : Hash_Type;
  49       Prev : Node_Access;
  50
  51    begin
  52       if HT.Length = 0 then
  53          X := null;
  54          return;
  55       end if;
  56
  57       Indx := Index (HT, Key);
  58       X := HT.Buckets (Indx);
  59
  60       if X = null then
  61          return;
  62       end if;
  63
  64       if Equivalent_Keys (Key, X) then
  65          if HT.Busy > 0 then
  66             raise Program_Error;
  67          end if;
  68          HT.Buckets (Indx) := Next (X);
  69          HT.Length := HT.Length - 1;
  70          return;
  71       end if;
  72
  73       loop
  74          Prev := X;
  75          X := Next (Prev);
  76
  77          if X = null then
  78             return;
  79          end if;
  80
  81          if Equivalent_Keys (Key, X) then
  82             if HT.Busy > 0 then
  83                raise Program_Error;
  84             end if;
  85             Set_Next (Node => Prev, Next => Next (X));
  86             HT.Length := HT.Length - 1;
  87             return;
  88          end if;
  89       end loop;
  90    end Delete_Key_Sans_Free;
  91
  92    ----------
  93    -- Find --
  94    ----------
  95
  96    function Find
  97      (HT  : Hash_Table_Type;
  98       Key : Key_Type) return Node_Access is
  99
 100       Indx : Hash_Type;
 101       Node : Node_Access;
 102
 103    begin
 104       if HT.Length = 0 then
 105          return null;
 106       end if;
 107
 108       Indx := Index (HT, Key);
 109
 110       Node := HT.Buckets (Indx);
 111       while Node /= null loop
 112          if Equivalent_Keys (Key, Node) then
 113             return Node;
 114          end if;
 115          Node := Next (Node);
 116       end loop;
 117
 118       return null;
 119    end Find;
 120
 121    --------------------------------
 122    -- Generic_Conditional_Insert --
 123    --------------------------------
 124
 125    procedure Generic_Conditional_Insert
 126      (HT       : in out Hash_Table_Type;
 127       Key      : Key_Type;
 128       Node     : out Node_Access;
 129       Inserted : out Boolean)
 130    is
 131       Indx : constant Hash_Type := Index (HT, Key);
 132       B    : Node_Access renames HT.Buckets (Indx);
 133
 134       subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
 135
 136    begin
 137       if B = null then
 138          if HT.Busy > 0 then
 139             raise Program_Error;
 140          end if;
 141
 142          declare
 143             Length : constant Length_Subtype := HT.Length;
 144          begin
 145             Node := New_Node (Next => null);
 146             Inserted := True;
 147
 148             B := Node;
 149             HT.Length := Length + 1;
 150          end;
 151
 152          return;
 153       end if;
 154
 155       Node := B;
 156       loop
 157          if Equivalent_Keys (Key, Node) then
 158             Inserted := False;
 159             return;
 160          end if;
 161
 162          Node := Next (Node);
 163
 164          exit when Node = null;
 165       end loop;
 166
 167       if HT.Busy > 0 then
 168          raise Program_Error;
 169       end if;
 170
 171       declare
 172          Length : constant Length_Subtype := HT.Length;
 173       begin
 174          Node := New_Node (Next => B);
 175          Inserted := True;
 176
 177          B := Node;
 178          HT.Length := Length + 1;
 179       end;
 180    end Generic_Conditional_Insert;
 181
 182    -----------
 183    -- Index --
 184    -----------
 185
 186    function Index
 187      (HT  : Hash_Table_Type;
 188       Key : Key_Type) return Hash_Type is
 189    begin
 190       return Hash (Key) mod HT.Buckets'Length;
 191    end Index;
 192
 193 end Ada.Containers.Hash_Tables.Generic_Keys;