1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              D E B U G _ A                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- GNAT was originally developed  by the GNAT team at  New York University. --
23-- Extensive contributions were provided by Ada Core Technologies Inc.      --
24--                                                                          --
25------------------------------------------------------------------------------
26
27with Atree;   use Atree;
28with Debug;   use Debug;
29with Sinfo;   use Sinfo;
30with Sinput;  use Sinput;
31with Output;  use Output;
32
33package body Debug_A is
34
35   Debug_A_Depth : Natural := 0;
36   --  Output for the debug A flag is preceded by a sequence of vertical bar
37   --  characters corresponding to the recursion depth of the actions being
38   --  recorded (analysis, expansion, resolution and evaluation of nodes)
39   --  This variable records the depth.
40
41   Max_Node_Ids : constant := 200;
42   --  Maximum number of Node_Id values that get stacked
43
44   Node_Ids : array (1 .. Max_Node_Ids) of Node_Id;
45   --  A stack used to keep track of Node_Id values for setting the value of
46   --  Current_Error_Node correctly. Note that if we have more than 200
47   --  recursion levels, we just don't reset the right value on exit, which
48   --  is not crucial, since this is only for debugging!
49
50   -----------------------
51   -- Local Subprograms --
52   -----------------------
53
54   procedure Debug_Output_Astring;
55   --  Outputs Debug_A_Depth number of vertical bars, used to preface messages
56
57   -------------------
58   -- Debug_A_Entry --
59   -------------------
60
61   procedure Debug_A_Entry (S : String; N : Node_Id) is
62   begin
63      --  Output debugging information if -gnatda flag set
64
65      if Debug_Flag_A then
66         Debug_Output_Astring;
67         Write_Str (S);
68         Write_Str ("Node_Id = ");
69         Write_Int (Int (N));
70         Write_Str ("  ");
71         Write_Location (Sloc (N));
72         Write_Str ("  ");
73         Write_Str (Node_Kind'Image (Nkind (N)));
74         Write_Eol;
75      end if;
76
77      --  Now push the new element
78
79      Debug_A_Depth := Debug_A_Depth + 1;
80
81      if Debug_A_Depth <= Max_Node_Ids then
82         Node_Ids (Debug_A_Depth) := N;
83      end if;
84
85      --  Set Current_Error_Node only if the new node has a decent Sloc
86      --  value, since it is for the Sloc value that we set this anyway.
87      --  If we don't have a decent Sloc value, we leave it unchanged.
88
89      if Sloc (N) > No_Location then
90         Current_Error_Node := N;
91      end if;
92   end Debug_A_Entry;
93
94   ------------------
95   -- Debug_A_Exit --
96   ------------------
97
98   procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
99   begin
100      Debug_A_Depth := Debug_A_Depth - 1;
101
102      --  We look down the stack to find something with a decent Sloc. (If
103      --  we find nothing, just leave it unchanged which is not so terrible)
104
105      for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
106         if Sloc (Node_Ids (J)) > No_Location then
107            Current_Error_Node := Node_Ids (J);
108            exit;
109         end if;
110      end loop;
111
112      --  Output debugging information if -gnatda flag set
113
114      if Debug_Flag_A then
115         Debug_Output_Astring;
116         Write_Str (S);
117         Write_Str ("Node_Id = ");
118         Write_Int (Int (N));
119         Write_Str (Comment);
120         Write_Eol;
121      end if;
122   end Debug_A_Exit;
123
124   --------------------------
125   -- Debug_Output_Astring --
126   --------------------------
127
128   procedure Debug_Output_Astring is
129      Vbars : constant String := "|||||||||||||||||||||||||";
130      --  Should be constant, removed because of GNAT 1.78 bug ???
131
132   begin
133      if Debug_A_Depth > Vbars'Length then
134         for I in Vbars'Length .. Debug_A_Depth loop
135            Write_Char ('|');
136         end loop;
137
138         Write_Str (Vbars);
139
140      else
141         Write_Str (Vbars (1 .. Debug_A_Depth));
142      end if;
143   end Debug_Output_Astring;
144
145end Debug_A;
146