]>
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 | -- -- | |
9 | -- $Revision: 1.11 $ -- | |
10 | -- -- | |
11 | -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- | |
12 | -- -- | |
13 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
14 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
15 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
16 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
17 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
18 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
19 | -- for more details. You should have received a copy of the GNU General -- | |
20 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
21 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
22 | -- MA 02111-1307, USA. -- | |
23 | -- -- | |
24 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
25 | -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- | |
26 | -- -- | |
27 | ------------------------------------------------------------------------------ | |
28 | ||
29 | with Atree; use Atree; | |
30 | with Debug; use Debug; | |
31 | with Sinfo; use Sinfo; | |
32 | with Sinput; use Sinput; | |
33 | with Output; use Output; | |
34 | ||
35 | package body Debug_A is | |
36 | ||
37 | Debug_A_Depth : Natural := 0; | |
38 | -- Output for the debug A flag is preceded by a sequence of vertical bar | |
39 | -- characters corresponding to the recursion depth of the actions being | |
40 | -- recorded (analysis, expansion, resolution and evaluation of nodes) | |
41 | -- This variable records the depth. | |
42 | ||
43 | Max_Node_Ids : constant := 200; | |
44 | -- Maximum number of Node_Id values that get stacked | |
45 | ||
46 | Node_Ids : array (1 .. Max_Node_Ids) of Node_Id; | |
47 | -- A stack used to keep track of Node_Id values for setting the value of | |
48 | -- Current_Error_Node correctly. Note that if we have more than 200 | |
49 | -- recursion levels, we just don't reset the right value on exit, which | |
50 | -- is not crucial, since this is only for debugging! | |
51 | ||
52 | ----------------------- | |
53 | -- Local Subprograms -- | |
54 | ----------------------- | |
55 | ||
56 | procedure Debug_Output_Astring; | |
57 | -- Outputs Debug_A_Depth number of vertical bars, used to preface messages | |
58 | ||
59 | ------------------- | |
60 | -- Debug_A_Entry -- | |
61 | ------------------- | |
62 | ||
63 | procedure Debug_A_Entry (S : String; N : Node_Id) is | |
64 | begin | |
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 | ||
77 | Debug_A_Depth := Debug_A_Depth + 1; | |
78 | Current_Error_Node := N; | |
79 | ||
80 | if Debug_A_Depth <= Max_Node_Ids then | |
81 | Node_Ids (Debug_A_Depth) := N; | |
82 | end if; | |
83 | end Debug_A_Entry; | |
84 | ||
85 | ------------------ | |
86 | -- Debug_A_Exit -- | |
87 | ------------------ | |
88 | ||
89 | procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is | |
90 | begin | |
91 | Debug_A_Depth := Debug_A_Depth - 1; | |
92 | ||
93 | if Debug_A_Depth in 1 .. Max_Node_Ids then | |
94 | Current_Error_Node := Node_Ids (Debug_A_Depth); | |
95 | end if; | |
96 | ||
97 | if Debug_Flag_A then | |
98 | Debug_Output_Astring; | |
99 | Write_Str (S); | |
100 | Write_Str ("Node_Id = "); | |
101 | Write_Int (Int (N)); | |
102 | Write_Str (Comment); | |
103 | Write_Eol; | |
104 | end if; | |
105 | end Debug_A_Exit; | |
106 | ||
107 | -------------------------- | |
108 | -- Debug_Output_Astring -- | |
109 | -------------------------- | |
110 | ||
111 | procedure Debug_Output_Astring is | |
112 | Vbars : String := "|||||||||||||||||||||||||"; | |
113 | -- Should be constant, removed because of GNAT 1.78 bug ??? | |
114 | ||
115 | begin | |
116 | if Debug_A_Depth > Vbars'Length then | |
117 | for I in Vbars'Length .. Debug_A_Depth loop | |
118 | Write_Char ('|'); | |
119 | end loop; | |
120 | ||
121 | Write_Str (Vbars); | |
122 | ||
123 | else | |
124 | Write_Str (Vbars (1 .. Debug_A_Depth)); | |
125 | end if; | |
126 | end Debug_Output_Astring; | |
127 | ||
128 | end Debug_A; |