]>
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 | -- -- | |
06c565cc | 9 | -- Copyright (C) 1992-2024, 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; | |
dba07790 | 28 | with Namet; use Namet; |
104f58db BD |
29 | with Sinfo; use Sinfo; |
30 | with Sinfo.Nodes; use Sinfo.Nodes; | |
31 | with Sinput; use Sinput; | |
32 | with Output; use Output; | |
70482933 RK |
33 | |
34 | package body Debug_A is | |
35 | ||
36 | Debug_A_Depth : Natural := 0; | |
dba07790 | 37 | -- Output for the -gnatda switch is preceded by a sequence of vertical bar |
70482933 RK |
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. | |
41 | ||
42 | Max_Node_Ids : constant := 200; | |
43 | -- Maximum number of Node_Id values that get stacked | |
44 | ||
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 | |
a90bd866 | 49 | -- is not crucial, since this is only for debugging. |
70482933 | 50 | |
0964be07 BD |
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. | |
56 | ||
70482933 RK |
57 | ----------------------- |
58 | -- Local Subprograms -- | |
59 | ----------------------- | |
60 | ||
61 | procedure Debug_Output_Astring; | |
62 | -- Outputs Debug_A_Depth number of vertical bars, used to preface messages | |
63 | ||
64 | ------------------- | |
65 | -- Debug_A_Entry -- | |
66 | ------------------- | |
67 | ||
68 | procedure Debug_A_Entry (S : String; N : Node_Id) is | |
69 | begin | |
dba07790 | 70 | -- Output debugging information if -gnatda switch set |
fbf5a39b | 71 | |
70482933 RK |
72 | if Debug_Flag_A then |
73 | Debug_Output_Astring; | |
74 | Write_Str (S); | |
75 | Write_Str ("Node_Id = "); | |
76 | Write_Int (Int (N)); | |
77 | Write_Str (" "); | |
78 | Write_Location (Sloc (N)); | |
79 | Write_Str (" "); | |
80 | Write_Str (Node_Kind'Image (Nkind (N))); | |
dba07790 BD |
81 | |
82 | -- Print the Chars field, if appropriate | |
83 | ||
84 | case Nkind (N) is | |
85 | when N_Has_Chars => | |
86 | Write_Str (" """); | |
87 | if Present (Chars (N)) then | |
88 | Write_Str (Get_Name_String (Chars (N))); | |
89 | end if; | |
90 | Write_Str (""""); | |
91 | when others => null; | |
92 | end case; | |
93 | ||
70482933 RK |
94 | Write_Eol; |
95 | end if; | |
96 | ||
fbf5a39b AC |
97 | -- Now push the new element |
98 | ||
70482933 | 99 | Debug_A_Depth := Debug_A_Depth + 1; |
70482933 RK |
100 | |
101 | if Debug_A_Depth <= Max_Node_Ids then | |
102 | Node_Ids (Debug_A_Depth) := N; | |
103 | end if; | |
fbf5a39b AC |
104 | |
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. | |
108 | ||
109 | if Sloc (N) > No_Location then | |
110 | Current_Error_Node := N; | |
111 | end if; | |
70482933 RK |
112 | end Debug_A_Entry; |
113 | ||
114 | ------------------ | |
115 | -- Debug_A_Exit -- | |
116 | ------------------ | |
117 | ||
118 | procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is | |
119 | begin | |
120 | Debug_A_Depth := Debug_A_Depth - 1; | |
121 | ||
fbf5a39b AC |
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) | |
124 | ||
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); | |
128 | exit; | |
129 | end if; | |
130 | end loop; | |
131 | ||
dba07790 | 132 | -- Output debugging information if -gnatda switch set |
70482933 RK |
133 | |
134 | if Debug_Flag_A then | |
135 | Debug_Output_Astring; | |
136 | Write_Str (S); | |
137 | Write_Str ("Node_Id = "); | |
138 | Write_Int (Int (N)); | |
139 | Write_Str (Comment); | |
140 | Write_Eol; | |
141 | end if; | |
142 | end Debug_A_Exit; | |
143 | ||
144 | -------------------------- | |
145 | -- Debug_Output_Astring -- | |
146 | -------------------------- | |
147 | ||
148 | procedure Debug_Output_Astring is | |
70482933 | 149 | begin |
dba07790 | 150 | Write_Str ((1 .. Debug_A_Depth => '|')); |
70482933 RK |
151 | end Debug_Output_Astring; |
152 | ||
153 | end Debug_A; |