--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/libgnat/a-chtgbo.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,553 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--           ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS          --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 2004-2017, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- This unit was originally developed by Matthew J Heaney.                  --
+------------------------------------------------------------------------------
+
+with System; use type System.Address;
+
+package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
+
+   pragma Warnings (Off, "variable ""Busy*"" is not referenced");
+   pragma Warnings (Off, "variable ""Lock*"" is not referenced");
+   --  See comment in Ada.Containers.Helpers
+
+   -------------------
+   -- Checked_Index --
+   -------------------
+
+   function Checked_Index
+     (Hash_Table : aliased in out Hash_Table_Type'Class;
+      Node       : Count_Type) return Hash_Type
+   is
+      Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
+   begin
+      return Index (Hash_Table, Hash_Table.Nodes (Node));
+   end Checked_Index;
+
+   -----------
+   -- Clear --
+   -----------
+
+   procedure Clear (HT : in out Hash_Table_Type'Class) is
+   begin
+      TC_Check (HT.TC);
+
+      HT.Length := 0;
+      --  HT.Busy := 0;
+      --  HT.Lock := 0;
+      HT.Free := -1;
+      HT.Buckets := (others => 0);  -- optimize this somehow ???
+   end Clear;
+
+   --------------------------
+   -- Delete_Node_At_Index --
+   --------------------------
+
+   procedure Delete_Node_At_Index
+     (HT   : in out Hash_Table_Type'Class;
+      Indx : Hash_Type;
+      X    : Count_Type)
+   is
+      Prev : Count_Type;
+      Curr : Count_Type;
+
+   begin
+      Prev := HT.Buckets (Indx);
+
+      if Checks and then Prev = 0 then
+         raise Program_Error with
+           "attempt to delete node from empty hash bucket";
+      end if;
+
+      if Prev = X then
+         HT.Buckets (Indx) := Next (HT.Nodes (Prev));
+         HT.Length := HT.Length - 1;
+         return;
+      end if;
+
+      if Checks and then HT.Length = 1 then
+         raise Program_Error with
+           "attempt to delete node not in its proper hash bucket";
+      end if;
+
+      loop
+         Curr := Next (HT.Nodes (Prev));
+
+         if Checks and then Curr = 0 then
+            raise Program_Error with
+              "attempt to delete node not in its proper hash bucket";
+         end if;
+
+         Prev := Curr;
+      end loop;
+   end Delete_Node_At_Index;
+
+   ---------------------------
+   -- Delete_Node_Sans_Free --
+   ---------------------------
+
+   procedure Delete_Node_Sans_Free
+     (HT : in out Hash_Table_Type'Class;
+      X  : Count_Type)
+   is
+      pragma Assert (X /= 0);
+
+      Indx : Hash_Type;
+      Prev : Count_Type;
+      Curr : Count_Type;
+
+   begin
+      if Checks and then HT.Length = 0 then
+         raise Program_Error with
+           "attempt to delete node from empty hashed container";
+      end if;
+
+      Indx := Checked_Index (HT, X);
+      Prev := HT.Buckets (Indx);
+
+      if Checks and then Prev = 0 then
+         raise Program_Error with
+           "attempt to delete node from empty hash bucket";
+      end if;
+
+      if Prev = X then
+         HT.Buckets (Indx) := Next (HT.Nodes (Prev));
+         HT.Length := HT.Length - 1;
+         return;
+      end if;
+
+      if Checks and then HT.Length = 1 then
+         raise Program_Error with
+           "attempt to delete node not in its proper hash bucket";
+      end if;
+
+      loop
+         Curr := Next (HT.Nodes (Prev));
+
+         if Checks and then Curr = 0 then
+            raise Program_Error with
+              "attempt to delete node not in its proper hash bucket";
+         end if;
+
+         if Curr = X then
+            Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
+            HT.Length := HT.Length - 1;
+            return;
+         end if;
+
+         Prev := Curr;
+      end loop;
+   end Delete_Node_Sans_Free;
+
+   -----------
+   -- First --
+   -----------
+
+   function First (HT : Hash_Table_Type'Class) return Count_Type is
+      Indx : Hash_Type;
+
+   begin
+      if HT.Length = 0 then
+         return 0;
+      end if;
+
+      Indx := HT.Buckets'First;
+      loop
+         if HT.Buckets (Indx) /= 0 then
+            return HT.Buckets (Indx);
+         end if;
+
+         Indx := Indx + 1;
+      end loop;
+   end First;
+
+   ----------
+   -- Free --
+   ----------
+
+   procedure Free
+     (HT : in out Hash_Table_Type'Class;
+      X  : Count_Type)
+   is
+      N : Nodes_Type renames HT.Nodes;
+
+   begin
+      --  This subprogram "deallocates" a node by relinking the node off of the
+      --  active list and onto the free list. Previously it would flag index
+      --  value 0 as an error. The precondition was weakened, so that index
+      --  value 0 is now allowed, and this value is interpreted to mean "do
+      --  nothing". This makes its behavior analogous to the behavior of
+      --  Ada.Unchecked_Deallocation, and allows callers to avoid having to add
+      --  special-case checks at the point of call.
+
+      if X = 0 then
+         return;
+      end if;
+
+      pragma Assert (X <= HT.Capacity);
+
+      --  pragma Assert (N (X).Prev >= 0);  -- node is active
+      --  Find a way to mark a node as active vs. inactive; we could
+      --  use a special value in Color_Type for this.  ???
+
+      --  The hash table actually contains two data structures: a list for
+      --  the "active" nodes that contain elements that have been inserted
+      --  onto the container, and another for the "inactive" nodes of the free
+      --  store.
+      --
+      --  We desire that merely declaring an object should have only minimal
+      --  cost; specially, we want to avoid having to initialize the free
+      --  store (to fill in the links), especially if the capacity is large.
+      --
+      --  The head of the free list is indicated by Container.Free. If its
+      --  value is non-negative, then the free store has been initialized
+      --  in the "normal" way: Container.Free points to the head of the list
+      --  of free (inactive) nodes, and the value 0 means the free list is
+      --  empty. Each node on the free list has been initialized to point
+      --  to the next free node (via its Parent component), and the value 0
+      --  means that this is the last free node.
+      --
+      --  If Container.Free is negative, then the links on the free store
+      --  have not been initialized. In this case the link values are
+      --  implied: the free store comprises the components of the node array
+      --  started with the absolute value of Container.Free, and continuing
+      --  until the end of the array (Nodes'Last).
+      --
+      --  ???
+      --  It might be possible to perform an optimization here. Suppose that
+      --  the free store can be represented as having two parts: one
+      --  comprising the non-contiguous inactive nodes linked together
+      --  in the normal way, and the other comprising the contiguous
+      --  inactive nodes (that are not linked together, at the end of the
+      --  nodes array). This would allow us to never have to initialize
+      --  the free store, except in a lazy way as nodes become inactive.
+
+      --  When an element is deleted from the list container, its node
+      --  becomes inactive, and so we set its Next component to value of
+      --  the node's index (in the nodes array), to indicate that it is
+      --  now inactive. This provides a useful way to detect a dangling
+      --  cursor reference.  ???
+
+      Set_Next (N (X), Next => X);  -- Node is deallocated (not on active list)
+
+      if HT.Free >= 0 then
+         --  The free store has previously been initialized. All we need to
+         --  do here is link the newly-free'd node onto the free list.
+
+         Set_Next (N (X), HT.Free);
+         HT.Free := X;
+
+      elsif X + 1 = abs HT.Free then
+         --  The free store has not been initialized, and the node becoming
+         --  inactive immediately precedes the start of the free store. All
+         --  we need to do is move the start of the free store back by one.
+
+         HT.Free := HT.Free + 1;
+
+      else
+         --  The free store has not been initialized, and the node becoming
+         --  inactive does not immediately precede the free store. Here we
+         --  first initialize the free store (meaning the links are given
+         --  values in the traditional way), and then link the newly-free'd
+         --  node onto the head of the free store.
+
+         --  ???
+         --  See the comments above for an optimization opportunity. If
+         --  the next link for a node on the free store is negative, then
+         --  this means the remaining nodes on the free store are
+         --  physically contiguous, starting as the absolute value of
+         --  that index value.
+
+         HT.Free := abs HT.Free;
+
+         if HT.Free > HT.Capacity then
+            HT.Free := 0;
+
+         else
+            for I in HT.Free .. HT.Capacity - 1 loop
+               Set_Next (Node => N (I), Next => I + 1);
+            end loop;
+
+            Set_Next (Node => N (HT.Capacity), Next => 0);
+         end if;
+
+         Set_Next (Node => N (X), Next => HT.Free);
+         HT.Free := X;
+      end if;
+   end Free;
+
+   ----------------------
+   -- Generic_Allocate --
+   ----------------------
+
+   procedure Generic_Allocate
+     (HT   : in out Hash_Table_Type'Class;
+      Node : out Count_Type)
+   is
+      N : Nodes_Type renames HT.Nodes;
+
+   begin
+      if HT.Free >= 0 then
+         Node := HT.Free;
+
+         --  We always perform the assignment first, before we
+         --  change container state, in order to defend against
+         --  exceptions duration assignment.
+
+         Set_Element (N (Node));
+         HT.Free := Next (N (Node));
+
+      else
+         --  A negative free store value means that the links of the nodes
+         --  in the free store have not been initialized. In this case, the
+         --  nodes are physically contiguous in the array, starting at the
+         --  index that is the absolute value of the Container.Free, and
+         --  continuing until the end of the array (Nodes'Last).
+
+         Node := abs HT.Free;
+
+         --  As above, we perform this assignment first, before modifying
+         --  any container state.
+
+         Set_Element (N (Node));
+         HT.Free := HT.Free - 1;
+      end if;
+   end Generic_Allocate;
+
+   -------------------
+   -- Generic_Equal --
+   -------------------
+
+   function Generic_Equal
+     (L, R : Hash_Table_Type'Class) return Boolean
+   is
+      --  Per AI05-0022, the container implementation is required to detect
+      --  element tampering by a generic actual subprogram.
+
+      Lock_L : With_Lock (L.TC'Unrestricted_Access);
+      Lock_R : With_Lock (R.TC'Unrestricted_Access);
+
+      L_Index : Hash_Type;
+      L_Node  : Count_Type;
+
+      N : Count_Type;
+
+   begin
+      if L'Address = R'Address then
+         return True;
+      end if;
+
+      if L.Length /= R.Length then
+         return False;
+      end if;
+
+      if L.Length = 0 then
+         return True;
+      end if;
+
+      --  Find the first node of hash table L
+
+      L_Index := L.Buckets'First;
+      loop
+         L_Node := L.Buckets (L_Index);
+         exit when L_Node /= 0;
+         L_Index := L_Index + 1;
+      end loop;
+
+      --  For each node of hash table L, search for an equivalent node in hash
+      --  table R.
+
+      N := L.Length;
+      loop
+         if not Find (HT => R, Key => L.Nodes (L_Node)) then
+            return False;
+         end if;
+
+         N := N - 1;
+
+         L_Node := Next (L.Nodes (L_Node));
+
+         if L_Node = 0 then
+
+            --  We have exhausted the nodes in this bucket
+
+            if N = 0 then
+               return True;
+            end if;
+
+            --  Find the next bucket
+
+            loop
+               L_Index := L_Index + 1;
+               L_Node := L.Buckets (L_Index);
+               exit when L_Node /= 0;
+            end loop;
+         end if;
+      end loop;
+   end Generic_Equal;
+
+   -----------------------
+   -- Generic_Iteration --
+   -----------------------
+
+   procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
+      Node : Count_Type;
+
+   begin
+      if HT.Length = 0 then
+         return;
+      end if;
+
+      for Indx in HT.Buckets'Range loop
+         Node := HT.Buckets (Indx);
+         while Node /= 0 loop
+            Process (Node);
+            Node := Next (HT.Nodes (Node));
+         end loop;
+      end loop;
+   end Generic_Iteration;
+
+   ------------------
+   -- Generic_Read --
+   ------------------
+
+   procedure Generic_Read
+     (Stream : not null access Root_Stream_Type'Class;
+      HT     : out Hash_Table_Type'Class)
+   is
+      N  : Count_Type'Base;
+
+   begin
+      Clear (HT);
+
+      Count_Type'Base'Read (Stream, N);
+
+      if Checks and then N < 0 then
+         raise Program_Error with "stream appears to be corrupt";
+      end if;
+
+      if N = 0 then
+         return;
+      end if;
+
+      if Checks and then N > HT.Capacity then
+         raise Capacity_Error with "too many elements in stream";
+      end if;
+
+      for J in 1 .. N loop
+         declare
+            Node : constant Count_Type := New_Node (Stream);
+            Indx : constant Hash_Type := Checked_Index (HT, Node);
+            B    : Count_Type renames HT.Buckets (Indx);
+         begin
+            Set_Next (HT.Nodes (Node), Next => B);
+            B := Node;
+         end;
+
+         HT.Length := HT.Length + 1;
+      end loop;
+   end Generic_Read;
+
+   -------------------
+   -- Generic_Write --
+   -------------------
+
+   procedure Generic_Write
+     (Stream : not null access Root_Stream_Type'Class;
+      HT     : Hash_Table_Type'Class)
+   is
+      procedure Write (Node : Count_Type);
+      pragma Inline (Write);
+
+      procedure Write is new Generic_Iteration (Write);
+
+      -----------
+      -- Write --
+      -----------
+
+      procedure Write (Node : Count_Type) is
+      begin
+         Write (Stream, HT.Nodes (Node));
+      end Write;
+
+   begin
+      Count_Type'Base'Write (Stream, HT.Length);
+      Write (HT);
+   end Generic_Write;
+
+   -----------
+   -- Index --
+   -----------
+
+   function Index
+     (Buckets : Buckets_Type;
+      Node    : Node_Type) return Hash_Type is
+   begin
+      return Buckets'First + Hash_Node (Node) mod Buckets'Length;
+   end Index;
+
+   function Index
+     (HT   : Hash_Table_Type'Class;
+      Node : Node_Type) return Hash_Type is
+   begin
+      return Index (HT.Buckets, Node);
+   end Index;
+
+   ----------
+   -- Next --
+   ----------
+
+   function Next
+     (HT   : Hash_Table_Type'Class;
+      Node : Count_Type) return Count_Type
+   is
+      Result : Count_Type;
+      First  : Hash_Type;
+
+   begin
+      Result := Next (HT.Nodes (Node));
+
+      if Result /= 0 then  -- another node in same bucket
+         return Result;
+      end if;
+
+      --  This was the last node in the bucket, so move to the next
+      --  bucket, and start searching for next node from there.
+
+      First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
+      for Indx in First .. HT.Buckets'Last loop
+         Result := HT.Buckets (Indx);
+
+         if Result /= 0 then  -- bucket is not empty
+            return Result;
+         end if;
+      end loop;
+
+      return 0;
+   end Next;
+
+end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;