source: trunk/ada-2012/src/semantic/gela-debug_properties.adb@ 384

Last change on this file since 384 was 384, checked in by Maxim Reznik, 6 years ago

Add --debug= parameter

When user specifies --debug=UP,DOWN,ENV_IN,ENV_OUT library will
dump corresponding attributes.

File size: 8.0 KB
Line 
1with Ada.Tags;
2with Gela.Compilations;
3with Gela.Elements.Defining_Names;
4with Gela.Interpretations;
5with Gela.Lexical_Types;
6with Gela.Property_Visiters;
7with Gela.Semantic_Types;
8
9package body Gela.Debug_Properties is
10
11 procedure Put_Line (Text : String);
12
13 package Dump_Property is
14
15 type Property is (Up, Down, Env_In, Env_Out);
16 pragma Unreferenced (Env_In, Env_Out);
17
18 type Property_Flags is array (Property) of Boolean;
19
20 type Property_Visiter is new Gela.Property_Visiters.Property_Visiter with
21 record
22 Flags : Property_Flags := (others => False);
23 end record;
24
25 overriding procedure On_Down
26 (Self : in out Property_Visiter;
27 Element : Gela.Elements.Element_Access;
28 Value : Gela.Interpretations.Interpretation_Index);
29
30 overriding procedure On_Up
31 (Self : in out Property_Visiter;
32 Element : Gela.Elements.Element_Access;
33 Value : Gela.Interpretations.Interpretation_Set_Index);
34
35 end Dump_Property;
36
37 package Dump_Interpretation is
38 type Visiter is new Gela.Interpretations.Visiter with record
39 Comp : not null Gela.Compilations.Compilation_Access;
40 end record;
41
42 overriding procedure On_Defining_Name
43 (Self : in out Visiter;
44 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
45 Down : Gela.Interpretations.Interpretation_Index_Array);
46
47 overriding procedure On_Expression
48 (Self : in out Visiter;
49 Tipe : Gela.Semantic_Types.Type_Index;
50 Down : Gela.Interpretations.Interpretation_Index_Array);
51
52 overriding procedure On_Attr_Function
53 (Self : in out Visiter;
54 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
55 Down : Gela.Interpretations.Interpretation_Index_Array);
56
57 overriding procedure On_Tuple
58 (Self : in out Visiter;
59 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
60 Down : Gela.Interpretations.Interpretation_Index_Array);
61
62 end Dump_Interpretation;
63
64 package body Dump_Property is
65 overriding procedure On_Down
66 (Self : in out Property_Visiter;
67 Element : Gela.Elements.Element_Access;
68 Value : Gela.Interpretations.Interpretation_Index)
69 is
70 Comp : constant Gela.Compilations.Compilation_Access :=
71 Element.Enclosing_Compilation;
72 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
73 Comp.Context.Interpretation_Manager;
74 IV : Dump_Interpretation.Visiter := (Comp => Comp);
75 begin
76 if Self.Flags (Down) = False then
77 return;
78 end if;
79
80 Put_Line
81 ("down:" &
82 Gela.Interpretations.Interpretation_Index'Image (Value));
83 IM.Visit (Value, IV);
84 end On_Down;
85
86 overriding procedure On_Up
87 (Self : in out Property_Visiter;
88 Element : Gela.Elements.Element_Access;
89 Value : Gela.Interpretations.Interpretation_Set_Index)
90 is
91 Comp : constant Gela.Compilations.Compilation_Access :=
92 Element.Enclosing_Compilation;
93 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
94 Comp.Context.Interpretation_Manager;
95 IV : aliased Dump_Interpretation.Visiter := (Comp => Comp);
96 Pos : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Value);
97 begin
98 if Self.Flags (Up) = False then
99 return;
100 end if;
101
102 Put_Line
103 ("up:" &
104 Gela.Interpretations.Interpretation_Set_Index'Image (Value));
105
106 while Pos.Has_Element loop
107 Put_Line
108 (" INDEX:" &
109 Gela.Interpretations.Interpretation_Index'Image
110 (Pos.Get_Index));
111 Pos.Visit (IV'Access);
112 Pos.Next;
113 end loop;
114 end On_Up;
115
116 end Dump_Property;
117
118 package body Dump_Interpretation is
119
120 overriding procedure On_Defining_Name
121 (Self : in out Visiter;
122 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
123 Down : Gela.Interpretations.Interpretation_Index_Array)
124 is
125 Symbol : constant Gela.Lexical_Types.Symbol := Name.Full_Name;
126 begin
127 Put_Line
128 (" Defining_Name " &
129 Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
130
131 for J of Down loop
132 Put_Line
133 (" DOWN" &
134 Gela.Interpretations.Interpretation_Index'Image (J));
135 end loop;
136 end On_Defining_Name;
137
138 overriding procedure On_Expression
139 (Self : in out Visiter;
140 Tipe : Gela.Semantic_Types.Type_Index;
141 Down : Gela.Interpretations.Interpretation_Index_Array)
142 is
143 pragma Unreferenced (Self, Tipe);
144 begin
145 Put_Line
146 (" Expression ");
147
148 for J of Down loop
149 Put_Line
150 (" DOWN" &
151 Gela.Interpretations.Interpretation_Index'Image (J));
152 end loop;
153 end On_Expression;
154
155 overriding procedure On_Attr_Function
156 (Self : in out Visiter;
157 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
158 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
159
160 overriding procedure On_Tuple
161 (Self : in out Visiter;
162 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
163 Down : Gela.Interpretations.Interpretation_Index_Array)
164 is
165 pragma Unreferenced (Self);
166 begin
167 Put_Line (" Tuple");
168
169 for J of Value loop
170 Put_Line
171 (" " &
172 Gela.Interpretations.Interpretation_Set_Index'Image (J));
173 end loop;
174
175 for J of Down loop
176 Put_Line
177 (" DOWN" &
178 Gela.Interpretations.Interpretation_Index'Image (J));
179 end loop;
180 end On_Tuple;
181
182 end Dump_Interpretation;
183
184 procedure Dump
185 (Element : Gela.Elements.Element_Access;
186 PV : access Dump_Property.Property_Visiter;
187 EV : in out Gela.Property_Visiters.Visiter);
188
189 ----------
190 -- Dump --
191 ----------
192
193 procedure Dump
194 (Element : Gela.Elements.Element_Access;
195 PV : access Dump_Property.Property_Visiter;
196 EV : in out Gela.Property_Visiters.Visiter) is
197 begin
198 if not Element.Assigned then
199 return;
200 end if;
201
202 declare
203 N : constant Gela.Elements.Nested_Array := Element.Nested_Items;
204 begin
205 Put_Line (Ada.Tags.Expanded_Name (Element'Tag));
206 Element.Visit (EV);
207
208 for J of N loop
209 case J.Kind is
210 when Gela.Elements.Nested_Element =>
211 Dump (J.Nested_Element, PV, EV);
212 when Gela.Elements.Nested_Sequence =>
213 declare
214 Pos : Gela.Elements.Element_Sequence_Cursor :=
215 J.Nested_Sequence.First;
216 begin
217 while Pos.Has_Element loop
218 Dump (Pos.Element, PV, EV);
219 Pos.Next;
220 end loop;
221 end;
222 when Gela.Elements.Nested_Token =>
223 null;
224 end case;
225 end loop;
226 end;
227 end Dump;
228
229 ----------
230 -- Dump --
231 ----------
232
233 procedure Dump
234 (Element : Gela.Elements.Element_Access;
235 Debug : League.Strings.Universal_String)
236 is
237 PV : aliased Dump_Property.Property_Visiter;
238 EV : Gela.Property_Visiters.Visiter (PV'Access);
239 begin
240 for J in Dump_Property.Property loop
241 if Debug.Index (Dump_Property.Property'Wide_Wide_Image (J)) > 0 then
242 PV.Flags (J) := True;
243 end if;
244 end loop;
245
246 Dump (Element, PV'Access, EV);
247 end Dump;
248
249 --------------
250 -- Put_Line --
251 --------------
252
253 procedure Put_Line (Text : String) is
254 procedure puts (Text : String);
255 pragma Import (C, puts, "puts");
256 begin
257 puts (Text & Character'Val (0));
258 end Put_Line;
259
260end Gela.Debug_Properties;
Note: See TracBrowser for help on using the repository browser.