diff options
Diffstat (limited to 'gcc/ada/vast.adb')
| -rw-r--r-- | gcc/ada/vast.adb | 519 |
1 files changed, 437 insertions, 82 deletions
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index acb48b6..59470fd 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -29,58 +29,285 @@ pragma Assertion_Policy (Check); -- 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 Ada.Unchecked_Deallocation; + +with System.Case_Util; + +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; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinput; +with Table; +with Types; use Types; package body VAST is + -- ???Basic tree properties not yet checked: + -- - No dangling trees. Every node that is reachable at all is reachable + -- by some syntactic path. + -- - Basic properties of Nlists/Elists (next/prev pointers make sense, + -- for example). + 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. - 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_Error_Nodes); - Enabled_Checks : constant array (Check_Enum) of Boolean := - (Check_Other => True, --- others => False); - others => True); - -- Passing checks are Check_Other, which should always be enabled. + -- set this to True. + + type Check_Enum is + (Check_Other, + Check_Sloc, + Check_Analyzed, + Check_Error_Nodes, + Check_Sharing, + Check_Parent_Present, + Check_Parent_Correct); + + type Check_Status is + -- Action in case of check failure: + (Disabled, -- Do nothing + Enabled, -- Print messages, and raise an exception + Print_And_Continue); -- Print a message + + pragma Warnings (Off, "Status*could be declared constant"); + Status : array (Check_Enum) of Check_Status := + (Check_Other => Enabled, + Check_Sloc => Disabled, + Check_Analyzed => Disabled, + Check_Error_Nodes => Print_And_Continue, + Check_Sharing => Disabled, + Check_Parent_Present => Print_And_Continue, + Check_Parent_Correct => Disabled); +-- others => Print_And_Continue); +-- others => Enabled); +-- others => Disabled); + -- 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. + -- and play around with the value of Status 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. + type Node_Stack_Index is new Pos; + subtype Node_Stack_Count is + Node_Stack_Index'Base range 0 .. Node_Stack_Index'Last; + + package Node_Stack is new Table.Table + (Table_Component_Type => Node_Id, + Table_Index_Type => Node_Stack_Index'Base, + Table_Low_Bound => 1, + Table_Initial => 1, + Table_Increment => 100, + Table_Name => "Node_Stack"); + 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); + -- Check that the Condition is True. Status determines action on failure. + + function To_Mixed (A : String) return String; + -- Copied from System.Case_Util; old versions of that package do not have + -- this function, so this is needed for bootstrapping. + + function Image (Kind : Node_Kind) return String is (To_Mixed (Kind'Img)); + function Image (Kind : Entity_Kind) return String is (To_Mixed (Kind'Img)); + + procedure Put (S : String); + procedure Put_Line (S : String); + procedure Put_Node (N : Node_Id); + procedure Put_Node_Stack; + -- Output routines; print only if -gnatd_W (VAST in verbose mode) is + -- enabled. + + procedure Put_Indentation; + -- Print spaces to indicate nesting depth of Node_Stack + + procedure Enter_Node (N : Node_Id); + procedure Leave_Node (N : Node_Id); + -- Called for each node while walking the tree. + -- Push/pop N to/from Node_Stack. + -- Print enter/leave debugging messages. + -- ???Possible improvements to messages: + -- Walk subtrees in a better order. + -- Print field names. + -- Don't print boring fields (such as N_Empty nodes). + -- Print more info (value of literals, "A.B.C" for expanded names, etc.). + -- Share some code with Treepr. + + procedure Do_Tree (N : Node_Id); -- Do VAST checking on a tree of nodes + function Has_Subtrees (N : Node_Id) return Boolean; + -- True if N has one or more syntactic fields + + procedure Do_Subtrees (N : Node_Id); + -- Call Do_Tree on all the subtrees (i.e. syntactic fields) of N + + procedure Do_List (L : List_Id); + -- Call Do_Tree on the list elements + procedure Do_Unit (U : Unit_Number_Type); - -- Call Do_Node on the root node of a compilation unit + -- Call Do_Tree on the root node of a compilation unit + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id; + -- Nth ancestor on the Node_Stack. Ancestor_Node(0) is the current node, + -- Ancestor_Node(1) is its parent, Ancestor_Node(2) is its grandparent, + -- and so on. + + function Top_Node return Node_Id is (Ancestor_Node (0)); + + type Node_Set is array (Node_Id range <>) of Boolean; + pragma Pack (Node_Set); + type Node_Set_Ptr is access all Node_Set; + procedure Free is new Ada.Unchecked_Deallocation (Node_Set, Node_Set_Ptr); + + Visited : Node_Set_Ptr; + -- Giant array of Booleans; Visited (N) is True if and only if we have + -- visited N in the tree walk. Used to detect incorrect sharing of subtrees + -- or (worse) cycles. We don't allocate the set on the stack, for fear of + -- Storage_Error. + + function Get_Node_Field_Union is new + Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; + + -------------- + -- To_Mixed -- + -------------- + + function To_Mixed (A : String) return String is + Result : String := A; + begin + System.Case_Util.To_Mixed (Result); + return Result; + end To_Mixed; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Line (S); + end if; + end Put_Line; + + -------------- + -- Put_Node -- + -------------- + + procedure Put_Node (N : Node_Id) is + begin + if Debug.Debug_Flag_Underscore_WW then + if Nkind (N) in N_Entity then + Put (Image (Ekind (N))); + else + Put (Image (Nkind (N))); + end if; + + Put (N'Img & " "); + Sinput.Write_Location (Sloc (N)); + + if Comes_From_Source (N) then + Put (" (s)"); + end if; + + case Nkind (N) is + when N_Has_Chars => + Put (" "); + Write_Name_For_Debug (Chars (N), Quote => """"); + when others => null; + end case; + + end if; + end Put_Node; + + --------------------- + -- Put_Indentation -- + --------------------- + + procedure Put_Indentation is + begin + Put (String'(Natural (Node_Stack.First) .. + Natural (Node_Stack.Last) * 2 => ' ')); + end Put_Indentation; + + ---------------- + -- Enter_Node -- + ---------------- + + procedure Enter_Node (N : Node_Id) is + begin + Node_Stack.Append (N); -- push + + if Has_Subtrees (N) then + Put ("-->"); + else + -- If no subtrees, just print one line for enter/leave + Put (" "); + end if; + Put_Indentation; + Put_Node (N); + Put_Line (""); + end Enter_Node; + + ---------------- + -- Leave_Node -- + ---------------- + + procedure Leave_Node (N : Node_Id) is + begin + if Has_Subtrees (N) then + Put ("<--"); + Put_Indentation; + Put_Node (N); + Put_Line (""); + end if; + + Node_Stack.Decrement_Last; -- pop + end Leave_Node; + + -------------------- + -- Put_Node_Stack -- + -------------------- + + procedure Put_Node_Stack is + begin + for J in reverse Node_Stack.First .. Node_Stack.Last loop + Put_Node (Node_Stack.Table (J)); + Put_Line (""); + end loop; + end Put_Node_Stack; + + ------------------- + -- Ancestor_Node -- + ------------------- + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id is + begin + return Node_Stack.Table (Node_Stack.Last - Count); + end Ancestor_Node; ------------ -- Assert -- @@ -98,34 +325,70 @@ package body VAST is declare Part1 : constant String := "VAST fail"; Part2 : constant String := - (if Check = Check_Other then "" else ": " & Check'Img); + (if Check = Check_Other then "" + else ": " & To_Mixed (Check'Img)); Part3 : constant String := (if Detail = "" then "" else " -- " & Detail); Message : constant String := Part1 & Part2 & Part3; + Save : constant Boolean := Debug.Debug_Flag_Underscore_WW; 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; + case Status (Check) is + when Disabled => null; + when Enabled | Print_And_Continue => + Debug.Debug_Flag_Underscore_WW := True; + -- ???We should probably avoid changing the debug flag here + Put (Message & ": "); + Put_Node (Top_Node); + Put_Line (""); + + if Status (Check) = Enabled then + Put_Node_Stack; + raise VAST_Failure with Message; + end if; + + Debug.Debug_Flag_Underscore_WW := Save; + end case; end; end if; end Assert; ------------- - -- Do_Node -- + -- Do_Tree -- ------------- - function Do_Node (N : Node_Id) return Traverse_Result is + procedure Do_Tree (N : Node_Id) is begin - Debug_A_Entry ("do ", N); + Enter_Node (N); + + -- Skip the rest if empty. Check Sloc: + + case Nkind (N) is + when N_Empty => + Assert (No (Sloc (N))); + goto Done; -- --------------> + -- Don't do any further checks on Empty + + -- ???Some nodes, including exception handlers, have no Sloc; + -- it's unclear why. + + when N_Exception_Handler => + Assert (if Comes_From_Source (N) then Present (Sloc (N))); + when others => + Assert (Present (Sloc (N)), Check_Sloc); + end case; + + -- All reachable nodes should have been analyzed by the time we get + -- here: + + Assert (Analyzed (N), Check_Analyzed); + + -- If we visit the same node more than once, then there are shared + -- nodes; the "tree" is not a tree: + + Assert (not Visited (N), Check_Sharing); + Visited (N) := True; + + -- Misc checks based on node/entity kind: case Nkind (N) is when N_Unused_At_Start | N_Unused_At_End => @@ -148,27 +411,105 @@ package body VAST is -- 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 - null; -- An Itype might or might not have a parent + case Nkind (N) is + when N_Empty => + raise Program_Error; -- can't get here - else - if Nkind (N) = N_Error then + when N_Error => 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"); + -- error nodes in VAST at all. See earlier "when N_Error". + + when N_Compilation_Unit => + Assert (No (Parent (N))); + -- The parent of the root of each unit is empty. + + when N_Entity => + if not Is_Itype (N) then + -- An Itype might or might not have a parent + + Assert + (Present (Parent (N)), Detail => "missing parent of entity"); + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + + when others => + Assert (Present (Parent (N)), Check_Parent_Present); -- All other nodes should have a parent - end if; - end if; + if Status (Check_Parent_Present) = Enabled then + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + end case; - Debug_A_Exit ("do ", N, " (done)"); - return OK; - end Do_Node; + Do_Subtrees (N); + + <<Done>> + Leave_Node (N); + end Do_Tree; + + ----------------- + -- Has_Subtrees -- + ----------------- + + function Has_Subtrees (N : Node_Id) return Boolean is + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + -- True if sentinel comes first + return Offsets (Offsets'First) /= No_Field_Offset; + end Has_Subtrees; + + ----------------- + -- Do_Subtrees -- + ----------------- + + procedure Do_Subtrees (N : Node_Id) is + -- ???Do we need tail recursion elimination here, + -- as in Atree.Traverse_Func? + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + for Cur_Field in Offset_Array_Index loop + exit when Offsets (Cur_Field) = No_Field_Offset; + + declare + F : constant Union_Id := + Get_Node_Field_Union (N, Offsets (Cur_Field)); + begin + if F in Node_Range then + Do_Tree (Node_Id (F)); + elsif F in List_Range then + Do_List (List_Id (F)); + else + raise Program_Error; + end if; + end; + end loop; + end Do_Subtrees; + + ------------- + -- Do_List -- + ------------- + + procedure Do_List (L : List_Id) is + Elmt : Node_Id := First (L); + Len : constant String := List_Length (L)'Img; + begin + if Is_Non_Empty_List (L) then + Put ("-->"); + Put_Indentation; + Put_Line ("list len=" & Len); + + while Present (Elmt) loop + Do_Tree (Elmt); + Next (Elmt); + end loop; + + Put ("<--"); + Put_Indentation; + Put_Line ("list len=" & Len); + end if; + end Do_List; ------------- -- Do_Unit -- @@ -183,8 +524,10 @@ package body VAST is (if Is_Predefined_Unit (U) then " (predef)" elsif Is_Internal_Unit (U) then " (gnat)" else ""); + Is_Main : constant String := + (if U = Main_Unit then " (main unit)" else ""); Msg : constant String := - "VAST for unit" & U'Img & " " & U_Name_S & Predef; + "VAST for unit" & U'Img & " " & U_Name_S & Predef & Is_Main; Is_Preprocessing_Dependency : constant Boolean := U_Name = No_Unit_Name; @@ -194,24 +537,26 @@ package body VAST is Root : constant Node_Id := Cunit (U); begin + pragma Assert (Node_Stack.Last = 0); Assert (No (Root) = Is_Preprocessing_Dependency); -- All compilation units except these bogus ones should have a Cunit. - Write_Line (Msg); + Put_Line (Msg); if Is_Preprocessing_Dependency then - Write_Line ("Skipping preprocessing dependency"); + Put_Line ("Skipping preprocessing dependency"); return; end if; Assert (Present (Root)); - Traverse (Root); - Write_Line (Msg & " (done)"); + Do_Tree (Root); + Put_Line (Msg & " (done)"); + pragma Assert (Node_Stack.Last = 0); end Do_Unit; - ---------------- - -- Check_Tree -- - ---------------- + ---------- + -- VAST -- + ---------- procedure VAST is pragma Assert (Expander_Active = (Operating_Mode = Generate_Code)); @@ -228,12 +573,10 @@ package body VAST is 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. + -- -gnatd_V (enable VAST). if Debug_Flag_Underscore_WW then Debug_Flag_Underscore_VV := True; - Debug_Flag_A := True; end if; -- Do nothing if VAST is disabled @@ -244,22 +587,34 @@ package body VAST is -- 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"); + Put_Line ("VAST"); -- 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 - Do_Unit (U); - end loop; + Put_Line ("VAST checking" & Last_Unit'Img & " units"); + + declare + use Atree_Private_Part; + Last_Node : constant Node_Id := Node_Offsets.Last; + begin + pragma Assert (Visited = null); + Visited := new Node_Set'(Node_Id'First .. Last_Node => False); + + for U in Main_Unit .. Last_Unit loop + -- Main_Unit is the one passed to the back end, but here we are + -- walking all the units. + Do_Unit (U); + end loop; + + -- We shouldn't have allocated any new nodes during VAST: + + pragma Assert (Node_Offsets.Last = Last_Node); + Free (Visited); + end; - Write_Line ("VAST done."); - Cancel_Special_Output; + Put_Line ("VAST done."); end VAST; end VAST; |