]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- D E B U G _ A -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Atree; use Atree; |
27 | with Debug; use Debug; | |
28 | with Sinfo; use Sinfo; | |
29 | with Sinfo.Nodes; use Sinfo.Nodes; | |
30 | with Sinput; use Sinput; | |
31 | with Output; use Output; | |
70482933 RK |
32 | |
33 | package 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 | |
a90bd866 | 48 | -- is not crucial, since this is only for debugging. |
70482933 | 49 | |
0964be07 BD |
50 | -- Note that Current_Error_Node must be maintained unconditionally (not |
51 | -- only when Debug_Flag_A is True), because we want to print a correct sloc | |
52 | -- in bug boxes. Also, Current_Error_Node is not just used for printing bug | |
53 | -- boxes. For example, an incorrect Current_Error_Node can cause some code | |
54 | -- in Rtsfind to malfunction. | |
55 | ||
70482933 RK |
56 | ----------------------- |
57 | -- Local Subprograms -- | |
58 | ----------------------- | |
59 | ||
60 | procedure Debug_Output_Astring; | |
61 | -- Outputs Debug_A_Depth number of vertical bars, used to preface messages | |
62 | ||
63 | ------------------- | |
64 | -- Debug_A_Entry -- | |
65 | ------------------- | |
66 | ||
67 | procedure Debug_A_Entry (S : String; N : Node_Id) is | |
68 | begin | |
fbf5a39b AC |
69 | -- Output debugging information if -gnatda flag set |
70 | ||
70482933 RK |
71 | if Debug_Flag_A then |
72 | Debug_Output_Astring; | |
73 | Write_Str (S); | |
74 | Write_Str ("Node_Id = "); | |
75 | Write_Int (Int (N)); | |
76 | Write_Str (" "); | |
77 | Write_Location (Sloc (N)); | |
78 | Write_Str (" "); | |
79 | Write_Str (Node_Kind'Image (Nkind (N))); | |
80 | Write_Eol; | |
81 | end if; | |
82 | ||
fbf5a39b AC |
83 | -- Now push the new element |
84 | ||
70482933 | 85 | Debug_A_Depth := Debug_A_Depth + 1; |
70482933 RK |
86 | |
87 | if Debug_A_Depth <= Max_Node_Ids then | |
88 | Node_Ids (Debug_A_Depth) := N; | |
89 | end if; | |
fbf5a39b AC |
90 | |
91 | -- Set Current_Error_Node only if the new node has a decent Sloc | |
92 | -- value, since it is for the Sloc value that we set this anyway. | |
93 | -- If we don't have a decent Sloc value, we leave it unchanged. | |
94 | ||
95 | if Sloc (N) > No_Location then | |
96 | Current_Error_Node := N; | |
97 | end if; | |
70482933 RK |
98 | end Debug_A_Entry; |
99 | ||
100 | ------------------ | |
101 | -- Debug_A_Exit -- | |
102 | ------------------ | |
103 | ||
104 | procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is | |
105 | begin | |
106 | Debug_A_Depth := Debug_A_Depth - 1; | |
107 | ||
fbf5a39b AC |
108 | -- We look down the stack to find something with a decent Sloc. (If |
109 | -- we find nothing, just leave it unchanged which is not so terrible) | |
110 | ||
111 | for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop | |
112 | if Sloc (Node_Ids (J)) > No_Location then | |
113 | Current_Error_Node := Node_Ids (J); | |
114 | exit; | |
115 | end if; | |
116 | end loop; | |
117 | ||
118 | -- Output debugging information if -gnatda flag set | |
70482933 RK |
119 | |
120 | if Debug_Flag_A then | |
121 | Debug_Output_Astring; | |
122 | Write_Str (S); | |
123 | Write_Str ("Node_Id = "); | |
124 | Write_Int (Int (N)); | |
125 | Write_Str (Comment); | |
126 | Write_Eol; | |
127 | end if; | |
128 | end Debug_A_Exit; | |
129 | ||
130 | -------------------------- | |
131 | -- Debug_Output_Astring -- | |
132 | -------------------------- | |
133 | ||
134 | procedure Debug_Output_Astring is | |
fbf5a39b | 135 | Vbars : constant String := "|||||||||||||||||||||||||"; |
70482933 RK |
136 | begin |
137 | if Debug_A_Depth > Vbars'Length then | |
138 | for I in Vbars'Length .. Debug_A_Depth loop | |
139 | Write_Char ('|'); | |
140 | end loop; | |
141 | ||
142 | Write_Str (Vbars); | |
143 | ||
144 | else | |
145 | Write_Str (Vbars (1 .. Debug_A_Depth)); | |
146 | end if; | |
147 | end Debug_Output_Astring; | |
148 | ||
149 | end Debug_A; |