Skip to content

R
riscv-gcc-1
Commit 5a428808 by Hristian Kirtchev Committed by Pierre-Marie de Rodat
Options

[Ada] Implement GNAT.Graphs 

This patch introduces new unit GNAT.Graphs which currently provides a
directed graph abstraction.

------------
-- Source --
------------

--  operations.adb

with Ada.Text_IO; use Ada.Text_IO;
with GNAT;        use GNAT;
with GNAT.Graphs; use GNAT.Graphs;
with GNAT.Sets;   use GNAT.Sets;

procedure Operations is
   type Vertex_Id is
     (No_V, VA, VB, VC, VD, VE, VF, VG, VH, VX, VY, VZ);
   No_Vertex_Id : constant Vertex_Id := No_V;

   function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type;

   type Edge_Id is
    (No_E, E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E97, E98, E99);
   No_Edge_Id : constant Edge_Id := No_E;

   function Hash_Edge (E : Edge_Id) return Bucket_Range_Type;

   package ES is new Membership_Set
     (Element_Type => Edge_Id,
      "="          => "=",
      Hash         => Hash_Edge);

   package DG is new Directed_Graph
     (Vertex_Id   => Vertex_Id,
      No_Vertex   => No_Vertex_Id,
      Hash_Vertex => Hash_Vertex,
      Same_Vertex => "=",
      Edge_Id     => Edge_Id,
      No_Edge     => No_Edge_Id,
      Hash_Edge   => Hash_Edge,
      Same_Edge   => "=");
   use DG;

   package VS is new Membership_Set
     (Element_Type => Vertex_Id,
      "="          => "=",
      Hash         => Hash_Vertex);

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Check_Belongs_To_Component
     (R        : String;
      G        : Instance;
      V        : Vertex_Id;
      Exp_Comp : Component_Id);
   --  Verify that vertex V of graph G belongs to component Exp_Comp. R is the
   --  calling routine.

   procedure Check_Belongs_To_Some_Component
     (R : String;
      G : Instance;
      V : Vertex_Id);
   --  Verify that vertex V of graph G belongs to some component. R is the
   --  calling routine.

   procedure Check_Destination_Vertex
     (R     : String;
      G     : Instance;
      E     : Edge_Id;
      Exp_V : Vertex_Id);
   --  Vertify that the destination vertex of edge E of grah G is Exp_V. R is
   --  the calling routine.

   procedure Check_Distinct_Components
     (R      : String;
      Comp_1 : Component_Id;
      Comp_2 : Component_Id);
   --  Verify that components Comp_1 and Comp_2 are distinct (not the same)

   procedure Check_Has_Component
     (R      : String;
      G      : Instance;
      G_Name : String;
      Comp   : Component_Id);
   --  Verify that graph G with name G_Name contains component Comp. R is the
   --  calling routine.

   procedure Check_Has_Edge
     (R : String;
      G : Instance;
      E : Edge_Id);
   --  Verify that graph G contains edge E. R is the calling routine.

   procedure Check_Has_Vertex
     (R : String;
      G : Instance;
      V : Vertex_Id);
   --  Verify that graph G contains vertex V. R is the calling routine.

   procedure Check_No_Component
     (R : String;
      G : Instance;
      V : Vertex_Id);
   --  Verify that vertex V does not belong to some component. R is the calling
   --  routine.

   procedure Check_No_Component
     (R      : String;
      G      : Instance;
      G_Name : String;
      Comp   : Component_Id);
   --  Verify that graph G with name G_Name does not contain component Comp. R
   --  is the calling routine.

   procedure Check_No_Edge
     (R : String;
      G : Instance;
      E : Edge_Id);
   --  Verify that graph G does not contain edge E. R is the calling routine.

   procedure Check_No_Vertex
     (R : String;
      G : Instance;
      V : Vertex_Id);
   --  Verify that graph G does not contain vertex V. R is the calling routine.

   procedure Check_Number_Of_Components
     (R       : String;
      G       : Instance;
      Exp_Num : Natural);
   --  Verify that graph G has exactly Exp_Num components. R is the calling
   --  routine.

   procedure Check_Number_Of_Edges
     (R       : String;
      G       : Instance;
      Exp_Num : Natural);
   --  Verify that graph G has exactly Exp_Num edges. R is the calling routine.

   procedure Check_Number_Of_Vertices
     (R       : String;
      G       : Instance;
      Exp_Num : Natural);
   --  Verify that graph G has exactly Exp_Num vertices. R is the calling
   --  routine.

   procedure Check_Outgoing_Edge_Iterator
     (R   : String;
      G   : Instance;
      V   : Vertex_Id;
      Set : ES.Instance);
   --  Verify that all outgoing edges of vertex V of graph G can be iterated
   --  and appear in set Set. R is the calling routine.

   procedure Check_Source_Vertex
     (R     : String;
      G     : Instance;
      E     : Edge_Id;
      Exp_V : Vertex_Id);
   --  Vertify that the source vertex of edge E of grah G is Exp_V. R is the
   --  calling routine.

   procedure Check_Vertex_Iterator
     (R    : String;
      G    : Instance;
      Comp : Component_Id;
      Set  : VS.Instance);
   --  Verify that all vertices of component Comp of graph G can be iterated
   --  and appear in set Set. R is the calling routine.

   function Create_And_Populate return Instance;
   --  Create a brand new graph (see body for the shape of the graph)

   procedure Error (R : String; Msg : String);
   --  Output an error message with text Msg within the context of routine R

   procedure Test_Add_Edge;
   --  Verify the semantics of routine Add_Edge

   procedure Test_Add_Vertex;
   --  Verify the semantics of routine Add_Vertex

   procedure Test_All_Edge_Iterator;
   --  Verify the semantics of All_Edge_Iterator

   procedure Test_All_Vertex_Iterator;
   --  Verify the semantics of All_Vertex_Iterator

   procedure Test_Component;
   --  Verify the semantics of routine Component

   procedure Test_Component_Iterator;
   --  Verify the semantics of Component_Iterator

   procedure Test_Contains_Component;
   --  Verify the semantics of routine Contains_Component

   procedure Test_Contains_Edge;
   --  Verify the semantics of routine Contains_Edge

   procedure Test_Contains_Vertex;
   --  Verify the semantics of routine Contains_Vertex

   procedure Test_Delete_Edge;
   --  Verify the semantics of routine Delete_Edge

   procedure Test_Destination_Vertex;
   --  Verify the semantics of routine Destination_Vertex

   procedure Test_Find_Components;
   --  Verify the semantics of routine Find_Components

   procedure Test_Is_Empty;
   --  Verify the semantics of routine Is_Empty

   procedure Test_Number_Of_Components;
   --  Verify the semantics of routine Number_Of_Components

   procedure Test_Number_Of_Edges;
   --  Verify the semantics of routine Number_Of_Edges

   procedure Test_Number_Of_Vertices;
   --  Verify the semantics of routine Number_Of_Vertices

   procedure Test_Outgoing_Edge_Iterator;
   --  Verify the semantics of Outgoing_Edge_Iterator

   procedure Test_Present;
   --  Verify the semantics of routine Present

   procedure Test_Source_Vertex;
   --  Verify the semantics of routine Source_Vertex

   procedure Test_Vertex_Iterator;
   --  Verify the semantics of Vertex_Iterator;

   procedure Unexpected_Exception (R : String);
   --  Output an error message concerning an unexpected exception within
   --  routine R.

   --------------------------------
   -- Check_Belongs_To_Component --
   --------------------------------

   procedure Check_Belongs_To_Component
     (R        : String;
      G        : Instance;
      V        : Vertex_Id;
      Exp_Comp : Component_Id)
   is
      Act_Comp : constant Component_Id := Component (G, V);

   begin
      if Act_Comp /= Exp_Comp then
         Error (R, "inconsistent component for vertex " & V'Img);
         Error (R, "  expected: " & Exp_Comp'Img);
         Error (R, "  got     : " & Act_Comp'Img);
      end if;
   end Check_Belongs_To_Component;

   -------------------------------------
   -- Check_Belongs_To_Some_Component --
   -------------------------------------

   procedure Check_Belongs_To_Some_Component
     (R : String;
      G : Instance;
      V : Vertex_Id)
   is
   begin
      if not Present (Component (G, V)) then
         Error (R, "vertex " & V'Img & " does not belong to a component");
      end if;
   end Check_Belongs_To_Some_Component;

   ------------------------------
   -- Check_Destination_Vertex --
   ------------------------------

   procedure Check_Destination_Vertex
     (R     : String;
      G     : Instance;
      E     : Edge_Id;
      Exp_V : Vertex_Id)
   is
      Act_V : constant Vertex_Id := Destination_Vertex (G, E);

   begin
      if Act_V /= Exp_V then
         Error (R, "inconsistent destination vertex for edge " & E'Img);
         Error (R, "  expected: " & Exp_V'Img);
         Error (R, "  got     : " & Act_V'Img);
      end if;
   end Check_Destination_Vertex;

   -------------------------------
   -- Check_Distinct_Components --
   -------------------------------

   procedure Check_Distinct_Components
     (R      : String;
      Comp_1 : Component_Id;
      Comp_2 : Component_Id)
   is
   begin
      if Comp_1 = Comp_2 then
         Error (R, "components are not distinct");
      end if;
   end Check_Distinct_Components;

   -------------------------
   -- Check_Has_Component --
   -------------------------

   procedure Check_Has_Component
     (R      : String;
      G      : Instance;
      G_Name : String;
      Comp   : Component_Id)
   is
   begin
      if not Contains_Component (G, Comp) then
         Error (R, "graph " & G_Name & " lacks component");
      end if;
   end Check_Has_Component;

   --------------------
   -- Check_Has_Edge --
   --------------------

   procedure Check_Has_Edge
     (R : String;
      G : Instance;
      E : Edge_Id)
   is
   begin
      if not Contains_Edge (G, E) then
         Error (R, "graph lacks edge " & E'Img);
      end if;
   end Check_Has_Edge;

   ----------------------
   -- Check_Has_Vertex --
   ----------------------

   procedure Check_Has_Vertex
     (R : String;
      G : Instance;
      V : Vertex_Id)
   is
   begin
      if not Contains_Vertex (G, V) then
         Error (R, "graph lacks vertex " & V'Img);
      end if;
   end Check_Has_Vertex;

   ------------------------
   -- Check_No_Component --
   ------------------------

   procedure Check_No_Component
     (R : String;
      G : Instance;
      V : Vertex_Id)
   is
   begin
      if Present (Component (G, V)) then
         Error (R, "vertex " & V'Img & " belongs to a component");
      end if;
   end Check_No_Component;

   procedure Check_No_Component
     (R      : String;
      G      : Instance;
      G_Name : String;
      Comp   : Component_Id)
   is
   begin
      if Contains_Component (G, Comp) then
         Error (R, "graph " & G_Name & " contains component");
      end if;
   end Check_No_Component;

   -------------------
   -- Check_No_Edge --
   -------------------

   procedure Check_No_Edge
     (R : String;
      G : Instance;
      E : Edge_Id)
   is
   begin
      if Contains_Edge (G, E) then
         Error (R, "graph contains edge " & E'Img);
      end if;
   end Check_No_Edge;

   ---------------------
   -- Check_No_Vertex --
   ---------------------

   procedure Check_No_Vertex
     (R : String;
      G : Instance;
      V : Vertex_Id)
   is
   begin
      if Contains_Vertex (G, V) then
         Error (R, "graph contains vertex " & V'Img);
      end if;
   end Check_No_Vertex;

   --------------------------------
   -- Check_Number_Of_Components --
   --------------------------------

   procedure Check_Number_Of_Components
     (R       : String;
      G       : Instance;
      Exp_Num : Natural)
   is
      Act_Num : constant Natural := Number_Of_Components (G);

   begin
      if Act_Num /= Exp_Num then
         Error (R, "inconsistent number of components");
         Error (R, "  expected: " & Exp_Num'Img);
         Error (R, "  got     : " & Act_Num'Img);
      end if;
   end Check_Number_Of_Components;

   ---------------------------
   -- Check_Number_Of_Edges --
   ---------------------------

   procedure Check_Number_Of_Edges
     (R       : String;
      G       : Instance;
      Exp_Num : Natural)
   is
      Act_Num : constant Natural := Number_Of_Edges (G);

   begin
      if Act_Num /= Exp_Num then
         Error (R, "inconsistent number of edges");
         Error (R, "  expected: " & Exp_Num'Img);
         Error (R, "  got     : " & Act_Num'Img);
      end if;
   end Check_Number_Of_Edges;

   ------------------------------
   -- Check_Number_Of_Vertices --
   ------------------------------

   procedure Check_Number_Of_Vertices
     (R       : String;
      G       : Instance;
      Exp_Num : Natural)
   is
      Act_Num : constant Natural := Number_Of_Vertices (G);

   begin
      if Act_Num /= Exp_Num then
         Error (R, "inconsistent number of vertices");
         Error (R, "  expected: " & Exp_Num'Img);
         Error (R, "  got     : " & Act_Num'Img);
      end if;
   end Check_Number_Of_Vertices;

   ----------------------------------
   -- Check_Outgoing_Edge_Iterator --
   ----------------------------------

   procedure Check_Outgoing_Edge_Iterator
     (R   : String;
      G   : Instance;
      V   : Vertex_Id;
      Set : ES.Instance)
   is
      E : Edge_Id;

      Out_E_Iter : Outgoing_Edge_Iterator;

   begin
      --  Iterate over all outgoing edges of vertex V while removing edges seen
      --  from the set.

      Out_E_Iter := Iterate_Outgoing_Edges (G, V);
      while Has_Next (Out_E_Iter) loop
         Next (Out_E_Iter, E);

         if ES.Contains (Set, E) then
            ES.Delete (Set, E);
         else
            Error (R, "outgoing edge " & E'Img & " is not iterated");
         end if;
      end loop;

      --  At this point the set of edges should be empty

      if not ES.Is_Empty (Set) then
         Error (R, "not all outgoing edges were iterated");
      end if;
   end Check_Outgoing_Edge_Iterator;

   -------------------------
   -- Check_Source_Vertex --
   -------------------------

   procedure Check_Source_Vertex
     (R     : String;
      G     : Instance;
      E     : Edge_Id;
      Exp_V : Vertex_Id)
   is
      Act_V : constant Vertex_Id := Source_Vertex (G, E);

   begin
      if Act_V /= Exp_V then
         Error (R, "inconsistent source vertex");
         Error (R, "  expected: " & Exp_V'Img);
         Error (R, "  got     : " & Act_V'Img);
      end if;
   end Check_Source_Vertex;

   ---------------------------
   -- Check_Vertex_Iterator --
   ---------------------------

   procedure Check_Vertex_Iterator
     (R    : String;
      G    : Instance;
      Comp : Component_Id;
      Set  : VS.Instance)
   is
      V : Vertex_Id;

      V_Iter : Vertex_Iterator;

   begin
      --  Iterate over all vertices of component Comp while removing vertices
      --  seen from the set.

      V_Iter := Iterate_Vertices (G, Comp);
      while Has_Next (V_Iter) loop
         Next (V_Iter, V);

         if VS.Contains (Set, V) then
            VS.Delete (Set, V);
         else
            Error (R, "vertex " & V'Img & " is not iterated");
         end if;
      end loop;

      --  At this point the set of vertices should be empty

      if not VS.Is_Empty (Set) then
         Error (R, "not all vertices were iterated");
      end if;
   end Check_Vertex_Iterator;

   -------------------------
   -- Create_And_Populate --
   -------------------------

   function Create_And_Populate return Instance is
      G : constant Instance :=
            Create (Initial_Vertices => Vertex_Id'Size,
                    Initial_Edges    => Edge_Id'Size);

   begin
      --       9         8           1        2
      --  G <------ F <------  A  ------> B -------> C
      --  |                  ^ | |        ^          ^
      --  +------------------+ | +-------------------+
      --       10              |          |   3
      --                    4  |        5 |
      --                       v          |
      --            H          D ---------+
      --                      | ^
      --                      | |
      --                    6 | | 7
      --                      | |
      --                      v |
      --                       E
      --
      --  Components:
      --
      --    [A, F, G]
      --    [B]
      --    [C]
      --    [D, E]
      --    [H]

      Add_Vertex (G, VA);
      Add_Vertex (G, VB);
      Add_Vertex (G, VC);
      Add_Vertex (G, VD);
      Add_Vertex (G, VE);
      Add_Vertex (G, VF);
      Add_Vertex (G, VG);
      Add_Vertex (G, VH);

      Add_Edge (G, E1,  Source => VA, Destination => VB);
      Add_Edge (G, E2,  Source => VB, Destination => VC);
      Add_Edge (G, E3,  Source => VA, Destination => VC);
      Add_Edge (G, E4,  Source => VA, Destination => VD);
      Add_Edge (G, E5,  Source => VD, Destination => VB);
      Add_Edge (G, E6,  Source => VD, Destination => VE);
      Add_Edge (G, E7,  Source => VE, Destination => VD);
      Add_Edge (G, E8,  Source => VA, Destination => VF);
      Add_Edge (G, E9,  Source => VF, Destination => VG);
      Add_Edge (G, E10, Source => VG, Destination => VA);

      return G;
   end Create_And_Populate;

   -----------
   -- Error --
   -----------

   procedure Error (R : String; Msg : String) is
   begin
      Put_Line ("ERROR: " & R & ": " & Msg);
   end Error;

   ---------------
   -- Hash_Edge --
   ---------------

   function Hash_Edge (E : Edge_Id) return Bucket_Range_Type is
   begin
      return Bucket_Range_Type (Edge_Id'Pos (E));
   end Hash_Edge;

   -----------------
   -- Hash_Vertex --
   -----------------

   function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type is
   begin
      return Bucket_Range_Type (Vertex_Id'Pos (V));
   end Hash_Vertex;

   -------------------
   -- Test_Add_Edge --
   -------------------

   procedure Test_Add_Edge is
      R : constant String := "Test_Add_Edge";

      E : Edge_Id;
      G : Instance := Create_And_Populate;

      All_E_Iter : All_Edge_Iterator;
      Out_E_Iter : Outgoing_Edge_Iterator;

   begin
      --  Try to add the same edge twice

      begin
         Add_Edge (G, E1, VB, VH);
         Error (R, "duplicate edge not detected");
      exception
         when Duplicate_Edge => null;
         when others         => Unexpected_Exception (R);
      end;

      --  Try to add an edge with a bogus source

      begin
         Add_Edge (G, E97, Source => VX, Destination => VC);
         Error (R, "missing vertex not detected");
      exception
         when Missing_Vertex => null;
         when others         => Unexpected_Exception (R);
      end;

      --  Try to add an edge with a bogus destination

      begin
         Add_Edge (G, E97, Source => VF, Destination => VY);
         Error (R, "missing vertex not detected");
      exception
         when Missing_Vertex => null;
         when others         => Unexpected_Exception (R);
      end;

      --  Delete edge E1 between vertices VA and VB

      begin
         Delete_Edge (G, E1);
      exception
         when others => Unexpected_Exception (R);
      end;

      --  Try to re-add edge E1

      begin
         Add_Edge (G, E1, Source => VA, Destination => VB);
      exception
         when others => Unexpected_Exception (R);
      end;

      --  Lock all edges in the graph

      All_E_Iter := Iterate_All_Edges (G);

      --  Try to add an edge given that all edges are locked

      begin
         Add_Edge (G, E97, Source => VG, Destination => VH);
         Error (R, "all edges not locked");
      exception
         when Iterated => null;
         when others   => Unexpected_Exception (R);
      end;

      --  Unlock all edges by iterating over them

      while Has_Next (All_E_Iter) loop Next (All_E_Iter, E); end loop;

      --  Lock all outgoing edges of vertex VD

      Out_E_Iter := Iterate_Outgoing_Edges (G, VD);

      --  Try to add an edge with source VD given that all edges of VD are
      --  locked.

      begin
         Add_Edge (G, E97, Source => VD, Destination => VG);
         Error (R, "outgoing edges of VD not locked");
      exception
         when Iterated => null;
         when others   => Unexpected_Exception (R);
      end;

      --  Unlock the edges of vertex VD by iterating over them

      while Has_Next (Out_E_Iter) loop Next (Out_E_Iter, E); end loop;

      Destroy (G);
   end Test_Add_Edge;

   ---------------------
   -- Test_Add_Vertex --
   ---------------------

   procedure Test_Add_Vertex is
      R : constant String := "Test_Add_Vertex";

      G : Instance := Create_And_Populate;
      V : Vertex_Id;

      All_V_Iter : All_Vertex_Iterator;

   begin
      --  Try to add the same vertex twice

      begin
         Add_Vertex (G, VD);
         Error (R, "duplicate vertex not detected");
      exception
         when Duplicate_Vertex => null;
         when others           => Unexpected_Exception (R);
      end;

      --  Lock all vertices in the graph

      All_V_Iter := Iterate_All_Vertices (G);

      --  Try to add a vertex given that all vertices are locked

      begin
         Add_Vertex (G, VZ);
         Error (R, "all vertices not locked");
      exception
         when Iterated => null;
         when others   => Unexpected_Exception (R);
      end;

      --  Unlock all vertices by iterating over them

      while Has_Next (All_V_Iter) loop Next (All_V_Iter, V); end loop;

      Destroy (G);
   end Test_Add_Vertex;

   ----------------------------
   -- Test_All_Edge_Iterator --
   ----------------------------

   procedure Test_All_Edge_Iterator is
      R : constant String := "Test_All_Edge_Iterator";

      E : Edge_Id;
      G : Instance := Create_And_Populate;

      All_E_Iter : All_Edge_Iterator;
      All_Edges  : ES.Instance;

   begin
      --  Collect all expected edges in a set

      All_Edges := ES.Create (Number_Of_Edges (G));

      for Curr_E in E1 .. E10 loop
         ES.Insert (All_Edges, Curr_E);
      end loop;

      --  Iterate over all edges while removing encountered edges from the set

      All_E_Iter := Iterate_All_Edges (G);
      while Has_Next (All_E_Iter) loop
         Next (All_E_Iter, E);

         if ES.Contains (All_Edges, E) then
            ES.Delete (All_Edges, E);
         else
            Error (R, "edge " & E'Img & " is not iterated");
         end if;
      end loop;

      --  At this point the set of edges should be empty

      if not ES.Is_Empty (All_Edges) then
         Error (R, "not all edges were iterated");
      end if;

      ES.Destroy (All_Edges);
      Destroy (G);
   end Test_All_Edge_Iterator;

   ------------------------------
   -- Test_All_Vertex_Iterator --
   ------------------------------

   procedure Test_All_Vertex_Iterator is
      R : constant String := "Test_All_Vertex_Iterator";

      G : Instance := Create_And_Populate;
      V : Vertex_Id;

      All_V_Iter   : All_Vertex_Iterator;
      All_Vertices : VS.Instance;

   begin
      --  Collect all expected vertices in a set

      All_Vertices := VS.Create (Number_Of_Vertices (G));

      for Curr_V in VA .. VH loop
         VS.Insert (All_Vertices, Curr_V);
      end loop;

      --  Iterate over all vertices while removing encountered vertices from
      --  the set.

      All_V_Iter := Iterate_All_Vertices (G);
      while Has_Next (All_V_Iter) loop
         Next (All_V_Iter, V);

         if VS.Contains (All_Vertices, V) then
            VS.Delete (All_Vertices, V);
         else
            Error (R, "vertex " & V'Img & " is not iterated");
         end if;
      end loop;

      --  At this point the set of vertices should be empty

      if not VS.Is_Empty (All_Vertices) then
         Error (R, "not all vertices were iterated");
      end if;

      VS.Destroy (All_Vertices);
      Destroy (G);
   end Test_All_Vertex_Iterator;

   --------------------
   -- Test_Component --
   --------------------

   procedure Test_Component is
      R : constant String := "Test_Component";

      G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);

   begin
      --      E1
      --    ----->
      --  VA       VB     VC
      --    <-----
      --      E2
      --
      --  Components:
      --
      --    [VA, VB]
      --    [VC]

      Add_Vertex (G, VA);
      Add_Vertex (G, VB);
      Add_Vertex (G, VC);

      Add_Edge (G, E1, Source => VA, Destination => VB);
      Add_Edge (G, E2, Source => VB, Destination => VA);

      --  None of the vertices should belong to a component

      Check_No_Component (R, G, VA);
      Check_No_Component (R, G, VB);
      Check_No_Component (R, G, VC);

      --  Find the strongly connected components in the graph

      Find_Components (G);

      --  Vertices should belong to a component

      Check_Belongs_To_Some_Component (R, G, VA);
      Check_Belongs_To_Some_Component (R, G, VB);
      Check_Belongs_To_Some_Component (R, G, VC);

      Destroy (G);
   end Test_Component;

   -----------------------------
   -- Test_Component_Iterator --
   -----------------------------

   procedure Test_Component_Iterator is
      R : constant String := "Test_Component_Iterator";

      G : Instance := Create_And_Populate;

      Comp       : Component_Id;
      Comp_Count : Natural;
      Comp_Iter  : Component_Iterator;

   begin
      Find_Components (G);
      Check_Number_Of_Components (R, G, 5);

      Comp_Count := Number_Of_Components (G);

      --  Iterate over all components while decrementing their number

      Comp_Iter := Iterate_Components (G);
      while Has_Next (Comp_Iter) loop
         Next (Comp_Iter, Comp);

         Comp_Count := Comp_Count - 1;
      end loop;

      --  At this point all components should have been accounted for

      if Comp_Count /= 0 then
         Error (R, "not all components were iterated");
      end if;

      Destroy (G);
   end Test_Component_Iterator;

   -----------------------------
   -- Test_Contains_Component --
   -----------------------------

   procedure Test_Contains_Component is
      R : constant String := "Test_Contains_Component";

      G1 : Instance := Create (Initial_Vertices => 2, Initial_Edges => 2);
      G2 : Instance := Create (Initial_Vertices => 2, Initial_Edges => 2);

   begin
      --      E1
      --    ----->
      --  VA       VB
      --    <-----
      --      E2
      --
      --  Components:
      --
      --    [VA, VB]

      Add_Vertex (G1, VA);
      Add_Vertex (G1, VB);

      Add_Edge (G1, E1, Source => VA, Destination => VB);
      Add_Edge (G1, E2, Source => VB, Destination => VA);

      --      E97
      --    ----->
      --  VX       VY
      --    <-----
      --      E98
      --
      --  Components:
      --
      --    [VX, VY]

      Add_Vertex (G2, VX);
      Add_Vertex (G2, VY);

      Add_Edge (G2, E97, Source => VX, Destination => VY);
      Add_Edge (G2, E98, Source => VY, Destination => VX);

      --  Find the strongly connected components in both graphs

      Find_Components (G1);
      Find_Components (G2);

      --  Vertices should belong to a component

      Check_Belongs_To_Some_Component (R, G1, VA);
      Check_Belongs_To_Some_Component (R, G1, VB);
      Check_Belongs_To_Some_Component (R, G2, VX);
      Check_Belongs_To_Some_Component (R, G2, VY);

      --  Verify that each graph contains the correct component

      Check_Has_Component (R, G1, "G1", Component (G1, VA));
      Check_Has_Component (R, G1, "G1", Component (G1, VB));
      Check_Has_Component (R, G2, "G2", Component (G2, VX));
      Check_Has_Component (R, G2, "G2", Component (G2, VY));

      --  Verify that each graph does not contain components from the other
      --  graph.

      Check_No_Component (R, G1, "G1", Component (G2, VX));
      Check_No_Component (R, G1, "G1", Component (G2, VY));
      Check_No_Component (R, G2, "G2", Component (G1, VA));
      Check_No_Component (R, G2, "G2", Component (G1, VB));

      Destroy (G1);
      Destroy (G2);
   end Test_Contains_Component;

   ------------------------
   -- Test_Contains_Edge --
   ------------------------

   procedure Test_Contains_Edge is
      R : constant String := "Test_Contains_Edge";

      G : Instance := Create_And_Populate;

   begin
      --  Verify that all edges in the range E1 .. E10 exist

      for Curr_E in E1 .. E10 loop
         Check_Has_Edge (R, G, Curr_E);
      end loop;

      --  Verify that no extra edges are present

      for Curr_E in E97 .. E99 loop
         Check_No_Edge (R, G, Curr_E);
      end loop;

      --  Add new edges E97, E98, and E99

      Add_Edge (G, E97, Source => VG, Destination => VF);
      Add_Edge (G, E98, Source => VH, Destination => VE);
      Add_Edge (G, E99, Source => VD, Destination => VC);

      --  Verify that all edges in the range E1 .. E99 exist

      for Curr_E in E1 .. E99 loop
         Check_Has_Edge (R, G, Curr_E);
      end loop;

      --  Delete each edge that corresponds to an even position in Edge_Id

      for Curr_E in E1 .. E99 loop
         if Edge_Id'Pos (Curr_E) mod 2 = 0 then
            Delete_Edge (G, Curr_E);
         end if;
      end loop;

      --  Verify that all "even" edges are missing, and all "odd" edges are
      --  present.

      for Curr_E in E1 .. E99 loop
         if Edge_Id'Pos (Curr_E) mod 2 = 0 then
            Check_No_Edge (R, G, Curr_E);
         else
            Check_Has_Edge (R, G, Curr_E);
         end if;
      end loop;

      Destroy (G);
   end Test_Contains_Edge;

   --------------------------
   -- Test_Contains_Vertex --
   --------------------------

   procedure Test_Contains_Vertex is
      R : constant String := "Test_Contains_Vertex";

      G : Instance := Create_And_Populate;

   begin
      --  Verify that all vertices in the range VA .. VH exist

      for Curr_V in VA .. VH loop
         Check_Has_Vertex (R, G, Curr_V);
      end loop;

      --  Verify that no extra vertices are present

      for Curr_V in VX .. VZ loop
         Check_No_Vertex (R, G, Curr_V);
      end loop;

      --  Add new vertices VX, VY, and VZ

      Add_Vertex (G, VX);
      Add_Vertex (G, VY);
      Add_Vertex (G, VZ);

      --  Verify that all vertices in the range VA .. VZ exist

      for Curr_V in VA .. VZ loop
         Check_Has_Vertex (R, G, Curr_V);
      end loop;

      Destroy (G);
   end Test_Contains_Vertex;

   ----------------------
   -- Test_Delete_Edge --
   ----------------------

   procedure Test_Delete_Edge is
      R : constant String := "Test_Delete_Edge";

      E : Edge_Id;
      G : Instance := Create_And_Populate;
      V : Vertex_Id;

      All_E_Iter : All_Edge_Iterator;
      All_V_Iter : All_Vertex_Iterator;
      Out_E_Iter : Outgoing_Edge_Iterator;

   begin
      --  Try to delete a bogus edge

      begin
         Delete_Edge (G, E97);
         Error (R, "missing vertex deleted");
      exception
         when Missing_Edge => null;
         when others       => Unexpected_Exception (R);
      end;

      --  Delete edge E1 between vertices VA and VB

      begin
         Delete_Edge (G, E1);
      exception
         when others => Unexpected_Exception (R);
      end;

      --  Verify that edge E1 is gone from all edges in the graph

      All_E_Iter := Iterate_All_Edges (G);
      while Has_Next (All_E_Iter) loop
         Next (All_E_Iter, E);

         if E = E1 then
            Error (R, "edge " & E'Img & " not removed from all edges");
         end if;
      end loop;

      --  Verify that edge E1 is gone from the outgoing edges of vertex VA

      Out_E_Iter := Iterate_Outgoing_Edges (G, VA);
      while Has_Next (Out_E_Iter) loop
         Next (Out_E_Iter, E);

         if E = E1 then
            Error
              (R, "edge " & E'Img & "not removed from outgoing edges of VA");
         end if;
      end loop;

      --  Delete all edges in the range E2 .. E10

      for Curr_E in E2 .. E10 loop
         Delete_Edge (G, Curr_E);
      end loop;

      --  Verify that all edges are gone from the graph

      All_E_Iter := Iterate_All_Edges (G);
      while Has_Next (All_E_Iter) loop
         Next (All_E_Iter, E);

         Error (R, "edge " & E'Img & " not removed from all edges");
      end loop;

      --  Verify that all edges are gone from the respective source vertices

      All_V_Iter := Iterate_All_Vertices (G);
      while Has_Next (All_V_Iter) loop
         Next (All_V_Iter, V);

         Out_E_Iter := Iterate_Outgoing_Edges (G, V);
         while Has_Next (Out_E_Iter) loop
            Next (Out_E_Iter, E);

            Error (R, "edge " & E'Img & " not removed from vertex " & V'Img);
         end loop;
      end loop;

      Destroy (G);
   end Test_Delete_Edge;

   -----------------------------
   -- Test_Destination_Vertex --
   -----------------------------

   procedure Test_Destination_Vertex is
      R : constant String := "Test_Destination_Vertex";

      G : Instance := Create_And_Populate;

   begin
      --  Verify the destination vertices of all edges in the graph

      Check_Destination_Vertex (R, G, E1,  VB);
      Check_Destination_Vertex (R, G, E2,  VC);
      Check_Destination_Vertex (R, G, E3,  VC);
      Check_Destination_Vertex (R, G, E4,  VD);
      Check_Destination_Vertex (R, G, E5,  VB);
      Check_Destination_Vertex (R, G, E6,  VE);
      Check_Destination_Vertex (R, G, E7,  VD);
      Check_Destination_Vertex (R, G, E8,  VF);
      Check_Destination_Vertex (R, G, E9,  VG);
      Check_Destination_Vertex (R, G, E10, VA);

      Destroy (G);
   end Test_Destination_Vertex;

   --------------------------
   -- Test_Find_Components --
   --------------------------

   procedure Test_Find_Components is
      R : constant String := "Test_Find_Components";

      G : Instance := Create_And_Populate;

      Comp_1 : Component_Id;  --  [A, F, G]
      Comp_2 : Component_Id;  --  [B]
      Comp_3 : Component_Id;  --  [C]
      Comp_4 : Component_Id;  --  [D, E]
      Comp_5 : Component_Id;  --  [H]

   begin
      Find_Components (G);

      --  Vertices should belong to a component

      Check_Belongs_To_Some_Component (R, G, VA);
      Check_Belongs_To_Some_Component (R, G, VB);
      Check_Belongs_To_Some_Component (R, G, VC);
      Check_Belongs_To_Some_Component (R, G, VD);
      Check_Belongs_To_Some_Component (R, G, VH);

      --  Extract the ids of the components from the first vertices in each
      --  component.

      Comp_1 := Component (G, VA);
      Comp_2 := Component (G, VB);
      Comp_3 := Component (G, VC);
      Comp_4 := Component (G, VD);
      Comp_5 := Component (G, VH);

      --  Verify that the components are distinct

      Check_Distinct_Components (R, Comp_1, Comp_2);
      Check_Distinct_Components (R, Comp_1, Comp_3);
      Check_Distinct_Components (R, Comp_1, Comp_4);
      Check_Distinct_Components (R, Comp_1, Comp_5);

      Check_Distinct_Components (R, Comp_2, Comp_3);
      Check_Distinct_Components (R, Comp_2, Comp_4);
      Check_Distinct_Components (R, Comp_2, Comp_5);

      Check_Distinct_Components (R, Comp_3, Comp_4);
      Check_Distinct_Components (R, Comp_3, Comp_5);

      Check_Distinct_Components (R, Comp_4, Comp_5);

      --  Verify that the remaining nodes belong to the proper component

      Check_Belongs_To_Component (R, G, VF, Comp_1);
      Check_Belongs_To_Component (R, G, VG, Comp_1);
      Check_Belongs_To_Component (R, G, VE, Comp_4);

      Destroy (G);
   end Test_Find_Components;

   -------------------
   -- Test_Is_Empty --
   -------------------

   procedure Test_Is_Empty is
      R : constant String := "Test_Is_Empty";

      G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);

   begin
      --  Verify that a graph without vertices and edges is empty

      if not Is_Empty (G) then
         Error (R, "graph is empty");
      end if;

      --  Add vertices

      Add_Vertex (G, VA);
      Add_Vertex (G, VB);

      --  Verify that a graph with vertices and no edges is not empty

      if Is_Empty (G) then
         Error (R, "graph is not empty");
      end if;

      --  Add edges

      Add_Edge (G, E1, Source => VA, Destination => VB);

      --  Verify that a graph with vertices and edges is not empty

      if Is_Empty (G) then
         Error (R, "graph is not empty");
      end if;

      Destroy (G);
   end Test_Is_Empty;

   -------------------------------
   -- Test_Number_Of_Components --
   -------------------------------

   procedure Test_Number_Of_Components is
      R : constant String := "Test_Number_Of_Components";

      G : Instance := Create (Initial_Vertices => 3, Initial_Edges => 2);

   begin
      --  Verify that an empty graph has exactly 0 components

      Check_Number_Of_Components (R, G, 0);

      --      E1
      --    ----->
      --  VA       VB     VC
      --    <-----
      --      E2
      --
      --  Components:
      --
      --    [VA, VB]
      --    [VC]

      Add_Vertex (G, VA);
      Add_Vertex (G, VB);
      Add_Vertex (G, VC);

      Add_Edge (G, E1, Source => VA, Destination => VB);
      Add_Edge (G, E2, Source => VB, Destination => VA);

      --  Verify that the graph has exact 0 components even though it contains
      --  vertices and edges.

      Check_Number_Of_Components (R, G, 0);

      Find_Components (G);

      --  Verify that the graph has exactly 2 components

      Check_Number_Of_Components (R, G, 2);

      Destroy (G);
   end Test_Number_Of_Components;

   --------------------------
   -- Test_Number_Of_Edges --
   --------------------------

   procedure Test_Number_Of_Edges is
      R : constant String := "Test_Number_Of_Edges";

      G : Instance := Create_And_Populate;

   begin
      --  Verify that the graph has exactly 10 edges

      Check_Number_Of_Edges (R, G, 10);

      --  Delete two edges

      Delete_Edge (G, E1);
      Delete_Edge (G, E2);

      --  Verify that the graph has exactly 8 edges

      Check_Number_Of_Edges (R, G, 8);

      --  Delete the remaining edge

      for Curr_E in E3 .. E10 loop
         Delete_Edge (G, Curr_E);
      end loop;

      --  Verify that the graph has exactly 0 edges

      Check_Number_Of_Edges (R, G, 0);

      --  Add two edges

      Add_Edge (G, E1, Source => VF, Destination => VA);
      Add_Edge (G, E2, Source => VC, Destination => VH);

      --  Verify that the graph has exactly 2 edges

      Check_Number_Of_Edges (R, G, 2);

      Destroy (G);
   end Test_Number_Of_Edges;

   -----------------------------
   -- Test_Number_Of_Vertices --
   -----------------------------

   procedure Test_Number_Of_Vertices is
      R : constant String := "Test_Number_Of_Vertices";

      G : Instance := Create (Initial_Vertices => 4, Initial_Edges => 12);

   begin
      --  Verify that an empty graph has exactly 0 vertices

      Check_Number_Of_Vertices (R, G, 0);

      --  Add three vertices

      Add_Vertex (G, VC);
      Add_Vertex (G, VG);
      Add_Vertex (G, VX);

      --  Verify that the graph has exactly 3 vertices

      Check_Number_Of_Vertices (R, G, 3);

      --  Add one edge

      Add_Edge (G, E8, Source => VX, Destination => VG);

      --  Verify that the graph has exactly 3 vertices

      Check_Number_Of_Vertices (R, G, 3);

      Destroy (G);
   end Test_Number_Of_Vertices;

   ---------------------------------
   -- Test_Outgoing_Edge_Iterator --
   ---------------------------------

   procedure Test_Outgoing_Edge_Iterator is
      R : constant String := "Test_Outgoing_Edge_Iterator";

      G   : Instance := Create_And_Populate;
      Set : ES.Instance;

   begin
      Set := ES.Create (4);

      ES.Insert (Set, E1);
      ES.Insert (Set, E3);
      ES.Insert (Set, E4);
      ES.Insert (Set, E8);
      Check_Outgoing_Edge_Iterator (R, G, VA, Set);

      ES.Insert (Set, E2);
      Check_Outgoing_Edge_Iterator (R, G, VB, Set);

      Check_Outgoing_Edge_Iterator (R, G, VC, Set);

      ES.Insert (Set, E5);
      ES.Insert (Set, E6);
      Check_Outgoing_Edge_Iterator (R, G, VD, Set);

      ES.Insert (Set, E7);
      Check_Outgoing_Edge_Iterator (R, G, VE, Set);

      ES.Insert (Set, E9);
      Check_Outgoing_Edge_Iterator (R, G, VF, Set);

      ES.Insert (Set, E10);
      Check_Outgoing_Edge_Iterator (R, G, VG, Set);

      Check_Outgoing_Edge_Iterator (R, G, VH, Set);

      ES.Destroy (Set);
      Destroy (G);
   end Test_Outgoing_Edge_Iterator;

   ------------------
   -- Test_Present --
   ------------------

   procedure Test_Present is
      R : constant String := "Test_Present";

      G : Instance := Nil;

   begin
      --  Verify that a non-existent graph is not present

      if Present (G) then
         Error (R, "graph is not present");
      end if;

      G := Create_And_Populate;

      --  Verify that an existing graph is present

      if not Present (G) then
         Error (R, "graph is present");
      end if;

      Destroy (G);

      --  Verify that a destroyed graph is not present

      if Present (G) then
         Error (R, "graph is not present");
      end if;
   end Test_Present;

   ------------------------
   -- Test_Source_Vertex --
   ------------------------

   procedure Test_Source_Vertex is
      R : constant String := "Test_Source_Vertex";

      G : Instance := Create_And_Populate;

   begin
      --  Verify the source vertices of all edges in the graph

      Check_Source_Vertex (R, G, E1,  VA);
      Check_Source_Vertex (R, G, E2,  VB);
      Check_Source_Vertex (R, G, E3,  VA);
      Check_Source_Vertex (R, G, E4,  VA);
      Check_Source_Vertex (R, G, E5,  VD);
      Check_Source_Vertex (R, G, E6,  VD);
      Check_Source_Vertex (R, G, E7,  VE);
      Check_Source_Vertex (R, G, E8,  VA);
      Check_Source_Vertex (R, G, E9,  VF);
      Check_Source_Vertex (R, G, E10, VG);

      Destroy (G);
   end Test_Source_Vertex;

   --------------------------
   -- Test_Vertex_Iterator --
   --------------------------

   procedure Test_Vertex_Iterator is
      R : constant String := "Test_Vertex_Iterator";

      G   : Instance := Create_And_Populate;
      Set : VS.Instance;

   begin
      Find_Components (G);

      Set := VS.Create (3);

      VS.Insert (Set, VA);
      VS.Insert (Set, VF);
      VS.Insert (Set, VG);
      Check_Vertex_Iterator (R, G, Component (G, VA), Set);

      VS.Insert (Set, VB);
      Check_Vertex_Iterator (R, G, Component (G, VB), Set);

      VS.Insert (Set, VC);
      Check_Vertex_Iterator (R, G, Component (G, VC), Set);

      VS.Insert (Set, VD);
      VS.Insert (Set, VE);
      Check_Vertex_Iterator (R, G, Component (G, VD), Set);

      VS.Insert (Set, VH);
      Check_Vertex_Iterator (R, G, Component (G, VH), Set);

      VS.Destroy (Set);
      Destroy (G);
   end Test_Vertex_Iterator;

   --------------------------
   -- Unexpected_Exception --
   --------------------------

   procedure Unexpected_Exception (R : String) is
   begin
      Error (R, "unexpected exception");
   end Unexpected_Exception;

--  Start of processing for Operations

begin
   Test_Add_Edge;
   Test_Add_Vertex;
   Test_All_Edge_Iterator;
   Test_All_Vertex_Iterator;
   Test_Component;
   Test_Component_Iterator;
   Test_Contains_Component;
   Test_Contains_Edge;
   Test_Contains_Vertex;
   Test_Delete_Edge;
   Test_Destination_Vertex;
   Test_Find_Components;
   Test_Is_Empty;
   Test_Number_Of_Components;
   Test_Number_Of_Edges;
   Test_Number_Of_Vertices;
   Test_Outgoing_Edge_Iterator;
   Test_Present;
   Test_Source_Vertex;
   Test_Vertex_Iterator;

end Operations;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0

2019-07-01  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95.
	* Makefile.rtl, gcc-interface/Make-lang.in: Register unit
	GNAT.Graphs.
	* libgnat/g-dynhta.adb: Various minor cleanups (use Present
	rather than direct comparisons).
	(Delete): Reimplement to use Delete_Node.
	(Delete_Node): New routine.
	(Destroy_Bucket): Invoke the provided destructor.
	(Present): New routines.
	* libgnat/g-dynhta.ads: Add new generic formal Destroy_Value.
	Use better names for the components of iterators.
	* libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit.
	* libgnat/g-lists.adb: Various minor cleanups (use Present
	rather than direct comparisons).
	(Delete_Node): Invoke the provided destructor.
	(Present): New routine.
	* libgnat/g-lists.ads: Add new generic formal Destroy_Element.
	Use better names for the components of iterators.
	(Present): New routine.
	* libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset,
	Reset): New routines.

From-SVN: r272857
parent 7c46e926
Showing with 148 additions and 42 deletions
gcc/ada/ChangeLog
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
* impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95.
* Makefile.rtl, gcc-interface/Make-lang.in: Register unit
GNAT.Graphs.
* libgnat/g-dynhta.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete): Reimplement to use Delete_Node.
(Delete_Node): New routine.
(Destroy_Bucket): Invoke the provided destructor.
(Present): New routines.
* libgnat/g-dynhta.ads: Add new generic formal Destroy_Value.
Use better names for the components of iterators.
* libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit.
* libgnat/g-lists.adb: Various minor cleanups (use Present
rather than direct comparisons).
(Delete_Node): Invoke the provided destructor.
(Present): New routine.
* libgnat/g-lists.ads: Add new generic formal Destroy_Element.
Use better names for the components of iterators.
(Present): New routine.
* libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset,
Reset): New routines.
2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com>
* libgnat/g-sothco.adb (Get_Address): Fix the case when AF_INET6
......
gcc/ada/Makefile.rtl
......@@ -421,6 +421,7 @@ GNATRTL_NONTASKING_OBJS= \
g-exptty$(objext) \
g-flocon$(objext) \
g-forstr$(objext) \
g-graphs$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
g-hesorg$(objext) \
......
gcc/ada/gcc-interface/Make-lang.in
......@@ -317,6 +317,7 @@ GNAT_ADA_OBJS = \
ada/frontend.o \
ada/libgnat/g-byorma.o \
ada/libgnat/g-dynhta.o \
ada/libgnat/g-graphs.o \
ada/libgnat/g-hesora.o \
ada/libgnat/g-htable.o \
ada/libgnat/g-lists.o \
......
gcc/ada/impunit.adb
......@@ -275,6 +275,7 @@ package body Impunit is
("g-exptty", F), -- GNAT.Expect.TTY
("g-flocon", F), -- GNAT.Float_Control
("g-forstr", F), -- GNAT.Formatted_String
("g-graphs", F), -- GNAT.Graphs
("g-heasor", F), -- GNAT.Heap_Sort
("g-hesora", F), -- GNAT.Heap_Sort_A
("g-hesorg", F), -- GNAT.Heap_Sort_G
......
gcc/ada/libgnat/g-dynhta.ads
......@@ -265,9 +265,9 @@ package GNAT.Dynamic_HTables is
-- The following package offers a hash table abstraction with the following
-- characteristics:
--
-- * Dynamic resizing based on load factor.
-- * Creation of multiple instances, of different sizes.
-- * Iterable keys.
-- * Dynamic resizing based on load factor
-- * Creation of multiple instances, of different sizes
-- * Iterable keys
--
-- This type of hash table is best used in scenarios where the size of the
-- key set is not known. The dynamic resizing aspect allows for performance
......@@ -327,6 +327,9 @@ package GNAT.Dynamic_HTables is
(Left : Key_Type;
Right : Key_Type) return Boolean;
with procedure Destroy_Value (Val : in out Value_Type);
-- Value destructor
with function Hash (Key : Key_Type) return Bucket_Range_Type;
-- Map an arbitrary key into the range of buckets
......@@ -366,6 +369,9 @@ package GNAT.Dynamic_HTables is
function Is_Empty (T : Instance) return Boolean;
-- Determine whether hash table T is empty
function Present (T : Instance) return Boolean;
-- Determine whether hash table T exists
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type);
-- Associate value Value with key Key in hash table T. If the table
-- already contains a mapping of the same key to a previous value, the
......@@ -401,15 +407,15 @@ package GNAT.Dynamic_HTables is
type Iterator is private;
function Iterate (T : Instance) return Iterator;
-- Obtain an iterator over the keys of hash table T. This action locks
-- all mutation functionality of the associated hash table.
function Has_Next (Iter : Iterator) return Boolean;
-- Determine whether iterator Iter has more keys to examine. If the
-- iterator has been exhausted, restore all mutation functionality of
-- the associated hash table.
function Iterate (T : Instance) return Iterator;
-- Obtain an iterator over the keys of hash table T. This action locks
-- all mutation functionality of the associated hash table.
procedure Next (Iter : in out Iterator; Key : out Key_Type);
-- Return the current key referenced by iterator Iter and advance to
-- the next available key. If the iterator has been exhausted and
......@@ -475,11 +481,11 @@ package GNAT.Dynamic_HTables is
-- The following type represents a key iterator
type Iterator is record
Idx : Bucket_Range_Type := 0;
Curr_Idx : Bucket_Range_Type := 0;
-- Index of the current bucket being examined. This index is always
-- kept within the range of the buckets.
Nod : Node_Ptr := null;
Curr_Nod : Node_Ptr := null;
-- Reference to the current node being examined within the current
-- bucket. The invariant of the iterator requires that this field
-- always point to a valid node. A value of null indicates that the
......
gcc/ada/libgnat/g-lists.adb
......@@ -90,6 +90,10 @@ package body GNAT.Lists is
pragma Inline (Lock);
-- Lock all mutation functionality of list L
function Present (Nod : Node_Ptr) return Boolean;
pragma Inline (Present);
-- Determine whether node Nod exists
procedure Unlock (L : Instance);
pragma Inline (Unlock);
-- Unlock all mutation functionality of list L
......@@ -217,15 +221,15 @@ package body GNAT.Lists is
procedure Delete_Node (L : Instance; Nod : Node_Ptr) is
Ref : Node_Ptr := Nod;
pragma Assert (Ref /= null);
pragma Assert (Present (Ref));
Next : constant Node_Ptr := Ref.Next;
Prev : constant Node_Ptr := Ref.Prev;
begin
pragma Assert (L /= null);
pragma Assert (Next /= null);
pragma Assert (Prev /= null);
pragma Assert (Present (L));
pragma Assert (Present (Next));
pragma Assert (Present (Prev));
Prev.Next := Next; -- Prev ---> Next
Next.Prev := Prev; -- Prev <--> Next
......@@ -235,6 +239,10 @@ package body GNAT.Lists is
L.Elements := L.Elements - 1;
-- Invoke the element destructor before deallocating the node
Destroy_Element (Nod.Elem);
Free (Ref);
end Delete_Node;
......@@ -263,10 +271,10 @@ package body GNAT.Lists is
---------------------
procedure Ensure_Circular (Head : Node_Ptr) is
pragma Assert (Head /= null);
pragma Assert (Present (Head));
begin
if Head.Next = null and then Head.Prev = null then
if not Present (Head.Next) and then not Present (Head.Prev) then
Head.Next := Head;
Head.Prev := Head;
end if;
......@@ -278,7 +286,7 @@ package body GNAT.Lists is
procedure Ensure_Created (L : Instance) is
begin
if L = null then
if not Present (L) then
raise Not_Created;
end if;
end Ensure_Created;
......@@ -289,7 +297,7 @@ package body GNAT.Lists is
procedure Ensure_Full (L : Instance) is
begin
pragma Assert (L /= null);
pragma Assert (Present (L));
if L.Elements = 0 then
raise List_Empty;
......@@ -302,7 +310,7 @@ package body GNAT.Lists is
procedure Ensure_Unlocked (L : Instance) is
begin
pragma Assert (L /= null);
pragma Assert (Present (L));
-- The list has at least one outstanding iterator
......@@ -319,7 +327,7 @@ package body GNAT.Lists is
(Head : Node_Ptr;
Elem : Element_Type) return Node_Ptr
is
pragma Assert (Head /= null);
pragma Assert (Present (Head));
Nod : Node_Ptr;
......@@ -435,9 +443,9 @@ package body GNAT.Lists is
Left : Node_Ptr;
Right : Node_Ptr)
is
pragma Assert (L /= null);
pragma Assert (Left /= null);
pragma Assert (Right /= null);
pragma Assert (Present (L));
pragma Assert (Present (Left));
pragma Assert (Present (Right));
Nod : constant Node_Ptr :=
new Node'(Elem => Elem,
......@@ -471,7 +479,7 @@ package body GNAT.Lists is
-- The invariant of Iterate and Next ensures that the iterator always
-- refers to a valid node if there exists one.
return Is_Valid (Iter.Nod, Iter.List.Nodes'Access);
return Is_Valid (Iter.Curr_Nod, Iter.List.Nodes'Access);
end Is_Valid;
--------------
......@@ -483,7 +491,7 @@ package body GNAT.Lists is
-- A node is valid if it is non-null, and does not refer to the dummy
-- head of some list.
return Nod /= null and then Nod /= Head;
return Present (Nod) and then Nod /= Head;
end Is_Valid;
-------------
......@@ -499,7 +507,7 @@ package body GNAT.Lists is
Lock (L);
return (List => L, Nod => L.Nodes.Next);
return (List => L, Curr_Nod => L.Nodes.Next);
end Iterate;
----------
......@@ -520,7 +528,7 @@ package body GNAT.Lists is
procedure Lock (L : Instance) is
begin
pragma Assert (L /= null);
pragma Assert (Present (L));
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
......@@ -534,7 +542,7 @@ package body GNAT.Lists is
procedure Next (Iter : in out Iterator; Elem : out Element_Type) is
Is_OK : constant Boolean := Is_Valid (Iter);
Saved : constant Node_Ptr := Iter.Nod;
Saved : constant Node_Ptr := Iter.Curr_Nod;
begin
-- The iterator is no linger valid which indicates that it has been
......@@ -548,8 +556,9 @@ package body GNAT.Lists is
-- Advance to the next node along the list
Iter.Nod := Iter.Nod.Next;
Elem := Saved.Elem;
Iter.Curr_Nod := Iter.Curr_Nod.Next;
Elem := Saved.Elem;
end Next;
-------------
......@@ -580,6 +589,24 @@ package body GNAT.Lists is
end Prepend;
-------------
-- Present --
-------------
function Present (L : Instance) return Boolean is
begin
return L /= Nil;
end Present;
-------------
-- Present --
-------------
function Present (Nod : Node_Ptr) return Boolean is
begin
return Nod /= null;
end Present;
-------------
-- Replace --
-------------
......@@ -620,7 +647,7 @@ package body GNAT.Lists is
procedure Unlock (L : Instance) is
begin
pragma Assert (L /= null);
pragma Assert (Present (L));
-- The list may be locked multiple times if multiple iterators are
-- operating over it.
......
gcc/ada/libgnat/g-lists.ads
......@@ -40,8 +40,8 @@ package GNAT.Lists is
-- The following package offers a doubly linked list abstraction with the
-- following characteristics:
--
-- * Creation of multiple instances, of different sizes.
-- * Iterable elements.
-- * Creation of multiple instances, of different sizes
-- * Iterable elements
--
-- The following use pattern must be employed with this list:
--
......@@ -60,6 +60,9 @@ package GNAT.Lists is
(Left : Element_Type;
Right : Element_Type) return Boolean;
with procedure Destroy_Element (Elem : in out Element_Type);
-- Element destructor
package Doubly_Linked_List is
---------------------
......@@ -139,6 +142,9 @@ package GNAT.Lists is
-- Insert element Elem at the start of list L. This action will raise
-- Iterated if the list has outstanding iterators.
function Present (L : Instance) return Boolean;
-- Determine whether list L exists
procedure Replace
(L : Instance;
Old_Elem : Element_Type;
......@@ -168,15 +174,15 @@ package GNAT.Lists is
type Iterator is private;
function Iterate (L : Instance) return Iterator;
-- Obtain an iterator over the elements of list L. This action locks all
-- mutation functionality of the associated list.
function Has_Next (Iter : Iterator) return Boolean;
-- Determine whether iterator Iter has more elements to examine. If the
-- iterator has been exhausted, restore all mutation functionality of
-- the associated list.
function Iterate (L : Instance) return Iterator;
-- Obtain an iterator over the elements of list L. This action locks all
-- mutation functionality of the associated list.
procedure Next (Iter : in out Iterator; Elem : out Element_Type);
-- Return the current element referenced by iterator Iter and advance
-- to the next available element. If the iterator has been exhausted
......@@ -215,13 +221,13 @@ package GNAT.Lists is
-- The following type represents an element iterator
type Iterator is record
List : Instance := null;
-- Reference to the associated list
Nod : Node_Ptr := null;
Curr_Nod : Node_Ptr := null;
-- Reference to the current node being examined. The invariant of the
-- iterator requires that this field always points to a valid node. A
-- value of null indicates that the iterator is exhausted.
List : Instance := null;
-- Reference to the associated list
end record;
end Doubly_Linked_List;
......
gcc/ada/libgnat/g-sets.adb
......@@ -68,6 +68,16 @@ package body GNAT.Sets is
-- Destroy --
-------------
procedure Destroy (B : in out Boolean) is
pragma Unreferenced (B);
begin
null;
end Destroy;
-------------
-- Destroy --
-------------
procedure Destroy (S : in out Instance) is
begin
Hashed_Set.Destroy (Hashed_Set.Instance (S));
......@@ -118,6 +128,24 @@ package body GNAT.Sets is
Hashed_Set.Next (Hashed_Set.Iterator (Iter), Elem);
end Next;
-------------
-- Present --
-------------
function Present (S : Instance) return Boolean is
begin
return Hashed_Set.Present (Hashed_Set.Instance (S));
end Present;
-----------
-- Reset --
-----------
procedure Reset (S : Instance) is
begin
Hashed_Set.Reset (Hashed_Set.Instance (S));
end Reset;
----------
-- Size --
----------
......
gcc/ada/libgnat/g-sets.ads
......@@ -42,8 +42,8 @@ package GNAT.Sets is
-- The following package offers a membership set abstraction with the
-- following characteristics:
--
-- * Creation of multiple instances, of different sizes.
-- * Iterable elements.
-- * Creation of multiple instances, of different sizes
-- * Iterable elements
--
-- The following use pattern must be employed with this set:
--
......@@ -103,6 +103,14 @@ package GNAT.Sets is
function Is_Empty (S : Instance) return Boolean;
-- Determine whether set S is empty
function Present (S : Instance) return Boolean;
-- Determine whether set S exists
procedure Reset (S : Instance);
-- Destroy the contents of membership set S, and reset it to its initial
-- created state. This action will raise Iterated if the membership set
-- has outstanding iterators.
function Size (S : Instance) return Natural;
-- Obtain the number of elements in membership set S
......@@ -141,6 +149,9 @@ package GNAT.Sets is
-- raises Iterator_Exhausted.
private
procedure Destroy (B : in out Boolean);
-- Destroy boolean B
package Hashed_Set is new Dynamic_HTable
(Key_Type => Element_Type,
Value_Type => Boolean,
......@@ -150,6 +161,7 @@ package GNAT.Sets is
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
Destroy_Value => Destroy,
Hash => Hash);
type Instance is new Hashed_Set.Instance;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment