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

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

Generate Gela.Property_Visiters

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