gcc/ada/a-chtgbo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --           ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with System;  use type System.Address;
  31
  32 package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
  33
  34    -----------
  35    -- Clear --
  36    -----------
  37
  38    procedure Clear (HT : in out Hash_Table_Type'Class) is
  39    begin
  40       if HT.Busy > 0 then
  41          raise Program_Error with
  42            "attempt to tamper with cursors (container is busy)";
  43       end if;
  44
  45       HT.Length := 0;
  46       --  HT.Busy := 0;
  47       --  HT.Lock := 0;
  48       HT.Free := -1;
  49       HT.Buckets := (others => 0);  -- optimize this somehow ???
  50    end Clear;
  51
  52    ---------------------------
  53    -- Delete_Node_Sans_Free --
  54    ---------------------------
  55
  56    procedure Delete_Node_Sans_Free
  57      (HT : in out Hash_Table_Type'Class;
  58       X  : Count_Type)
  59    is
  60       pragma Assert (X /= 0);
  61
  62       Indx : Hash_Type;
  63       Prev : Count_Type;
  64       Curr : Count_Type;
  65
  66    begin
  67       if HT.Length = 0 then
  68          raise Program_Error with
  69            "attempt to delete node from empty hashed container";
  70       end if;
  71
  72       Indx := Index (HT, HT.Nodes (X));
  73       Prev := HT.Buckets (Indx);
  74
  75       if Prev = 0 then
  76          raise Program_Error with
  77            "attempt to delete node from empty hash bucket";
  78       end if;
  79
  80       if Prev = X then
  81          HT.Buckets (Indx) := Next (HT, Prev);
  82          HT.Length := HT.Length - 1;
  83          return;
  84       end if;
  85
  86       if HT.Length = 1 then
  87          raise Program_Error with
  88            "attempt to delete node not in its proper hash bucket";
  89       end if;
  90
  91       loop
  92          Curr := Next (HT, Prev);
  93
  94          if Curr = 0 then
  95             raise Program_Error with
  96               "attempt to delete node not in its proper hash bucket";
  97          end if;
  98
  99          if Curr = X then
 100             Set_Next (HT.Nodes (Prev), Next => Next (HT, Curr));
 101             HT.Length := HT.Length - 1;
 102             return;
 103          end if;
 104
 105          Prev := Curr;
 106       end loop;
 107    end Delete_Node_Sans_Free;
 108
 109    -----------
 110    -- First --
 111    -----------
 112
 113    function First (HT : Hash_Table_Type'Class) return Count_Type is
 114       Indx : Hash_Type;
 115
 116    begin
 117       if HT.Length = 0 then
 118          return 0;
 119       end if;
 120
 121       Indx := HT.Buckets'First;
 122       loop
 123          if HT.Buckets (Indx) /= 0 then
 124             return HT.Buckets (Indx);
 125          end if;
 126
 127          Indx := Indx + 1;
 128       end loop;
 129    end First;
 130
 131    ----------
 132    -- Free --
 133    ----------
 134
 135    procedure Free
 136      (HT : in out Hash_Table_Type'Class;
 137       X  : Count_Type)
 138    is
 139       pragma Assert (X > 0);
 140       pragma Assert (X <= HT.Capacity);
 141
 142       N : Nodes_Type renames HT.Nodes;
 143       --  pragma Assert (N (X).Prev >= 0);  -- node is active
 144       --  Find a way to mark a node as active vs. inactive; we could
 145       --  use a special value in Color_Type for this.  ???
 146
 147    begin
 148       --  The hash table actually contains two data structures: a list for
 149       --  the "active" nodes that contain elements that have been inserted
 150       --  onto the container, and another for the "inactive" nodes of the free
 151       --  store.
 152       --
 153       --  We desire that merely declaring an object should have only minimal
 154       --  cost; specially, we want to avoid having to initialize the free
 155       --  store (to fill in the links), especially if the capacity is large.
 156       --
 157       --  The head of the free list is indicated by Container.Free. If its
 158       --  value is non-negative, then the free store has been initialized
 159       --  in the "normal" way: Container.Free points to the head of the list
 160       --  of free (inactive) nodes, and the value 0 means the free list is
 161       --  empty. Each node on the free list has been initialized to point
 162       --  to the next free node (via its Parent component), and the value 0
 163       --  means that this is the last free node.
 164       --
 165       --  If Container.Free is negative, then the links on the free store
 166       --  have not been initialized. In this case the link values are
 167       --  implied: the free store comprises the components of the node array
 168       --  started with the absolute value of Container.Free, and continuing
 169       --  until the end of the array (Nodes'Last).
 170       --
 171       --  ???
 172       --  It might be possible to perform an optimization here. Suppose that
 173       --  the free store can be represented as having two parts: one
 174       --  comprising the non-contiguous inactive nodes linked together
 175       --  in the normal way, and the other comprising the contiguous
 176       --  inactive nodes (that are not linked together, at the end of the
 177       --  nodes array). This would allow us to never have to initialize
 178       --  the free store, except in a lazy way as nodes become inactive.
 179
 180       --  When an element is deleted from the list container, its node
 181       --  becomes inactive, and so we set its Next component to value of
 182       --  the node's index (in the nodes array), to indicate that it is
 183       --  now inactive. This provides a useful way to detect a dangling
 184       --  cursor reference.  ???
 185
 186       Set_Next (N (X), Next => X);  -- Node is deallocated (not on active list)
 187
 188       if HT.Free >= 0 then
 189          --  The free store has previously been initialized. All we need to
 190          --  do here is link the newly-free'd node onto the free list.
 191
 192          Set_Next (N (X), HT.Free);
 193          HT.Free := X;
 194
 195       elsif X + 1 = abs HT.Free then
 196          --  The free store has not been initialized, and the node becoming
 197          --  inactive immediately precedes the start of the free store. All
 198          --  we need to do is move the start of the free store back by one.
 199
 200          HT.Free := HT.Free + 1;
 201
 202       else
 203          --  The free store has not been initialized, and the node becoming
 204          --  inactive does not immediately precede the free store. Here we
 205          --  first initialize the free store (meaning the links are given
 206          --  values in the traditional way), and then link the newly-free'd
 207          --  node onto the head of the free store.
 208
 209          --  ???
 210          --  See the comments above for an optimization opportunity. If
 211          --  the next link for a node on the free store is negative, then
 212          --  this means the remaining nodes on the free store are
 213          --  physically contiguous, starting as the absolute value of
 214          --  that index value.
 215
 216          HT.Free := abs HT.Free;
 217
 218          if HT.Free > HT.Capacity then
 219             HT.Free := 0;
 220
 221          else
 222             for I in HT.Free .. HT.Capacity - 1 loop
 223                Set_Next (Node => N (I), Next => I + 1);
 224             end loop;
 225
 226             Set_Next (Node => N (HT.Capacity), Next => 0);
 227          end if;
 228
 229          Set_Next (Node => N (X), Next => HT.Free);
 230          HT.Free := X;
 231       end if;
 232    end Free;
 233
 234    ----------------------
 235    -- Generic_Allocate --
 236    ----------------------
 237
 238    procedure Generic_Allocate
 239      (HT   : in out Hash_Table_Type'Class;
 240       Node : out Count_Type)
 241    is
 242       N : Nodes_Type renames HT.Nodes;
 243
 244    begin
 245       if HT.Free >= 0 then
 246          Node := HT.Free;
 247
 248          --  We always perform the assignment first, before we
 249          --  change container state, in order to defend against
 250          --  exceptions duration assignment.
 251
 252          Set_Element (N (Node));
 253          HT.Free := Next (N (Node));
 254
 255       else
 256          --  A negative free store value means that the links of the nodes
 257          --  in the free store have not been initialized. In this case, the
 258          --  nodes are physically contiguous in the array, starting at the
 259          --  index that is the absolute value of the Container.Free, and
 260          --  continuing until the end of the array (Nodes'Last).
 261
 262          Node := abs HT.Free;
 263
 264          --  As above, we perform this assignment first, before modifying
 265          --  any container state.
 266
 267          Set_Element (N (Node));
 268          HT.Free := HT.Free - 1;
 269       end if;
 270    end Generic_Allocate;
 271
 272    -------------------
 273    -- Generic_Equal --
 274    -------------------
 275
 276    function Generic_Equal
 277      (L, R : Hash_Table_Type'Class) return Boolean
 278    is
 279       L_Index : Hash_Type;
 280       L_Node  : Count_Type;
 281
 282       N : Count_Type;
 283
 284    begin
 285       if L'Address = R'Address then
 286          return True;
 287       end if;
 288
 289       if L.Length /= R.Length then
 290          return False;
 291       end if;
 292
 293       if L.Length = 0 then
 294          return True;
 295       end if;
 296
 297       --  Find the first node of hash table L
 298
 299       L_Index := 0;
 300       loop
 301          L_Node := L.Buckets (L_Index);
 302          exit when L_Node /= 0;
 303          L_Index := L_Index + 1;
 304       end loop;
 305
 306       --  For each node of hash table L, search for an equivalent node in hash
 307       --  table R.
 308
 309       N := L.Length;
 310       loop
 311          if not Find (HT => R, Key => L.Nodes (L_Node)) then
 312             return False;
 313          end if;
 314
 315          N := N - 1;
 316
 317          L_Node := Next (L, L_Node);
 318
 319          if L_Node = 0 then
 320             --  We have exhausted the nodes in this bucket
 321
 322             if N = 0 then
 323                return True;
 324             end if;
 325
 326             --  Find the next bucket
 327
 328             loop
 329                L_Index := L_Index + 1;
 330                L_Node := L.Buckets (L_Index);
 331                exit when L_Node /= 0;
 332             end loop;
 333          end if;
 334       end loop;
 335    end Generic_Equal;
 336
 337    -----------------------
 338    -- Generic_Iteration --
 339    -----------------------
 340
 341    procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
 342       Node : Count_Type;
 343
 344    begin
 345       if HT.Length = 0 then
 346          return;
 347       end if;
 348
 349       for Indx in HT.Buckets'Range loop
 350          Node := HT.Buckets (Indx);
 351          while Node /= 0 loop
 352             Process (Node);
 353             Node := Next (HT, Node);
 354          end loop;
 355       end loop;
 356    end Generic_Iteration;
 357
 358    ------------------
 359    -- Generic_Read --
 360    ------------------
 361
 362    procedure Generic_Read
 363      (Stream : not null access Root_Stream_Type'Class;
 364       HT     : out Hash_Table_Type'Class)
 365    is
 366       N  : Count_Type'Base;
 367
 368    begin
 369       Clear (HT);
 370
 371       Count_Type'Base'Read (Stream, N);
 372
 373       if N < 0 then
 374          raise Program_Error with "stream appears to be corrupt";
 375       end if;
 376
 377       if N = 0 then
 378          return;
 379       end if;
 380
 381       if N > HT.Capacity then
 382          raise Capacity_Error with "too many elements in stream";
 383       end if;
 384
 385       for J in 1 .. N loop
 386          declare
 387             Node : constant Count_Type := New_Node (Stream);
 388             Indx : constant Hash_Type := Index (HT, HT.Nodes (Node));
 389             B    : Count_Type renames HT.Buckets (Indx);
 390          begin
 391             Set_Next (HT.Nodes (Node), Next => B);
 392             B := Node;
 393          end;
 394
 395          HT.Length := HT.Length + 1;
 396       end loop;
 397    end Generic_Read;
 398
 399    -------------------
 400    -- Generic_Write --
 401    -------------------
 402
 403    procedure Generic_Write
 404      (Stream : not null access Root_Stream_Type'Class;
 405       HT     : Hash_Table_Type'Class)
 406    is
 407       procedure Write (Node : Count_Type);
 408       pragma Inline (Write);
 409
 410       procedure Write is new Generic_Iteration (Write);
 411
 412       -----------
 413       -- Write --
 414       -----------
 415
 416       procedure Write (Node : Count_Type) is
 417       begin
 418          Write (Stream, HT.Nodes (Node));
 419       end Write;
 420
 421    begin
 422       Count_Type'Base'Write (Stream, HT.Length);
 423       Write (HT);
 424    end Generic_Write;
 425
 426    -----------
 427    -- Index --
 428    -----------
 429
 430    function Index
 431      (Buckets : Buckets_Type;
 432       Node    : Node_Type) return Hash_Type is
 433    begin
 434       return Buckets'First + Hash_Node (Node) mod Buckets'Length;
 435    end Index;
 436
 437    function Index
 438      (HT   : Hash_Table_Type'Class;
 439       Node : Node_Type) return Hash_Type is
 440    begin
 441       return Index (HT.Buckets, Node);
 442    end Index;
 443
 444    ----------
 445    -- Next --
 446    ----------
 447
 448    function Next
 449      (HT   : Hash_Table_Type'Class;
 450       Node : Count_Type) return Count_Type
 451    is
 452       Result : Count_Type := Next (HT.Nodes (Node));
 453
 454    begin
 455       if Result /= 0 then  -- another node in same bucket
 456          return Result;
 457       end if;
 458
 459       --  This was the last node in the bucket, so move to the next
 460       --  bucket, and start searching for next node from there.
 461
 462       for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop
 463          Result := HT.Buckets (Indx);
 464
 465          if Result /= 0 then  -- bucket is not empty
 466             return Result;
 467          end if;
 468       end loop;
 469
 470       return 0;
 471    end Next;
 472
 473 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;