diff options
| -rw-r--r-- | gcc/ada/Makefile.rtl | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cfhama.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cfhama.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cfhase.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cfhase.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-chtgfk.adb | 316 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-chtgfk.ads | 120 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-chtgfo.adb | 542 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-chtgfo.ads | 156 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cohata.ads | 19 |
10 files changed, 1170 insertions, 15 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index aaf853e..0394d96 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -126,6 +126,8 @@ GNATRTL_NONTASKING_OBJS= \ a-chlat9$(objext) \ a-chtgbk$(objext) \ a-chtgbo$(objext) \ + a-chtgfk$(objext) \ + a-chtgfo$(objext) \ a-chtgke$(objext) \ a-chtgop$(objext) \ a-chzla1$(objext) \ diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb index da20b93..c688a86 100644 --- a/gcc/ada/libgnat/a-cfhama.adb +++ b/gcc/ada/libgnat/a-cfhama.adb @@ -25,11 +25,11 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); +with Ada.Containers.Hash_Tables.Generic_Formal_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Hash_Tables.Generic_Formal_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; @@ -75,14 +75,14 @@ is -------------------------- package HT_Ops is - new Hash_Tables.Generic_Bounded_Operations + new Hash_Tables.Generic_Formal_Operations (HT_Types => HT_Types, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next); package Key_Ops is - new Hash_Tables.Generic_Bounded_Keys + new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index 37024f0..bf1e85f 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -900,7 +900,7 @@ private end record; package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); type Map (Capacity : Count_Type; Modulus : Hash_Type) is record Content : HT_Types.Hash_Table_Type (Capacity, Modulus); diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb index 6e289e4..786abf1 100644 --- a/gcc/ada/libgnat/a-cfhase.adb +++ b/gcc/ada/libgnat/a-cfhase.adb @@ -25,11 +25,11 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); +with Ada.Containers.Hash_Tables.Generic_Formal_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Hash_Tables.Generic_Formal_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; @@ -95,13 +95,13 @@ is -- Local Instantiations -- -------------------------- - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + package HT_Ops is new Hash_Tables.Generic_Formal_Operations (HT_Types => HT_Types, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next); - package Element_Keys is new Hash_Tables.Generic_Bounded_Keys + package Element_Keys is new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, @@ -815,7 +815,7 @@ is -- Local Instantiations -- -------------------------- - package Key_Keys is new Hash_Tables.Generic_Bounded_Keys + package Key_Keys is new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 425824d..1a40118 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -1479,7 +1479,7 @@ private end record; package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); type Set (Capacity : Count_Type; Modulus : Hash_Type) is record Content : HT_Types.Hash_Table_Type (Capacity, Modulus); diff --git a/gcc/ada/libgnat/a-chtgfk.adb b/gcc/ada/libgnat/a-chtgfk.adb new file mode 100644 index 0000000..57967f9 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfk.adb @@ -0,0 +1,316 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2022, 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. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Formal_Keys is + + Checks : constant Boolean := Container_Checks'Enabled; + + ----------------------------- + -- Checked_Equivalent_Keys -- + ----------------------------- + + function Checked_Equivalent_Keys + (HT : Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean + is + begin + return Equivalent_Keys (Key, HT.Nodes (Node)); + end Checked_Equivalent_Keys; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type + is + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Checked_Index; + + -------------------------- + -- Delete_Key_Sans_Free -- + -------------------------- + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + X : out Count_Type) + is + Indx : Hash_Type; + Prev : Count_Type; + + begin + if HT.Length = 0 then + X := 0; + return; + end if; + + Indx := Checked_Index (HT, Key); + X := HT.Buckets (Indx); + + if X = 0 then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + HT.Buckets (Indx) := Next (HT.Nodes (X)); + HT.Length := HT.Length - 1; + return; + end if; + + loop + Prev := X; + X := Next (HT.Nodes (Prev)); + + if X = 0 then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); + HT.Length := HT.Length - 1; + return; + end if; + end loop; + end Delete_Key_Sans_Free; + + ---------- + -- Find -- + ---------- + + function Find + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Count_Type + is + Indx : Hash_Type; + Node : Count_Type; + + begin + if HT.Length = 0 then + return 0; + end if; + + Indx := Checked_Index (HT'Unrestricted_Access.all, Key); + + Node := HT.Buckets (Indx); + while Node /= 0 loop + if Checked_Equivalent_Keys + (HT'Unrestricted_Access.all, Key, Node) + then + return Node; + end if; + Node := Next (HT.Nodes (Node)); + end loop; + + return 0; + end Find; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + Indx : Hash_Type; + + begin + Indx := Checked_Index (HT, Key); + Node := HT.Buckets (Indx); + + if Node = 0 then + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + Node := New_Node; + Set_Next (HT.Nodes (Node), Next => 0); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + loop + if Checked_Equivalent_Keys (HT, Key, Node) then + Inserted := False; + return; + end if; + + Node := Next (HT.Nodes (Node)); + + exit when Node = 0; + end loop; + + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + Node := New_Node; + Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------------------------- + -- Generic_Replace_Element -- + ----------------------------- + + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type'Class; + Node : Count_Type; + Key : Key_Type) + is + pragma Assert (HT.Length > 0); + pragma Assert (Node /= 0); + + BB : Buckets_Type renames HT.Buckets; + NN : Nodes_Type renames HT.Nodes; + + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Checked_Index (HT, Key); + + New_Bucket : Count_Type renames BB (New_Indx); + N, M : Count_Type; + + begin + -- The following block appears to be vestigial -- this should be done + -- using Checked_Index instead. Also, we might have to move the actual + -- tampering checks to the top of the subprogram, in order to prevent + -- infinite recursion when calling Hash. (This is similar to how Insert + -- and Delete are implemented.) This implies that we will have to defer + -- the computation of New_Index until after the tampering check. ??? + + Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; + + -- Replace_Element is allowed to change a node's key to Key + -- (generic formal operation Assign provides the mechanism), but + -- only if Key is not already in the hash table. (In a unique-key + -- hash table as this one, a key is mapped to exactly one node.) + + if Checked_Equivalent_Keys (HT, Key, Node) then + -- The new Key value is mapped to this same Node, so Node + -- stays in the same bucket. + + Assign (NN (Node), Key); + return; + end if; + + -- Key is not equivalent to Node, so we now have to determine if it's + -- equivalent to some other node in the hash table. This is the case + -- irrespective of whether Key is in the same or a different bucket from + -- Node. + + N := New_Bucket; + while N /= 0 loop + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then + pragma Assert (N /= Node); + raise Program_Error with + "attempt to replace existing element"; + end if; + + N := Next (NN (N)); + end loop; + + -- We have determined that Key is not already in the hash table, so + -- the change is tentatively allowed. We now perform the standard + -- checks to determine whether the hash table is locked (because you + -- cannot change an element while it's in use by Query_Element or + -- Update_Element), or if the container is busy (because moving a + -- node to a different bucket would interfere with iteration). + + if Old_Indx = New_Indx then + -- The node is already in the bucket implied by Key. In this case + -- we merely change its value without moving it. + + Assign (NN (Node), Key); + return; + end if; + + -- The node is in a bucket different from the bucket implied by Key. + -- Do the assignment first, before moving the node, so that if Assign + -- propagates an exception, then the hash table will not have been + -- modified (except for any possible side-effect Assign had on Node). + + Assign (NN (Node), Key); + + -- Now we can safely remove the node from its current bucket + + N := BB (Old_Indx); -- get value of first node in old bucket + pragma Assert (N /= 0); + + if N = Node then -- node is first node in its bucket + BB (Old_Indx) := Next (NN (Node)); + + else + pragma Assert (HT.Length > 1); + + loop + M := Next (NN (N)); + pragma Assert (M /= 0); + + if M = Node then + Set_Next (NN (N), Next => Next (NN (Node))); + exit; + end if; + + N := M; + end loop; + end if; + + -- Now we link the node into its new bucket (corresponding to Key) + + Set_Next (NN (Node), Next => New_Bucket); + New_Bucket := Node; + end Generic_Replace_Element; + + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type is + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Index; + +end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfk.ads b/gcc/ada/libgnat/a-chtgfk.ads new file mode 100644 index 0000000..633887f --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfk.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2022, 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. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that depend on keys. + +generic + with package HT_Types is + new Generic_Formal_Hash_Table_Types (<>); + + use HT_Types; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + + type Key_Type (<>) is limited private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean; + +package Ada.Containers.Hash_Tables.Generic_Formal_Keys is + pragma Pure; + + function Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type; + pragma Inline (Index); + -- Returns the bucket number (array index value) for the given key + + function Checked_Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type; + pragma Inline (Checked_Index); + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Equivalent_Keys + (HT : Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean; + -- Calls Equivalent_Keys, but locks and unlocks the container, per + -- AI05-0022, in order to detect element tampering by that generic actual. + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + X : out Count_Type); + -- Removes the node (if any) with the given key from the hash table, + -- without deallocating it. Program_Error is raised if the hash + -- table is busy. + + function Find + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Count_Type; + -- Returns the node (if any) corresponding to the given key + + generic + with function New_Node return Count_Type; + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Attempts to insert a new node with the given key into the hash table. + -- If a node with that key already exists in the table, then that node + -- is returned and Inserted returns False. Otherwise New_Node is called + -- to allocate a new node, and Inserted returns True. Program_Error is + -- raised if the hash table is busy. + + generic + with function Hash (Node : Node_Type) return Hash_Type; + with procedure Assign (Node : in out Node_Type; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type'Class; + Node : Count_Type; + Key : Key_Type); + -- Assigns Key to Node, possibly changing its equivalence class. If Node + -- is in the same equivalence class as Key (that is, it's already in the + -- bucket implied by Key), then if the hash table is locked then + -- Program_Error is raised; otherwise Assign is called to assign Key to + -- Node. If Node is in a different bucket from Key, then Program_Error is + -- raised if the hash table is busy. Otherwise it Assigns Key to Node and + -- moves the Node from its current bucket to the bucket implied by Key. + -- Note that it is never proper to assign to Node a key value already + -- in the map, and so if Key is equivalent to some other node then + -- Program_Error is raised. + +end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfo.adb b/gcc/ada/libgnat/a-chtgfo.adb new file mode 100644 index 0000000..063537e --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfo.adb @@ -0,0 +1,542 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2022, 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_Formal_Operations is + + Checks : constant Boolean := Container_Checks'Enabled; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (Hash_Table : Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type + is + begin + return Index (Hash_Table, Hash_Table.Nodes (Node)); + end Checked_Index; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type'Class) is + begin + 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 + 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_Formal_Operations; diff --git a/gcc/ada/libgnat/a-chtgfo.ads b/gcc/ada/libgnat/a-chtgfo.ads new file mode 100644 index 0000000..4936c73 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfo.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2022, 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. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that do not depend on keys. + +with Ada.Streams; + +generic + with package HT_Types is + new Generic_Formal_Hash_Table_Types (<>); + + use HT_Types; + + with function Hash_Node (Node : Node_Type) return Hash_Type; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + +package Ada.Containers.Hash_Tables.Generic_Formal_Operations is + pragma Pure; + + function Index + (Buckets : Buckets_Type; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Buckets array index + + function Index + (HT : Hash_Table_Type'Class; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Hash_Table buckets array + -- index. + + function Checked_Index + (Hash_Table : Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type; + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + generic + with function Find + (HT : Hash_Table_Type'Class; + Key : Node_Type) return Boolean; + function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean; + -- Used to implement hashed container equality. For each node in hash table + -- L, it calls Find to search for an equivalent item in hash table R. If + -- Find returns False for any node then Generic_Equal terminates + -- immediately and returns False. Otherwise if Find returns True for every + -- node then Generic_Equal returns True. + + procedure Clear (HT : in out Hash_Table_Type'Class); + -- Deallocates each node in hash table HT. (Note that it only deallocates + -- the nodes, not the buckets array.) Program_Error is raised if the hash + -- table is busy. + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type); + -- Delete a node whose bucket position is known. extracted from following + -- subprogram, but also used directly to remove a node whose element has + -- been modified through a key_preserving reference: in that case we cannot + -- use the value of the element precisely because the current value does + -- not correspond to the hash code that determines its bucket. + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type); + -- Removes node X from the hash table without deallocating the node + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Hash_Table_Type'Class; + Node : out Count_Type); + -- Claim a node from the free store. Generic_Allocate first + -- calls Set_Element on the potential node, and then returns + -- the node's index as the value of the Node parameter. + + procedure Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type); + -- Return a node back to the free store, from where it had + -- been previously claimed via Generic_Allocate. + + function First (HT : Hash_Table_Type'Class) return Count_Type; + -- Returns the head of the list in the first (lowest-index) non-empty + -- bucket. + + function Next + (HT : Hash_Table_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the node that immediately follows Node. This corresponds to + -- either the next node in the same bucket, or (if Node is the last node in + -- its bucket) the head of the list in the first non-empty bucket that + -- follows. + + generic + with procedure Process (Node : Count_Type); + procedure Generic_Iteration (HT : Hash_Table_Type'Class); + -- Calls Process for each node in hash table HT + + generic + use Ada.Streams; + with procedure Write + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type'Class); + -- Used to implement the streaming attribute for hashed containers. It + -- calls Write for each node to write its value into Stream. + + generic + use Ada.Streams; + with function New_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type'Class); + -- Used to implement the streaming attribute for hashed containers. It + -- first clears hash table HT, then populates the hash table by calling + -- New_Node for each item in Stream. + +end Ada.Containers.Hash_Tables.Generic_Formal_Operations; diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads index 2c56321..2f035e3 100644 --- a/gcc/ada/libgnat/a-cohata.ads +++ b/gcc/ada/libgnat/a-cohata.ads @@ -79,4 +79,23 @@ package Ada.Containers.Hash_Tables is package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Hash_Table_Types; + generic + type Node_Type is private; + package Generic_Formal_Hash_Table_Types is + + type Nodes_Type is array (Count_Type range <>) of Node_Type; + type Buckets_Type is array (Hash_Type range <>) of Count_Type; + + type Hash_Table_Type + (Capacity : Count_Type; + Modulus : Hash_Type) is + tagged record + Length : Count_Type := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity); + Buckets : Buckets_Type (1 .. Modulus) := [others => 0]; + end record; + + end Generic_Formal_Hash_Table_Types; + end Ada.Containers.Hash_Tables; |