2010-10-26 Matthew Heaney <heaney@adacore.com>
+ * Makefile.rtl, impunit.adb: Add bounded hashed set and bounded hashed
+ map containers.
+ * a-cohata.ads: Add declaration of generic package for bounded hash
+ table types.
+ * a-chtgbo.ads, a-chtgbo.adb, a-chtgbk.ads, a-chtgbk.adb, a-cbhase.ads,
+ a-cbhase.adb, a-cbhama.ads, a-cbhama.adb: New files.
+
+2010-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb: Improve warning message on overlapping actuals.
+
+2010-10-26 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch4.adb, exp_dist.adb: Minor reformatting.
+
+2010-10-26 Vincent Celier <celier@adacore.com>
+
+ * makeusg.adb (Makeusg): Add lines for switches -vl, -vm and -vh.
+
+2010-10-26 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Move generation of
+ predicate check to analyzer, since too much rewriting occurs in the
+ analyzer.
+ * sem_ch13.adb (Build_Predicate_Function): Change calling sequence, and
+ change the order in which things are done to fix several errors in
+ dealing with qualification of the type name.
+ (Build_Static_Predicate): Built static predicate after full analysis
+ of the body. This is necessary to fix several problems.
+ * sem_ch3.adb (Analyze_Object_Declaration): Move predicate check here
+ from expander, since too much expansion occurs in the analyzer to leave
+ it that late.
+ (Analyze_Object_Declaration): Change parameter Include_Null to new name
+ Include_Implicit in Is_Partially_Initialized_Type call.
+ (Analyze_Subtype_Declaration): Make sure predicates are proapagated in
+ some strange cases of internal subtype generation.
+ * sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type): Change
+ Include_Null to Include_Implicit, now includes the case of
+ discriminants.
+
+2010-10-26 Sergey Rybin <rybin@adacore.com>
+
+ * gnat_rm.texi: Revise the documentation for pragma Eliminate.
+
+2010-10-26 Matthew Heaney <heaney@adacore.com>
+
* Makefile.rtl, impunit.adb: Added bounded list container.
* a-cbdlli.ads, a-cbdlli.adb: New file.
a-calend$(objext) \
a-calfor$(objext) \
a-catizo$(objext) \
+ a-cbhama$(objext) \
+ a-cbhase$(objext) \
a-cborse$(objext) \
a-cbdlli$(objext) \
a-cborma$(objext) \
a-charac$(objext) \
a-chlat1$(objext) \
a-chlat9$(objext) \
+ a-chtgbo$(objext) \
+ a-chtgbk$(objext) \
a-chtgke$(objext) \
a-chtgop$(objext) \
a-chzla1$(objext) \
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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 Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+
+with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+with System; use type System.Address;
+
+package body Ada.Containers.Bounded_Hashed_Maps is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Type) return Boolean;
+ pragma Inline (Equivalent_Key_Node);
+
+ function Hash_Node (Node : Node_Type) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ function Next (Node : Node_Type) return Count_Type;
+ pragma Inline (Next);
+
+ procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
+ pragma Inline (Set_Next);
+
+ function Vet (Position : Cursor) return Boolean;
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package HT_Ops is new Hash_Tables.Generic_Bounded_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
+ (HT_Types => HT_Types,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Key_Node);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Map) return Boolean is
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean;
+
+ function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
+
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean
+ is
+ R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
+ R_Node : Count_Type := R_HT.Buckets (R_Index);
+
+ begin
+ while R_Node /= 0 loop
+ if Equivalent_Keys (L_Node.Key, R_HT.Nodes (R_Node).Key) then
+ return L_Node.Element = R_HT.Nodes (R_Node).Element;
+ end if;
+
+ R_Node := R_HT.Nodes (R_Node).Next;
+ end loop;
+
+ return False;
+ end Find_Equal_Key;
+
+ -- Start of processing for "="
+
+ begin
+ return Is_Equal (Left, Right);
+ end "=";
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Map; Source : Map) is
+ procedure Insert_Element (Source_Node : Count_Type);
+
+ procedure Insert_Elements is
+ new HT_Ops.Generic_Iteration (Insert_Element);
+
+ --------------------
+ -- Insert_Element --
+ --------------------
+
+ procedure Insert_Element (Source_Node : Count_Type) is
+ N : Node_Type renames Source.Nodes (Source_Node);
+ C : Cursor;
+ B : Boolean;
+
+ begin
+ Insert (Target, N.Key, N.Element, C, B);
+ pragma Assert (B);
+ end Insert_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error
+ with "Target capacity is less than Source length";
+ end if;
+
+ HT_Ops.Clear (Target);
+ Insert_Elements (Source);
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Map) return Count_Type is
+ begin
+ return Container.Capacity;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ begin
+ HT_Ops.Clear (Container);
+ end Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy
+ (Source : Map;
+ Capacity : Count_Type := 0;
+ Modulus : Hash_Type := 0) return Map
+ is
+ C : Count_Type;
+ M : Hash_Type;
+
+ begin
+ if Capacity = 0 then
+ C := Source.Length;
+
+ elsif Capacity >= Source.Length then
+ C := Capacity;
+
+ else
+ raise Capacity_Error with "Capacity value too small";
+ end if;
+
+ if Modulus = 0 then
+ M := Default_Modulus (C);
+ else
+ M := Modulus;
+ end if;
+
+ return Target : Map (Capacity => C, Modulus => M) do
+ Assign (Target => Target, Source => Source);
+ end return;
+ end Copy;
+
+ ---------------------
+ -- Default_Modulus --
+ ---------------------
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type is
+ begin
+ return To_Prime (Capacity);
+ end Default_Modulus;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : Count_Type;
+
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in map";
+ end if;
+
+ HT_Ops.Free (Container, X);
+ end Delete;
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Delete equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Delete designates wrong map";
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "Delete attempted to tamper with cursors (map is busy)";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ HT_Ops.Free (Container, Position.Node);
+
+ Position := No_Element;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "no element available because key not in map";
+ end if;
+
+ return Container.Nodes (Node).Element;
+ end Element;
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of function Element equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
+ return Position.Container.Nodes (Position.Node).Element;
+ end Element;
+
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
+
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Type) return Boolean is
+ begin
+ return Equivalent_Keys (Key, Node.Key);
+ end Equivalent_Key_Node;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys (Left, Right : Cursor)
+ return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
+ pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return Equivalent_Keys (LN.Key, RN.Key);
+ end;
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+
+ begin
+ return Equivalent_Keys (LN.Key, Right);
+ end;
+ end Equivalent_Keys;
+
+ function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
+
+ declare
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return Equivalent_Keys (Left, RN.Key);
+ end;
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Count_Type;
+ begin
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ HT_Ops.Free (Container, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ Node : constant Count_Type := HT_Ops.First (Container);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end First;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Has_Element");
+ return Position.Node /= 0;
+ end Has_Element;
+
+ ---------------
+ -- Hash_Node --
+ ---------------
+
+ function Hash_Node (Node : Node_Type) return Hash_Type is
+ begin
+ return Hash (Node.Key);
+ end Hash_Node;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "Include attempted to tamper with elements (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+
+ begin
+ N.Key := Key;
+ N.Element := New_Item;
+ end;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
+
+ procedure Allocate is
+ new HT_Ops.Generic_Allocate (Assign_Key);
+
+ -----------------
+ -- Assign_Key --
+ -----------------
+
+ procedure Assign_Key (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ -- Node.Element := New_Item;
+ end Assign_Key;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ -- ???
+ -- if HT_Ops.Capacity (HT) = 0 then
+ -- HT_Ops.Reserve_Capacity (HT, 1);
+ -- end if;
+
+ Local_Insert (Container, Key, Position.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 Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
+
+ procedure Allocate is
+ new HT_Ops.Generic_Allocate (Assign_Key);
+
+ -----------------
+ -- Assign_Key --
+ -----------------
+
+ procedure Assign_Key (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Assign_Key;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ -- ??
+ -- if HT_Ops.Capacity (HT) = 0 then
+ -- HT_Ops.Reserve_Capacity (HT, 1);
+ -- end if;
+
+ Local_Insert (Container, Key, Position.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 Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error with
+ "attempt to insert key already in map";
+ end if;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of function Key equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
+ return Position.Container.Nodes (Position.Node).Key;
+ end Key;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Map;
+ Source : in out Map)
+ is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Assign (Target => Target, Source => Source);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Next;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = 0 then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in function Next");
+
+ declare
+ M : Map renames Position.Container.all;
+ Node : constant Count_Type := HT_Ops.Next (M, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
+ declare
+ M : Map renames Position.Container.all;
+ N : Node_Type renames M.Nodes (Position.Node);
+ B : Natural renames M.Busy;
+ L : Natural renames M.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+
+ begin
+ Process (N.Key, N.Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ function Read_Node
+ (Stream : not null access Root_Stream_Type'Class) return Count_Type;
+ -- pragma Inline (Read_Node); ???
+
+ procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node
+ (Stream : not null access Root_Stream_Type'Class) return Count_Type
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ -- pragma Inline (Read_Element); ???
+
+ procedure Allocate is
+ new HT_Ops.Generic_Allocate (Read_Element);
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ Node : Count_Type;
+
+ -- Start of processing for Read_Node
+
+ begin
+ Allocate (Container, Node);
+ return Node;
+ end Read_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Read_Nodes (Stream, Container);
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in map";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "Replace attempted to tamper with elements (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Nodes (Node);
+
+ begin
+ N.Key := Key;
+ N.Element := New_Item;
+ end;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Replace_Element equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Replace_Element designates wrong map";
+ end if;
+
+ if Position.Container.Lock > 0 then
+ raise Program_Error with
+ "Replace_Element attempted to tamper with elements (map is locked)";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
+ Container.Nodes (Position.Node).Element := New_Item;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type)
+ is
+ begin
+ if Capacity > Container.Capacity then
+ raise Capacity_Error with "requested capacity is too large";
+ end if;
+ end Reserve_Capacity;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Update_Element equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Update_Element designates wrong map";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
+
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (N.Key, N.Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Update_Element;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return Position.Container = null;
+ end if;
+
+ if Position.Container = null then
+ return False;
+ end if;
+
+ declare
+ M : Map renames Position.Container.all;
+ X : Count_Type;
+
+ begin
+ if M.Length = 0 then
+ return False;
+ end if;
+
+ if M.Capacity = 0 then
+ return False;
+ end if;
+
+ if M.Buckets'Length = 0 then
+ return False;
+ end if;
+
+ if Position.Node > M.Capacity then
+ return False;
+ end if;
+
+ if M.Nodes (Position.Node).Next = Position.Node then
+ return False;
+ end if;
+
+ X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key));
+
+ for J in 1 .. M.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
+
+ if X = 0 then
+ return False;
+ end if;
+
+ if X = M.Nodes (X).Next then -- to prevent unnecessary looping
+ return False;
+ end if;
+
+ X := M.Nodes (X).Next;
+ end loop;
+
+ return False;
+ end;
+ end Vet;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Write;
+
+end Ada.Containers.Bounded_Hashed_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Hash_Tables;
+private with Ada.Streams;
+
+generic
+ type Key_Type is private;
+ type Element_Type is private;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+ with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Bounded_Hashed_Maps is
+ pragma Pure;
+ pragma Remote_Types;
+
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
+ pragma Preelaborable_Initialization (Map);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Map : constant Map;
+ -- Map objects declared without an initialization expression are
+ -- initialized to the value Empty_Map.
+
+ No_Element : constant Cursor;
+ -- Cursor objects declared without an initialization expression are
+ -- initialized to the value No_Element.
+
+ function "=" (Left, Right : Map) return Boolean;
+ -- For each key/element pair in Left, equality attempts to find the key in
+ -- Right; if a search fails the equality returns False. The search works by
+ -- calling Hash to find the bucket in the Right map that corresponds to the
+ -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys
+ -- to compare the key (in Left) to the key of each node in the bucket (in
+ -- Right); if the keys are equivalent, then the equality test for this
+ -- key/element pair (in Left) completes by calling the element equality
+ -- operator to compare the element (in Left) to the element of the node
+ -- (in Right) whose key matched.
+
+ function Capacity (Container : Map) return Count_Type;
+ -- Returns the current capacity of the map. Capacity is the maximum length
+ -- before which rehashing in guaranteed not to occur.
+
+ procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type);
+ -- If the value of the Capacity actual parameter is less or equal to
+ -- Container.Capacity, then the operation has no effect. Otherwise it
+ -- raises Capacity_Error (as no expansion of capacity is possible for a
+ -- bounded form).
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type;
+ -- Returns a modulus value (hash table size) which is optimal for the
+ -- specified capacity (which corresponds to the maximum number of items).
+
+ function Length (Container : Map) return Count_Type;
+ -- Returns the number of items in the map
+
+ function Is_Empty (Container : Map) return Boolean;
+ -- Equivalent to Length (Container) = 0
+
+ procedure Clear (Container : in out Map);
+ -- Removes all of the items from the map
+
+ function Key (Position : Cursor) return Key_Type;
+ -- Returns the key of the node designated by the cursor
+
+ function Element (Position : Cursor) return Element_Type;
+ -- Returns the element of the node designated by the cursor
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type);
+ -- Assigns the value New_Item to the element designated by the cursor
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+ -- Calls Process with the key and element (both having only a constant
+ -- view) of the node designed by the cursor.
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+ -- Calls Process with the key (with only a constant view) and element (with
+ -- a variable view) of the node designed by the cursor.
+
+ procedure Assign (Target : in out Map; Source : Map);
+ -- If Target denotes the same object as Source, then the operation has no
+ -- effect. If the Target capacity is less then the Source length, then
+ -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
+ -- copies the (active) elements from Source to Target.
+
+ function Copy
+ (Source : Map;
+ Capacity : Count_Type := 0;
+ Modulus : Hash_Type := 0) return Map;
+ -- Constructs a new set object whose elements correspond to Source. If the
+ -- Capacity parameter is 0, then the capacity of the result is the same as
+ -- the length of Source. If the Capacity parameter is equal or greater than
+ -- the length of Source, then the capacity of the result is the specified
+ -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
+ -- is 0, then the modulus of the result is the value returned by a call to
+ -- Default_Modulus with the capacity parameter determined as above;
+ -- otherwise the modulus of the result is the specified value.
+
+ procedure Move (Target : in out Map; Source : in out Map);
+ -- Clears Target (if it's not empty), and then moves (not copies) the
+ -- buckets array and nodes from Source to Target.
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+ -- Conditionally inserts New_Item into the map. If Key is already in the
+ -- map, then Inserted returns False and Position designates the node
+ -- containing the existing key/element pair (neither of which is modified).
+ -- If Key is not already in the map, the Inserted returns True and Position
+ -- designates the newly-inserted node container Key and New_Item. The
+ -- search for the key works as follows. Hash is called to determine Key's
+ -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to
+ -- compare Key to each node in that bucket. If the bucket is empty, or
+ -- there were no matching keys in the bucket, the search "fails" and the
+ -- key/item pair is inserted in the map (and Inserted returns True);
+ -- otherwise, the search "succeeds" (and Inserted returns False).
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+ -- The same as the (conditional) Insert that accepts an element parameter,
+ -- with the difference that if Inserted returns True, then the element of
+ -- the newly-inserted node is initialized to its default value.
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+ -- Attempts to insert Key into the map, performing the usual search (which
+ -- involves calling both Hash and Equivalent_Keys); if the search succeeds
+ -- (because Key is already in the map), then it raises Constraint_Error.
+ -- (This version of Insert is similar to Replace, but having the opposite
+ -- exception behavior. It is intended for use when you want to assert that
+ -- Key is not already in the map.)
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+ -- Attempts to insert Key into the map. If Key is already in the map, then
+ -- both the existing key and element are assigned the values of Key and
+ -- New_Item, respectively. (This version of Insert only raises an exception
+ -- if cursor tampering occurs. It is intended for use when you want to
+ -- insert the key/element pair in the map, and you don't care whether Key
+ -- is already present.)
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+ -- Searches for Key in the map; if the search fails (because Key was not in
+ -- the map), then it raises Constraint_Error. Otherwise, both the existing
+ -- key and element are assigned the values of Key and New_Item rsp. (This
+ -- is similar to Insert, but with the opposite exception behavior. It is to
+ -- be used when you want to assert that Key is already in the map.)
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+ -- Searches for Key in the map, and if found, removes its node from the map
+ -- and then deallocates it. The search works as follows. The operation
+ -- calls Hash to determine the key's bucket; if the bucket is not empty, it
+ -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is
+ -- the deletion analog of Include. It is intended for use when you want to
+ -- remove the item from the map, but don't care whether the key is already
+ -- in the map.)
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+ -- Searches for Key in the map (which involves calling both Hash and
+ -- Equivalent_Keys). If the search fails, then the operation raises
+ -- Constraint_Error. Otherwise it removes the node from the map and then
+ -- deallocates it. (This is the deletion analog of non-conditional
+ -- Insert. It is intended for use when you want to assert that the item is
+ -- already in the map.)
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+ -- Removes the node designated by Position from the map, and then
+ -- deallocates the node. The operation calls Hash to determine the bucket,
+ -- and then compares Position to each node in the bucket until there's a
+ -- match (it does not call Equivalent_Keys).
+
+ function First (Container : Map) return Cursor;
+ -- Returns a cursor that designates the first non-empty bucket, by
+ -- searching from the beginning of the buckets array.
+
+ function Next (Position : Cursor) return Cursor;
+ -- Returns a cursor that designates the node that follows the current one
+ -- designated by Position. If Position designates the last node in its
+ -- bucket, the operation calls Hash to compute the index of this bucket,
+ -- and searches the buckets array for the first non-empty bucket, starting
+ -- from that index; otherwise, it simply follows the link to the next node
+ -- in the same bucket.
+
+ procedure Next (Position : in out Cursor);
+ -- Equivalent to Position := Next (Position)
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+ -- Searches for Key in the map. Find calls Hash to determine the key's
+ -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare
+ -- Key to each key in the bucket. If the search succeeds, Find returns a
+ -- cursor designating the matching node; otherwise, it returns No_Element.
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+ -- Equivalent to Find (Container, Key) /= No_Element
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+ -- Equivalent to Element (Find (Container, Key))
+
+ function Has_Element (Position : Cursor) return Boolean;
+ -- Equivalent to Position /= No_Element
+
+ function Equivalent_Keys (Left, Right : Cursor) return Boolean;
+ -- Returns the result of calling Equivalent_Keys with the keys of the nodes
+ -- designated by cursors Left and Right.
+
+ function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean;
+ -- Returns the result of calling Equivalent_Keys with key of the node
+ -- designated by Left and key Right.
+
+ function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean;
+ -- Returns the result of calling Equivalent_Keys with key Left and the node
+ -- designated by Right.
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+ -- Calls Process for each node in the map
+
+private
+ -- pragma Inline ("=");
+ pragma Inline (Length);
+ pragma Inline (Is_Empty);
+ pragma Inline (Clear);
+ pragma Inline (Key);
+ pragma Inline (Element);
+ pragma Inline (Move);
+ pragma Inline (Contains);
+ pragma Inline (Capacity);
+ pragma Inline (Reserve_Capacity);
+ pragma Inline (Has_Element);
+ pragma Inline (Equivalent_Keys);
+ pragma Inline (Next);
+
+ type Node_Type is record
+ Key : Key_Type;
+ Element : Element_Type;
+ Next : Count_Type;
+ end record;
+
+ package HT_Types is
+ new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
+
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is
+ new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
+
+ use HT_Types;
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ type Map_Access is access all Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Map_Access;
+ Node : Count_Type;
+ end record;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ No_Element : constant Cursor := (Container => null, Node => 0);
+
+ Empty_Map : constant Map :=
+ (Hash_Table_Type with Capacity => 0, Modulus => 0);
+
+end Ada.Containers.Bounded_Hashed_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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 Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+
+with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Bounded_Hashed_Sets is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Type) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Hash_Node (Node : Node_Type) return Hash_Type;
+ pragma Inline (Hash_Node);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+
+ function Is_In
+ (HT : Set;
+ Key : Node_Type) return Boolean;
+ pragma Inline (Is_In);
+
+ procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
+ pragma Inline (Set_Element);
+
+ function Next (Node : Node_Type) return Count_Type;
+ pragma Inline (Next);
+
+ procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
+ pragma Inline (Set_Next);
+
+ function Vet (Position : Cursor) return Boolean;
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package HT_Ops is new Hash_Tables.Generic_Bounded_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
+ (HT_Types => HT_Types,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Element_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
+
+ procedure Replace_Element is
+ new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean;
+ pragma Inline (Find_Equal_Key);
+
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
+
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
+
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element);
+
+ R_Node : Count_Type := R_HT.Buckets (R_Index);
+
+ begin
+ loop
+ if R_Node = 0 then
+ return False;
+ end if;
+
+ if L_Node.Element = R_HT.Nodes (R_Node).Element then
+ return True;
+ end if;
+
+ R_Node := Next (R_HT.Nodes (R_Node));
+ end loop;
+ end Find_Equal_Key;
+
+ -- Start of processing for "="
+
+ begin
+ return Is_Equal (Left, Right);
+ end "=";
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Set; Source : Set) is
+ procedure Insert_Element (Source_Node : Count_Type);
+
+ procedure Insert_Elements is
+ new HT_Ops.Generic_Iteration (Insert_Element);
+
+ --------------------
+ -- Insert_Element --
+ --------------------
+
+ procedure Insert_Element (Source_Node : Count_Type) is
+ N : Node_Type renames Source.Nodes (Source_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ Insert (Target, N.Element, X, B);
+ pragma Assert (B);
+ end Insert_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error
+ with "Target capacity is less than Source length";
+ end if;
+
+ HT_Ops.Clear (Target);
+ Insert_Elements (Source);
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Set) return Count_Type is
+ begin
+ return Container.Capacity;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ begin
+ HT_Ops.Clear (Container);
+ end Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy
+ (Source : Set;
+ Capacity : Count_Type := 0;
+ Modulus : Hash_Type := 0) return Set
+ is
+ C : Count_Type;
+ M : Hash_Type;
+
+ begin
+ if Capacity = 0 then
+ C := Source.Length;
+
+ elsif Capacity >= Source.Length then
+ C := Capacity;
+
+ else
+ raise Capacity_Error with "Capacity value too small";
+ end if;
+
+ if Modulus = 0 then
+ M := Default_Modulus (C);
+ else
+ M := Modulus;
+ end if;
+
+ return Target : Set (Capacity => C, Modulus => M) do
+ Assign (Target => Target, Source => Source);
+ end return;
+ end Copy;
+
+ ---------------------
+ -- Default_Modulus --
+ ---------------------
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type is
+ begin
+ return To_Prime (Capacity);
+ end Default_Modulus;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Count_Type;
+
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete element not in set";
+ end if;
+
+ HT_Ops.Free (Container, X);
+ end Delete;
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor)
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor designates wrong set";
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ HT_Ops.Free (Container, Position.Node);
+
+ Position := No_Element;
+ end Delete;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node, Src_Node : Count_Type;
+
+ TN : Nodes_Type renames Target.Nodes;
+ SN : Nodes_Type renames Source.Nodes;
+
+ begin
+ if Target'Address = Source'Address then
+ HT_Ops.Clear (Target);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
+ if Source.Length < Target.Length then
+ Src_Node := HT_Ops.First (Source);
+ while Src_Node /= 0 loop
+ Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
+
+ if Tgt_Node /= 0 then
+ HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
+ HT_Ops.Free (Target, Tgt_Node);
+ end if;
+
+ Src_Node := HT_Ops.Next (Source, Src_Node);
+ end loop;
+
+ else
+ Tgt_Node := HT_Ops.First (Target);
+ while Tgt_Node /= 0 loop
+ if Is_In (Source, TN (Tgt_Node)) then
+ declare
+ X : constant Count_Type := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ HT_Ops.Free (Target, X);
+ end;
+
+ else
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ end if;
+ end loop;
+ end if;
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ return Result : Set (Left.Length, To_Prime (Left.Length)) do
+ Iterate_Left : declare
+ procedure Process (L_Node : Count_Type);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (L_Node : Count_Type) is
+ N : Node_Type renames Left.Nodes (L_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if not Is_In (Right, N) then
+ Insert (Result, N.Element, X, B); -- optimize this ???
+ pragma Assert (B);
+ pragma Assert (X > 0);
+ end if;
+ end Process;
+
+ -- Start of processing for Iterate_Left
+
+ begin
+ Iterate (Left);
+ end Iterate_Left;
+ end return;
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
+ declare
+ S : Set renames Position.Container.all;
+ N : Node_Type renames S.Nodes (Position.Node);
+
+ begin
+ return N.Element;
+ end;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean;
+ pragma Inline (Find_Equivalent_Key);
+
+ function Is_Equivalent is
+ new HT_Ops.Generic_Equal (Find_Equivalent_Key);
+
+ -------------------------
+ -- Find_Equivalent_Key --
+ -------------------------
+
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element);
+
+ R_Node : Count_Type := R_HT.Buckets (R_Index);
+
+ RN : Nodes_Type renames R_HT.Nodes;
+
+ begin
+ loop
+ if R_Node = 0 then
+ return False;
+ end if;
+
+ if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then
+ return True;
+ end if;
+
+ R_Node := HT_Ops.Next (R_HT, R_Node);
+ end loop;
+ end Find_Equivalent_Key;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left, Right);
+ end Equivalent_Sets;
+
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
+
+ function Equivalent_Elements (Left, Right : Cursor)
+ return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return Equivalent_Elements (LN.Element, RN.Element);
+ end;
+ end Equivalent_Elements;
+
+ function Equivalent_Elements (Left : Cursor; Right : Element_Type)
+ return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+ begin
+ return Equivalent_Elements (LN.Element, Right);
+ end;
+ end Equivalent_Elements;
+
+ function Equivalent_Elements (Left : Element_Type; Right : Cursor)
+ return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
+ end if;
+
+ pragma Assert
+ (Vet (Right),
+ "Right cursor of Equivalent_Elements is bad");
+
+ declare
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+ begin
+ return Equivalent_Elements (Left, RN.Element);
+ end;
+ end Equivalent_Elements;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys (Key : Element_Type; Node : Node_Type)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Key, Node.Element);
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Count_Type;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ HT_Ops.Free (Container, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor
+ is
+ Node : constant Count_Type := Element_Keys.Find (Container, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ Node : constant Count_Type := HT_Ops.First (Container);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end First;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Has_Element");
+ return Position.Node /= 0;
+ end Has_Element;
+
+ ---------------
+ -- Hash_Node --
+ ---------------
+
+ function Hash_Node (Node : Node_Type) return Hash_Type is
+ begin
+ return Hash (Node.Element);
+ end Hash_Node;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ Container.Nodes (Position.Node).Element := New_Item;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+ Insert (Container, 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
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean)
+ is
+ procedure Allocate_Set_Element (Node : in out Node_Type);
+ pragma Inline (Allocate_Set_Element);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+
+ procedure Allocate is
+ new HT_Ops.Generic_Allocate (Allocate_Set_Element);
+
+ ---------------------------
+ -- Allocate_Set_Element --
+ ---------------------------
+
+ procedure Allocate_Set_Element (Node : in out Node_Type) is
+ begin
+ Node.Element := New_Item;
+ end Allocate_Set_Element;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ -- ???
+ -- if HT_Ops.Capacity (HT) = 0 then
+ -- HT_Ops.Reserve_Capacity (HT, 1);
+ -- end if;
+
+ Local_Insert (Container, New_Item, Node, Inserted);
+
+ -- ???
+ -- if Inserted
+ -- and then HT.Length > HT_Ops.Capacity (HT)
+ -- then
+ -- HT_Ops.Reserve_Capacity (HT, HT.Length);
+ -- end if;
+ end Insert;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Count_Type;
+ TN : Nodes_Type renames Target.Nodes;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ HT_Ops.Clear (Target);
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
+ Tgt_Node := HT_Ops.First (Target);
+ while Tgt_Node /= 0 loop
+ if Is_In (Source, TN (Tgt_Node)) then
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+
+ else
+ declare
+ X : constant Count_Type := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ HT_Ops.Free (Target, X);
+ end;
+ end if;
+ end loop;
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ C : Count_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ C := Count_Type'Min (Left.Length, Right.Length);
+
+ if C = 0 then
+ return Empty_Set;
+ end if;
+
+ return Result : Set (C, To_Prime (C)) do
+ Iterate_Left : declare
+ procedure Process (L_Node : Count_Type);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (L_Node : Count_Type) is
+ N : Node_Type renames Left.Nodes (L_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Is_In (Right, N) then
+ Insert (Result, N.Element, X, B); -- optimize ???
+ pragma Assert (B);
+ pragma Assert (X > 0);
+ end if;
+ end Process;
+
+ -- Start of processing for Iterate_Left
+
+ begin
+ Iterate (Left);
+ end Iterate_Left;
+ end return;
+ end Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -----------
+ -- Is_In --
+ -----------
+
+ function Is_In (HT : Set; Key : Node_Type) return Boolean is
+ begin
+ return Element_Keys.Find (HT, Key.Element) /= 0;
+ end Is_In;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ Subset_Node : Count_Type;
+ SN : Nodes_Type renames Subset.Nodes;
+
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ if Subset.Length > Of_Set.Length then
+ return False;
+ end if;
+
+ Subset_Node := HT_Ops.First (Subset);
+ while Subset_Node /= 0 loop
+ if not Is_In (Of_Set, SN (Subset_Node)) then
+ return False;
+ end if;
+ Subset_Node := HT_Ops.Next (Subset, Subset_Node);
+ end loop;
+
+ return True;
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Iterate (Container);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Assign (Target => Target, Source => Source);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Next;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = 0 then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Next");
+
+ declare
+ HT : Set renames Position.Container.all;
+ Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ Left_Node : Count_Type;
+
+ begin
+ if Right.Length = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.First (Left);
+ while Left_Node /= 0 loop
+ if Is_In (Right, Left.Nodes (Left_Node)) then
+ return True;
+ end if;
+ Left_Node := HT_Ops.Next (Left, Left_Node);
+ end loop;
+
+ return False;
+ end Overlap;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
+ declare
+ S : Set renames Position.Container.all;
+ B : Natural renames S.Busy;
+ L : Natural renames S.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (S.Nodes (Position.Node).Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type;
+
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new HT_Ops.Generic_Allocate (Read_Element);
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ Node : Count_Type;
+
+ -- Start of processing for Read_Node
+
+ begin
+ Allocate (Container, Node);
+ return Node;
+ end Read_Node;
+
+ -- Start of processing for Read
+
+ begin
+ Read_Nodes (Stream, Container);
+ 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;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container, New_Item);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ Container.Nodes (Node).Element := New_Item;
+ end Replace;
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong set";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
+ Replace_Element (Container, Position.Node, New_Item);
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type)
+ is
+ begin
+ if Capacity > Container.Capacity then
+ raise Capacity_Error with "requested capacity is too large";
+ end if;
+ end Reserve_Capacity;
+
+ ------------------
+ -- Set_Element --
+ ------------------
+
+ procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
+ begin
+ Node.Element := Item;
+ end Set_Element;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ procedure Process (Source_Node : Count_Type);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Source_Node : Count_Type) is
+ N : Node_Type renames Source.Nodes (Source_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Is_In (Target, N) then
+ Delete (Target, N.Element);
+ else
+ Insert (Target, N.Element, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Symmetric_Difference
+
+ begin
+ if Target'Address = Source'Address then
+ HT_Ops.Clear (Target);
+ return;
+ end if;
+
+ if Target.Length = 0 then
+ Assign (Target => Target, Source => Source);
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
+ Iterate (Source);
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ C : Count_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ C := Left.Length + Right.Length;
+
+ return Result : Set (C, To_Prime (C)) do
+ Iterate_Left : declare
+ procedure Process (L_Node : Count_Type);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (L_Node : Count_Type) is
+ N : Node_Type renames Left.Nodes (L_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if not Is_In (Right, N) then
+ Insert (Result, N.Element, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Iterate_Left
+
+ begin
+ Iterate (Left);
+ end Iterate_Left;
+
+ Iterate_Right : declare
+ procedure Process (R_Node : Count_Type);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (R_Node : Count_Type) is
+ N : Node_Type renames Left.Nodes (R_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if not Is_In (Left, N) then
+ Insert (Result, N.Element, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Iterate_Right
+
+ begin
+ Iterate (Right);
+ end Iterate_Right;
+ end return;
+ end Symmetric_Difference;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ function To_Set (New_Item : Element_Type) return Set is
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ return Result : Set (1, 1) do
+ Insert (Result, New_Item, X, B);
+ pragma Assert (B);
+ end return;
+ end To_Set;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union
+ (Target : in out Set;
+ Source : Set)
+ is
+ procedure Process (Src_Node : Count_Type);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Src_Node : Count_Type) is
+ N : Node_Type renames Source.Nodes (Src_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ Insert (Target, N.Element, X, B);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
+ -- ???
+ -- declare
+ -- N : constant Count_Type := Target.Length + Source.Length;
+ -- begin
+ -- if N > HT_Ops.Capacity (Target.HT) then
+ -- HT_Ops.Reserve_Capacity (Target.HT, N);
+ -- end if;
+ -- end;
+
+ Iterate (Source);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ C : Count_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
+
+ if Right.Length = 0 then
+ return Left;
+ end if;
+
+ if Left.Length = 0 then
+ return Right;
+ end if;
+
+ C := Left.Length + Right.Length;
+
+ return Result : Set (C, To_Prime (C)) do
+ Assign (Target => Result, Source => Left);
+ Union (Target => Result, Source => Right);
+ end return;
+ end Union;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return Position.Container = null;
+ end if;
+
+ if Position.Container = null then
+ return False;
+ end if;
+
+ declare
+ S : Set renames Position.Container.all;
+ N : Nodes_Type renames S.Nodes;
+ X : Count_Type;
+
+ begin
+ if S.Length = 0 then
+ return False;
+ end if;
+
+ if Position.Node > N'Last then
+ return False;
+ end if;
+
+ if N (Position.Node).Next = Position.Node then
+ return False;
+ end if;
+
+ X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
+
+ for J in 1 .. S.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
+
+ if X = 0 then
+ return False;
+ end if;
+
+ if X = N (X).Next then -- to prevent unnecessary looping
+ return False;
+ end if;
+
+ X := N (X).Next;
+ end loop;
+
+ return False;
+ end;
+ end Vet;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container);
+ 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;
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Type) return Boolean;
+ pragma Inline (Equivalent_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Hash_Tables.Generic_Bounded_Keys
+ (HT_Types => HT_Types,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Key_Node);
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : Set;
+ Key : Key_Type) return Boolean
+ is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Count_Type;
+
+ begin
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in set";
+ end if;
+
+ HT_Ops.Free (Container, X);
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type
+ is
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ return Container.Nodes (Node).Element;
+ end Element;
+
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
+
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Type) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
+ end Equivalent_Key_Node;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Count_Type;
+ begin
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ HT_Ops.Free (Container, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor
+ is
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
+ return Key (Position.Container.Nodes (Position.Node).Element);
+ end Key;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
+ end if;
+
+ Replace_Element (Container, Node, New_Item);
+ end Replace;
+
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type))
+ is
+ Indx : Hash_Type;
+ N : Nodes_Type renames Container.Nodes;
+
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ 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
+ -- or else Position.Node.Next = Position.Node
+ -- then
+ -- raise Program_Error with
+ -- "Position cursor is bad (set is empty)";
+ -- end if;
+
+ pragma Assert
+ (Vet (Position),
+ "bad cursor in Update_Element_Preserving_Key");
+
+ -- Record bucket now, in case key is changed.
+ Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
+
+ declare
+ E : Element_Type renames N (Position.Node).Element;
+ K : constant Key_Type := Key (E);
+
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if Equivalent_Keys (K, Key (E)) then
+ pragma Assert (Hash (K) = Hash (E));
+ return;
+ end if;
+ end;
+
+ -- Key was modified, so remove this node from set.
+
+ if Container.Buckets (Indx) = Position.Node then
+ Container.Buckets (Indx) := N (Position.Node).Next;
+
+ else
+ declare
+ Prev : Count_Type := Container.Buckets (Indx);
+
+ begin
+ while N (Prev).Next /= Position.Node loop
+ Prev := N (Prev).Next;
+
+ if Prev = 0 then
+ raise Program_Error with
+ "Position cursor is bad (node not found)";
+ end if;
+ end loop;
+
+ N (Prev).Next := N (Position.Node).Next;
+ end;
+ end if;
+
+ Container.Length := Container.Length - 1;
+ HT_Ops.Free (Container, Position.Node);
+
+ raise Program_Error with "key was modified";
+ end Update_Element_Preserving_Key;
+
+ end Generic_Keys;
+
+end Ada.Containers.Bounded_Hashed_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Hash_Tables;
+private with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function Hash (Element : Element_Type) return Hash_Type;
+
+ with function Equivalent_Elements
+ (Left, Right : Element_Type) return Boolean;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Bounded_Hashed_Sets is
+ pragma Pure;
+ pragma Remote_Types;
+
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
+ pragma Preelaborable_Initialization (Set);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Set : constant Set;
+ -- Set objects declared without an initialization expression are
+ -- initialized to the value Empty_Set.
+
+ No_Element : constant Cursor;
+ -- Cursor objects declared without an initialization expression are
+ -- initialized to the value No_Element.
+
+ function "=" (Left, Right : Set) return Boolean;
+ -- For each element in Left, set equality attempts to find the equal
+ -- element in Right; if a search fails, then set equality immediately
+ -- returns False. The search works by calling Hash to find the bucket in
+ -- the Right set that corresponds to the Left element. If the bucket is
+ -- non-empty, the search calls the generic formal element equality operator
+ -- to compare the element (in Left) to the element of each node in the
+ -- bucket (in Right); the search terminates when a matching node in the
+ -- bucket is found, or the nodes in the bucket are exhausted. (Note that
+ -- element equality is called here, not Equivalent_Elements. Set equality
+ -- is the only operation in which element equality is used. Compare set
+ -- equality to Equivalent_Sets, which does call Equivalent_Elements.)
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+ -- Similar to set equality, with the difference that the element in Left is
+ -- compared to the elements in Right using the generic formal
+ -- Equivalent_Elements operation instead of element equality.
+
+ function To_Set (New_Item : Element_Type) return Set;
+ -- Constructs a singleton set comprising New_Element. To_Set calls Hash to
+ -- determine the bucket for New_Item.
+
+ function Capacity (Container : Set) return Count_Type;
+ -- Returns the current capacity of the set. Capacity is the maximum length
+ -- before which rehashing in guaranteed not to occur.
+
+ procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type);
+ -- If the value of the Capacity actual parameter is less or equal to
+ -- Container.Capacity, then the operation has no effect. Otherwise it
+ -- raises Capacity_Error (as no expansion of capacity is possible for a
+ -- bounded form).
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type;
+ -- Returns a modulus value (hash table size) which is optimal for the
+ -- specified capacity (which corresponds to the maximum number of items).
+
+ function Length (Container : Set) return Count_Type;
+ -- Returns the number of items in the set
+
+ function Is_Empty (Container : Set) return Boolean;
+ -- Equivalent to Length (Container) = 0
+
+ procedure Clear (Container : in out Set);
+ -- Removes all of the items from the set
+
+ function Element (Position : Cursor) return Element_Type;
+ -- Returns the element of the node designated by the cursor
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type);
+ -- If New_Item is equivalent (as determined by calling Equivalent_Elements)
+ -- to the element of the node designated by Position, then New_Element is
+ -- assigned to that element. Otherwise, it calls Hash to determine the
+ -- bucket for New_Item. If the bucket is not empty, then it calls
+ -- Equivalent_Elements for each node in that bucket to determine whether
+ -- New_Item is equivalent to an element in that bucket. If
+ -- Equivalent_Elements returns True then Program_Error is raised (because
+ -- an element may appear only once in the set); otherwise, New_Item is
+ -- assigned to the node designated by Position, and the node is moved to
+ -- its new bucket.
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+ -- Calls Process with the element (having only a constant view) of the node
+ -- designed by the cursor.
+
+ procedure Assign (Target : in out Set; Source : Set);
+ -- If Target denotes the same object as Source, then the operation has no
+ -- effect. If the Target capacity is less then the Source length, then
+ -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
+ -- copies the (active) elements from Source to Target.
+
+ function Copy
+ (Source : Set;
+ Capacity : Count_Type := 0;
+ Modulus : Hash_Type := 0) return Set;
+ -- Constructs a new set object whose elements correspond to Source. If the
+ -- Capacity parameter is 0, then the capacity of the result is the same as
+ -- the length of Source. If the Capacity parameter is equal or greater than
+ -- the length of Source, then the capacity of the result is the specified
+ -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
+ -- is 0, then the modulus of the result is the value returned by a call to
+ -- Default_Modulus with the capacity parameter determined as above;
+ -- otherwise the modulus of the result is the specified value.
+
+ procedure Move (Target : in out Set; Source : in out Set);
+ -- Clears Target (if it's not empty), and then moves (not copies) the
+ -- buckets array and nodes from Source to Target.
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+ -- Conditionally inserts New_Item into the set. If New_Item is already in
+ -- the set, then Inserted returns False and Position designates the node
+ -- containing the existing element (which is not modified). If New_Item is
+ -- not already in the set, then Inserted returns True and Position
+ -- designates the newly-inserted node containing New_Item. The search for
+ -- an existing element works as follows. Hash is called to determine
+ -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements
+ -- is called to compare New_Item to the element of each node in that
+ -- bucket. If the bucket is empty, or there were no equivalent elements in
+ -- the bucket, the search "fails" and the New_Item is inserted in the set
+ -- (and Inserted returns True); otherwise, the search "succeeds" (and
+ -- Inserted returns False).
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type);
+ -- Attempts to insert New_Item into the set, performing the usual insertion
+ -- search (which involves calling both Hash and Equivalent_Elements); if
+ -- the search succeeds (New_Item is equivalent to an element already in the
+ -- set, and so was not inserted), then this operation raises
+ -- Constraint_Error. (This version of Insert is similar to Replace, but
+ -- having the opposite exception behavior. It is intended for use when you
+ -- want to assert that the item is not already in the set.)
+
+ procedure Include (Container : in out Set; New_Item : Element_Type);
+ -- Attempts to insert New_Item into the set. If an element equivalent to
+ -- New_Item is already in the set (the insertion search succeeded, and
+ -- hence New_Item was not inserted), then the value of New_Item is assigned
+ -- to the existing element. (This insertion operation only raises an
+ -- exception if cursor tampering occurs. It is intended for use when you
+ -- want to insert the item in the set, and you don't care whether an
+ -- equivalent element is already present.)
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type);
+ -- Searches for New_Item in the set; if the search fails (because an
+ -- equivalent element was not in the set), then it raises
+ -- Constraint_Error. Otherwise, the existing element is assigned the value
+ -- New_Item. (This is similar to Insert, but with the opposite exception
+ -- behavior. It is intended for use when you want to assert that the item
+ -- is already in the set.)
+
+ procedure Exclude (Container : in out Set; Item : Element_Type);
+ -- Searches for Item in the set, and if found, removes its node from the
+ -- set and then deallocates it. The search works as follows. The operation
+ -- calls Hash to determine the item's bucket; if the bucket is not empty,
+ -- it calls Equivalent_Elements to compare Item to the element of each node
+ -- in the bucket. (This is the deletion analog of Include. It is intended
+ -- for use when you want to remove the item from the set, but don't care
+ -- whether the item is already in the set.)
+
+ procedure Delete (Container : in out Set; Item : Element_Type);
+ -- Searches for Item in the set (which involves calling both Hash and
+ -- Equivalent_Elements). If the search fails, then the operation raises
+ -- Constraint_Error. Otherwise it removes the node from the set and then
+ -- deallocates it. (This is the deletion analog of non-conditional
+ -- Insert. It is intended for use when you want to assert that the item is
+ -- already in the set.)
+
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+ -- Removes the node designated by Position from the set, and then
+ -- deallocates the node. The operation calls Hash to determine the bucket,
+ -- and then compares Position to each node in the bucket until there's a
+ -- match (it does not call Equivalent_Elements).
+
+ procedure Union (Target : in out Set; Source : Set);
+ -- Iterates over the Source set, and conditionally inserts each element
+ -- into Target.
+
+ function Union (Left, Right : Set) return Set;
+ -- The operation first copies the Left set to the result, and then iterates
+ -- over the Right set to conditionally insert each element into the result.
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+ -- Iterates over the Target set (calling First and Next), calling Find to
+ -- determine whether the element is in Source. If an equivalent element is
+ -- not found in Source, the element is deleted from Target.
+
+ function Intersection (Left, Right : Set) return Set;
+ -- Iterates over the Left set, calling Find to determine whether the
+ -- element is in Right. If an equivalent element is found, it is inserted
+ -- into the result set.
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+ -- Iterates over the Source (calling First and Next), calling Find to
+ -- determine whether the element is in Target. If an equivalent element is
+ -- found, it is deleted from Target.
+
+ function Difference (Left, Right : Set) return Set;
+ -- Iterates over the Left set, calling Find to determine whether the
+ -- element is in the Right set. If an equivalent element is not found, the
+ -- element is inserted into the result set.
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+ -- The operation iterates over the Source set, searching for the element
+ -- in Target (calling Hash and Equivalent_Elements). If an equivalent
+ -- elementis found, it is removed from Target; otherwise it is inserted
+ -- into Target.
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+ -- The operation first iterates over the Left set. It calls Find to
+ -- determine whether the element is in the Right set. If no equivalent
+ -- element is found, the element from Left is inserted into the result. The
+ -- operation then iterates over the Right set, to determine whether the
+ -- element is in the Left set. If no equivalent element is found, the Right
+ -- element is inserted into the result.
+
+ function "xor" (Left, Right : Set) return Set
+ renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+ -- Iterates over the Left set (calling First and Next), calling Find to
+ -- determine whether the element is in the Right set. If an equivalent
+ -- element is found, the operation immediately returns True. The operation
+ -- returns False if the iteration over Left terminates without finding any
+ -- equivalent element in Right.
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+ -- Iterates over Subset (calling First and Next), calling Find to determine
+ -- whether the element is in Of_Set. If no equivalent element is found in
+ -- Of_Set, the operation immediately returns False. The operation returns
+ -- True if the iteration over Subset terminates without finding an element
+ -- not in Of_Set (that is, every element in Subset is equivalent to an
+ -- element in Of_Set).
+
+ function First (Container : Set) return Cursor;
+ -- Returns a cursor that designates the first non-empty bucket, by
+ -- searching from the beginning of the buckets array.
+
+ function Next (Position : Cursor) return Cursor;
+ -- Returns a cursor that designates the node that follows the current one
+ -- designated by Position. If Position designates the last node in its
+ -- bucket, the operation calls Hash to compute the index of this bucket,
+ -- and searches the buckets array for the first non-empty bucket, starting
+ -- from that index; otherwise, it simply follows the link to the next node
+ -- in the same bucket.
+
+ procedure Next (Position : in out Cursor);
+ -- Equivalent to Position := Next (Position)
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor;
+ -- Searches for Item in the set. Find calls Hash to determine the item's
+ -- bucket; if the bucket is not empty, it calls Equivalent_Elements to
+ -- compare Item to each element in the bucket. If the search succeeds, Find
+ -- returns a cursor designating the node containing the equivalent element;
+ -- otherwise, it returns No_Element.
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+ -- Equivalent to Find (Container, Item) /= No_Element
+
+ function Has_Element (Position : Cursor) return Boolean;
+ -- Equivalent to Position /= No_Element
+
+ function Equivalent_Elements (Left, Right : Cursor) return Boolean;
+ -- Returns the result of calling Equivalent_Elements with the elements of
+ -- the nodes designated by cursors Left and Right.
+
+ function Equivalent_Elements
+ (Left : Cursor;
+ Right : Element_Type) return Boolean;
+ -- Returns the result of calling Equivalent_Elements with element of the
+ -- node designated by Left and element Right.
+
+ function Equivalent_Elements
+ (Left : Element_Type;
+ Right : Cursor) return Boolean;
+ -- Returns the result of calling Equivalent_Elements with element Left and
+ -- the element of the node designated by Right.
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+ -- Calls Process for each node in the set
+
+ generic
+ type Key_Type (<>) is private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function Hash (Key : Key_Type) return Hash_Type;
+
+ with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ package Generic_Keys is
+
+ function Key (Position : Cursor) return Key_Type;
+ -- Applies generic formal operation Key to the element of the node
+ -- designated by Position.
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+ -- Searches (as per the key-based Find) for the node containing Key, and
+ -- returns the associated element.
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type);
+ -- Searches (as per the key-based Find) for the node containing Key, and
+ -- then replaces the element of that node (as per the element-based
+ -- Replace_Element).
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+ -- Searches for Key in the set, and if found, removes its node from the
+ -- set and then deallocates it. The search works by first calling Hash
+ -- (on Key) to determine the bucket; if the bucket is not empty, it
+ -- calls Equivalent_Keys to compare parameter Key to the value of
+ -- generic formal operation Key applied to element of each node in the
+ -- bucket.
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+ -- Deletes the node containing Key as per Exclude, with the difference
+ -- that Constraint_Error is raised if Key is not found.
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+ -- Searches for the node containing Key, and returns a cursor
+ -- designating the node. The search works by first calling Hash (on Key)
+ -- to determine the bucket. If the bucket is not empty, the search
+ -- compares Key to the element of each node in the bucket, and returns
+ -- the matching node. The comparison itself works by applying the
+ -- generic formal Key operation to the element of the node, and then
+ -- calling generic formal operation Equivalent_Keys.
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+ -- Equivalent to Find (Container, Key) /= No_Element
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+ -- Calls Process with the element of the node designated by Position,
+ -- but with the restriction that the key-value of the element is not
+ -- modified. The operation first makes a copy of the value returned by
+ -- applying generic formal operation Key on the element of the node, and
+ -- then calls Process with the element. The operation verifies that the
+ -- key-part has not been modified by calling generic formal operation
+ -- Equivalent_Keys to compare the saved key-value to the value returned
+ -- by applying generic formal operation Key to the post-Process value of
+ -- element. If the key values compare equal then the operation
+ -- completes. Otherwise, the node is removed from the map and
+ -- Program_Error is raised.
+
+ end Generic_Keys;
+
+private
+
+ pragma Inline (Next);
+
+ type Node_Type is record
+ Element : Element_Type;
+ Next : Count_Type;
+ end record;
+
+ package HT_Types is
+ new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
+
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is
+ new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
+
+ use HT_Types;
+ use Ada.Streams;
+
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Count_Type;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := (Container => null, Node => 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Hash_Table_Type with Capacity => 0, Modulus => 0);
+
+end Ada.Containers.Bounded_Hashed_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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_Bounded_Keys is
+
+ --------------------------
+ -- 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 := Index (HT, Key);
+ X := HT.Buckets (Indx);
+
+ if X = 0 then
+ return;
+ end if;
+
+ if Equivalent_Keys (Key, HT.Nodes (X)) then
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+ 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 Equivalent_Keys (Key, HT.Nodes (X)) then
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+ 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 := Index (HT, Key);
+
+ Node := HT.Buckets (Indx);
+ while Node /= 0 loop
+ if Equivalent_Keys (Key, HT.Nodes (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 : constant Hash_Type := Index (HT, Key);
+ B : Count_Type renames HT.Buckets (Indx);
+
+ begin
+ if B = 0 then
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ if 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;
+
+ B := Node;
+ HT.Length := HT.Length + 1;
+
+ return;
+ end if;
+
+ Node := B;
+ loop
+ if Equivalent_Keys (Key, HT.Nodes (Node)) then
+ Inserted := False;
+ return;
+ end if;
+
+ Node := Next (HT.Nodes (Node));
+
+ exit when Node = 0;
+ end loop;
+
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ if 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 => B);
+
+ Inserted := True;
+
+ B := Node;
+ HT.Length := HT.Length + 1;
+ end Generic_Conditional_Insert;
+
+ -----------
+ -- 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;
+
+ -----------------------------
+ -- 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_Hash : constant Hash_Type := Hash (NN (Node));
+ Old_Indx : constant Hash_Type := BB'First + Old_Hash mod BB'Length;
+
+ New_Hash : constant Hash_Type := Hash (Key);
+ New_Indx : constant Hash_Type := BB'First + New_Hash mod BB'Length;
+
+ New_Bucket : Count_Type renames BB (New_Indx);
+ N, M : Count_Type;
+
+ begin
+ -- 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 Equivalent_Keys (Key, NN (Node)) then
+ pragma Assert (New_Hash = Old_Hash);
+
+ if HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (container is locked)";
+ end if;
+
+ -- The new Key value is mapped to this same Node, so Node
+ -- stays in the same bucket.
+
+ Assign (NN (Node), Key);
+ pragma Assert (Hash (NN (Node)) = New_Hash);
+ pragma Assert (Equivalent_Keys (Key, NN (Node)));
+ 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 Equivalent_Keys (Key, NN (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.
+
+ if HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (container is locked)";
+ end if;
+
+ Assign (NN (Node), Key);
+ pragma Assert (Hash (NN (Node)) = New_Hash);
+ pragma Assert (Equivalent_Keys (Key, NN (Node)));
+ return;
+ end if;
+
+ -- The node is a bucket different from the bucket implied by Key
+
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ -- 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);
+ pragma Assert (Hash (NN (Node)) = New_Hash);
+ pragma Assert (Equivalent_Keys (Key, NN (Node)));
+
+ -- 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;
+
+end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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_Bounded_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_Bounded_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
+
+ 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_Bounded_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (HT : in out Hash_Table_Type'Class) is
+ begin
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ HT.Length := 0;
+ -- HT.Busy := 0;
+ -- HT.Lock := 0;
+ HT.Free := -1;
+ HT.Buckets := (others => 0); -- optimize this somehow ???
+ end Clear;
+
+ ---------------------------
+ -- 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 HT.Length = 0 then
+ raise Program_Error with
+ "attempt to delete node from empty hashed container";
+ end if;
+
+ Indx := Index (HT, HT.Nodes (X));
+ Prev := HT.Buckets (Indx);
+
+ if 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, Prev);
+ HT.Length := HT.Length - 1;
+ return;
+ end if;
+
+ if HT.Length = 1 then
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
+ end if;
+
+ loop
+ Curr := Next (HT, Prev);
+
+ if 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, 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
+ pragma Assert (X > 0);
+ pragma Assert (X <= HT.Capacity);
+
+ N : Nodes_Type renames HT.Nodes;
+ -- 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. ???
+
+ begin
+ -- 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 := 0;
+ 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, 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, 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 N < 0 then
+ raise Program_Error with "stream appears to be corrupt";
+ end if;
+
+ if N = 0 then
+ return;
+ end if;
+
+ if 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 := Index (HT, HT.Nodes (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 := Next (HT.Nodes (Node));
+
+ begin
+ 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.
+
+ for Indx in Index (HT, HT.Nodes (Node)) + 1 .. 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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_Bounded_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_Bounded_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.
+
+ 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_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_Bounded_Operations;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2010, 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- --
end record;
end Generic_Hash_Table_Types;
+ generic
+ type Node_Type is private;
+ package Generic_Bounded_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;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
+ Free : Count_Type'Base := -1;
+ Nodes : Nodes_Type (1 .. Capacity);
+ Buckets : Buckets_Type (1 .. Modulus) := (others => 0);
+ end record;
+ end Generic_Bounded_Hash_Table_Types;
+
end Ada.Containers.Hash_Tables;
return;
end if;
- -- Deal with predicate check before we start to do major rewriting.
- -- it is OK to initialize and then check the initialized value, since
- -- the object goes out of scope if we get a predicate failure.
-
- -- We need a predicate check if the type has predicates, and if either
- -- there is an initializing expression, or for default initialization
- -- when we have at least one case of an explicit default initial value.
-
- if not Suppress_Assignment_Checks (N)
- and then Present (Predicate_Function (Typ))
- and then
- (Present (Expr)
- or else
- Is_Partially_Initialized_Type (Typ, Include_Null => False))
- then
- Insert_After (N,
- Make_Predicate_Check (Typ, New_Occurrence_Of (Def_Id, Loc)));
- end if;
-
-- Force construction of dispatch tables of library level tagged types
if Tagged_Type_Expansion
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
- RCI_Instantiation : Node_Id;
+ RCI_Instantiation : Node_Id;
procedure Visit_Subprogram (Decl : Node_Id);
-- Generate calling stub for one remote subprogram
Loc : constant Source_Ptr := Sloc (Decl);
Spec : constant Node_Id := Specification (Decl);
Subp_Stubs : Node_Id;
- Subp_Str : String_Id;
+
+ Subp_Str : String_Id;
pragma Warnings (Off, Subp_Str);
begin
(Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
Subp_Stubs :=
- Build_Subprogram_Calling_Stubs (
- Vis_Decl => Decl,
- Subp_Id =>
- Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
- Asynchronous =>
- Nkind (Spec) = N_Procedure_Specification
- and then Is_Asynchronous (Defining_Unit_Name (Spec)));
+ Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Defining_Unit_Name (Spec)));
Append_To (List_Containing (Decl), Subp_Stubs);
Analyze (Subp_Stubs);
-- For each subprogram declaration visible in the spec, we do build a
-- body. We also increment a counter to assign a different Subprogram_Id
- -- to each subprograms. The receiving stubs processing uses the same
+ -- to each subprogram. The receiving stubs processing uses the same
-- mechanism and will thus assign the same Id and do the correct
-- dispatching.
Subp_Val : String_Id;
Subp_Dist_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name
- (Related_Id => Chars (Subp_Def),
- Suffix => 'D',
- Suffix_Index => -1));
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name
+ (Related_Id => Chars (Subp_Def),
+ Suffix => 'D',
+ Suffix_Index => -1));
Current_Stubs : Node_Id;
Proxy_Obj_Addr : Entity_Id;
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Decl,
- Asynchronous =>
- Nkind (Spec) = N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
+ Asynchronous => Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Syntax:
@smallexample @c ada
-pragma Eliminate (
- [Unit_Name =>] IDENTIFIER |
- SELECTED_COMPONENT);
+pragma Eliminate (UNIT_NAME, ENTITY, Source_Location => SOURCE_TRACE)
-pragma Eliminate (
- [Unit_Name =>] IDENTIFIER |
- SELECTED_COMPONENT,
- [Entity =>] IDENTIFIER |
- SELECTED_COMPONENT |
- STRING_LITERAL
- [,OVERLOADING_RESOLUTION]);
+UNIT_NAME ::= IDENTIFIER |
+ SELECTED_COMPONENT,
-OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
- SOURCE_LOCATION
+ENTITY ::= IDENTIFIER |
+ SELECTED_COMPONENT,
-PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
- FUNCTION_PROFILE
+SOURCE_TRACE ::= SOURCE_REFERENCE |
+ SOURCE_REFERENCE LBRACKET SOURCE_TRACE RBRACKET
-PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
+LBRACKET ::= [
+RBRACKET ::= ]
-FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
- Result_Type => result_SUBTYPE_NAME]
+SOURCE_REFERENCE ::= FILE_NAME : LINE_NUMBER
-PARAMETER_TYPES ::= (SUBTYPE_NAME @{, SUBTYPE_NAME@})
-SUBTYPE_NAME ::= STRING_VALUE
-
-SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
-SOURCE_TRACE ::= STRING_VALUE
-
-STRING_VALUE ::= STRING_LITERAL @{& STRING_LITERAL@}
+FILE_NAME ::= STRING_LITERAL
+LINE_NUMBER ::= INTEGER_LITERAL
@end smallexample
@noindent
-This pragma indicates that the given entity is not used outside the
-compilation unit it is defined in. The entity must be an explicitly declared
-subprogram; this includes generic subprogram instances and
-subprograms declared in generic package instances.
-
-If the entity to be eliminated is a library level subprogram, then
-the first form of pragma @code{Eliminate} is used with only a single argument.
-In this form, the @code{Unit_Name} argument specifies the name of the
-library level unit to be eliminated.
-
-In all other cases, both @code{Unit_Name} and @code{Entity} arguments
-are required. If item is an entity of a library package, then the first
-argument specifies the unit name, and the second argument specifies
-the particular entity. If the second argument is in string form, it must
-correspond to the internal manner in which GNAT stores entity names (see
-compilation unit Namet in the compiler sources for details).
+This pragma indicates that the given entity is not used in the program
+to be compiled and built. The entity must be an explicitly declared
+subprogram; this includes generic subprogram instances and
+subprograms declared in generic package instances. @code{Unit_Name}
+must be the name of the compilation unit in which the entity is declared.
-The remaining parameters (OVERLOADING_RESOLUTION) are optionally used
-to distinguish between overloaded subprograms. If a pragma does not contain
-the OVERLOADING_RESOLUTION parameter(s), it is applied to all the overloaded
-subprograms denoted by the first two parameters.
-
-Use PARAMETER_AND_RESULT_TYPE_PROFILE to specify the profile of the subprogram
-to be eliminated in a manner similar to that used for the extended
-@code{Import} and @code{Export} pragmas, except that the subtype names are
-always given as strings. At the moment, this form of distinguishing
-overloaded subprograms is implemented only partially, so we do not recommend
-using it for practical subprogram elimination.
-
-Note that in case of a parameterless procedure its profile is represented
-as @code{Parameter_Types => ("")}
-
-Alternatively, the @code{Source_Location} parameter is used to specify
-which overloaded alternative is to be eliminated by pointing to the
-location of the DEFINING_PROGRAM_UNIT_NAME of this subprogram in the
-source text. The string literal (or concatenation of string literals)
-given as SOURCE_TRACE must have the following format:
-
-@smallexample @c ada
-SOURCE_TRACE ::= SOURCE_LOCATION@{LBRACKET SOURCE_LOCATION RBRACKET@}
-
-LBRACKET ::= [
-RBRACKET ::= ]
-
-SOURCE_LOCATION ::= FILE_NAME:LINE_NUMBER
-FILE_NAME ::= STRING_LITERAL
-LINE_NUMBER ::= DIGIT @{DIGIT@}
-@end smallexample
-
-SOURCE_TRACE should be the short name of the source file (with no directory
-information), and LINE_NUMBER is supposed to point to the line where the
-defining name of the subprogram is located.
-
-For the subprograms that are not a part of generic instantiations, only one
-SOURCE_LOCATION is used. If a subprogram is declared in a package
-instantiation, SOURCE_TRACE contains two SOURCE_LOCATIONs, the first one is
-the location of the (DEFINING_PROGRAM_UNIT_NAME of the) instantiation, and the
-second one denotes the declaration of the corresponding subprogram in the
-generic package. This approach is recursively used to create SOURCE_LOCATIONs
-in case of nested instantiations.
+The @code{Source_Location} argument is used to resolve overloading
+in case more then one callable entity with the same name is declared
+in the given compilation unit. Each file name must be the short name of the
+source file (with no directory information).
+If an entity is not declared in
+a generic instantiation (this includes generic subprogram instances),
+the source trace includes only one source
+reference. If an entity is declared inside a generic instantiation,
+its source trace starts from the source location in the instantiation and
+ends with the source location of the declaration of the corresponding
+entity in the generic
+unit. This approach is recursively used in case of nested instantiations:
+the leftmost element of the
+source trace is the location of the outermost instantiation, the next
+element is the location of the next (first nested) instantiation in the
+code of the corresponding generic unit, and so on.
The effect of the pragma is to allow the compiler to eliminate
the code or data associated with the named entity. Any reference to
-an eliminated entity outside the compilation unit it is defined in,
-causes a compile time or link time error.
+an eliminated entity outside the compilation unit where it is defined
+causes a compile-time or link-time error.
The intention of pragma @code{Eliminate} is to allow a program to be compiled
-in a system independent manner, with unused entities eliminated, without
-the requirement of modifying the source text. Normally the required set
+in a system-independent manner, with unused entities eliminated, without
+needing to modify the source text. Normally the required set
of @code{Eliminate} pragmas is constructed automatically using the gnatelim
tool. Elimination of unused entities local to a compilation unit is
automatic, without requiring the use of pragma @code{Eliminate}.
-Note that the reason this pragma takes string literals where names might
-be expected is that a pragma @code{Eliminate} can appear in a context where the
-relevant names are not visible.
-
-Note that any change in the source files that includes removing, splitting of
-adding lines may make the set of Eliminate pragmas using SOURCE_LOCATION
-parameter illegal.
+Any source file change that removes, splits, or
+adds lines may make the set of Eliminate pragmas invalid because their
+@code{Source_Location} argument values may get out of date.
-It is legal to use pragma Eliminate where the referenced entity is a
-dispatching operation, but it is not clear what this would mean, since
-in general the call does not know which entity is actually being called.
-Consequently, a pragma Eliminate for a dispatching operation is ignored.
+Pragma Eliminate may be used where the referenced entity is a
+dispatching operation. In this case all the subprograms to which the
+given operation can dispatch are considered to be unused (are never called
+as a result of a direct or a dispatching call).
@node Pragma Export_Exception
@unnumberedsec Pragma Export_Exception
"a-cobove", -- Ada.Containers.Bounded_Vectors
"a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
- "a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps
+ "a-cborma", -- Ada.Containers.Bounded_Ordered_Maps
+ "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets
+ "a-cbhama"); -- Ada.Containers.Bounded_Hashed_Maps
-----------------------
-- Alternative Units --
Write_Str (" -v Display reasons for all (re)compilations");
Write_Eol;
+ -- Line for -vl
+
+ Write_Str (" -vl Verbose output (low verbosity)");
+ Write_Eol;
+
+ -- Line for -vm
+
+ Write_Str (" -vm Verbose output (medium verbosity)");
+ Write_Eol;
+
+ -- Line for -vh
+
+ Write_Str (" -vh Equivalent to -v (high verbosity)");
+ Write_Eol;
+
-- Line for -vPx
Write_Str (" -vPx Specify verbosity when parsing GNAT Project Files");
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id);
+ procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragam Predicate), or
- -- there are inherited aspects from a parent type, or ancestor subtypes,
- -- or interfaces. This procedure builds the spec and body for the Predicate
- -- function that tests these predicates, returning them in PDecl and Pbody
- -- and setting Predicate_Procedure for Typ. In some error situations no
- -- procedure is built, in which case PDecl/PBody are empty on return.
+ -- there are inherited aspects from a parent type, or ancestor subtypes.
+ -- This procedure builds the spec and body for the Predicate function that
+ -- tests these predicates. N is the freeze node for the type. The spec of
+ -- the function is inserted before the freeze node, and the body of the
+ -- funtion is inserted after the freeze node.
procedure Build_Static_Predicate
(Typ : Entity_Id;
-- If we have a type with predicates, build predicate function
if Is_Type (E) and then Has_Predicates (E) then
- declare
- FDecl : Node_Id;
- FBody : Node_Id;
-
- begin
- Build_Predicate_Function (E, FDecl, FBody);
-
- if Present (FDecl) then
- Insert_After (N, FBody);
- Insert_After (N, FDecl);
- end if;
- end;
+ Build_Predicate_Function (E, N);
end if;
end Analyze_Freeze_Entity;
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id)
- is
+ procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
SId : Entity_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
+
+ TName : constant Name_Id := Chars (Typ);
+ -- Name of the type, used for replacement in predicate expression
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
-- Output info message on inheritance if required. Note we do not
-- give this information for generic actual types, since it is
-- unwelcome noise in that case in instantiations. We also
- -- generally suppress the message in instantiations.
+ -- generally suppress the message in instantiations, and also
+ -- if it involves internal names.
if Opt.List_Inherited_Aspects
and then not Is_Generic_Actual_Type (Typ)
and then Instantiation_Depth (Sloc (Typ)) = 0
+ and then not Is_Internal_Name (Chars (T))
+ and then not Is_Internal_Name (Chars (Typ))
then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
-- Process single node for traversal to replace type references
procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
+ -- Traverse an expression changing every occurrence of an identifier
+ -- whose name is TName with a reference to the object argument.
------------------
-- Replace_Node --
------------------
function Replace_Node (N : Node_Id) return Traverse_Result is
+ S : Entity_Id;
+ P : Node_Id;
+
begin
- -- Case of entity name referencing the type
+ -- Case of identifier
- if Is_Entity_Name (N) and then Entity (N) = Typ then
+ if Nkind (N) = N_Identifier then
- -- Replace with object
+ -- If not the type name, all done with this node
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
+ if Chars (N) /= TName then
+ return Skip;
- -- All done with this node
+ -- Otherwise do the replacement
- return Skip;
+ else
+ goto Do_Replace;
+ end if;
+
+ -- Case of selected component (which is what a qualification
+ -- looks like in the unanalyzed tree, which is what we have.
+
+ elsif Nkind (N) = N_Selected_Component then
+
+ -- If selector name is not our type, keeping going (we might
+ -- still have an occurrence of the type in the prefix).
+
+ if Nkind (Selector_Name (N)) /= N_Identifier
+ or else Chars (Selector_Name (N)) /= TName
+ then
+ return OK;
+
+ -- Selector name is our type, check qualification
+
+ else
+ -- Loop through scopes and prefixes, doing comparison
+
+ S := Current_Scope;
+ P := Prefix (N);
+ loop
+ -- Continue if no more scopes or scope with no name
+
+ if No (S) or else Nkind (S) not in N_Has_Chars then
+ return OK;
+ end if;
+
+ -- Do replace if prefix is an identifier matching the
+ -- scope that we are currently looking at.
+
+ if Nkind (P) = N_Identifier
+ and then Chars (P) = Chars (S)
+ then
+ goto Do_Replace;
+ end if;
+
+ -- Go check scope above us if prefix is itself of the
+ -- form of a selected component, whose selector matches
+ -- the scope we are currently looking at.
+
+ if Nkind (P) = N_Selected_Component
+ and then Nkind (Selector_Name (P)) = N_Identifier
+ and then Chars (Selector_Name (P)) = Chars (S)
+ then
+ S := Scope (S);
+ P := Prefix (P);
- -- Not an occurrence of the type entity, keep going
+ -- For anything else, we don't have a match, so keep on
+ -- going, there are still some weird cases where we may
+ -- still have a replacement within the prefix.
+
+ else
+ return OK;
+ end if;
+ end loop;
+ end if;
+
+ -- Continue for any other node kind
else
return OK;
end if;
+
+ <<Do_Replace>>
+
+ -- Replace with object
+
+ Rewrite (N, Make_Identifier (Loc, Chars => Object_Name));
+ return Skip;
end Replace_Node;
-- Start of processing for Add_Predicates
-- We have a match, this entry is for our subtype
-- First We need to replace any occurrences of the name of
- -- the type with references to the object. We do this by
- -- first doing a preanalysis, to identify all the entities,
- -- then we traverse looking for the type entity, doing the
- -- needed substitution. The preanalysis is done with the
- -- special OK_To_Reference flag set on the type, so that if
- -- we get an occurrence of this type, it will be recognized
- -- as legitimate.
-
- Set_OK_To_Reference (Typ, True);
- Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
- Set_OK_To_Reference (Typ, False);
+ -- the type with references to the object.
+
Replace_Type (Arg2);
-- OK, replacement complete, now we can add the expression
-- Initialize for construction of statement list
Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
-- Return if already built or if type does not have predicates
if Present (Expr) then
- -- Deal with static predicate case
-
- if Ekind_In (Typ, E_Enumeration_Subtype,
- E_Modular_Integer_Subtype,
- E_Signed_Integer_Subtype)
- and then Is_Static_Subtype (Typ)
- then
- Build_Static_Predicate (Typ, Expr, Object_Name);
- end if;
-
-- Build function declaration
pragma Assert (Has_Predicates (Typ));
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-- Build function body
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
+
+ -- Insert declaration before freeze node and body after
+
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
+
+ -- Deal with static predicate case
+
+ if Ekind_In (Typ, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ and then Is_Static_Subtype (Typ)
+ then
+ Build_Static_Predicate (Typ, Expr, Object_Name);
+ end if;
end if;
end Build_Predicate_Function;
Left_Opnd => Make_Identifier (Loc, Nam),
Right_Opnd => Empty,
Alternatives => New_Alts));
+
+ -- Resolve new expression in function context
+
+ Install_Formals (Predicate_Function (Typ));
+ Push_Scope (Predicate_Function (Typ));
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+ Pop_Scope;
end if;
end;
end;
end if;
end if;
+ -- Deal with predicate check before we start to do major rewriting.
+ -- it is OK to initialize and then check the initialized value, since
+ -- the object goes out of scope if we get a predicate failure. Note
+ -- that we do this in the analyzer and not the expander because the
+ -- analyzer does some substantial rewriting in some cases.
+
+ -- We need a predicate check if the type has predicates, and if either
+ -- there is an initializing expression, or for default initialization
+ -- when we have at least one case of an explicit default initial value.
+
+ if not Suppress_Assignment_Checks (N)
+ and then Present (Predicate_Function (T))
+ and then
+ (Present (E)
+ or else
+ Is_Partially_Initialized_Type (T, Include_Implicit => False))
+ then
+ Insert_After (N,
+ Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ end if;
+
-- Case of unconstrained type
if Is_Indefinite_Subtype (T) then
-- If ancestor has predicates then so does the subtype, and in addition
-- we must delay the freeze to properly arrange predicate inheritance.
- if Has_Predicates (T) then
+ -- The Ancestor_Type test is a big kludge, there seem to be cases in
+ -- which T = ID, so the above tests and assignments do nothing???
+
+ if Has_Predicates (T)
+ or else (Present (Ancestor_Subtype (T))
+ and then Has_Predicates (Ancestor_Subtype (T)))
+ then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
end if;
procedure Analyze_Membership_Op (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
Index : Interp_Index;
It : Interp;
-----------------------------------
function Is_Partially_Initialized_Type
- (Typ : Entity_Id;
- Include_Null : Boolean := True) return Boolean
+ (Typ : Entity_Id;
+ Include_Implicit : Boolean := True) return Boolean
is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
- return Include_Null;
+ return Include_Implicit;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
if Is_Partially_Initialized_Type
- (Component_Type (Typ), Include_Null)
+ (Component_Type (Typ), Include_Implicit)
then
return True;
elsif Is_Record_Type (Typ) then
- -- A discriminated type is always partially initialized
+ -- A discriminated type is always partially initialized if in
+ -- all mode
- if Has_Discriminants (Typ) then
+ if Has_Discriminants (Typ) and then Include_Implicit then
return True;
-- A tagged type is always partially initialized
-- initialized, then the enclosing record type is also.
elsif Is_Partially_Initialized_Type
- (Etype (Ent), Include_Null)
+ (Etype (Ent), Include_Implicit)
then
return True;
end if;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U, Include_Null);
+ return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;
-- conversions and hence variables.
function Is_Partially_Initialized_Type
- (Typ : Entity_Id;
- Include_Null : Boolean := True) return Boolean;
+ (Typ : Entity_Id;
+ Include_Implicit : Boolean := True) return Boolean;
-- Typ is a type entity. This function returns true if this type is partly
-- initialized, meaning that an object of the type is at least partly
-- initialized (in particular in the record case, that at least one
-- component has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
- -- Include_Null controls the handling of access types, and components of
- -- access types not explicitly initialized. If set to True, the default,
- -- default initialization of access types counts as making the type be
- -- partially initialized. If False, this does not count.
+ -- Include_Implicit controls whether implicit initialiation of access
+ -- values to null, and of discriminant values, is counted as making the
+ -- type be partially initialized. For the default setting of True, these
+ -- implicit cases do count, and discriminated types or types containing
+ -- access values not explicitly initialized will return True. Otherwise
+ -- if Include_Implicit is False, these cases do not count as making the
+ -- type be partially initialied.
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
-- Determines if type T is a potentially persistent type. A potentially
end if;
else
+ Error_Msg_Node_2 := Form;
Error_Msg_FE
- ("writable actual overlaps with actual for&?",
- Act1, Form);
+ ("writable actual for & overlaps with"
+ & " actual for&?", Act1, Form1);
end if;
end;
end if;
projects / platform / upstream / linaro-gcc.git / commitdiff