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

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

Drop Cursor and Visiter for up interpretation set.

Replace it with Any_Cursor and iterator.

  • Property svn:keywords set to Author Date Revision
File size: 17.1 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;
10with Gela.Types;
11with Gela.Type_Managers;
12with Gela.Types.Visitors;
13with Gela.Types.Simple;
14with Gela.Types.Arrays;
15with Gela.Types.Untagged_Records;
16
17package body Gela.Debug_Properties is
18
19 procedure Put_Line (Text : String);
20
21 procedure Put_Expression (Text : String);
22
23 package Dump_Type is
24 type Type_Visitor (Put_Line : access procedure (Text : String)) is
25 new Gela.Types.Visitors.Type_Visitor with null record;
26
27 overriding procedure Enumeration_Type
28 (Self : in out Type_Visitor;
29 Value : not null Gela.Types.Simple.Enumeration_Type_Access);
30
31 overriding procedure Signed_Integer_Type
32 (Self : in out Type_Visitor;
33 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
34
35 overriding procedure Floating_Point_Type
36 (Self : in out Type_Visitor;
37 Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
38
39 overriding procedure Array_Type
40 (Self : in out Type_Visitor;
41 Value : not null Gela.Types.Arrays.Array_Type_Access);
42
43 overriding procedure Untagged_Record
44 (Self : in out Type_Visitor;
45 Value : not null Gela.Types.Untagged_Records
46 .Untagged_Record_Type_Access);
47
48 overriding procedure Object_Access_Type
49 (Self : in out Type_Visitor;
50 Value : not null Gela.Types.Simple.Object_Access_Type_Access);
51
52 overriding procedure Subprogram_Access_Type
53 (Self : in out Type_Visitor;
54 Value : not null Gela.Types.Simple.Subprogram_Access_Type_Access);
55
56 end Dump_Type;
57
58 package Dump_Property is
59
60 type Property is (Up, Down, Env_In, Env_Out, Full_Name);
61
62 type Property_Flags is array (Property) of Boolean;
63
64 type Property_Visiter is new Gela.Property_Visiters.Property_Visiter with
65 record
66 Flags : Property_Flags := (others => False);
67 end record;
68
69 overriding procedure On_Down
70 (Self : in out Property_Visiter;
71 Element : Gela.Elements.Element_Access;
72 Value : Gela.Interpretations.Interpretation_Index);
73
74 overriding procedure On_Env_In
75 (Self : in out Property_Visiter;
76 Element : Gela.Elements.Element_Access;
77 Value : Gela.Semantic_Types.Env_Index);
78
79 overriding procedure On_Env_Out
80 (Self : in out Property_Visiter;
81 Element : Gela.Elements.Element_Access;
82 Value : Gela.Semantic_Types.Env_Index);
83
84 overriding procedure On_Full_Name
85 (Self : in out Property_Visiter;
86 Element : Gela.Elements.Element_Access;
87 Value : Gela.Lexical_Types.Symbol);
88
89 overriding procedure On_Up
90 (Self : in out Property_Visiter;
91 Element : Gela.Elements.Element_Access;
92 Value : Gela.Interpretations.Interpretation_Set_Index);
93
94 end Dump_Property;
95
96 package Dump_Interpretation is
97 type Visiter is new Gela.Interpretations.Down_Visiter with record
98 Comp : not null Gela.Compilations.Compilation_Access;
99 end record;
100
101 overriding procedure On_Defining_Name
102 (Self : in out Visiter;
103 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
104 Down : Gela.Interpretations.Interpretation_Index_Array);
105
106 overriding procedure On_Expression
107 (Self : in out Visiter;
108 Tipe : Gela.Semantic_Types.Type_Index;
109 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
110 Down : Gela.Interpretations.Interpretation_Index_Array);
111
112 overriding procedure On_Expression_Category
113 (Self : in out Visiter;
114 Match : not null Gela.Interpretations.Type_Matcher_Access;
115 Down : Gela.Interpretations.Interpretation_Index_Array);
116
117 overriding procedure On_Attr_Function
118 (Self : in out Visiter;
119 Tipe : Gela.Semantic_Types.Type_Index;
120 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
121 Down : Gela.Interpretations.Interpretation_Index_Array);
122
123 overriding procedure On_Tuple
124 (Self : in out Visiter;
125 Down : Gela.Interpretations.Interpretation_Index_Array);
126
127 end Dump_Interpretation;
128
129 package body Dump_Property is
130 overriding procedure On_Down
131 (Self : in out Property_Visiter;
132 Element : Gela.Elements.Element_Access;
133 Value : Gela.Interpretations.Interpretation_Index)
134 is
135 Comp : constant Gela.Compilations.Compilation_Access :=
136 Element.Enclosing_Compilation;
137 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
138 Comp.Context.Interpretation_Manager;
139 IV : Dump_Interpretation.Visiter := (Comp => Comp);
140 begin
141 if Self.Flags (Down) = False then
142 return;
143 end if;
144
145 Put_Line
146 ("down:" &
147 Gela.Interpretations.Interpretation_Index'Image (Value));
148 IM.Visit (Value, IV);
149 end On_Down;
150
151 overriding procedure On_Env_In
152 (Self : in out Property_Visiter;
153 Element : Gela.Elements.Element_Access;
154 Value : Gela.Semantic_Types.Env_Index)
155 is
156 Comp : constant Gela.Compilations.Compilation_Access :=
157 Element.Enclosing_Compilation;
158 Env : constant Gela.Environments.Environment_Set_Access :=
159 Comp.Context.Environment_Set;
160 begin
161 if Self.Flags (Env_In) = False then
162 return;
163 end if;
164
165 Put_Line
166 ("env_in:" &
167 Gela.Semantic_Types.Env_Index'Image (Value));
168
169 Gela.Plain_Environments.Debug
170 (Gela.Plain_Environments.Plain_Environment_Set_Access (Env),
171 Value);
172 end On_Env_In;
173
174 overriding procedure On_Env_Out
175 (Self : in out Property_Visiter;
176 Element : Gela.Elements.Element_Access;
177 Value : Gela.Semantic_Types.Env_Index)
178 is
179 Comp : constant Gela.Compilations.Compilation_Access :=
180 Element.Enclosing_Compilation;
181 Env : constant Gela.Environments.Environment_Set_Access :=
182 Comp.Context.Environment_Set;
183 begin
184 if Self.Flags (Env_Out) = False then
185 return;
186 end if;
187
188 Put_Line
189 ("env_out:" &
190 Gela.Semantic_Types.Env_Index'Image (Value));
191
192 Gela.Plain_Environments.Debug
193 (Gela.Plain_Environments.Plain_Environment_Set_Access (Env),
194 Value);
195 end On_Env_Out;
196
197 overriding procedure On_Full_Name
198 (Self : in out Property_Visiter;
199 Element : Gela.Elements.Element_Access;
200 Value : Gela.Lexical_Types.Symbol)
201 is
202 pragma Unreferenced (Element);
203 begin
204 if Self.Flags (Full_Name) = False then
205 return;
206 end if;
207
208 Put_Line
209 ("full_name:" &
210 Gela.Lexical_Types.Symbol'Image (Value));
211 end On_Full_Name;
212
213 overriding procedure On_Up
214 (Self : in out Property_Visiter;
215 Element : Gela.Elements.Element_Access;
216 Value : Gela.Interpretations.Interpretation_Set_Index)
217 is
218 Comp : constant Gela.Compilations.Compilation_Access :=
219 Element.Enclosing_Compilation;
220 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
221 Comp.Context.Interpretation_Manager;
222 TM : constant Gela.Type_Managers.Type_Manager_Access :=
223 Comp.Context.Types;
224 begin
225 if Self.Flags (Up) = False then
226 return;
227 end if;
228
229 Put_Line
230 ("up:" &
231 Gela.Interpretations.Interpretation_Set_Index'Image (Value));
232
233 for J in IM.Each (Value) loop
234 Put_Line
235 (" INDEX:" &
236 Gela.Interpretations.Interpretation_Index'Image
237 (J.Get_Index));
238
239 if J.Is_Defining_Name then
240 declare
241 Name : constant Gela.Elements.Defining_Names.
242 Defining_Name_Access := J.Defining_Name;
243 Symbol : constant Gela.Lexical_Types.Symbol :=
244 Name.Full_Name;
245 begin
246 Put_Line
247 (" Defining_Name " &
248 Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
249 end;
250 elsif J.Is_Expression then
251 declare
252 use type Gela.Semantic_Types.Type_Index;
253 use type Gela.Types.Type_View_Access;
254
255 Tipe : constant Gela.Semantic_Types.Type_Index :=
256 J.Expression_Type;
257 View : Gela.Types.Type_View_Access;
258 DT : Dump_Type.Type_Visitor (Put_Expression'Access);
259 begin
260 if Tipe /= 0 then
261 View := TM.Get (Tipe);
262 end if;
263
264 if View = null then
265 Put_Line (" Expression NULL");
266 else
267 View.Visit (DT);
268 end if;
269 end;
270 elsif J.Is_Expression_Category then
271 Put_Line (" Expression_Category: ");
272 elsif J.Is_Symbol then
273 Put_Line
274 (" Symbol " &
275 Comp.Context.Symbols.Image (J.Symbol).To_UTF_8_String);
276 elsif J.Is_Profile then
277 Put_Line
278 (" Attr_Function " &
279 Comp.Context.Symbols.Image (J.Attribute_Kind).
280 To_UTF_8_String);
281 end if;
282 end loop;
283 end On_Up;
284
285 end Dump_Property;
286
287 package body Dump_Interpretation is
288
289 overriding procedure On_Defining_Name
290 (Self : in out Visiter;
291 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
292 Down : Gela.Interpretations.Interpretation_Index_Array)
293 is
294 Symbol : constant Gela.Lexical_Types.Symbol := Name.Full_Name;
295 begin
296 Put_Line
297 (" Defining_Name " &
298 Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
299
300 for J of Down loop
301 Put_Line
302 (" DOWN" &
303 Gela.Interpretations.Interpretation_Index'Image (J));
304 end loop;
305 end On_Defining_Name;
306
307 overriding procedure On_Expression
308 (Self : in out Visiter;
309 Tipe : Gela.Semantic_Types.Type_Index;
310 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
311 Down : Gela.Interpretations.Interpretation_Index_Array)
312 is
313 use type Gela.Semantic_Types.Type_Index;
314 use type Gela.Types.Type_View_Access;
315
316 TM : constant Gela.Type_Managers.Type_Manager_Access :=
317 Self.Comp.Context.Types;
318 View : Gela.Types.Type_View_Access;
319 DT : Dump_Type.Type_Visitor (Put_Expression'Access);
320 begin
321 if Tipe /= 0 then
322 View := TM.Get (Tipe);
323 end if;
324
325 if View = null then
326 Put_Line (" Expression NULL");
327 else
328 View.Visit (DT);
329 end if;
330
331 Put_Line
332 (" Kind:" &
333 Gela.Interpretations.Interpretation_Kinds'Image (Kind));
334
335 for J of Down loop
336 Put_Line
337 (" DOWN" &
338 Gela.Interpretations.Interpretation_Index'Image (J));
339 end loop;
340 end On_Expression;
341
342 overriding procedure On_Expression_Category
343 (Self : in out Visiter;
344 Match : not null Gela.Interpretations.Type_Matcher_Access;
345 Down : Gela.Interpretations.Interpretation_Index_Array)
346 is
347 pragma Unreferenced (Self, Match);
348 begin
349 Put_Line (" Expression_Category: ");
350
351 for J of Down loop
352 Put_Line
353 (" DOWN" &
354 Gela.Interpretations.Interpretation_Index'Image (J));
355 end loop;
356 end On_Expression_Category;
357
358 overriding procedure On_Attr_Function
359 (Self : in out Visiter;
360 Tipe : Gela.Semantic_Types.Type_Index;
361 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
362 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
363
364 overriding procedure On_Tuple
365 (Self : in out Visiter;
366 Down : Gela.Interpretations.Interpretation_Index_Array)
367 is
368 pragma Unreferenced (Self);
369 begin
370 Put_Line (" Tuple");
371
372 for J of Down loop
373 Put_Line
374 (" DOWN" &
375 Gela.Interpretations.Interpretation_Index'Image (J));
376 end loop;
377 end On_Tuple;
378
379 end Dump_Interpretation;
380
381
382 package body Dump_Type is
383
384 overriding procedure Enumeration_Type
385 (Self : in out Type_Visitor;
386 Value : not null Gela.Types.Simple.Enumeration_Type_Access)
387 is
388 begin
389 if Value.Is_Character then
390 Self.Put_Line ("Character");
391 else
392 Self.Put_Line ("Enumeration");
393 end if;
394 end Enumeration_Type;
395
396 overriding procedure Signed_Integer_Type
397 (Self : in out Type_Visitor;
398 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access) is
399 begin
400 if Value.Is_Universal then
401 Self.Put_Line ("Universal_Integer");
402 else
403 Self.Put_Line ("Signed_Integer");
404 end if;
405 end Signed_Integer_Type;
406
407 overriding procedure Floating_Point_Type
408 (Self : in out Type_Visitor;
409 Value : not null Gela.Types.Simple.Floating_Point_Type_Access) is
410 begin
411 if Value.Is_Universal then
412 Self.Put_Line ("Universal_Real");
413 else
414 Self.Put_Line ("Floating_Point");
415 end if;
416 end Floating_Point_Type;
417
418 overriding procedure Array_Type
419 (Self : in out Type_Visitor;
420 Value : not null Gela.Types.Arrays.Array_Type_Access)
421 is
422 pragma Unreferenced (Value);
423 begin
424 Self.Put_Line ("Array");
425 end Array_Type;
426
427 overriding procedure Untagged_Record
428 (Self : in out Type_Visitor;
429 Value : not null Gela.Types.Untagged_Records
430 .Untagged_Record_Type_Access)
431 is
432 pragma Unreferenced (Value);
433 begin
434 Self.Put_Line ("Untagged_Record");
435 end Untagged_Record;
436
437 overriding procedure Object_Access_Type
438 (Self : in out Type_Visitor;
439 Value : not null Gela.Types.Simple.Object_Access_Type_Access)
440 is
441 pragma Unreferenced (Value);
442 begin
443 Self.Put_Line ("Object_Access");
444 end Object_Access_Type;
445
446 overriding procedure Subprogram_Access_Type
447 (Self : in out Type_Visitor;
448 Value : not null Gela.Types.Simple.Subprogram_Access_Type_Access)
449 is
450 pragma Unreferenced (Value);
451 begin
452 Self.Put_Line ("Subprogram_Access");
453 end Subprogram_Access_Type;
454
455 end Dump_Type;
456
457
458 procedure Dump
459 (Element : Gela.Elements.Element_Access;
460 PV : access Dump_Property.Property_Visiter;
461 EV : in out Gela.Property_Visiters.Visiter);
462
463 ----------
464 -- Dump --
465 ----------
466
467 procedure Dump
468 (Element : Gela.Elements.Element_Access;
469 PV : access Dump_Property.Property_Visiter;
470 EV : in out Gela.Property_Visiters.Visiter) is
471 begin
472 if not Element.Assigned then
473 return;
474 end if;
475
476 declare
477 N : constant Gela.Elements.Nested_Array := Element.Nested_Items;
478 begin
479 Put_Line (Ada.Tags.Expanded_Name (Element'Tag));
480 Element.Visit (EV);
481
482 for J of N loop
483 case J.Kind is
484 when Gela.Elements.Nested_Element =>
485 Dump (J.Nested_Element, PV, EV);
486 when Gela.Elements.Nested_Sequence =>
487 declare
488 Pos : Gela.Elements.Element_Sequence_Cursor :=
489 J.Nested_Sequence.First;
490 begin
491 while Pos.Has_Element loop
492 Dump (Pos.Element, PV, EV);
493 Pos.Next;
494 end loop;
495 end;
496 when Gela.Elements.Nested_Token =>
497 null;
498 end case;
499 end loop;
500 end;
501 end Dump;
502
503 ----------
504 -- Dump --
505 ----------
506
507 procedure Dump
508 (Element : Gela.Elements.Element_Access;
509 Debug : League.Strings.Universal_String)
510 is
511 PV : aliased Dump_Property.Property_Visiter;
512 EV : Gela.Property_Visiters.Visiter (PV'Access);
513 begin
514 for J in Dump_Property.Property loop
515 if Debug.Index (Dump_Property.Property'Wide_Wide_Image (J)) > 0 then
516 PV.Flags (J) := True;
517 end if;
518 end loop;
519
520 Dump (Element, PV'Access, EV);
521 end Dump;
522
523 --------------------
524 -- Put_Expression --
525 --------------------
526
527 procedure Put_Expression (Text : String) is
528 begin
529 Put_Line (" Expression " & Text);
530 end Put_Expression;
531
532 --------------
533 -- Put_Line --
534 --------------
535
536 procedure Put_Line (Text : String) is
537 procedure puts (Text : String);
538 pragma Import (C, puts, "puts");
539 begin
540 puts (Text & Character'Val (0));
541 end Put_Line;
542
543end Gela.Debug_Properties;
Note: See TracBrowser for help on using the repository browser.