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-2016, 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    pragma Warnings (Off, "variable ""Busy*"" is not referenced");
  35    pragma Warnings (Off, "variable ""Lock*"" is not referenced");
  36    --  See comment in Ada.Containers.Helpers
  37
  38    -------------------
  39    -- Checked_Index --
  40    -------------------
  41
  42    function Checked_Index
  43      (Hash_Table : aliased in out Hash_Table_Type'Class;
  44       Node       : Count_Type) return Hash_Type
  45    is
  46       Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
  47    begin
  48       return Index (Hash_Table, Hash_Table.Nodes (Node));
  49    end Checked_Index;
  50
  51    -----------
  52    -- Clear --
  53    -----------
  54
  55    procedure Clear (HT : in out Hash_Table_Type'Class) is
  56    begin
  57       TC_Check (HT.TC);
  58
  59       HT.Length := 0;
  60       --  HT.Busy := 0;
  61       --  HT.Lock := 0;
  62       HT.Free := -1;
  63       HT.Buckets := (others => 0);  -- optimize this somehow ???
  64    end Clear;
  65
  66    --------------------------
  67    -- Delete_Node_At_Index --
  68    --------------------------
  69
  70    procedure Delete_Node_At_Index
  71      (HT   : in out Hash_Table_Type'Class;
  72       Indx : Hash_Type;
  73       X    : Count_Type)
  74    is
  75       Prev : Count_Type;
  76       Curr : Count_Type;
  77
  78    begin
  79       Prev := HT.Buckets (Indx);
  80
  81       if Checks and then Prev = 0 then
  82          raise Program_Error with
  83            "attempt to delete node from empty hash bucket";
  84       end if;
  85
  86       if Prev = X then
  87          HT.Buckets (Indx) := Next (HT.Nodes (Prev));
  88          HT.Length := HT.Length - 1;
  89          return;
  90       end if;
  91
  92       if Checks and then HT.Length = 1 then
  93          raise Program_Error with
  94            "attempt to delete node not in its proper hash bucket";
  95       end if;
  96
  97       loop
  98          Curr := Next (HT.Nodes (Prev));
  99
 100          if Checks and then Curr = 0 then
 101             raise Program_Error with
 102               "attempt to delete node not in its proper hash bucket";
 103          end if;
 104
 105          Prev := Curr;
 106       end loop;
 107    end Delete_Node_At_Index;
 108
 109    ---------------------------
 110    -- Delete_Node_Sans_Free --
 111    ---------------------------
 112
 113    procedure Delete_Node_Sans_Free
 114      (HT : in out Hash_Table_Type'Class;
 115       X  : Count_Type)
 116    is
 117       pragma Assert (X /= 0);
 118
 119       Indx : Hash_Type;
 120       Prev : Count_Type;
 121       Curr : Count_Type;
 122
 123    begin
 124       if Checks and then HT.Length = 0 then
 125          raise Program_Error with
 126            "attempt to delete node from empty hashed container";
 127       end if;
 128
 129       Indx := Checked_Index (HT, X);
 130       Prev := HT.Buckets (Indx);
 131
 132       if Checks and then Prev = 0 then
 133          raise Program_Error with
 134            "attempt to delete node from empty hash bucket";
 135       end if;
 136
 137       if Prev = X then
 138          HT.Buckets (Indx) := Next (HT.Nodes (Prev));
 139          HT.Length := HT.Length - 1;
 140          return;
 141       end if;
 142
 143       if Checks and then HT.Length = 1 then
 144          raise Program_Error with
 145            "attempt to delete node not in its proper hash bucket";
 146       end if;
 147
 148       loop
 149          Curr := Next (HT.Nodes (Prev));
 150
 151          if Checks and then Curr = 0 then
 152             raise Program_Error with
 153               "attempt to delete node not in its proper hash bucket";
 154          end if;
 155
 156          if Curr = X then
 157             Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
 158             HT.Length := HT.Length - 1;
 159             return;
 160          end if;
 161
 162          Prev := Curr;
 163       end loop;
 164    end Delete_Node_Sans_Free;
 165
 166    -----------
 167    -- First --
 168    -----------
 169
 170    function First (HT : Hash_Table_Type'Class) return Count_Type is
 171       Indx : Hash_Type;
 172
 173    begin
 174       if HT.Length = 0 then
 175          return 0;
 176       end if;
 177
 178       Indx := HT.Buckets'First;
 179       loop
 180          if HT.Buckets (Indx) /= 0 then
 181             return HT.Buckets (Indx);
 182          end if;
 183
 184          Indx := Indx + 1;
 185       end loop;
 186    end First;
 187
 188    ----------
 189    -- Free --
 190    ----------
 191
 192    procedure Free
 193      (HT : in out Hash_Table_Type'Class;
 194       X  : Count_Type)
 195    is
 196       N : Nodes_Type renames HT.Nodes;
 197
 198    begin
 199       --  This subprogram "deallocates" a node by relinking the node off of the
 200       --  active list and onto the free list. Previously it would flag index
 201       --  value 0 as an error. The precondition was weakened, so that index
 202       --  value 0 is now allowed, and this value is interpreted to mean "do
 203       --  nothing". This makes its behavior analogous to the behavior of
 204       --  Ada.Unchecked_Deallocation, and allows callers to avoid having to add
 205       --  special-case checks at the point of call.
 206
 207       if X = 0 then
 208          return;
 209       end if;
 210
 211       pragma Assert (X <= HT.Capacity);
 212
 213       --  pragma Assert (N (X).Prev >= 0);  -- node is active
 214       --  Find a way to mark a node as active vs. inactive; we could
 215       --  use a special value in Color_Type for this.  ???
 216
 217       --  The hash table actually contains two data structures: a list for
 218       --  the "active" nodes that contain elements that have been inserted
 219       --  onto the container, and another for the "inactive" nodes of the free
 220       --  store.
 221       --
 222       --  We desire that merely declaring an object should have only minimal
 223       --  cost; specially, we want to avoid having to initialize the free
 224       --  store (to fill in the links), especially if the capacity is large.
 225       --
 226       --  The head of the free list is indicated by Container.Free. If its
 227       --  value is non-negative, then the free store has been initialized
 228       --  in the "normal" way: Container.Free points to the head of the list
 229       --  of free (inactive) nodes, and the value 0 means the free list is
 230       --  empty. Each node on the free list has been initialized to point
 231       --  to the next free node (via its Parent component), and the value 0
 232       --  means that this is the last free node.
 233       --
 234       --  If Container.Free is negative, then the links on the free store
 235       --  have not been initialized. In this case the link values are
 236       --  implied: the free store comprises the components of the node array
 237       --  started with the absolute value of Container.Free, and continuing
 238       --  until the end of the array (Nodes'Last).
 239       --
 240       --  ???
 241       --  It might be possible to perform an optimization here. Suppose that
 242       --  the free store can be represented as having two parts: one
 243       --  comprising the non-contiguous inactive nodes linked together
 244       --  in the normal way, and the other comprising the contiguous
 245       --  inactive nodes (that are not linked together, at the end of the
 246       --  nodes array). This would allow us to never have to initialize
 247       --  the free store, except in a lazy way as nodes become inactive.
 248
 249       --  When an element is deleted from the list container, its node
 250       --  becomes inactive, and so we set its Next component to value of
 251       --  the node's index (in the nodes array), to indicate that it is
 252       --  now inactive. This provides a useful way to detect a dangling
 253       --  cursor reference.  ???
 254
 255       Set_Next (N (X), Next => X);  -- Node is deallocated (not on active list)
 256
 257       if HT.Free >= 0 then
 258          --  The free store has previously been initialized. All we need to
 259          --  do here is link the newly-free'd node onto the free list.
 260
 261          Set_Next (N (X), HT.Free);
 262          HT.Free := X;
 263
 264       elsif X + 1 = abs HT.Free then
 265          --  The free store has not been initialized, and the node becoming
 266          --  inactive immediately precedes the start of the free store. All
 267          --  we need to do is move the start of the free store back by one.
 268
 269          HT.Free := HT.Free + 1;
 270
 271       else
 272          --  The free store has not been initialized, and the node becoming
 273          --  inactive does not immediately precede the free store. Here we
 274          --  first initialize the free store (meaning the links are given
 275          --  values in the traditional way), and then link the newly-free'd
 276          --  node onto the head of the free store.
 277
 278          --  ???
 279          --  See the comments above for an optimization opportunity. If
 280          --  the next link for a node on the free store is negative, then
 281          --  this means the remaining nodes on the free store are
 282          --  physically contiguous, starting as the absolute value of
 283          --  that index value.
 284
 285          HT.Free := abs HT.Free;
 286
 287          if HT.Free > HT.Capacity then
 288             HT.Free := 0;
 289
 290          else
 291             for I in HT.Free .. HT.Capacity - 1 loop
 292                Set_Next (Node => N (I), Next => I + 1);
 293             end loop;
 294
 295             Set_Next (Node => N (HT.Capacity), Next => 0);
 296          end if;
 297
 298          Set_Next (Node => N (X), Next => HT.Free);
 299          HT.Free := X;
 300       end if;
 301    end Free;
 302
 303    ----------------------
 304    -- Generic_Allocate --
 305    ----------------------
 306
 307    procedure Generic_Allocate
 308      (HT   : in out Hash_Table_Type'Class;
 309       Node : out Count_Type)
 310    is
 311       N : Nodes_Type renames HT.Nodes;
 312
 313    begin
 314       if HT.Free >= 0 then
 315          Node := HT.Free;
 316
 317          --  We always perform the assignment first, before we
 318          --  change container state, in order to defend against
 319          --  exceptions duration assignment.
 320
 321          Set_Element (N (Node));
 322          HT.Free := Next (N (Node));
 323
 324       else
 325          --  A negative free store value means that the links of the nodes
 326          --  in the free store have not been initialized. In this case, the
 327          --  nodes are physically contiguous in the array, starting at the
 328          --  index that is the absolute value of the Container.Free, and
 329          --  continuing until the end of the array (Nodes'Last).
 330
 331          Node := abs HT.Free;
 332
 333          --  As above, we perform this assignment first, before modifying
 334          --  any container state.
 335
 336          Set_Element (N (Node));
 337          HT.Free := HT.Free - 1;
 338       end if;
 339    end Generic_Allocate;
 340
 341    -------------------
 342    -- Generic_Equal --
 343    -------------------
 344
 345    function Generic_Equal
 346      (L, R : Hash_Table_Type'Class) return Boolean
 347    is
 348       --  Per AI05-0022, the container implementation is required to detect
 349       --  element tampering by a generic actual subprogram.
 350
 351       Lock_L : With_Lock (L.TC'Unrestricted_Access);
 352       Lock_R : With_Lock (R.TC'Unrestricted_Access);
 353
 354       L_Index : Hash_Type;
 355       L_Node  : Count_Type;
 356
 357       N : Count_Type;
 358
 359    begin
 360       if L'Address = R'Address then
 361          return True;
 362       end if;
 363
 364       if L.Length /= R.Length then
 365          return False;
 366       end if;
 367
 368       if L.Length = 0 then
 369          return True;
 370       end if;
 371
 372       --  Find the first node of hash table L
 373
 374       L_Index := L.Buckets'First;
 375       loop
 376          L_Node := L.Buckets (L_Index);
 377          exit when L_Node /= 0;
 378          L_Index := L_Index + 1;
 379       end loop;
 380
 381       --  For each node of hash table L, search for an equivalent node in hash
 382       --  table R.
 383
 384       N := L.Length;
 385       loop
 386          if not Find (HT => R, Key => L.Nodes (L_Node)) then
 387             return False;
 388          end if;
 389
 390          N := N - 1;
 391
 392          L_Node := Next (L.Nodes (L_Node));
 393
 394          if L_Node = 0 then
 395
 396             --  We have exhausted the nodes in this bucket
 397
 398             if N = 0 then
 399                return True;
 400             end if;
 401
 402             --  Find the next bucket
 403
 404             loop
 405                L_Index := L_Index + 1;
 406                L_Node := L.Buckets (L_Index);
 407                exit when L_Node /= 0;
 408             end loop;
 409          end if;
 410       end loop;
 411    end Generic_Equal;
 412
 413    -----------------------
 414    -- Generic_Iteration --
 415    -----------------------
 416
 417    procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
 418       Node : Count_Type;
 419
 420    begin
 421       if HT.Length = 0 then
 422          return;
 423       end if;
 424
 425       for Indx in HT.Buckets'Range loop
 426          Node := HT.Buckets (Indx);
 427          while Node /= 0 loop
 428             Process (Node);
 429             Node := Next (HT.Nodes (Node));
 430          end loop;
 431       end loop;
 432    end Generic_Iteration;
 433
 434    ------------------
 435    -- Generic_Read --
 436    ------------------
 437
 438    procedure Generic_Read
 439      (Stream : not null access Root_Stream_Type'Class;
 440       HT     : out Hash_Table_Type'Class)
 441    is
 442       N  : Count_Type'Base;
 443
 444    begin
 445       Clear (HT);
 446
 447       Count_Type'Base'Read (Stream, N);
 448
 449       if Checks and then N < 0 then
 450          raise Program_Error with "stream appears to be corrupt";
 451       end if;
 452
 453       if N = 0 then
 454          return;
 455       end if;
 456
 457       if Checks and then N > HT.Capacity then
 458          raise Capacity_Error with "too many elements in stream";
 459       end if;
 460
 461       for J in 1 .. N loop
 462          declare
 463             Node : constant Count_Type := New_Node (Stream);
 464             Indx : constant Hash_Type := Checked_Index (HT, Node);
 465             B    : Count_Type renames HT.Buckets (Indx);
 466          begin
 467             Set_Next (HT.Nodes (Node), Next => B);
 468             B := Node;
 469          end;
 470
 471          HT.Length := HT.Length + 1;
 472       end loop;
 473    end Generic_Read;
 474
 475    -------------------
 476    -- Generic_Write --
 477    -------------------
 478
 479    procedure Generic_Write
 480      (Stream : not null access Root_Stream_Type'Class;
 481       HT     : Hash_Table_Type'Class)
 482    is
 483       procedure Write (Node : Count_Type);
 484       pragma Inline (Write);
 485
 486       procedure Write is new Generic_Iteration (Write);
 487
 488       -----------
 489       -- Write --
 490       -----------
 491
 492       procedure Write (Node : Count_Type) is
 493       begin
 494          Write (Stream, HT.Nodes (Node));
 495       end Write;
 496
 497    begin
 498       Count_Type'Base'Write (Stream, HT.Length);
 499       Write (HT);
 500    end Generic_Write;
 501
 502    -----------
 503    -- Index --
 504    -----------
 505
 506    function Index
 507      (Buckets : Buckets_Type;
 508       Node    : Node_Type) return Hash_Type is
 509    begin
 510       return Buckets'First + Hash_Node (Node) mod Buckets'Length;
 511    end Index;
 512
 513    function Index
 514      (HT   : Hash_Table_Type'Class;
 515       Node : Node_Type) return Hash_Type is
 516    begin
 517       return Index (HT.Buckets, Node);
 518    end Index;
 519
 520    ----------
 521    -- Next --
 522    ----------
 523
 524    function Next
 525      (HT   : Hash_Table_Type'Class;
 526       Node : Count_Type) return Count_Type
 527    is
 528       Result : Count_Type;
 529       First  : Hash_Type;
 530
 531    begin
 532       Result := Next (HT.Nodes (Node));
 533
 534       if Result /= 0 then  -- another node in same bucket
 535          return Result;
 536       end if;
 537
 538       --  This was the last node in the bucket, so move to the next
 539       --  bucket, and start searching for next node from there.
 540
 541       First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
 542       for Indx in First .. HT.Buckets'Last loop
 543          Result := HT.Buckets (Indx);
 544
 545          if Result /= 0 then  -- bucket is not empty
 546             return Result;
 547          end if;
 548       end loop;
 549
 550       return 0;
 551    end Next;
 552
 553 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;