blob: 1a6188ac3b0d33b8ac4f9677c0bd60b636f5c208 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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-2021, 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;