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