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-2011, 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.Nodes (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.Nodes (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.Nodes (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       N : Nodes_Type renames HT.Nodes;
 140
 141    begin
 142       --  This subprogram "deallocates" a node by relinking the node off of the
 143       --  active list and onto the free list. Previously it would flag index
 144       --  value 0 as an error. The precondition was weakened, so that index
 145       --  value 0 is now allowed, and this value is interpreted to mean "do
 146       --  nothing". This makes its behavior analogous to the behavior of
 147       --  Ada.Unchecked_Deallocation, and allows callers to avoid having to add
 148       --  special-case checks at the point of call.
 149
 150       if X = 0 then
 151          return;
 152       end if;
 153
 154       pragma Assert (X <= HT.Capacity);
 155
 156       --  pragma Assert (N (X).Prev >= 0);  -- node is active
 157       --  Find a way to mark a node as active vs. inactive; we could
 158       --  use a special value in Color_Type for this.  ???
 159
 160       --  The hash table actually contains two data structures: a list for
 161       --  the "active" nodes that contain elements that have been inserted
 162       --  onto the container, and another for the "inactive" nodes of the free
 163       --  store.
 164       --
 165       --  We desire that merely declaring an object should have only minimal
 166       --  cost; specially, we want to avoid having to initialize the free
 167       --  store (to fill in the links), especially if the capacity is large.
 168       --
 169       --  The head of the free list is indicated by Container.Free. If its
 170       --  value is non-negative, then the free store has been initialized
 171       --  in the "normal" way: Container.Free points to the head of the list
 172       --  of free (inactive) nodes, and the value 0 means the free list is
 173       --  empty. Each node on the free list has been initialized to point
 174       --  to the next free node (via its Parent component), and the value 0
 175       --  means that this is the last free node.
 176       --
 177       --  If Container.Free is negative, then the links on the free store
 178       --  have not been initialized. In this case the link values are
 179       --  implied: the free store comprises the components of the node array
 180       --  started with the absolute value of Container.Free, and continuing
 181       --  until the end of the array (Nodes'Last).
 182       --
 183       --  ???
 184       --  It might be possible to perform an optimization here. Suppose that
 185       --  the free store can be represented as having two parts: one
 186       --  comprising the non-contiguous inactive nodes linked together
 187       --  in the normal way, and the other comprising the contiguous
 188       --  inactive nodes (that are not linked together, at the end of the
 189       --  nodes array). This would allow us to never have to initialize
 190       --  the free store, except in a lazy way as nodes become inactive.
 191
 192       --  When an element is deleted from the list container, its node
 193       --  becomes inactive, and so we set its Next component to value of
 194       --  the node's index (in the nodes array), to indicate that it is
 195       --  now inactive. This provides a useful way to detect a dangling
 196       --  cursor reference.  ???
 197
 198       Set_Next (N (X), Next => X);  -- Node is deallocated (not on active list)
 199
 200       if HT.Free >= 0 then
 201          --  The free store has previously been initialized. All we need to
 202          --  do here is link the newly-free'd node onto the free list.
 203
 204          Set_Next (N (X), HT.Free);
 205          HT.Free := X;
 206
 207       elsif X + 1 = abs HT.Free then
 208          --  The free store has not been initialized, and the node becoming
 209          --  inactive immediately precedes the start of the free store. All
 210          --  we need to do is move the start of the free store back by one.
 211
 212          HT.Free := HT.Free + 1;
 213
 214       else
 215          --  The free store has not been initialized, and the node becoming
 216          --  inactive does not immediately precede the free store. Here we
 217          --  first initialize the free store (meaning the links are given
 218          --  values in the traditional way), and then link the newly-free'd
 219          --  node onto the head of the free store.
 220
 221          --  ???
 222          --  See the comments above for an optimization opportunity. If
 223          --  the next link for a node on the free store is negative, then
 224          --  this means the remaining nodes on the free store are
 225          --  physically contiguous, starting as the absolute value of
 226          --  that index value.
 227
 228          HT.Free := abs HT.Free;
 229
 230          if HT.Free > HT.Capacity then
 231             HT.Free := 0;
 232
 233          else
 234             for I in HT.Free .. HT.Capacity - 1 loop
 235                Set_Next (Node => N (I), Next => I + 1);
 236             end loop;
 237
 238             Set_Next (Node => N (HT.Capacity), Next => 0);
 239          end if;
 240
 241          Set_Next (Node => N (X), Next => HT.Free);
 242          HT.Free := X;
 243       end if;
 244    end Free;
 245
 246    ----------------------
 247    -- Generic_Allocate --
 248    ----------------------
 249
 250    procedure Generic_Allocate
 251      (HT   : in out Hash_Table_Type'Class;
 252       Node : out Count_Type)
 253    is
 254       N : Nodes_Type renames HT.Nodes;
 255
 256    begin
 257       if HT.Free >= 0 then
 258          Node := HT.Free;
 259
 260          --  We always perform the assignment first, before we
 261          --  change container state, in order to defend against
 262          --  exceptions duration assignment.
 263
 264          Set_Element (N (Node));
 265          HT.Free := Next (N (Node));
 266
 267       else
 268          --  A negative free store value means that the links of the nodes
 269          --  in the free store have not been initialized. In this case, the
 270          --  nodes are physically contiguous in the array, starting at the
 271          --  index that is the absolute value of the Container.Free, and
 272          --  continuing until the end of the array (Nodes'Last).
 273
 274          Node := abs HT.Free;
 275
 276          --  As above, we perform this assignment first, before modifying
 277          --  any container state.
 278
 279          Set_Element (N (Node));
 280          HT.Free := HT.Free - 1;
 281       end if;
 282    end Generic_Allocate;
 283
 284    -------------------
 285    -- Generic_Equal --
 286    -------------------
 287
 288    function Generic_Equal
 289      (L, R : Hash_Table_Type'Class) return Boolean
 290    is
 291       L_Index : Hash_Type;
 292       L_Node  : Count_Type;
 293
 294       N : Count_Type;
 295
 296    begin
 297       if L'Address = R'Address then
 298          return True;
 299       end if;
 300
 301       if L.Length /= R.Length then
 302          return False;
 303       end if;
 304
 305       if L.Length = 0 then
 306          return True;
 307       end if;
 308
 309       --  Find the first node of hash table L
 310
 311       L_Index := L.Buckets'First;
 312       loop
 313          L_Node := L.Buckets (L_Index);
 314          exit when L_Node /= 0;
 315          L_Index := L_Index + 1;
 316       end loop;
 317
 318       --  For each node of hash table L, search for an equivalent node in hash
 319       --  table R.
 320
 321       N := L.Length;
 322       loop
 323          if not Find (HT => R, Key => L.Nodes (L_Node)) then
 324             return False;
 325          end if;
 326
 327          N := N - 1;
 328
 329          L_Node := Next (L.Nodes (L_Node));
 330
 331          if L_Node = 0 then
 332             --  We have exhausted the nodes in this bucket
 333
 334             if N = 0 then
 335                return True;
 336             end if;
 337
 338             --  Find the next bucket
 339
 340             loop
 341                L_Index := L_Index + 1;
 342                L_Node := L.Buckets (L_Index);
 343                exit when L_Node /= 0;
 344             end loop;
 345          end if;
 346       end loop;
 347    end Generic_Equal;
 348
 349    -----------------------
 350    -- Generic_Iteration --
 351    -----------------------
 352
 353    procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
 354       Node : Count_Type;
 355
 356    begin
 357       if HT.Length = 0 then
 358          return;
 359       end if;
 360
 361       for Indx in HT.Buckets'Range loop
 362          Node := HT.Buckets (Indx);
 363          while Node /= 0 loop
 364             Process (Node);
 365             Node := Next (HT.Nodes (Node));
 366          end loop;
 367       end loop;
 368    end Generic_Iteration;
 369
 370    ------------------
 371    -- Generic_Read --
 372    ------------------
 373
 374    procedure Generic_Read
 375      (Stream : not null access Root_Stream_Type'Class;
 376       HT     : out Hash_Table_Type'Class)
 377    is
 378       N  : Count_Type'Base;
 379
 380    begin
 381       Clear (HT);
 382
 383       Count_Type'Base'Read (Stream, N);
 384
 385       if N < 0 then
 386          raise Program_Error with "stream appears to be corrupt";
 387       end if;
 388
 389       if N = 0 then
 390          return;
 391       end if;
 392
 393       if N > HT.Capacity then
 394          raise Capacity_Error with "too many elements in stream";
 395       end if;
 396
 397       for J in 1 .. N loop
 398          declare
 399             Node : constant Count_Type := New_Node (Stream);
 400             Indx : constant Hash_Type := Index (HT, HT.Nodes (Node));
 401             B    : Count_Type renames HT.Buckets (Indx);
 402          begin
 403             Set_Next (HT.Nodes (Node), Next => B);
 404             B := Node;
 405          end;
 406
 407          HT.Length := HT.Length + 1;
 408       end loop;
 409    end Generic_Read;
 410
 411    -------------------
 412    -- Generic_Write --
 413    -------------------
 414
 415    procedure Generic_Write
 416      (Stream : not null access Root_Stream_Type'Class;
 417       HT     : Hash_Table_Type'Class)
 418    is
 419       procedure Write (Node : Count_Type);
 420       pragma Inline (Write);
 421
 422       procedure Write is new Generic_Iteration (Write);
 423
 424       -----------
 425       -- Write --
 426       -----------
 427
 428       procedure Write (Node : Count_Type) is
 429       begin
 430          Write (Stream, HT.Nodes (Node));
 431       end Write;
 432
 433    begin
 434       Count_Type'Base'Write (Stream, HT.Length);
 435       Write (HT);
 436    end Generic_Write;
 437
 438    -----------
 439    -- Index --
 440    -----------
 441
 442    function Index
 443      (Buckets : Buckets_Type;
 444       Node    : Node_Type) return Hash_Type is
 445    begin
 446       return Buckets'First + Hash_Node (Node) mod Buckets'Length;
 447    end Index;
 448
 449    function Index
 450      (HT   : Hash_Table_Type'Class;
 451       Node : Node_Type) return Hash_Type is
 452    begin
 453       return Index (HT.Buckets, Node);
 454    end Index;
 455
 456    ----------
 457    -- Next --
 458    ----------
 459
 460    function Next
 461      (HT   : Hash_Table_Type'Class;
 462       Node : Count_Type) return Count_Type
 463    is
 464       Result : Count_Type := Next (HT.Nodes (Node));
 465
 466    begin
 467       if Result /= 0 then  -- another node in same bucket
 468          return Result;
 469       end if;
 470
 471       --  This was the last node in the bucket, so move to the next
 472       --  bucket, and start searching for next node from there.
 473
 474       for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop
 475          Result := HT.Buckets (Indx);
 476
 477          if Result /= 0 then  -- bucket is not empty
 478             return Result;
 479          end if;
 480       end loop;
 481
 482       return 0;
 483    end Next;
 484
 485 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;