-- d_S
-- d_T Output trace information on invocation path recording
-- d_U Disable prepending messages with "error:".
- -- d_V Enable verifications on the expanded tree
- -- d_W
+ -- d_V Enable VAST (verifications on the expanded tree)
+ -- d_W Enable VAST in verbose mode
-- d_X Disable assertions to check matching of extra formals
-- d_Y
-- d_Z
-- d_U Disable prepending 'error:' to error messages. This used to be the
-- default and can be seen as the opposite of -gnatU.
- -- d_V Enable verification of the expanded code before calling the backend
- -- and generate error messages on each inconsistency found.
+ -- d_V Enable VAST (Verifier for the Ada Semantic Tree). This does
+ -- verification of the expanded code before calling the backend.
+
+ -- d_W Same as d_V, but also prints lots of tracing/debugging output
+ -- as it walks the tree.
-- d_X Disable assertions to check matching of extra formals; switch added
-- temporarily to disable these checks until this work is complete if
case Nkind (N) is
when N_Has_Chars =>
- Write_Str (" """);
- if Present (Chars (N)) then
- Write_Str (Get_Name_String (Chars (N)));
- end if;
- Write_Str ("""");
+ Write_Str (" ");
+ Write_Name_For_Debug (Chars (N));
when others => null;
end case;
-- Start of processing for Validate_Subprogram_Calls
begin
- -- No action required if we are not generating code or compiling sources
- -- that have errors.
+ -- No action if we are not generating code (including if we have
+ -- errors).
- if Serious_Errors_Detected > 0
- or else Operating_Mode /= Generate_Code
- then
+ if Operating_Mode /= Generate_Code then
return;
end if;
+ pragma Assert (Serious_Errors_Detected = 0);
+
Check_Calls (N);
end Validate_Subprogram_Calls;
-- Verify the validity of the tree
- if Debug_Flag_Underscore_VV then
- VAST.Check_Tree (Cunit (Main_Unit));
- end if;
+ VAST.VAST;
-- Validate all the subprogram calls; this work will be done by VAST; in
-- the meantime it is done to check extra formals and it can be disabled
Units.Locked := True;
end Lock;
- ---------------
- -- Num_Units --
- ---------------
-
- function Num_Units return Nat is
- begin
- return Int (Units.Last) - Int (Main_Unit) + 1;
- end Num_Units;
-
-----------------
-- Remove_Unit --
-----------------
-- Same as above, but for Source_Ptr
function ipu (N : Node_Or_Entity_Id) return Boolean;
- -- Same as In_Predefined_Unit, but renamed so it can assist debugging.
- -- Otherwise, there is a disambiguous name conflict in the two versions of
- -- In_Predefined_Unit which makes it inconvient to set as a breakpoint
- -- condition.
+ -- Same as In_Predefined_Unit, but renamed to this unambiguous name for use
+ -- in the debugger.
function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean;
-- Returns True if the given node or entity appears within the source text
procedure Lock;
-- Lock internal tables before calling back end
- function Num_Units return Nat;
- -- Number of units currently in unit table
-
procedure Remove_Unit (U : Unit_Number_Type);
- -- Remove unit U from unit table. Currently this is effective only if U is
- -- the last unit currently stored in the unit table.
+ -- Remove unit U from unit table. U must be the last unit currently stored
+ -- in the unit table.
procedure Replace_Linker_Option_String
(S : String_Id;
-- Present --
-------------
- function Present (Nam : File_Name_Type) return Boolean is
- begin
- return Nam /= No_File;
- end Present;
-
- -------------
- -- Present --
- -------------
-
function Present (Nam : Name_Id) return Boolean is
begin
return Nam /= No_Name;
end Present;
- -------------
- -- Present --
- -------------
-
- function Present (Nam : Unit_Name_Type) return Boolean is
- begin
- return Nam /= No_Unit_Name;
- end Present;
-
------------------
-- Reinitialize --
------------------
-- Constant used to indicate no file is present (this is used for example
-- when a search for a file indicates that no file of the name exists).
- function Present (Nam : File_Name_Type) return Boolean;
- pragma Inline (Present);
- -- Determine whether file name Nam exists
-
Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name);
-- The special File_Name_Type value Error_File_Name is used to indicate
-- a unit name where some previous processing has found an error.
No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name);
-- Constant used to indicate no file name present
- function Present (Nam : Unit_Name_Type) return Boolean;
- pragma Inline (Present);
- -- Determine whether unit name Nam exists
-
Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name);
-- The special Unit_Name_Type value Error_Unit_Name is used to indicate
-- a unit name where some previous processing has found an error.
-- --
------------------------------------------------------------------------------
--- Dummy implementation
+with Atree; use Atree;
+with Debug;
+with Debug_A; use Debug_A;
+with Lib; use Lib;
+with Namet; use Namet;
+with Output; use Output;
+with Opt; use Opt;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Einfo.Entities; use Einfo.Entities;
+with Types; use Types;
package body VAST is
+ Force_Enable_VAST : constant Boolean := False;
+ -- Normally, VAST is enabled by the the -gnatd_V switch.
+ -- To force it to be enabled independent of any switches,
+ -- change the above to True.
+
+ function Do_Node (N : Node_Id) return Traverse_Result;
+ procedure Traverse is new Traverse_Proc (Do_Node);
+ -- Do VAST checking on a tree of nodes
+
+ procedure Do_Unit (U : Unit_Number_Type);
+ -- Call Do_Node on the root node of a compilation unit
+
+ ------------------
+ -- Do_Node --
+ ------------------
+
+ function Do_Node (N : Node_Id) return Traverse_Result is
+ begin
+ Debug_A_Entry ("do ", N);
+
+ case Nkind (N) is
+ when N_Unused_At_Start | N_Unused_At_End =>
+ pragma Assert (False);
+
+ when N_Entity =>
+ case Ekind (N) is
+ when others =>
+ null; -- more to be done here
+ end case;
+
+ when others =>
+ null; -- more to be done here
+ end case;
+
+ Debug_A_Exit ("do ", N, " (done)");
+ return OK;
+ end Do_Node;
+
+ ------------------
+ -- Do_Unit --
+ ------------------
+
+ procedure Do_Unit (U : Unit_Number_Type) is
+ Root : constant Node_Id := Cunit (U);
+ U_Name : constant Unit_Name_Type := Unit_Name (U);
+ U_Name_S : constant String :=
+ (if U_Name = No_Unit_Name then "<No_Unit_Name>"
+ else Get_Name_String (U_Name));
+ Predef : constant String :=
+ (if Is_Predefined_Unit (U) then " (predef)"
+ elsif Is_Internal_Unit (U) then " (gnat)"
+ else "");
+ Msg : constant String :=
+ "VAST for unit" & U'Img & " " & U_Name_S & Predef;
+
+ Is_Preprocessing_Dependency : constant Boolean :=
+ U_Name = No_Unit_Name;
+ -- True if this is a bogus unit added by Add_Preprocessing_Dependency.
+ -- ???Not sure what that's about.
+ pragma Assert (No (Root) = Is_Preprocessing_Dependency);
+ -- There should be no Cunit (only) for these bogus units.
+ begin
+ Write_Line (Msg);
+
+ if Is_Preprocessing_Dependency then
+ Write_Line ("Skipping preprocessing dependency");
+ return;
+ end if;
+
+ pragma Assert (Present (Root));
+ Traverse (Root);
+ Write_Line (Msg & " (done)");
+ end Do_Unit;
+
----------------
-- Check_Tree --
----------------
- procedure Check_Tree (GNAT_Root : Node_Id) is
- pragma Unreferenced (GNAT_Root);
+ procedure VAST is
+ use Debug;
begin
- null;
- end Check_Tree;
+ if Operating_Mode /= Generate_Code then
+ return;
+ end if;
+
+ -- If -gnatd_W (VAST in verbose mode) is enabled, then that should imply
+ -- -gnatd_V (enable VAST). In addition, we use the Debug_A routines to
+ -- print debugging information, so enable -gnatda.
+
+ if Debug_Flag_Underscore_WW then
+ Debug_Flag_Underscore_VV := True;
+ Debug_Flag_A := True;
+ end if;
+
+ if not Debug_Flag_Underscore_VV and then not Force_Enable_VAST then
+ return;
+ end if;
+
+ if not Debug_Flag_Underscore_WW then
+ Set_Special_Output (Ignore_Output'Access);
+ end if;
+ Write_Line ("VAST");
+
+ pragma Assert (Serious_Errors_Detected = 0);
+
+ Write_Line ("VAST checking" & Last_Unit'Img & " units");
+ for U in Main_Unit .. Last_Unit loop
+ Do_Unit (U);
+ end loop;
+
+ Write_Line ("VAST done.");
+ Cancel_Special_Output;
+ end VAST;
end VAST;
------------------------------------------------------------------------------
-- This package is the entry point for VAST: Verifier for the Ada Semantic
--- Tree.
-
-with Types; use Types;
+-- Tree. It walks the expanded trees, and verifies their validity.
package VAST is
- procedure Check_Tree (GNAT_Root : Node_Id);
- -- Check the validity of the given Root tree
+ procedure VAST;
end VAST;
projects / thirdparty / gcc.git / commitdiff
