X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fa-cihase.adb;h=c901e646e66ae99278ddf250c52292ab039f9c50;hb=20d2f5309ee374943308566fa4f174cd3312853b;hp=8e747eadf08196c7ef50ac049d94aa268e154a64;hpb=a4f57dfb8913775e2031ff0a074ca54b188d2ec3;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 8e747eadf08..c901e646e66 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -2,36 +2,29 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- A D A . C O N T A I N E R S . -- --- I N D E F I N I T E _ H A S H E D _ S E T S -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- -- -- -- B o d y -- -- -- --- 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 -- --- apply solely to the contents of the part following the private keyword. -- +-- Copyright (C) 2004-2009, 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 2, or (at your option) any later ver- -- +-- 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- 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. -- -- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- +-- 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 -- +-- . -- -- -- --- This unit has originally being developed by Matthew J Heaney. -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; @@ -42,16 +35,19 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); -with System; use type System.Address; - with Ada.Containers.Prime_Numbers; +with System; use type System.Address; + package body Ada.Containers.Indefinite_Hashed_Sets is ----------------------- -- Local Subprograms -- ----------------------- + procedure Assign (Node : Node_Access; Item : Element_Type); + pragma Inline (Assign); + function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); @@ -73,28 +69,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Hash_Node (Node : Node_Access) return Hash_Type; pragma Inline (Hash_Node); + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; pragma Inline (Is_In); function Next (Node : Node_Access) return Node_Access; pragma Inline (Next); - function Read_Node (Stream : access Root_Stream_Type'Class) + function Read_Node (Stream : not null access Root_Stream_Type'Class) return Node_Access; pragma Inline (Read_Node); - procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type); - 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; + (Stream : not null access Root_Stream_Type'Class; Node : Node_Access); pragma Inline (Write_Node); @@ -103,25 +100,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -------------------------- procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - package HT_Ops is - new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Element_Keys is - new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); @@ -132,6 +127,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); @@ -153,6 +151,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end Assign; + -------------- -- Capacity -- -------------- @@ -208,7 +217,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); if X = null then - raise Constraint_Error; + raise Constraint_Error with "attempt to delete element not in set"; end if; Free (X); @@ -219,24 +228,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : in out Cursor) is begin - pragma Assert (Vet (Position), "bad cursor in Delete"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor equals No_Element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "Position cursor is bad"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with "Position cursor designates wrong set"; end if; if Container.HT.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (set is busy)"; end if; + pragma Assert (Vet (Position), "Position cursor is bad"); + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); Free (Position.Node); @@ -259,32 +269,50 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Source.Length = 0 then + if Source.HT.Length = 0 then return; end if; if Target.HT.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (set is busy)"; end if; - -- TODO: This can be written in terms of a loop instead as - -- active-iterator style, sort of like a passive iterator. + if Source.HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; - Tgt_Node := HT_Ops.First (Target.HT); - while Tgt_Node /= null loop - if Is_In (Source.HT, Tgt_Node) then - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT, X); - Free (X); - end; + begin + Src_Node := HT_Ops.First (Source.HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); - else - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - end if; - end loop; + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Source.HT, Src_Node); + end loop; + end; + + else + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.HT, Tgt_Node) then + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end if; end Difference; function Difference (Left, Right : Set) return Set is @@ -307,7 +335,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); + Buckets := HT_Ops.New_Buckets (Length => Size); end; Length := 0; @@ -326,13 +354,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if not Is_In (Right.HT, L_Node) then declare - Indx : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; - + Src : Element_Type renames L_Node.Element.all; + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (Indx); - + Tgt : Element_Access := new Element_Type'(Src); begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end; Length := Length + 1; @@ -358,16 +389,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Vet (Position), "bad cursor in function Element"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor of equals No_Element"; end if; if Position.Node.Element = null then -- handle dangling reference - raise Program_Error; + raise Program_Error with "Position cursor is bad"; end if; + pragma Assert (Vet (Position), "bad cursor in function Element"); + return Position.Node.Element.all; end Element; @@ -387,21 +418,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; - if Left.Node = null - or else Right.Node = null - then - raise Constraint_Error; + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null -- handle dangling cursor reference - or else Right.Node.Element = null - then - raise Program_Error; + if Left.Node.Element = null then + raise Program_Error with + "Left cursor of Equivalent_Elements is bad"; end if; + if Right.Node.Element = null then + raise Program_Error with + "Right cursor of Equivalent_Elements is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + return Equivalent_Elements (Left.Node.Element.all, Right.Node.Element.all); @@ -410,32 +449,36 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left : Cursor; Right : Element_Type) return Boolean is begin - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - if Left.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null then -- handling dangling reference - raise Program_Error; + if Left.Node.Element = null then + raise Program_Error with + "Left cursor of Equivalent_Elements is bad"; end if; + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + return Equivalent_Elements (Left.Node.Element.all, Right); end Equivalent_Elements; function Equivalent_Elements (Left : Element_Type; Right : Cursor) return Boolean is begin - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); - if Right.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node.Element = null then -- handle dangling cursor reference - raise Program_Error; + if Right.Node.Element = null then + raise Program_Error with + "Right cursor of Equivalent_Elements is bad"; end if; + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + return Equivalent_Elements (Left, Right.Node.Element.all); end Equivalent_Elements; @@ -623,7 +666,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is if not Inserted then if Container.HT.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; end if; X := Position.Node.Element; @@ -644,6 +688,35 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : out Cursor; Inserted : out Boolean) is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is function New_Node (Next : Node_Access) return Node_Access; pragma Inline (New_Node); @@ -665,8 +738,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end New_Node; - HT : Hash_Table_Type renames Container.HT; - -- Start of processing for Insert begin @@ -674,30 +745,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; - Local_Insert (HT, New_Item, Position.Node, Inserted); + Local_Insert (HT, New_Item, Node, Inserted); if Inserted and then HT.Length > HT_Ops.Capacity (HT) then HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error; - end if; end Insert; ------------------ @@ -721,18 +775,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; if Target.HT.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (set is busy)"; end if; - -- TODO: optimize this to use an explicit - -- loop instead of an active iterator - -- (similar to how a passive iterator is - -- implemented). - -- - -- Another possibility is to test which - -- set is smaller, and iterate over the - -- smaller set. - Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop if Is_In (Source.HT, Tgt_Node) then @@ -768,7 +814,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); + Buckets := HT_Ops.New_Buckets (Length => Size); end; Length := 0; @@ -787,13 +833,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Is_In (Right.HT, L_Node) then declare - Indx : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; + Src : Element_Type renames L_Node.Element.all; + + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (Indx); + Tgt : Element_Access := new Element_Type'(Src); + begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end; Length := Length + 1; @@ -850,9 +903,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end if; - -- TODO: rewrite this to loop in the - -- style of a passive iterator. - Subset_Node := HT_Ops.First (Subset.HT); while Subset_Node /= null loop if not Is_In (Of_Set.HT, Subset_Node) then @@ -888,15 +938,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames Container'Unrestricted_Access.HT.Busy; -- Start of processing for Iterate begin - -- TODO: resolve whether HT_Ops.Generic_Iteration should - -- manipulate busy bit. + B := B + 1; - Iterate (HT); + begin + Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ------------ @@ -928,16 +985,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Next (Position : Cursor) return Cursor is begin - pragma Assert (Vet (Position), "bad cursor in function Next"); - if Position.Node = null then return No_Element; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "bad cursor in Next"; end if; + pragma Assert (Vet (Position), "bad cursor in Next"); + declare HT : Hash_Table_Type renames Position.Container.HT; Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); @@ -993,16 +1050,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "bad cursor in Query_Element"; end if; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + declare HT : Hash_Table_Type renames Position.Container'Unrestricted_Access.all.HT; @@ -1033,19 +1091,27 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ---------- procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : out Set) is begin Read_Nodes (Stream, Container.HT); end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + --------------- -- Read_Node -- --------------- function Read_Node - (Stream : access Root_Stream_Type'Class) return Node_Access + (Stream : not null access Root_Stream_Type'Class) return Node_Access is X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); @@ -1069,14 +1135,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Element_Keys.Find (Container.HT, New_Item); X : Element_Access; + pragma Warnings (Off, X); begin if Node = null then - raise Constraint_Error; + raise Constraint_Error with + "attempt to replace element not in set"; end if; if Container.HT.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; end if; X := Node.Element; @@ -1091,134 +1160,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is --------------------- procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type) - is - begin - if Equivalent_Elements (Node.Element.all, New_Item) then - pragma Assert (Hash (Node.Element.all) = Hash (New_Item)); - - if HT.Lock > 0 then - raise Program_Error; - end if; - - declare - X : Element_Access := Node.Element; - begin - Node.Element := new Element_Type'(New_Item); -- OK if fails - Free_Element (X); - end; - - return; - end if; - - if HT.Busy > 0 then - raise Program_Error; - end if; - - HT_Ops.Delete_Node_Sans_Free (HT, Node); - - Insert_New_Element : declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - ------------------------ - -- Insert_New_Element -- - ------------------------ - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Element := new Element_Type'(New_Item); -- OK if fails - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - X : Element_Access := Node.Element; - - -- Start of processing for Insert_New_Element - - begin - Attempt_Insert : begin - Insert - (HT => HT, - Key => New_Item, - Node => Result, - Inserted => Inserted); - exception - when others => - Inserted := False; -- Assignment failed - end Attempt_Insert; - - if Inserted then - Free_Element (X); -- Just propagate if fails - return; - end if; - end Insert_New_Element; - - Reinsert_Old_Element : - declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - -- Start of processing for Reinsert_Old_Element - - begin - Insert - (HT => HT, - Key => Node.Element.all, - Node => Result, - Inserted => Inserted); - exception - when others => - null; - end Reinsert_Old_Element; - - raise Program_Error; - end Replace_Element; - - procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type) is begin - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor equals No_Element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "bad cursor in Replace_Element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong set"; end if; + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + Replace_Element (Container.HT, Position.Node, New_Item); end Replace_Element; @@ -1258,7 +1219,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; if Target.HT.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (set is busy)"; end if; declare @@ -1408,7 +1370,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length + Right.Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); + Buckets := HT_Ops.New_Buckets (Length => Size); end; Length := 0; @@ -1502,6 +1464,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return (Controlled with HT => (Buckets, Length, 0, 0)); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + ----------- -- Union -- ----------- @@ -1545,6 +1523,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Tgt_Node : Node_Access; Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); -- Start of processing for Process @@ -1560,7 +1539,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; if Target.HT.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (set is busy)"; end if; declare @@ -1595,7 +1575,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length + Right.Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); + Buckets := HT_Ops.New_Buckets (Length => Size); end; Iterate_Left : declare @@ -1609,13 +1589,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ------------- procedure Process (L_Node : Node_Access) is - J : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; + Src : Element_Type renames L_Node.Element.all; + + J : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (J); + Tgt : Element_Access := new Element_Type'(Src); + begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end Process; -- Start of processing for Process @@ -1744,19 +1731,27 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ----------- procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Container : Set) is begin Write_Nodes (Stream, Container.HT); end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + ---------------- -- Write_Node -- ---------------- procedure Write_Node - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Node : Node_Access) is begin @@ -1813,7 +1808,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error; + raise Constraint_Error with "key not in map"; end if; Free (X); @@ -1828,7 +1823,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + return Node.Element.all; end Element; @@ -1881,16 +1881,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - pragma Assert (Vet (Position), "bad cursor in function Key"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor equals No_Element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "Position cursor is bad"; end if; + pragma Assert (Vet (Position), "bad cursor in function Key"); + return Key (Position.Node.Element.all); end Key; @@ -1908,7 +1909,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Node = null then - raise Constraint_Error; + raise Constraint_Error with + "attempt to replace key not in set"; end if; Replace_Element (Container.HT, Node, New_Item); @@ -1916,7 +1918,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Update_Element_Preserving_Key (Container : in out Set; - Position : in Cursor; + Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is @@ -1924,31 +1926,33 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Indx : Hash_Type; begin - pragma Assert - (Vet (Position), - "bad cursor in Update_Element_Preserving_Key"); - if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor equals No_Element"; end if; if Position.Node.Element = null or else Position.Node.Next = Position.Node then - raise Program_Error; + raise Program_Error with "Position cursor is bad"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong set"; end if; if HT.Buckets = null or else HT.Buckets'Length = 0 or else HT.Length = 0 then - raise Program_Error; + raise Program_Error with "Position cursor is bad (set is empty)"; end if; + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + Indx := HT_Ops.Index (HT, Position.Node); declare @@ -1992,7 +1996,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Prev := Prev.Next; if Prev = null then - raise Program_Error; + raise Program_Error with + "Position cursor is bad (node not found)"; end if; end loop; @@ -2009,7 +2014,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Free (X); end; - raise Program_Error; + raise Program_Error with "key was modified"; end Update_Element_Preserving_Key; end Generic_Keys;