blob: 8a8ccc67f19c48a4e1912725f50622a29dfd1e56 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- D E B U G _ A --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-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 Atree; use Atree;
with Debug; use Debug;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinput; use Sinput;
with Output; use Output;
package body Debug_A is
Debug_A_Depth : Natural := 0;
-- Output for the debug A flag is preceded by a sequence of vertical bar
-- characters corresponding to the recursion depth of the actions being
-- recorded (analysis, expansion, resolution and evaluation of nodes)
-- This variable records the depth.
Max_Node_Ids : constant := 200;
-- Maximum number of Node_Id values that get stacked
Node_Ids : array (1 .. Max_Node_Ids) of Node_Id;
-- A stack used to keep track of Node_Id values for setting the value of
-- Current_Error_Node correctly. Note that if we have more than 200
-- recursion levels, we just don't reset the right value on exit, which
-- is not crucial, since this is only for debugging.
-- Note that Current_Error_Node must be maintained unconditionally (not
-- only when Debug_Flag_A is True), because we want to print a correct sloc
-- in bug boxes. Also, Current_Error_Node is not just used for printing bug
-- boxes. For example, an incorrect Current_Error_Node can cause some code
-- in Rtsfind to malfunction.
-----------------------
-- Local Subprograms --
-----------------------
procedure Debug_Output_Astring;
-- Outputs Debug_A_Depth number of vertical bars, used to preface messages
-------------------
-- Debug_A_Entry --
-------------------
procedure Debug_A_Entry (S : String; N : Node_Id) is
begin
-- Output debugging information if -gnatda flag set
if Debug_Flag_A then
Debug_Output_Astring;
Write_Str (S);
Write_Str ("Node_Id = ");
Write_Int (Int (N));
Write_Str (" ");
Write_Location (Sloc (N));
Write_Str (" ");
Write_Str (Node_Kind'Image (Nkind (N)));
Write_Eol;
end if;
-- Now push the new element
Debug_A_Depth := Debug_A_Depth + 1;
if Debug_A_Depth <= Max_Node_Ids then
Node_Ids (Debug_A_Depth) := N;
end if;
-- Set Current_Error_Node only if the new node has a decent Sloc
-- value, since it is for the Sloc value that we set this anyway.
-- If we don't have a decent Sloc value, we leave it unchanged.
if Sloc (N) > No_Location then
Current_Error_Node := N;
end if;
end Debug_A_Entry;
------------------
-- Debug_A_Exit --
------------------
procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
begin
Debug_A_Depth := Debug_A_Depth - 1;
-- We look down the stack to find something with a decent Sloc. (If
-- we find nothing, just leave it unchanged which is not so terrible)
for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
if Sloc (Node_Ids (J)) > No_Location then
Current_Error_Node := Node_Ids (J);
exit;
end if;
end loop;
-- Output debugging information if -gnatda flag set
if Debug_Flag_A then
Debug_Output_Astring;
Write_Str (S);
Write_Str ("Node_Id = ");
Write_Int (Int (N));
Write_Str (Comment);
Write_Eol;
end if;
end Debug_A_Exit;
--------------------------
-- Debug_Output_Astring --
--------------------------
procedure Debug_Output_Astring is
Vbars : constant String := "|||||||||||||||||||||||||";
begin
if Debug_A_Depth > Vbars'Length then
for I in Vbars'Length .. Debug_A_Depth loop
Write_Char ('|');
end loop;
Write_Str (Vbars);
else
Write_Str (Vbars (1 .. Debug_A_Depth));
end if;
end Debug_Output_Astring;
end Debug_A;