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

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

Add interpretation of record aggregate

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