Merge from mainline (167278:168000).
[official-gcc/graphite-test-results.git] / gcc / ada / debug_a.adb
blob35b7f002553655d15b78b03fb1b3a7af54bf6f03
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-2007, 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 ------------------------------------------------------------------------------
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;
32 package body Debug_A is
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.
40 Max_Node_Ids : constant := 200;
41 -- Maximum number of Node_Id values that get stacked
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!
49 -----------------------
50 -- Local Subprograms --
51 -----------------------
53 procedure Debug_Output_Astring;
54 -- Outputs Debug_A_Depth number of vertical bars, used to preface messages
56 -------------------
57 -- Debug_A_Entry --
58 -------------------
60 procedure Debug_A_Entry (S : String; N : Node_Id) is
61 begin
62 -- Output debugging information if -gnatda flag set
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;
76 -- Now push the new element
78 Debug_A_Depth := Debug_A_Depth + 1;
80 if Debug_A_Depth <= Max_Node_Ids then
81 Node_Ids (Debug_A_Depth) := N;
82 end if;
84 -- Set Current_Error_Node only if the new node has a decent Sloc
85 -- value, since it is for the Sloc value that we set this anyway.
86 -- If we don't have a decent Sloc value, we leave it unchanged.
88 if Sloc (N) > No_Location then
89 Current_Error_Node := N;
90 end if;
91 end Debug_A_Entry;
93 ------------------
94 -- Debug_A_Exit --
95 ------------------
97 procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
98 begin
99 Debug_A_Depth := Debug_A_Depth - 1;
101 -- We look down the stack to find something with a decent Sloc. (If
102 -- we find nothing, just leave it unchanged which is not so terrible)
104 for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
105 if Sloc (Node_Ids (J)) > No_Location then
106 Current_Error_Node := Node_Ids (J);
107 exit;
108 end if;
109 end loop;
111 -- Output debugging information if -gnatda flag set
113 if Debug_Flag_A then
114 Debug_Output_Astring;
115 Write_Str (S);
116 Write_Str ("Node_Id = ");
117 Write_Int (Int (N));
118 Write_Str (Comment);
119 Write_Eol;
120 end if;
121 end Debug_A_Exit;
123 --------------------------
124 -- Debug_Output_Astring --
125 --------------------------
127 procedure Debug_Output_Astring is
128 Vbars : constant String := "|||||||||||||||||||||||||";
129 -- Should be constant, removed because of GNAT 1.78 bug ???
131 begin
132 if Debug_A_Depth > Vbars'Length then
133 for I in Vbars'Length .. Debug_A_Depth loop
134 Write_Char ('|');
135 end loop;
137 Write_Str (Vbars);
139 else
140 Write_Str (Vbars (1 .. Debug_A_Depth));
141 end if;
142 end Debug_Output_Astring;
144 end Debug_A;