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