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

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

Split subtype_indication into two

scalar_subtype_indication and composite_subtype_indication.
This allows have different types for "Up" property.
scalar_subtype_indication has Interpretation_Set_Index and
composite_subtype_indication has Interpretation_Tuple_List_Index.
"Up" property of scalar_subtype_indication should have the same
type as expression, because both of them are membership_choice.

File size: 13.9 KB
Line 
1with Ada.Containers.Hashed_Maps;
2with Gela.Element_Cloners;
3with Gela.Element_Visiters;
4with Gela.Elements.Component_Declarations;
5with Gela.Elements.Component_Items;
6with Gela.Elements.Composite_Subtype_Indications;
7with Gela.Elements.Defining_Identifiers;
8with Gela.Elements.Defining_Names;
9with Gela.Elements.Full_Type_Declarations;
10with Gela.Elements.Identifiers;
11with Gela.Elements.Record_Definitions;
12with Gela.Elements.Record_Type_Definitions;
13with Gela.Elements.Scalar_Subtype_Indications;
14with Gela.Elements.Selected_Components;
15with Gela.Elements.Subtype_Indications;
16with Gela.Elements.Subtype_Marks;
17with Gela.Environments;
18with Gela.Interpretations;
19with Gela.Lexical_Types;
20with Gela.Property_Getters;
21with Gela.Property_Resets;
22with Gela.Property_Setters;
23with Gela.Property_Visiters;
24
25package body Gela.Inheritance is
26
27 function Hash (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
28 return Ada.Containers.Hash_Type;
29
30 ----------
31 -- Hash --
32 ----------
33
34 function Hash (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
35 return Ada.Containers.Hash_Type is
36 begin
37 return Self.Hash;
38 end Hash;
39
40 package Name_Maps is new Ada.Containers.Hashed_Maps
41 (Key_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
42 Element_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
43 Hash => Hash,
44 Equivalent_Keys => Gela.Elements.Defining_Names."=",
45 "=" => Gela.Elements.Defining_Names."=");
46
47 package Cloners is
48
49 type Property_Getter is limited new Gela.Property_Getters.Getter with
50 record
51 Visiter : Gela.Property_Visiters.Visiter
52 (Property_Getter'Unchecked_Access);
53 end record;
54
55 type Cloner is new Gela.Element_Cloners.Cloner with record
56 Map : Name_Maps.Map;
57 Getter : Property_Getter;
58 end record;
59
60 overriding function Clone
61 (Self : in out Cloner;
62 Element : access Gela.Elements.Element'Class)
63 return Gela.Elements.Element_Access;
64
65 end Cloners;
66
67 package Setters is
68
69 type Property_Setter
70 (Source : Gela.Elements.Element_Access;
71 Cloner : access Cloners.Cloner)
72 is new Gela.Property_Resets.Property_Reset with null record;
73
74 overriding procedure On_Defining_Name
75 (Self : in out Property_Setter;
76 Element : Gela.Elements.Element_Access;
77 Value : out Gela.Elements.Defining_Names.
78 Defining_Name_Access);
79
80 overriding procedure On_Full_Name
81 (Self : in out Property_Setter;
82 Element : Gela.Elements.Element_Access;
83 Value : out Gela.Lexical_Types.Symbol);
84
85 overriding procedure On_Chosen_Interpretation
86 (Self : in out Property_Setter;
87 Element : Gela.Elements.Element_Access;
88 Value : out Gela.Interpretations.Interpretation_Kinds);
89
90 end Setters;
91
92 package body Cloners is
93
94 overriding function Clone
95 (Self : in out Cloner;
96 Element : access Gela.Elements.Element'Class)
97 return Gela.Elements.Element_Access
98 is
99 Result : Gela.Elements.Element_Access;
100 Setter : aliased Setters.Property_Setter
101 (Element, Self'Unchecked_Access);
102 Visiter : Gela.Property_Setters.Visiter (Setter'Access);
103 begin
104 if Element.Assigned then
105 Result := Gela.Element_Cloners.Cloner (Self).Clone (Element);
106 Result.Set_Part_Of_Inherited;
107 Result.Visit (Visiter);
108 end if;
109
110 return Result;
111 end Clone;
112
113 end Cloners;
114
115 package body Setters is
116
117 overriding procedure On_Chosen_Interpretation
118 (Self : in out Property_Setter;
119 Element : Gela.Elements.Element_Access;
120 Value : out Gela.Interpretations.Interpretation_Kinds)
121 is
122 pragma Unreferenced (Element);
123 begin
124 Self.Source.Visit (Self.Cloner.Getter.Visiter);
125 Value := Self.Cloner.Getter.Chosen_Interpretation;
126 Self.Cloner.Getter.Chosen_Interpretation :=
127 Self.Chosen_Interpretation;
128 end On_Chosen_Interpretation;
129
130 overriding procedure On_Defining_Name
131 (Self : in out Property_Setter;
132 Element : Gela.Elements.Element_Access;
133 Value : out Gela.Elements.Defining_Names.
134 Defining_Name_Access)
135 is
136 pragma Unreferenced (Element);
137
138 Cursor : Name_Maps.Cursor;
139 begin
140 Self.Source.Visit (Self.Cloner.Getter.Visiter);
141 Value := Self.Cloner.Getter.Defining_Name;
142 Self.Cloner.Getter.Defining_Name := null;
143
144 if Value.Assigned then
145 Cursor := Self.Cloner.Map.Find (Value);
146
147 if Name_Maps.Has_Element (Cursor) then
148 Value := Name_Maps.Element (Cursor);
149 end if;
150 end if;
151 end On_Defining_Name;
152
153 ------------------
154 -- On_Full_Name --
155 ------------------
156
157 overriding procedure On_Full_Name
158 (Self : in out Property_Setter;
159 Element : Gela.Elements.Element_Access;
160 Value : out Gela.Lexical_Types.Symbol)
161 is
162 pragma Unreferenced (Element);
163 begin
164 Self.Source.Visit (Self.Cloner.Getter.Visiter);
165 Value := Self.Cloner.Getter.Full_Name;
166 Self.Cloner.Getter.Full_Name := Self.Full_Name;
167 end On_Full_Name;
168
169 end Setters;
170
171 package Update_Env is
172 type Visiter is new Gela.Element_Visiters.Visiter with record
173 Set : Gela.Environments.Environment_Set_Access;
174 Env : Gela.Semantic_Types.Env_Index;
175 end record;
176
177 overriding procedure Component_Declaration
178 (Self : in out Visiter;
179 Node : not null Gela.Elements.Component_Declarations.
180 Component_Declaration_Access);
181
182 overriding procedure Defining_Identifier
183 (Self : in out Visiter;
184 Node : not null Gela.Elements.Defining_Identifiers.
185 Defining_Identifier_Access);
186 end Update_Env;
187
188 package body Update_Env is
189
190 overriding procedure Component_Declaration
191 (Self : in out Visiter;
192 Node : not null Gela.Elements.Component_Declarations.
193 Component_Declaration_Access)
194 is
195 Cursor : Gela.Elements.Defining_Identifiers.
196 Defining_Identifier_Sequence_Cursor := Node.Names.First;
197 begin
198 while Cursor.Has_Element loop
199 Cursor.Element.Visit (Self);
200 Cursor.Next;
201 end loop;
202 end Component_Declaration;
203
204 overriding procedure Defining_Identifier
205 (Self : in out Visiter;
206 Node : not null Gela.Elements.Defining_Identifiers.
207 Defining_Identifier_Access) is
208 begin
209 Self.Env := Self.Set.Add_Defining_Name
210 (Self.Env, Node.Full_Name, Node.all'Access);
211 end Defining_Identifier;
212
213 end Update_Env;
214
215 -----------------------
216 -- Copy_Declarations --
217 -----------------------
218
219 procedure Copy_Declarations
220 (Comp : Gela.Compilations.Compilation_Access;
221 Env : Gela.Semantic_Types.Env_Index;
222 Node : not null Gela.Elements.Derived_Type_Definitions.
223 Derived_Type_Definition_Access;
224 Inherited : out Gela.Elements.Element_Sequence_Access)
225 is
226 pragma Unreferenced (Env);
227 -- Put in the map (parent type name -> derived type name) to
228 -- replace possible T'Unchecked_Access.
229 -- If there is known discriminants put in the map
230 -- (old discriminant -> new discriminant) for each discriminant
231 -- according to constraint in subtype_indication.
232 -- Else clone known discriminants from parent if any.
233 -- Then clone components, entries and protected subprograms.
234
235 Parent : constant
236 Gela.Elements.Subtype_Indications.Subtype_Indication_Access :=
237 Node.Parent_Subtype_Indication;
238
239 package Each is
240 type Visiter is new Gela.Element_Visiters.Visiter with record
241 Parent_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
242 Parent_Declaration : Gela.Elements.Element_Access;
243 Components : Gela.Elements.Component_Items.
244 Component_Item_Sequence_Access;
245 end record;
246
247 overriding procedure Composite_Subtype_Indication
248 (Self : in out Visiter;
249 Node : not null Gela.Elements.Composite_Subtype_Indications.
250 Composite_Subtype_Indication_Access);
251
252 overriding procedure Scalar_Subtype_Indication
253 (Self : in out Visiter;
254 Node : not null Gela.Elements.Scalar_Subtype_Indications.
255 Scalar_Subtype_Indication_Access);
256
257 overriding procedure Identifier
258 (Self : in out Visiter;
259 Node : not null Gela.Elements.Identifiers.
260 Identifier_Access);
261
262 overriding procedure Selected_Component
263 (Self : in out Visiter;
264 Node : not null Gela.Elements.Selected_Components.
265 Selected_Component_Access);
266
267 overriding procedure Full_Type_Declaration
268 (Self : in out Visiter;
269 Node : not null Gela.Elements.Full_Type_Declarations.
270 Full_Type_Declaration_Access);
271
272 overriding procedure Record_Definition
273 (Self : in out Visiter;
274 Node : not null Gela.Elements.Record_Definitions.
275 Record_Definition_Access);
276
277 overriding procedure Record_Type_Definition
278 (Self : in out Visiter;
279 Node : not null Gela.Elements.Record_Type_Definitions.
280 Record_Type_Definition_Access);
281
282 overriding procedure Component_Declaration
283 (Self : in out Visiter;
284 Node : not null Gela.Elements.Component_Declarations.
285 Component_Declaration_Access);
286
287 end Each;
288
289 package body Each is
290
291 overriding procedure Component_Declaration
292 (Self : in out Visiter;
293 Node : not null Gela.Elements.Component_Declarations.
294 Component_Declaration_Access)
295 is
296 Cloner : Cloners.Cloner (Node.Enclosing_Compilation.Factory);
297 Item : Gela.Elements.Component_Items.Component_Item_Access;
298 begin
299 Node.Visit (Cloner);
300 Item := Gela.Elements.Component_Items.Component_Item_Access
301 (Cloner.Result);
302 Self.Components.Append (Item);
303 end Component_Declaration;
304
305 overriding procedure Composite_Subtype_Indication
306 (Self : in out Visiter;
307 Node : not null Gela.Elements.Composite_Subtype_Indications.
308 Composite_Subtype_Indication_Access) is
309 begin
310 Node.Subtype_Mark.Visit (Self);
311 end Composite_Subtype_Indication;
312
313 overriding procedure Full_Type_Declaration
314 (Self : in out Visiter;
315 Node : not null Gela.Elements.Full_Type_Declarations.
316 Full_Type_Declaration_Access) is
317 begin
318 Node.Type_Declaration_View.Visit (Self);
319 end Full_Type_Declaration;
320
321 overriding procedure Identifier
322 (Self : in out Visiter;
323 Node : not null Gela.Elements.Identifiers.
324 Identifier_Access) is
325 begin
326 Self.Parent_Name := Node.Defining_Name;
327
328 if Self.Parent_Name.Assigned then
329 Self.Parent_Declaration := Self.Parent_Name.Enclosing_Element;
330 Self.Parent_Declaration.Visit (Self);
331 end if;
332 end Identifier;
333
334 overriding procedure Record_Definition
335 (Self : in out Visiter;
336 Node : not null Gela.Elements.Record_Definitions.
337 Record_Definition_Access) is
338 begin
339 Self.Components := Comp.Factory.Component_Item_Sequence;
340
341 for J in Node.Record_Components.Each_Element loop
342 J.Element.Visit (Self);
343 end loop;
344 end Record_Definition;
345
346 overriding procedure Record_Type_Definition
347 (Self : in out Visiter;
348 Node : not null Gela.Elements.Record_Type_Definitions.
349 Record_Type_Definition_Access) is
350 begin
351 Node.Record_Definition.Visit (Self);
352 end Record_Type_Definition;
353
354 overriding procedure Scalar_Subtype_Indication
355 (Self : in out Visiter;
356 Node : not null Gela.Elements.Scalar_Subtype_Indications.
357 Scalar_Subtype_Indication_Access) is
358 begin
359 Node.Subtype_Mark.Visit (Self);
360 end Scalar_Subtype_Indication;
361
362 overriding procedure Selected_Component
363 (Self : in out Visiter;
364 Node : not null Gela.Elements.Selected_Components.
365 Selected_Component_Access) is
366 begin
367 Node.Selector.Visit (Self);
368 end Selected_Component;
369
370 end Each;
371
372 V : Each.Visiter;
373 begin
374 Inherited := Node.Inh_List;
375
376 if Inherited not in null then
377 return;
378 end if;
379 Parent.Visit (V);
380 Inherited := Gela.Elements.Element_Sequence_Access (V.Components);
381 end Copy_Declarations;
382
383 -----------------
384 -- Environment --
385 -----------------
386
387 procedure Environment
388 (Comp : Gela.Compilations.Compilation_Access;
389 Node : not null Gela.Elements.Derived_Type_Definitions.
390 Derived_Type_Definition_Access;
391 Env_In : Gela.Semantic_Types.Env_Index;
392 Env_Out : out Gela.Semantic_Types.Env_Index)
393 is
394 Inherited : Gela.Elements.Element_Sequence_Access := Node.Inh_List;
395 begin
396 if Inherited in null then
397 Copy_Declarations (Comp, Env_In, Node, Inherited);
398 Node.Set_Inh_List (Inherited);
399 end if;
400
401 if Inherited not in null then
402 declare
403 Visiter : Update_Env.Visiter;
404 begin
405 Visiter.Set := Comp.Context.Environment_Set;
406 Visiter.Env := Env_In;
407
408 for Cursor in Inherited.Each_Element loop
409 Cursor.Element.Visit (Visiter);
410 end loop;
411
412 Env_Out := Visiter.Env;
413 end;
414 else
415 Env_Out := Env_In;
416 end if;
417 end Environment;
418
419end Gela.Inheritance;
Note: See TracBrowser for help on using the repository browser.