From: Bob Duff <d...@adacore.com>
Walks all trees (not just the main unit), deals with switches and
flags. Doesn't check much of anything yet (asserts that "unused" nodes
are not present).
Move decisions (what tree(s) to check, what switches enable checking)
from the caller to the body of VAST.
gcc/ada/ChangeLog:
* vast.adb: Initial implementation.
* vast.ads: Rename procedure. Remove parameter; body should decide
what to do.
* lib.ads (ipu): Minor: Rewrite comment for brevity, and because
of an inconvenient misspelling.
(Num_Units): Not used; remove.
(Remove_Unit): Minor: Remove "Currently" (which was current a decade
ago from) comment.
* lib.adb (Num_Units): Not used; remove.
* debug_a.adb (Debug_A_Entry): Fix bug: Use Write_Name_For_Debug,
so this won't crash on the Error node.
* debug.adb: Document -gnatd_V and -gnatd_W compiler switches.
* exp_ch6.adb (Validate_Subprogram_Calls): Remove redundant check for
Serious_Errors_Detected. (We turn off code gen when errors are
detected.)
* frontend.adb: Move decisions into VAST body.
* namet.ads (Present): Remove unnecessary overriding; these are
inherited by the derived types.
* namet.adb (Present): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/debug.adb | 11 ++--
gcc/ada/debug_a.adb | 7 +--
gcc/ada/exp_ch6.adb | 10 ++--
gcc/ada/frontend.adb | 4 +-
gcc/ada/lib.adb | 9 ----
gcc/ada/lib.ads | 13 ++---
gcc/ada/namet.adb | 18 -------
gcc/ada/namet.ads | 8 ---
gcc/ada/vast.adb | 123 +++++++++++++++++++++++++++++++++++++++++--
gcc/ada/vast.ads | 7 +--
10 files changed, 139 insertions(+), 71 deletions(-)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 3a39ec89c40..f250d7429a9 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -186,8 +186,8 @@ package body Debug is
-- 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
@@ -1065,8 +1065,11 @@ package body Debug is
-- 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
diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb
index d36ae696af6..8d68fc8eff7 100644
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -83,11 +83,8 @@ package body Debug_A is
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;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 3a45b1c5934..2a246adbb8a 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9938,15 +9938,15 @@ package body Exp_Ch6 is
-- 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;
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 12cea9c794a..d5376788ce4 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -506,9 +506,7 @@ begin
-- 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
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 2c6a6823eba..a727f48c611 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -1129,15 +1129,6 @@ package body Lib is
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 --
-----------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index c22db30219e..a085aa7f19f 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -633,10 +633,8 @@ package Lib is
-- 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
@@ -720,12 +718,9 @@ package Lib is
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;
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index e27669ef68d..b7d3abd899e 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -1297,29 +1297,11 @@ package body Namet is
-- 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 --
------------------
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index 7182fb87e7e..b05e4b506e6 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -504,10 +504,6 @@ package Namet is
-- 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.
@@ -532,10 +528,6 @@ package Namet is
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.
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb
index 302a89bd4a0..7446ea18063 100644
--- a/gcc/ada/vast.adb
+++ b/gcc/ada/vast.adb
@@ -23,18 +23,131 @@
-- --
------------------------------------------------------------------------------
--- 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;
diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads
index 031ea2119d4..faecd9a33f3 100644
--- a/gcc/ada/vast.ads
+++ b/gcc/ada/vast.ads
@@ -24,13 +24,10 @@
------------------------------------------------------------------------------
-- 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;
--
2.43.0
