diff options
Diffstat (limited to 'gcc/ada/a-cohama.adb')
| -rw-r--r-- | gcc/ada/a-cohama.adb | 327 |
1 files changed, 265 insertions, 62 deletions
diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index e1120c1..97d2723 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASHED_MAPS -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -43,12 +43,6 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); package body Ada.Containers.Hashed_Maps is - type Node_Type is limited record - Key : Key_Type; - Element : Element_Type; - Next : Node_Access; - end record; - ----------------------- -- Local Subprograms -- ----------------------- @@ -57,13 +51,15 @@ package body Ada.Containers.Hashed_Maps is (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + pragma Inline (Equivalent_Key_Node); + + procedure Free (X : in out Node_Access); function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean; function Hash_Node (Node : Node_Access) return Hash_Type; @@ -79,6 +75,8 @@ package body Ada.Containers.Hashed_Maps is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); + function Vet (Position : Cursor) return Boolean; + procedure Write_Node (Stream : access Root_Stream_Type'Class; Node : Node_Access); @@ -88,14 +86,9 @@ package body Ada.Containers.Hashed_Maps is -- Local Instantiations -- -------------------------- - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package HT_Ops is new Hash_Tables.Generic_Operations (HT_Types => HT_Types, - Hash_Table_Type => Map, - Null_Node => null, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next, @@ -105,13 +98,11 @@ package body Ada.Containers.Hashed_Maps is package Key_Ops is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Map, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Key_Type, Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + Equivalent_Keys => Equivalent_Key_Node); function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); @@ -122,26 +113,37 @@ package body Ada.Containers.Hashed_Maps is -- "=" -- --------- - function "=" (Left, Right : Map) return Boolean renames Is_Equal; + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; ------------ -- Adjust -- ------------ - procedure Adjust (Container : in out Map) renames HT_Ops.Adjust; + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; -------------- -- Capacity -- -------------- - function Capacity (Container : Map) return Count_Type - renames HT_Ops.Capacity; + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; ----------- -- Clear -- ----------- - procedure Clear (Container : in out Map) renames HT_Ops.Clear; + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; -------------- -- Contains -- @@ -175,7 +177,7 @@ package body Ada.Containers.Hashed_Maps is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then raise Constraint_Error; @@ -186,17 +188,23 @@ package body Ada.Containers.Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; if Position.Container /= Map_Access'(Container'Unchecked_Access) then raise Program_Error; end if; - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Position.Node); + pragma Assert (Position.Node.Next /= Position.Node); + + if Container.HT.Busy > 0 then + raise Program_Error; + end if; + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); Position.Container := null; end Delete; @@ -212,19 +220,20 @@ package body Ada.Containers.Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Element; end Element; - --------------------- - -- Equivalent_Keys -- - --------------------- + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean is begin return Equivalent_Keys (Key, Node.Key); - end Equivalent_Keys; + end Equivalent_Key_Node; --------------------- -- Equivalent_Keys -- @@ -233,16 +242,20 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin + pragma Assert (Vet (Left)); + pragma Assert (Vet (Right)); return Equivalent_Keys (Left.Node.Key, Right.Node.Key); end Equivalent_Keys; function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin + pragma Assert (Vet (Left)); return Equivalent_Keys (Left.Node.Key, Right); end Equivalent_Keys; function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin + pragma Assert (Vet (Right)); return Equivalent_Keys (Left, Right.Node.Key); end Equivalent_Keys; @@ -253,7 +266,7 @@ package body Ada.Containers.Hashed_Maps is procedure Exclude (Container : in out Map; Key : Key_Type) is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); Free (X); end Exclude; @@ -261,14 +274,17 @@ package body Ada.Containers.Hashed_Maps is -- Finalize -- -------------- - procedure Finalize (Container : in out Map) renames HT_Ops.Finalize; + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; ---------- -- Find -- ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin if Node = null then @@ -283,11 +299,11 @@ package body Ada.Containers.Hashed_Maps is -------------------- function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean is - R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key); - R_Node : Node_Access := R_Map.Buckets (R_Index); + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); + R_Node : Node_Access := R_HT.Buckets (R_Index); begin while R_Node /= null loop @@ -306,7 +322,7 @@ package body Ada.Containers.Hashed_Maps is ----------- function First (Container : Map) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container); + Node : constant Node_Access := HT_Ops.First (Container.HT); begin if Node = null then @@ -316,13 +332,33 @@ package body Ada.Containers.Hashed_Maps is return Cursor'(Container'Unchecked_Access, Node); end First; + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + ----------------- -- Has_Element -- ----------------- function Has_Element (Position : Cursor) return Boolean is begin - return Position /= No_Element; + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; + + pragma Assert (Vet (Position)); + return True; end Has_Element; --------------- @@ -350,6 +386,10 @@ package body Ada.Containers.Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Key := Key; Position.Node.Element := New_Item; end if; @@ -390,11 +430,30 @@ package body Ada.Containers.Hashed_Maps is raise; end New_Node; + HT : Hash_Table_Type renames Container.HT; + -- Start of processing for Insert begin - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Local_Insert (Container, Key, Position.Node, Inserted); + if HT.Length >= HT_Ops.Capacity (HT) then + + -- TODO: 17 Apr 2005 + -- We should defer the expansion until we're sure that the + -- element was successfully inserted. We can do that by + -- first performing the insertion attempt, and allowing the + -- invariant len <= cap to be violated temporarily. After + -- the insertion we can restore the invariant. The + -- worst that can happen is that the insertion succeeds + -- (new element is added to the map), but the + -- invariant is broken (len > cap). But it's only + -- broken by a little (since len = cap + 1), so the + -- effect is benign. + -- END TODO. + + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -421,11 +480,17 @@ package body Ada.Containers.Hashed_Maps is return Node; end New_Node; + HT : Hash_Table_Type renames Container.HT; + -- Start of processing for Insert begin - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Local_Insert (Container, Key, Position.Node, Inserted); + if HT.Length >= HT_Ops.Capacity (HT) then + -- TODO: see note above. + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -451,7 +516,7 @@ package body Ada.Containers.Hashed_Maps is function Is_Empty (Container : Map) return Boolean is begin - return Container.Length = 0; + return Container.HT.Length = 0; end Is_Empty; ------------- @@ -479,7 +544,7 @@ package body Ada.Containers.Hashed_Maps is -- Start of processing for Iterate begin - Local_Iterate (Container); + Local_Iterate (Container.HT); end Iterate; --------- @@ -488,6 +553,7 @@ package body Ada.Containers.Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Key; end Key; @@ -497,7 +563,7 @@ package body Ada.Containers.Hashed_Maps is function Length (Container : Map) return Count_Type is begin - return Container.Length; + return Container.HT.Length; end Length; ---------- @@ -506,7 +572,11 @@ package body Ada.Containers.Hashed_Maps is procedure Move (Target : in out Map; - Source : in out Map) renames HT_Ops.Move; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; ---------- -- Next -- @@ -519,13 +589,15 @@ package body Ada.Containers.Hashed_Maps is function Next (Position : Cursor) return Cursor is begin - if Position = No_Element then + if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; declare - M : Map renames Position.Container.all; - Node : constant Node_Access := HT_Ops.Next (M, Position.Node); + pragma Assert (Vet (Position)); + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); begin if Node = null then @@ -547,10 +619,36 @@ package body Ada.Containers.Hashed_Maps is procedure Query_Element (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -559,7 +657,11 @@ package body Ada.Containers.Hashed_Maps is procedure Read (Stream : access Root_Stream_Type'Class; - Container : out Map) renames Read_Nodes; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; --------------- -- Read_Node -- @@ -590,13 +692,17 @@ package body Ada.Containers.Hashed_Maps is Key : Key_Type; New_Item : Element_Type) is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin if Node = null then raise Constraint_Error; end if; + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + Node.Key := Key; Node.Element := New_Item; end Replace; @@ -606,8 +712,15 @@ package body Ada.Containers.Hashed_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is + pragma Assert (Vet (Position)); + E : Element_Type renames Position.Node.Element; + begin - Position.Node.Element := By; + if Position.Container.HT.Lock > 0 then + raise Program_Error; + end if; + + E := By; end Replace_Element; ---------------------- @@ -616,7 +729,11 @@ package body Ada.Containers.Hashed_Maps is procedure Reserve_Capacity (Container : in out Map; - Capacity : Count_Type) renames HT_Ops.Ensure_Capacity; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; -------------- -- Set_Next -- @@ -633,19 +750,105 @@ package body Ada.Containers.Hashed_Maps is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Container = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null then + return False; + end if; + +-- NOTE: see notes in Insert. +-- if HT.Length > HT.Buckets'Length then +-- return False; +-- end if; + + X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- weird + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + ----------- -- Write -- ----------- procedure Write (Stream : access Root_Stream_Type'Class; - Container : Map) renames Write_Nodes; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; ---------------- -- Write_Node -- |