]>
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 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2002 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- -- | |
13 | -- ware Foundation; either version 2, 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 COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Atree; use Atree; | |
28 | with Debug; use Debug; | |
29 | with Sinfo; use Sinfo; | |
30 | with Sinput; use Sinput; | |
31 | with Output; use Output; | |
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 | |
48 | -- is not crucial, since this is only for debugging! | |
49 | ||
50 | ----------------------- | |
51 | -- Local Subprograms -- | |
52 | ----------------------- | |
53 | ||
54 | procedure Debug_Output_Astring; | |
55 | -- Outputs Debug_A_Depth number of vertical bars, used to preface messages | |
56 | ||
57 | ------------------- | |
58 | -- Debug_A_Entry -- | |
59 | ------------------- | |
60 | ||
61 | procedure Debug_A_Entry (S : String; N : Node_Id) is | |
62 | begin | |
fbf5a39b AC |
63 | -- Output debugging information if -gnatda flag set |
64 | ||
70482933 RK |
65 | if Debug_Flag_A then |
66 | Debug_Output_Astring; | |
67 | Write_Str (S); | |
68 | Write_Str ("Node_Id = "); | |
69 | Write_Int (Int (N)); | |
70 | Write_Str (" "); | |
71 | Write_Location (Sloc (N)); | |
72 | Write_Str (" "); | |
73 | Write_Str (Node_Kind'Image (Nkind (N))); | |
74 | Write_Eol; | |
75 | end if; | |
76 | ||
fbf5a39b AC |
77 | -- Now push the new element |
78 | ||
70482933 | 79 | Debug_A_Depth := Debug_A_Depth + 1; |
70482933 RK |
80 | |
81 | if Debug_A_Depth <= Max_Node_Ids then | |
82 | Node_Ids (Debug_A_Depth) := N; | |
83 | end if; | |
fbf5a39b AC |
84 | |
85 | -- Set Current_Error_Node only if the new node has a decent Sloc | |
86 | -- value, since it is for the Sloc value that we set this anyway. | |
87 | -- If we don't have a decent Sloc value, we leave it unchanged. | |
88 | ||
89 | if Sloc (N) > No_Location then | |
90 | Current_Error_Node := N; | |
91 | end if; | |
70482933 RK |
92 | end Debug_A_Entry; |
93 | ||
94 | ------------------ | |
95 | -- Debug_A_Exit -- | |
96 | ------------------ | |
97 | ||
98 | procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is | |
99 | begin | |
100 | Debug_A_Depth := Debug_A_Depth - 1; | |
101 | ||
fbf5a39b AC |
102 | -- We look down the stack to find something with a decent Sloc. (If |
103 | -- we find nothing, just leave it unchanged which is not so terrible) | |
104 | ||
105 | for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop | |
106 | if Sloc (Node_Ids (J)) > No_Location then | |
107 | Current_Error_Node := Node_Ids (J); | |
108 | exit; | |
109 | end if; | |
110 | end loop; | |
111 | ||
112 | -- Output debugging information if -gnatda flag set | |
70482933 RK |
113 | |
114 | if Debug_Flag_A then | |
115 | Debug_Output_Astring; | |
116 | Write_Str (S); | |
117 | Write_Str ("Node_Id = "); | |
118 | Write_Int (Int (N)); | |
119 | Write_Str (Comment); | |
120 | Write_Eol; | |
121 | end if; | |
122 | end Debug_A_Exit; | |
123 | ||
124 | -------------------------- | |
125 | -- Debug_Output_Astring -- | |
126 | -------------------------- | |
127 | ||
128 | procedure Debug_Output_Astring is | |
fbf5a39b | 129 | Vbars : constant String := "|||||||||||||||||||||||||"; |
70482933 RK |
130 | -- Should be constant, removed because of GNAT 1.78 bug ??? |
131 | ||
132 | begin | |
133 | if Debug_A_Depth > Vbars'Length then | |
134 | for I in Vbars'Length .. Debug_A_Depth loop | |
135 | Write_Char ('|'); | |
136 | end loop; | |
137 | ||
138 | Write_Str (Vbars); | |
139 | ||
140 | else | |
141 | Write_Str (Vbars (1 .. Debug_A_Depth)); | |
142 | end if; | |
143 | end Debug_Output_Astring; | |
144 | ||
145 | end Debug_A; |