|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- D E B U G _ A --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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;
|
