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

Last change on this file since 398 was 398, checked in by Maxim Reznik, 5 years ago

Create completion region for package_body

File size: 11.0 KB
Line 
1with Ada.Tags;
2with Gela.Compilations;
3with Gela.Elements.Defining_Names;
4with Gela.Environments;
5with Gela.Interpretations;
6with Gela.Lexical_Types;
7with Gela.Plain_Environments.Debug;
8with Gela.Property_Visiters;
9with Gela.Semantic_Types;
10
11package body Gela.Debug_Properties is
12
13 procedure Put_Line (Text : String);
14
15 package Dump_Property is
16
17 type Property is (Up, Down, Env_In, Env_Out, Full_Name);
18
19 type Property_Flags is array (Property) of Boolean;
20
21 type Property_Visiter is new Gela.Property_Visiters.Property_Visiter with
22 record
23 Flags : Property_Flags := (others => False);
24 end record;
25
26 overriding procedure On_Down
27 (Self : in out Property_Visiter;
28 Element : Gela.Elements.Element_Access;
29 Value : Gela.Interpretations.Interpretation_Index);
30
31 overriding procedure On_Env_In
32 (Self : in out Property_Visiter;
33 Element : Gela.Elements.Element_Access;
34 Value : Gela.Semantic_Types.Env_Index);
35
36 overriding procedure On_Env_Out
37 (Self : in out Property_Visiter;
38 Element : Gela.Elements.Element_Access;
39 Value : Gela.Semantic_Types.Env_Index);
40
41 overriding procedure On_Full_Name
42 (Self : in out Property_Visiter;
43 Element : Gela.Elements.Element_Access;
44 Value : Gela.Lexical_Types.Symbol);
45
46 overriding procedure On_Up
47 (Self : in out Property_Visiter;
48 Element : Gela.Elements.Element_Access;
49 Value : Gela.Interpretations.Interpretation_Set_Index);
50
51 end Dump_Property;
52
53 package Dump_Interpretation is
54 type Visiter is new Gela.Interpretations.Visiter with record
55 Comp : not null Gela.Compilations.Compilation_Access;
56 end record;
57
58 overriding procedure On_Defining_Name
59 (Self : in out Visiter;
60 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
61 Down : Gela.Interpretations.Interpretation_Index_Array);
62
63 overriding procedure On_Expression
64 (Self : in out Visiter;
65 Tipe : Gela.Semantic_Types.Type_Index;
66 Down : Gela.Interpretations.Interpretation_Index_Array);
67
68 overriding procedure On_Attr_Function
69 (Self : in out Visiter;
70 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
71 Down : Gela.Interpretations.Interpretation_Index_Array);
72
73 overriding procedure On_Symbol
74 (Self : in out Visiter;
75 Symbol : Gela.Lexical_Types.Symbol;
76 Down : Gela.Interpretations.Interpretation_Index_Array);
77
78 overriding procedure On_Tuple
79 (Self : in out Visiter;
80 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
81 Down : Gela.Interpretations.Interpretation_Index_Array);
82
83 end Dump_Interpretation;
84
85 package body Dump_Property is
86 overriding procedure On_Down
87 (Self : in out Property_Visiter;
88 Element : Gela.Elements.Element_Access;
89 Value : Gela.Interpretations.Interpretation_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 : Dump_Interpretation.Visiter := (Comp => Comp);
96 begin
97 if Self.Flags (Down) = False then
98 return;
99 end if;
100
101 Put_Line
102 ("down:" &
103 Gela.Interpretations.Interpretation_Index'Image (Value));
104 IM.Visit (Value, IV);
105 end On_Down;
106
107 overriding procedure On_Env_In
108 (Self : in out Property_Visiter;
109 Element : Gela.Elements.Element_Access;
110 Value : Gela.Semantic_Types.Env_Index)
111 is
112 Comp : constant Gela.Compilations.Compilation_Access :=
113 Element.Enclosing_Compilation;
114 Env : constant Gela.Environments.Environment_Set_Access :=
115 Comp.Context.Environment_Set;
116 begin
117 if Self.Flags (Env_In) = False then
118 return;
119 end if;
120
121 Put_Line
122 ("env_in:" &
123 Gela.Semantic_Types.Env_Index'Image (Value));
124
125 Gela.Plain_Environments.Debug
126 (Gela.Plain_Environments.Plain_Environment_Set_Access (Env),
127 Value);
128 end On_Env_In;
129
130 overriding procedure On_Env_Out
131 (Self : in out Property_Visiter;
132 Element : Gela.Elements.Element_Access;
133 Value : Gela.Semantic_Types.Env_Index)
134 is
135 Comp : constant Gela.Compilations.Compilation_Access :=
136 Element.Enclosing_Compilation;
137 Env : constant Gela.Environments.Environment_Set_Access :=
138 Comp.Context.Environment_Set;
139 begin
140 if Self.Flags (Env_Out) = False then
141 return;
142 end if;
143
144 Put_Line
145 ("env_out:" &
146 Gela.Semantic_Types.Env_Index'Image (Value));
147
148 Gela.Plain_Environments.Debug
149 (Gela.Plain_Environments.Plain_Environment_Set_Access (Env),
150 Value);
151 end On_Env_Out;
152
153 overriding procedure On_Full_Name
154 (Self : in out Property_Visiter;
155 Element : Gela.Elements.Element_Access;
156 Value : Gela.Lexical_Types.Symbol)
157 is
158 pragma Unreferenced (Element);
159 begin
160 if Self.Flags (Full_Name) = False then
161 return;
162 end if;
163
164 Put_Line
165 ("full_name:" &
166 Gela.Lexical_Types.Symbol'Image (Value));
167 end On_Full_Name;
168
169 overriding procedure On_Up
170 (Self : in out Property_Visiter;
171 Element : Gela.Elements.Element_Access;
172 Value : Gela.Interpretations.Interpretation_Set_Index)
173 is
174 Comp : constant Gela.Compilations.Compilation_Access :=
175 Element.Enclosing_Compilation;
176 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
177 Comp.Context.Interpretation_Manager;
178 IV : aliased Dump_Interpretation.Visiter := (Comp => Comp);
179 Pos : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Value);
180 begin
181 if Self.Flags (Up) = False then
182 return;
183 end if;
184
185 Put_Line
186 ("up:" &
187 Gela.Interpretations.Interpretation_Set_Index'Image (Value));
188
189 while Pos.Has_Element loop
190 Put_Line
191 (" INDEX:" &
192 Gela.Interpretations.Interpretation_Index'Image
193 (Pos.Get_Index));
194 Pos.Visit (IV'Access);
195 Pos.Next;
196 end loop;
197 end On_Up;
198
199 end Dump_Property;
200
201 package body Dump_Interpretation is
202
203 overriding procedure On_Defining_Name
204 (Self : in out Visiter;
205 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
206 Down : Gela.Interpretations.Interpretation_Index_Array)
207 is
208 Symbol : constant Gela.Lexical_Types.Symbol := Name.Full_Name;
209 begin
210 Put_Line
211 (" Defining_Name " &
212 Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
213
214 for J of Down loop
215 Put_Line
216 (" DOWN" &
217 Gela.Interpretations.Interpretation_Index'Image (J));
218 end loop;
219 end On_Defining_Name;
220
221 overriding procedure On_Expression
222 (Self : in out Visiter;
223 Tipe : Gela.Semantic_Types.Type_Index;
224 Down : Gela.Interpretations.Interpretation_Index_Array)
225 is
226 pragma Unreferenced (Self, Tipe);
227 begin
228 Put_Line
229 (" Expression ");
230
231 for J of Down loop
232 Put_Line
233 (" DOWN" &
234 Gela.Interpretations.Interpretation_Index'Image (J));
235 end loop;
236 end On_Expression;
237
238 overriding procedure On_Attr_Function
239 (Self : in out Visiter;
240 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
241 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
242
243 overriding procedure On_Symbol
244 (Self : in out Visiter;
245 Symbol : Gela.Lexical_Types.Symbol;
246 Down : Gela.Interpretations.Interpretation_Index_Array)
247 is
248 pragma Unreferenced (Down);
249 begin
250 Put_Line
251 (" Symbol " &
252 Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
253 end On_Symbol;
254
255 overriding procedure On_Tuple
256 (Self : in out Visiter;
257 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
258 Down : Gela.Interpretations.Interpretation_Index_Array)
259 is
260 pragma Unreferenced (Self);
261 begin
262 Put_Line (" Tuple");
263
264 for J of Value loop
265 Put_Line
266 (" " &
267 Gela.Interpretations.Interpretation_Set_Index'Image (J));
268 end loop;
269
270 for J of Down loop
271 Put_Line
272 (" DOWN" &
273 Gela.Interpretations.Interpretation_Index'Image (J));
274 end loop;
275 end On_Tuple;
276
277 end Dump_Interpretation;
278
279 procedure Dump
280 (Element : Gela.Elements.Element_Access;
281 PV : access Dump_Property.Property_Visiter;
282 EV : in out Gela.Property_Visiters.Visiter);
283
284 ----------
285 -- Dump --
286 ----------
287
288 procedure Dump
289 (Element : Gela.Elements.Element_Access;
290 PV : access Dump_Property.Property_Visiter;
291 EV : in out Gela.Property_Visiters.Visiter) is
292 begin
293 if not Element.Assigned then
294 return;
295 end if;
296
297 declare
298 N : constant Gela.Elements.Nested_Array := Element.Nested_Items;
299 begin
300 Put_Line (Ada.Tags.Expanded_Name (Element'Tag));
301 Element.Visit (EV);
302
303 for J of N loop
304 case J.Kind is
305 when Gela.Elements.Nested_Element =>
306 Dump (J.Nested_Element, PV, EV);
307 when Gela.Elements.Nested_Sequence =>
308 declare
309 Pos : Gela.Elements.Element_Sequence_Cursor :=
310 J.Nested_Sequence.First;
311 begin
312 while Pos.Has_Element loop
313 Dump (Pos.Element, PV, EV);
314 Pos.Next;
315 end loop;
316 end;
317 when Gela.Elements.Nested_Token =>
318 null;
319 end case;
320 end loop;
321 end;
322 end Dump;
323
324 ----------
325 -- Dump --
326 ----------
327
328 procedure Dump
329 (Element : Gela.Elements.Element_Access;
330 Debug : League.Strings.Universal_String)
331 is
332 PV : aliased Dump_Property.Property_Visiter;
333 EV : Gela.Property_Visiters.Visiter (PV'Access);
334 begin
335 for J in Dump_Property.Property loop
336 if Debug.Index (Dump_Property.Property'Wide_Wide_Image (J)) > 0 then
337 PV.Flags (J) := True;
338 end if;
339 end loop;
340
341 Dump (Element, PV'Access, EV);
342 end Dump;
343
344 --------------
345 -- Put_Line --
346 --------------
347
348 procedure Put_Line (Text : String) is
349 procedure puts (Text : String);
350 pragma Import (C, puts, "puts");
351 begin
352 puts (Text & Character'Val (0));
353 end Put_Line;
354
355end Gela.Debug_Properties;
Note: See TracBrowser for help on using the repository browser.