8sa1-gcc/gcc/ada/bindo-validators.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                      B I N D O . V A L I D A T O R S                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2019-2020, 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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Debug;  use Debug;
with Output; use Output;
with Types;  use Types;

with Bindo.Units;
use  Bindo.Units;

with Bindo.Writers;
use  Bindo.Writers;
use  Bindo.Writers.Phase_Writers;

package body Bindo.Validators is

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

   procedure Write_Error
     (Msg  : String;
      Flag : out Boolean);
   pragma Inline (Write_Error);
   --  Write error message Msg to standard output and set flag Flag to True

   ----------------------
   -- Cycle_Validators --
   ----------------------

   package body Cycle_Validators is
      Has_Invalid_Cycle : Boolean := False;
      --  Flag set when the library graph contains an invalid cycle

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

      procedure Validate_Cycle
        (G     : Library_Graph;
         Cycle : Library_Graph_Cycle_Id);
      pragma Inline (Validate_Cycle);
      --  Ensure that a cycle meets the following requirements:
      --
      --    * Is of proper kind
      --    * Has enough edges to form a circuit
      --    * No edge is repeated

      procedure Validate_Cycle_Path
        (G     : Library_Graph;
         Cycle : Library_Graph_Cycle_Id);
      pragma Inline (Validate_Cycle_Path);
      --  Ensure that the path of a cycle meets the following requirements:
      --
      --    * No edge is repeated

      --------------------
      -- Validate_Cycle --
      --------------------

      procedure Validate_Cycle
        (G     : Library_Graph;
         Cycle : Library_Graph_Cycle_Id)
      is
         Msg : constant String := "Validate_Cycle";

      begin
         pragma Assert (Present (G));

         if not Present (Cycle) then
            Write_Error (Msg, Has_Invalid_Cycle);

            Write_Str ("  empty cycle");
            Write_Eol;
            Write_Eol;
            return;
         end if;

         if Kind (G, Cycle) = No_Cycle_Kind then
            Write_Error (Msg, Has_Invalid_Cycle);

            Write_Str ("  cycle (LGC_Id_");
            Write_Int (Int (Cycle));
            Write_Str (") is a No_Cycle");
            Write_Eol;
            Write_Eol;
         end if;

         --  A cycle requires at least one edge (self cycle) to form a circuit

         if Length (G, Cycle) < 1 then
            Write_Error (Msg, Has_Invalid_Cycle);

            Write_Str ("  cycle (LGC_Id_");
            Write_Int (Int (Cycle));
            Write_Str (") does not contain enough edges");
            Write_Eol;
            Write_Eol;
         end if;

         Validate_Cycle_Path (G, Cycle);
      end Validate_Cycle;

      -------------------------
      -- Validate_Cycle_Path --
      -------------------------

      procedure Validate_Cycle_Path
        (G     : Library_Graph;
         Cycle : Library_Graph_Cycle_Id)
      is
         Msg : constant String := "Validate_Cycle_Path";

         Edge  : Library_Graph_Edge_Id;
         Edges : LGE_Sets.Membership_Set;
         Iter  : Edges_Of_Cycle_Iterator;

      begin
         pragma Assert (Present (G));
         pragma Assert (Present (Cycle));

         --  Use a set to detect duplicate edges while traversing the cycle

         Edges := LGE_Sets.Create (Length (G, Cycle));

         --  Inspect the edges of the cycle, trying to catch duplicates

         Iter := Iterate_Edges_Of_Cycle (G, Cycle);
         while Has_Next (Iter) loop
            Next (Iter, Edge);

            --  The current edge has already been encountered while traversing
            --  the cycle. This indicates that the cycle is malformed as edges
            --  are not repeated in the circuit.

            if LGE_Sets.Contains (Edges, Edge) then
               Write_Error (Msg, Has_Invalid_Cycle);

               Write_Str ("  library graph edge (LGE_Id_");
               Write_Int (Int (Edge));
               Write_Str (") is repeated in cycle (LGC_Id_");
               Write_Int (Int (Cycle));
               Write_Str (")");
               Write_Eol;

            --  Otherwise add the current edge to the set of encountered edges

            else
               LGE_Sets.Insert (Edges, Edge);
            end if;
         end loop;

         LGE_Sets.Destroy (Edges);
      end Validate_Cycle_Path;

      ---------------------
      -- Validate_Cycles --
      ---------------------

      procedure Validate_Cycles (G : Library_Graph) is
         Cycle : Library_Graph_Cycle_Id;
         Iter  : All_Cycle_Iterator;

      begin
         pragma Assert (Present (G));

         --  Nothing to do when switch -d_V (validate bindo cycles, graphs, and
         --  order) is not in effect.

         if not Debug_Flag_Underscore_VV then
            return;
         end if;

         Start_Phase (Cycle_Validation);

         Iter := Iterate_All_Cycles (G);
         while Has_Next (Iter) loop
            Next (Iter, Cycle);

            Validate_Cycle (G, Cycle);
         end loop;

         End_Phase (Cycle_Validation);

         if Has_Invalid_Cycle then
            raise Invalid_Cycle;
         end if;
      end Validate_Cycles;
   end Cycle_Validators;

   ----------------------------------
   -- Elaboration_Order_Validators --
   ----------------------------------

   package body Elaboration_Order_Validators is
      Has_Invalid_Data : Boolean := False;
      --  Flag set when the elaboration order contains invalid data

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

      function Build_Elaborable_Unit_Set return Unit_Sets.Membership_Set;
      pragma Inline (Build_Elaborable_Unit_Set);
      --  Create a set from all units that need to be elaborated

      procedure Report_Missing_Elaboration (U_Id : Unit_Id);
      pragma Inline (Report_Missing_Elaboration);
      --  Emit an error concerning unit U_Id that must be elaborated, but was
      --  not.

      procedure Report_Missing_Elaborations (Set : Unit_Sets.Membership_Set);
      pragma Inline (Report_Missing_Elaborations);
      --  Emit errors on all units in set Set that must be elaborated, but were
      --  not.

      procedure Report_Spurious_Elaboration (U_Id : Unit_Id);
      pragma Inline (Report_Spurious_Elaboration);
      --  Emit an error concerning unit U_Id that is incorrectly elaborated

      procedure Validate_Unit
        (U_Id     : Unit_Id;
         Elab_Set : Unit_Sets.Membership_Set);
      pragma Inline (Validate_Unit);
      --  Validate the elaboration status of unit U_Id. Elab_Set is the set of
      --  all units that need to be elaborated.

      procedure Validate_Units (Order : Unit_Id_Table);
      pragma Inline (Validate_Units);
      --  Validate all units in elaboration order Order

      -------------------------------
      -- Build_Elaborable_Unit_Set --
      -------------------------------

      function Build_Elaborable_Unit_Set return Unit_Sets.Membership_Set is
         Iter : Elaborable_Units_Iterator;
         Set  : Unit_Sets.Membership_Set;
         U_Id : Unit_Id;

      begin
         Set  := Unit_Sets.Create (Number_Of_Elaborable_Units);
         Iter := Iterate_Elaborable_Units;
         while Has_Next (Iter) loop
            Next (Iter, U_Id);

            Unit_Sets.Insert (Set, U_Id);
         end loop;

         return Set;
      end Build_Elaborable_Unit_Set;

      --------------------------------
      -- Report_Missing_Elaboration --
      --------------------------------

      procedure Report_Missing_Elaboration (U_Id : Unit_Id) is
         Msg : constant String := "Report_Missing_Elaboration";

      begin
         pragma Assert (Present (U_Id));
         Write_Error (Msg, Has_Invalid_Data);

         Write_Str  ("unit (U_Id_");
         Write_Int  (Int (U_Id));
         Write_Str  (") name = ");
         Write_Name (Name (U_Id));
         Write_Str  (" must be elaborated");
         Write_Eol;
      end Report_Missing_Elaboration;

      ---------------------------------
      -- Report_Missing_Elaborations --
      ---------------------------------

      procedure Report_Missing_Elaborations (Set : Unit_Sets.Membership_Set) is
         Iter : Unit_Sets.Iterator;
         U_Id : Unit_Id;

      begin
         Iter := Unit_Sets.Iterate (Set);
         while Unit_Sets.Has_Next (Iter) loop
            Unit_Sets.Next (Iter, U_Id);

            Report_Missing_Elaboration (U_Id);
         end loop;
      end Report_Missing_Elaborations;

      ---------------------------------
      -- Report_Spurious_Elaboration --
      ---------------------------------

      procedure Report_Spurious_Elaboration (U_Id : Unit_Id) is
         Msg : constant String := "Report_Spurious_Elaboration";

      begin
         pragma Assert (Present (U_Id));
         Write_Error (Msg, Has_Invalid_Data);

         Write_Str  ("unit (U_Id_");
         Write_Int  (Int (U_Id));
         Write_Str  (") name = ");
         Write_Name (Name (U_Id));
         Write_Str  (" must not be elaborated");
      end Report_Spurious_Elaboration;

      --------------------------------
      -- Validate_Elaboration_Order --
      --------------------------------

      procedure Validate_Elaboration_Order (Order : Unit_Id_Table) is
      begin
         --  Nothing to do when switch -d_V (validate bindo cycles, graphs, and
         --  order) is not in effect.

         if not Debug_Flag_Underscore_VV then
            return;
         end if;

         Start_Phase (Elaboration_Order_Validation);

         Validate_Units (Order);

         End_Phase (Elaboration_Order_Validation);

         if Has_Invalid_Data then
            raise Invalid_Elaboration_Order;
         end if;
      end Validate_Elaboration_Order;

      -------------------
      -- Validate_Unit --
      -------------------

      procedure Validate_Unit
        (U_Id     : Unit_Id;
         Elab_Set : Unit_Sets.Membership_Set)
      is
      begin
         pragma Assert (Present (U_Id));

         --  The current unit in the elaboration order appears within the set
         --  of units that require elaboration. Remove it from the set.

         if Unit_Sets.Contains (Elab_Set, U_Id) then
            Unit_Sets.Delete (Elab_Set, U_Id);

         --  Otherwise the current unit in the elaboration order must not be
         --  elaborated.

         else
            Report_Spurious_Elaboration (U_Id);
         end if;
      end Validate_Unit;

      --------------------
      -- Validate_Units --
      --------------------

      procedure Validate_Units (Order : Unit_Id_Table) is
         Elab_Set : Unit_Sets.Membership_Set;

      begin
         --  Collect all units in the compilation that need to be elaborated
         --  in a set.

         Elab_Set := Build_Elaborable_Unit_Set;

         --  Validate each unit in the elaboration order against the set of
         --  units that need to be elaborated.

         for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop
            Validate_Unit
              (U_Id     => Order.Table (Index),
               Elab_Set => Elab_Set);
         end loop;

         --  At this point all units that need to be elaborated should have
         --  been eliminated from the set. Report any units that are missing
         --  their elaboration.

         Report_Missing_Elaborations (Elab_Set);
         Unit_Sets.Destroy (Elab_Set);
      end Validate_Units;
   end Elaboration_Order_Validators;

   ---------------------------------
   -- Invocation_Graph_Validators --
   ---------------------------------

   package body Invocation_Graph_Validators is
      Has_Invalid_Data : Boolean := False;
      --  Flag set when the invocation graph contains invalid data

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

      procedure Validate_Invocation_Graph_Edge
        (G    : Invocation_Graph;
         Edge : Invocation_Graph_Edge_Id);
      pragma Inline (Validate_Invocation_Graph_Edge);
      --  Verify that the attributes of edge Edge of invocation graph G are
      --  properly set.

      procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph);
      pragma Inline (Validate_Invocation_Graph_Edges);
      --  Verify that the attributes of all edges of invocation graph G are
      --  properly set.

      procedure Validate_Invocation_Graph_Vertex
        (G      : Invocation_Graph;
         Vertex : Invocation_Graph_Vertex_Id);
      pragma Inline (Validate_Invocation_Graph_Vertex);
      --  Verify that the attributes of vertex Vertex of invocation graph G are
      --  properly set.

      procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph);
      pragma Inline (Validate_Invocation_Graph_Vertices);
      --  Verify that the attributes of all vertices of invocation graph G are
      --  properly set.

      -------------------------------
      -- Validate_Invocation_Graph --
      -------------------------------

      procedure Validate_Invocation_Graph (G : Invocation_Graph) is
      begin
         pragma Assert (Present (G));

         --  Nothing to do when switch -d_V (validate bindo cycles, graphs, and
         --  order) is not in effect.

         if not Debug_Flag_Underscore_VV then
            return;
         end if;

         Start_Phase (Invocation_Graph_Validation);

         Validate_Invocation_Graph_Vertices (G);
         Validate_Invocation_Graph_Edges    (G);

         End_Phase (Invocation_Graph_Validation);

         if Has_Invalid_Data then
            raise Invalid_Invocation_Graph;
         end if;
      end Validate_Invocation_Graph;

      ------------------------------------
      -- Validate_Invocation_Graph_Edge --
      ------------------------------------

      procedure Validate_Invocation_Graph_Edge
        (G    : Invocation_Graph;
         Edge : Invocation_Graph_Edge_Id)
      is
         Msg : constant String := "Validate_Invocation_Graph_Edge";

      begin
         pragma Assert (Present (G));

         if not Present (Edge) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  empty invocation graph edge");
            Write_Eol;
            Write_Eol;
            return;
         end if;

         if not Present (Relation (G, Edge)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  invocation graph edge (IGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") lacks Relation");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Target (G, Edge)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  invocation graph edge (IGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") lacks Target");
            Write_Eol;
            Write_Eol;
         end if;
      end Validate_Invocation_Graph_Edge;

      -------------------------------------
      -- Validate_Invocation_Graph_Edges --
      -------------------------------------

      procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph) is
         Edge : Invocation_Graph_Edge_Id;
         Iter : Invocation_Graphs.All_Edge_Iterator;

      begin
         pragma Assert (Present (G));

         Iter := Iterate_All_Edges (G);
         while Has_Next (Iter) loop
            Next (Iter, Edge);

            Validate_Invocation_Graph_Edge (G, Edge);
         end loop;
      end Validate_Invocation_Graph_Edges;

      --------------------------------------
      -- Validate_Invocation_Graph_Vertex --
      --------------------------------------

      procedure Validate_Invocation_Graph_Vertex
        (G      : Invocation_Graph;
         Vertex : Invocation_Graph_Vertex_Id)
      is
         Msg : constant String := "Validate_Invocation_Graph_Vertex";

      begin
         pragma Assert (Present (G));

         if not Present (Vertex) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  empty invocation graph vertex");
            Write_Eol;
            Write_Eol;
            return;
         end if;

         if not Present (Body_Vertex (G, Vertex)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  invocation graph vertex (IGV_Id_");
            Write_Int (Int (Vertex));
            Write_Str (") lacks Body_Vertex");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Construct (G, Vertex)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  invocation graph vertex (IGV_Id_");
            Write_Int (Int (Vertex));
            Write_Str (") lacks Construct");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Spec_Vertex (G, Vertex)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  invocation graph vertex (IGV_Id_");
            Write_Int (Int (Vertex));
            Write_Str (") lacks Spec_Vertex");
            Write_Eol;
            Write_Eol;
         end if;
      end Validate_Invocation_Graph_Vertex;

      ----------------------------------------
      -- Validate_Invocation_Graph_Vertices --
      ----------------------------------------

      procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph) is
         Iter   : Invocation_Graphs.All_Vertex_Iterator;
         Vertex : Invocation_Graph_Vertex_Id;

      begin
         pragma Assert (Present (G));

         Iter := Iterate_All_Vertices (G);
         while Has_Next (Iter) loop
            Next (Iter, Vertex);

            Validate_Invocation_Graph_Vertex (G, Vertex);
         end loop;
      end Validate_Invocation_Graph_Vertices;
   end Invocation_Graph_Validators;

   ------------------------------
   -- Library_Graph_Validators --
   ------------------------------

   package body Library_Graph_Validators is
      Has_Invalid_Data : Boolean := False;
      --  Flag set when the library graph contains invalid data

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

      procedure Validate_Library_Graph_Edge
        (G    : Library_Graph;
         Edge : Library_Graph_Edge_Id);
      pragma Inline (Validate_Library_Graph_Edge);
      --  Verify that the attributes of edge Edge of library graph G are
      --  properly set.

      procedure Validate_Library_Graph_Edges (G : Library_Graph);
      pragma Inline (Validate_Library_Graph_Edges);
      --  Verify that the attributes of all edges of library graph G are
      --  properly set.

      procedure Validate_Library_Graph_Vertex
        (G      : Library_Graph;
         Vertex : Library_Graph_Vertex_Id);
      pragma Inline (Validate_Library_Graph_Vertex);
      --  Verify that the attributes of vertex Vertex of library graph G are
      --  properly set.

      procedure Validate_Library_Graph_Vertices (G : Library_Graph);
      pragma Inline (Validate_Library_Graph_Vertices);
      --  Verify that the attributes of all vertices of library graph G are
      --  properly set.

      ----------------------------
      -- Validate_Library_Graph --
      ----------------------------

      procedure Validate_Library_Graph (G : Library_Graph) is
      begin
         pragma Assert (Present (G));

         --  Nothing to do when switch -d_V (validate bindo cycles, graphs, and
         --  order) is not in effect.

         if not Debug_Flag_Underscore_VV then
            return;
         end if;

         Start_Phase (Library_Graph_Validation);

         Validate_Library_Graph_Vertices (G);
         Validate_Library_Graph_Edges    (G);

         End_Phase (Library_Graph_Validation);

         if Has_Invalid_Data then
            raise Invalid_Library_Graph;
         end if;
      end Validate_Library_Graph;

      ---------------------------------
      -- Validate_Library_Graph_Edge --
      ---------------------------------

      procedure Validate_Library_Graph_Edge
        (G    : Library_Graph;
         Edge : Library_Graph_Edge_Id)
      is
         Msg : constant String := "Validate_Library_Graph_Edge";

      begin
         pragma Assert (Present (G));

         if not Present (Edge) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  empty library graph edge");
            Write_Eol;
            Write_Eol;
            return;
         end if;

         if Kind (G, Edge) = No_Edge then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph edge (LGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") is not a valid edge");
            Write_Eol;
            Write_Eol;

         elsif Kind (G, Edge) = Body_Before_Spec_Edge then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph edge (LGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") is a Body_Before_Spec edge");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Predecessor (G, Edge)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph edge (LGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") lacks Predecessor");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Successor (G, Edge)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph edge (LGE_Id_");
            Write_Int (Int (Edge));
            Write_Str (") lacks Successor");
            Write_Eol;
            Write_Eol;
         end if;
      end Validate_Library_Graph_Edge;

      ----------------------------------
      -- Validate_Library_Graph_Edges --
      ----------------------------------

      procedure Validate_Library_Graph_Edges (G : Library_Graph) is
         Edge : Library_Graph_Edge_Id;
         Iter : Library_Graphs.All_Edge_Iterator;

      begin
         pragma Assert (Present (G));

         Iter := Iterate_All_Edges (G);
         while Has_Next (Iter) loop
            Next (Iter, Edge);

            Validate_Library_Graph_Edge (G, Edge);
         end loop;
      end Validate_Library_Graph_Edges;

      -----------------------------------
      -- Validate_Library_Graph_Vertex --
      -----------------------------------

      procedure Validate_Library_Graph_Vertex
        (G      : Library_Graph;
         Vertex : Library_Graph_Vertex_Id)
      is
         Msg : constant String := "Validate_Library_Graph_Vertex";

      begin
         pragma Assert (Present (G));

         if not Present (Vertex) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  empty library graph vertex");
            Write_Eol;
            Write_Eol;
            return;
         end if;

         if (Is_Body_With_Spec (G, Vertex)
               or else
             Is_Spec_With_Body (G, Vertex))
           and then not Present (Corresponding_Item (G, Vertex))
         then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph vertex (LGV_Id_");
            Write_Int (Int (Vertex));
            Write_Str (") lacks Corresponding_Item");
            Write_Eol;
            Write_Eol;
         end if;

         if not Present (Unit (G, Vertex)) then
            Write_Error (Msg, Has_Invalid_Data);

            Write_Str ("  library graph vertex (LGV_Id_");
            Write_Int (Int (Vertex));
            Write_Str (") lacks Unit");
            Write_Eol;
            Write_Eol;
         end if;
      end Validate_Library_Graph_Vertex;

      -------------------------------------
      -- Validate_Library_Graph_Vertices --
      -------------------------------------

      procedure Validate_Library_Graph_Vertices (G : Library_Graph) is
         Iter   : Library_Graphs.All_Vertex_Iterator;
         Vertex : Library_Graph_Vertex_Id;

      begin
         pragma Assert (Present (G));

         Iter := Iterate_All_Vertices (G);
         while Has_Next (Iter) loop
            Next (Iter, Vertex);

            Validate_Library_Graph_Vertex (G, Vertex);
         end loop;
      end Validate_Library_Graph_Vertices;
   end Library_Graph_Validators;

   -----------------
   -- Write_Error --
   -----------------

   procedure Write_Error
     (Msg  : String;
      Flag : out Boolean)
   is
   begin
      Write_Str ("ERROR: ");
      Write_Str (Msg);
      Write_Eol;

      Flag := True;
   end Write_Error;

end Bindo.Validators;