File : debug_a.adb
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-2013, 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 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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Sinfo; use Sinfo;
29 with Sinput; use Sinput;
30 with Output; use Output;
31
32 package body Debug_A is
33
34 Debug_A_Depth : Natural := 0;
35 -- Output for the debug A flag is preceded by a sequence of vertical bar
36 -- characters corresponding to the recursion depth of the actions being
37 -- recorded (analysis, expansion, resolution and evaluation of nodes)
38 -- This variable records the depth.
39
40 Max_Node_Ids : constant := 200;
41 -- Maximum number of Node_Id values that get stacked
42
43 Node_Ids : array (1 .. Max_Node_Ids) of Node_Id;
44 -- A stack used to keep track of Node_Id values for setting the value of
45 -- Current_Error_Node correctly. Note that if we have more than 200
46 -- recursion levels, we just don't reset the right value on exit, which
47 -- is not crucial, since this is only for debugging.
48
49 -----------------------
50 -- Local Subprograms --
51 -----------------------
52
53 procedure Debug_Output_Astring;
54 -- Outputs Debug_A_Depth number of vertical bars, used to preface messages
55
56 -------------------
57 -- Debug_A_Entry --
58 -------------------
59
60 procedure Debug_A_Entry (S : String; N : Node_Id) is
61 begin
62 -- Output debugging information if -gnatda flag set
63
64 if Debug_Flag_A then
65 Debug_Output_Astring;
66 Write_Str (S);
67 Write_Str ("Node_Id = ");
68 Write_Int (Int (N));
69 Write_Str (" ");
70 Write_Location (Sloc (N));
71 Write_Str (" ");
72 Write_Str (Node_Kind'Image (Nkind (N)));
73 Write_Eol;
74 end if;
75
76 -- Now push the new element
77
78 -- Why is this done unconditionally???
79
80 Debug_A_Depth := Debug_A_Depth + 1;
81
82 if Debug_A_Depth <= Max_Node_Ids then
83 Node_Ids (Debug_A_Depth) := N;
84 end if;
85
86 -- Set Current_Error_Node only if the new node has a decent Sloc
87 -- value, since it is for the Sloc value that we set this anyway.
88 -- If we don't have a decent Sloc value, we leave it unchanged.
89
90 if Sloc (N) > No_Location then
91 Current_Error_Node := N;
92 end if;
93 end Debug_A_Entry;
94
95 ------------------
96 -- Debug_A_Exit --
97 ------------------
98
99 procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
100 begin
101 Debug_A_Depth := Debug_A_Depth - 1;
102
103 -- We look down the stack to find something with a decent Sloc. (If
104 -- we find nothing, just leave it unchanged which is not so terrible)
105
106 -- This seems nasty overhead for the normal case ???
107
108 for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
109 if Sloc (Node_Ids (J)) > No_Location then
110 Current_Error_Node := Node_Ids (J);
111 exit;
112 end if;
113 end loop;
114
115 -- Output debugging information if -gnatda flag set
116
117 if Debug_Flag_A then
118 Debug_Output_Astring;
119 Write_Str (S);
120 Write_Str ("Node_Id = ");
121 Write_Int (Int (N));
122 Write_Str (Comment);
123 Write_Eol;
124 end if;
125 end Debug_A_Exit;
126
127 --------------------------
128 -- Debug_Output_Astring --
129 --------------------------
130
131 procedure Debug_Output_Astring is
132 Vbars : constant String := "|||||||||||||||||||||||||";
133 -- Should be constant, removed because of GNAT 1.78 bug ???
134
135 begin
136 if Debug_A_Depth > Vbars'Length then
137 for I in Vbars'Length .. Debug_A_Depth loop
138 Write_Char ('|');
139 end loop;
140
141 Write_Str (Vbars);
142
143 else
144 Write_Str (Vbars (1 .. Debug_A_Depth));
145 end if;
146 end Debug_Output_Astring;
147
148 end Debug_A;