1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Namet
; use Namet
;
29 with Sinfo
; use Sinfo
;
30 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
31 with Sinput
; use Sinput
;
32 with Output
; use Output
;
34 package body Debug_A
is
36 Debug_A_Depth
: Natural := 0;
37 -- Output for the -gnatda switch is preceded by a sequence of vertical bar
38 -- characters corresponding to the recursion depth of the actions being
39 -- recorded (analysis, expansion, resolution and evaluation of nodes)
40 -- This variable records the depth.
42 Max_Node_Ids
: constant := 200;
43 -- Maximum number of Node_Id values that get stacked
45 Node_Ids
: array (1 .. Max_Node_Ids
) of Node_Id
;
46 -- A stack used to keep track of Node_Id values for setting the value of
47 -- Current_Error_Node correctly. Note that if we have more than 200
48 -- recursion levels, we just don't reset the right value on exit, which
49 -- is not crucial, since this is only for debugging.
51 -- Note that Current_Error_Node must be maintained unconditionally (not
52 -- only when Debug_Flag_A is True), because we want to print a correct sloc
53 -- in bug boxes. Also, Current_Error_Node is not just used for printing bug
54 -- boxes. For example, an incorrect Current_Error_Node can cause some code
55 -- in Rtsfind to malfunction.
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 procedure Debug_Output_Astring
;
62 -- Outputs Debug_A_Depth number of vertical bars, used to preface messages
68 procedure Debug_A_Entry
(S
: String; N
: Node_Id
) is
70 -- Output debugging information if -gnatda switch set
75 Write_Str
("Node_Id = ");
78 Write_Location
(Sloc
(N
));
80 Write_Str
(Node_Kind
'Image (Nkind
(N
)));
82 -- Print the Chars field, if appropriate
87 if Present
(Chars
(N
)) then
88 Write_Str
(Get_Name_String
(Chars
(N
)));
97 -- Now push the new element
99 Debug_A_Depth
:= Debug_A_Depth
+ 1;
101 if Debug_A_Depth
<= Max_Node_Ids
then
102 Node_Ids
(Debug_A_Depth
) := N
;
105 -- Set Current_Error_Node only if the new node has a decent Sloc
106 -- value, since it is for the Sloc value that we set this anyway.
107 -- If we don't have a decent Sloc value, we leave it unchanged.
109 if Sloc
(N
) > No_Location
then
110 Current_Error_Node
:= N
;
118 procedure Debug_A_Exit
(S
: String; N
: Node_Id
; Comment
: String) is
120 Debug_A_Depth
:= Debug_A_Depth
- 1;
122 -- We look down the stack to find something with a decent Sloc. (If
123 -- we find nothing, just leave it unchanged which is not so terrible)
125 for J
in reverse 1 .. Integer'Min (Max_Node_Ids
, Debug_A_Depth
) loop
126 if Sloc
(Node_Ids
(J
)) > No_Location
then
127 Current_Error_Node
:= Node_Ids
(J
);
132 -- Output debugging information if -gnatda switch set
135 Debug_Output_Astring
;
137 Write_Str
("Node_Id = ");
144 --------------------------
145 -- Debug_Output_Astring --
146 --------------------------
148 procedure Debug_Output_Astring
is
150 Write_Str
((1 .. Debug_A_Depth
=> '|'));
151 end Debug_Output_Astring
;