https://gcc.gnu.org/g:a139b405338ca2f3d2d4bb3d4db0135d99cae4ae
commit r16-1379-ga139b405338ca2f3d2d4bb3d4db0135d99cae4ae
Author: Bob Duff <d...@adacore.com>
Date: Tue Mar 25 15:42:08 2025 -0400
ada: VAST: treewalker improvements
Implement two basic checks: Check that N_Error nodes cannot appear in the
tree (because VAST is not called when the source is illegal).
Check that every node has a parent, except for certain nodes where
we check the opposite. (We do not yet check that the parent pointers
actually point to the right node.)
Minor improvements. Flags for controlling debugging outputs and the like.
Capability to enable/disable individual checks. The intent is to
implement that only when needed -- i.e. when VAST finds a bug, and we
have not yet fixed the bug.
gcc/ada/ChangeLog:
* vast.adb: Implement two checks. Improve debugging
outputs.
Diff:
---
gcc/ada/vast.adb | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++-----
1 file changed, 124 insertions(+), 12 deletions(-)
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb
index 7446ea180637..a48707b2ce5c 100644
--- a/gcc/ada/vast.adb
+++ b/gcc/ada/vast.adb
@@ -23,6 +23,12 @@
-- --
------------------------------------------------------------------------------
+pragma Unsuppress (All_Checks);
+pragma Assertion_Policy (Check);
+-- Enable checking. This isn't really necessary, but it might come in handy if
+-- we want to run VAST with a compiler built without checks. Anyway, it's
+-- harmless, because VAST is not run by default.
+
with Atree; use Atree;
with Debug;
with Debug_A; use Debug_A;
@@ -40,6 +46,35 @@ package body VAST is
-- 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.
+ Print_Disabled_Failing_Checks : constant Boolean := True;
+ -- False means disabled checks are silent; True means we print a message
+ -- (but still don't raise VAST_Failure).
+
+ type Check_Enum is (Check_Other, Check_Itype_Parents, Check_Error_Nodes);
+ Enabled_Checks : constant array (Check_Enum) of Boolean :=
+-- (Check_Other => True, others => False);
+ (others => True);
+-- (Check_Itype_Parents => False, -- this one fails in bootstrap!
+-- others => True);
+ -- Passing checks are Check_Other, which should always be enabled.
+ -- Currently-failing checks are different enumerals in Check_Enum,
+ -- which can be disabled individually until we fix the bugs, or enabled
+ -- when debugging particular bugs. Pass a nondefault Check_Enum to
+ -- Assert in order to deal with bugs we have not yet fixed,
+ -- and play around with the value of Enabled_Checks above
+ -- for testing and debugging.
+ --
+ -- Note: Once a bug is fixed, and the check passes reliably, we may choose
+ -- to remove that check from Check_Enum and use Check_Other instead.
+
+ procedure Assert
+ (Condition : Boolean;
+ Check : Check_Enum := Check_Other;
+ Detail : String := "");
+ -- Check that the Condition is True, and raise an exception otherwise.
+ -- Check enables/disables the checking, according to Enabled_Checks above,
+ -- and is printed on failure. Detail is an additional error message,
+ -- also printed on failure.
function Do_Node (N : Node_Id) return Traverse_Result;
procedure Traverse is new Traverse_Proc (Do_Node);
@@ -48,9 +83,46 @@ package body VAST is
procedure Do_Unit (U : Unit_Number_Type);
-- Call Do_Node on the root node of a compilation unit
- ------------------
+ ------------
+ -- Assert --
+ ------------
+
+ VAST_Failure : exception;
+
+ procedure Assert
+ (Condition : Boolean;
+ Check : Check_Enum := Check_Other;
+ Detail : String := "")
+ is
+ begin
+ if not Condition then
+ declare
+ Part1 : constant String := "VAST fail";
+ Part2 : constant String :=
+ (if Check = Check_Other then "" else ": " & Check'Img);
+ Part3 : constant String :=
+ (if Detail = "" then "" else " -- " & Detail);
+ Message : constant String := Part1 & Part2 & Part3;
+ begin
+ if Enabled_Checks (Check) or else Print_Disabled_Failing_Checks
+ then
+ -- ???This Special_Output business is kind of ugly.
+ -- We can do better.
+ Cancel_Special_Output;
+ Write_Line (Message);
+ Set_Special_Output (Ignore_Output'Access);
+ end if;
+
+ if Enabled_Checks (Check) then
+ raise VAST_Failure with Message;
+ end if;
+ end;
+ end if;
+ end Assert;
+
+ -------------
-- Do_Node --
- ------------------
+ -------------
function Do_Node (N : Node_Id) return Traverse_Result is
begin
@@ -58,7 +130,12 @@ package body VAST is
case Nkind (N) is
when N_Unused_At_Start | N_Unused_At_End =>
- pragma Assert (False);
+ Assert (False);
+
+ when N_Error =>
+ -- VAST doesn't do anything when Serious_Errors_Detected > 0 (at
+ -- least for now), so we shouldn't encounter any N_Error nodes.
+ Assert (False, Check_Error_Nodes);
when N_Entity =>
case Ekind (N) is
@@ -70,16 +147,34 @@ package body VAST is
null; -- more to be done here
end case;
+ -- Check that N has a Parent, except in certain cases:
+
+ if Nkind (N) = N_Compilation_Unit then
+ Assert (No (Parent (N)));
+ -- The root of each unit should not have a parent
+ elsif N in N_Entity_Id and then Is_Itype (N) then
+ Assert (No (Parent (N)), Check_Itype_Parents);
+ -- Itypes should not have a parent
+ else
+ if Nkind (N) = N_Error then
+ Assert (False, Check_Error_Nodes);
+ -- The error node has no parent, but we shouldn't even be seeing
+ -- error nodes in VAST at all. See "when N_Error" above.
+ else
+ Assert (Present (Parent (N)), Detail => "missing parent");
+ -- All other nodes should have a parent
+ end if;
+ end if;
+
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>"
@@ -94,10 +189,14 @@ package body VAST is
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.
+ -- ???Not sure what that's about, but these units have no name and
+ -- no associated tree, so we had better not try to walk those trees.
+
+ Root : constant Node_Id := Cunit (U);
begin
+ Assert (No (Root) = Is_Preprocessing_Dependency);
+ -- All compilation units except these bogus ones should have a Cunit.
+
Write_Line (Msg);
if Is_Preprocessing_Dependency then
@@ -105,7 +204,7 @@ package body VAST is
return;
end if;
- pragma Assert (Present (Root));
+ Assert (Present (Root));
Traverse (Root);
Write_Line (Msg & " (done)");
end Do_Unit;
@@ -115,8 +214,15 @@ package body VAST is
----------------
procedure VAST is
+ pragma Assert (Expander_Active = (Operating_Mode = Generate_Code));
+ -- ???So why do we need both Operating_Mode and Expander_Active?
use Debug;
begin
+ -- Do nothing if we're not calling the back end; the main point of VAST
+ -- is to protect against code-generation bugs. This includes the
+ -- case where legality errors were detected; the tree is known to be
+ -- malformed in some error cases.
+
if Operating_Mode /= Generate_Code then
return;
end if;
@@ -130,16 +236,22 @@ package body VAST is
Debug_Flag_A := True;
end if;
- if not Debug_Flag_Underscore_VV and then not Force_Enable_VAST then
+ -- Do nothing if VAST is disabled
+
+ if not (Debug_Flag_Underscore_VV or Force_Enable_VAST) then
return;
end if;
+ -- Turn off output unless verbose mode is enabled
+
if not Debug_Flag_Underscore_WW then
Set_Special_Output (Ignore_Output'Access);
end if;
Write_Line ("VAST");
- pragma Assert (Serious_Errors_Detected = 0);
+ -- Operating_Mode = Generate_Code implies there are no legality errors:
+
+ Assert (Serious_Errors_Detected = 0);
Write_Line ("VAST checking" & Last_Unit'Img & " units");
for U in Main_Unit .. Last_Unit loop
