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

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

Separate Property_Reset and Property_Getter

from Gela.Instantiation to their-own packages.

  • Property svn:keywords set to Author Date Revision
File size: 12.5 KB
Line 
1with Ada.Containers.Hashed_Maps;
2
3with Gela.Element_Cloners;
4with Gela.Element_Visiters;
5with Gela.Lexical_Types;
6with Gela.Property_Getters;
7with Gela.Property_Resets;
8with Gela.Property_Setters;
9with Gela.Property_Visiters;
10
11with Gela.Elements.Basic_Declarative_Items;
12with Gela.Elements.Defining_Identifiers;
13with Gela.Elements.Defining_Names;
14with Gela.Elements.Full_Type_Declarations;
15with Gela.Elements.Generic_Package_Declarations;
16with Gela.Elements.Object_Declarations;
17with Gela.Elements.Subtype_Declarations;
18with Gela.Interpretations;
19with Gela.Environments;
20
21package body Gela.Instantiation is
22
23 function Hash (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
24 return Ada.Containers.Hash_Type;
25
26 ----------
27 -- Hash --
28 ----------
29
30 function Hash (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
31 return Ada.Containers.Hash_Type is
32 begin
33 return Self.Hash;
34 end Hash;
35
36 package Name_Maps is new Ada.Containers.Hashed_Maps
37 (Key_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
38 Element_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
39 Hash => Hash,
40 Equivalent_Keys => Gela.Elements.Defining_Names."=",
41 "=" => Gela.Elements.Defining_Names."=");
42
43 package Cloners is
44 type Property_Getter is limited new Gela.Property_Getters.Getter with
45 record
46 Visiter : Gela.Property_Visiters.Visiter
47 (Property_Getter'Unchecked_Access);
48 end record;
49
50 type Cloner is new Gela.Element_Cloners.Cloner with record
51 Map : Name_Maps.Map;
52 Instance_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
53 Template : access Gela.Elements.Element'Class;
54 Getter : Property_Getter;
55 end record;
56
57 overriding function Clone
58 (Self : in out Cloner;
59 Element : access Gela.Elements.Element'Class)
60 return Gela.Elements.Element_Access;
61
62 overriding procedure Defining_Identifier
63 (Self : in out Cloner;
64 Node : not null Gela.Elements.Defining_Identifiers.
65 Defining_Identifier_Access);
66
67 end Cloners;
68
69 package Setters is
70
71 type Property_Setter
72 (Source : Gela.Elements.Element_Access;
73 Cloner : access Cloners.Cloner)
74 is new Gela.Property_Resets.Property_Reset with null record;
75
76 overriding procedure On_Defining_Name
77 (Self : in out Property_Setter;
78 Element : Gela.Elements.Element_Access;
79 Value : out Gela.Elements.Defining_Names.
80 Defining_Name_Access);
81
82 overriding procedure On_Full_Name
83 (Self : in out Property_Setter;
84 Element : Gela.Elements.Element_Access;
85 Value : out Gela.Lexical_Types.Symbol);
86
87 overriding procedure On_Chosen_Interpretation
88 (Self : in out Property_Setter;
89 Element : Gela.Elements.Element_Access;
90 Value : out Gela.Interpretations.Interpretation_Kinds);
91
92 end Setters;
93
94 package Update_Env is
95 type Visiter is new Gela.Element_Visiters.Visiter with record
96 Set : Gela.Environments.Environment_Set_Access;
97 Env : Gela.Semantic_Types.Env_Index;
98 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
99 end record;
100
101 overriding procedure Full_Type_Declaration
102 (Self : in out Visiter;
103 Node : not null Gela.Elements.Full_Type_Declarations.
104 Full_Type_Declaration_Access);
105
106 overriding procedure Generic_Package_Declaration
107 (Self : in out Visiter;
108 Node : not null Gela.Elements.Generic_Package_Declarations.
109 Generic_Package_Declaration_Access);
110
111 overriding procedure Object_Declaration
112 (Self : in out Visiter;
113 Node : not null Gela.Elements.Object_Declarations.
114 Object_Declaration_Access);
115
116 overriding procedure Subtype_Declaration
117 (Self : in out Visiter;
118 Node : not null Gela.Elements.Subtype_Declarations.
119 Subtype_Declaration_Access);
120
121 end Update_Env;
122
123 -------------
124 -- Setters --
125 -------------
126
127 package body Setters is
128
129 ------------------
130 -- On_Full_Name --
131 ------------------
132
133 overriding procedure On_Full_Name
134 (Self : in out Property_Setter;
135 Element : Gela.Elements.Element_Access;
136 Value : out Gela.Lexical_Types.Symbol)
137 is
138 pragma Unreferenced (Element);
139 begin
140 Self.Source.Visit (Self.Cloner.Getter.Visiter);
141 Value := Self.Cloner.Getter.Full_Name;
142 Self.Cloner.Getter.Full_Name := Self.Full_Name;
143 end On_Full_Name;
144
145 ----------------------
146 -- On_Defining_Name --
147 ----------------------
148
149 overriding procedure On_Defining_Name
150 (Self : in out Property_Setter;
151 Element : Gela.Elements.Element_Access;
152 Value : out Gela.Elements.Defining_Names.Defining_Name_Access)
153 is
154 pragma Unreferenced (Element);
155
156 Cursor : Name_Maps.Cursor;
157 begin
158 Self.Source.Visit (Self.Cloner.Getter.Visiter);
159 Value := Self.Cloner.Getter.Defining_Name;
160 Self.Cloner.Getter.Defining_Name := null;
161
162 if Value.Assigned then
163 Cursor := Self.Cloner.Map.Find (Value);
164
165 if Name_Maps.Has_Element (Cursor) then
166 Value := Name_Maps.Element (Cursor);
167 end if;
168 end if;
169 end On_Defining_Name;
170
171 overriding procedure On_Chosen_Interpretation
172 (Self : in out Property_Setter;
173 Element : Gela.Elements.Element_Access;
174 Value : out Gela.Interpretations.Interpretation_Kinds)
175 is
176 pragma Unreferenced (Element);
177 begin
178 Self.Source.Visit (Self.Cloner.Getter.Visiter);
179 Value := Self.Cloner.Getter.Chosen_Interpretation;
180 Self.Cloner.Getter.Chosen_Interpretation :=
181 Self.Chosen_Interpretation;
182 end On_Chosen_Interpretation;
183 end Setters;
184
185
186 -------------
187 -- Cloners --
188 -------------
189
190 package body Cloners is
191
192 -----------
193 -- Clone --
194 -----------
195
196 overriding function Clone
197 (Self : in out Cloner;
198 Element : access Gela.Elements.Element'Class)
199 return Gela.Elements.Element_Access
200 is
201 Result : Gela.Elements.Element_Access;
202 Setter : aliased Setters.Property_Setter
203 (Element, Self'Unchecked_Access);
204 Visiter : Gela.Property_Setters.Visiter (Setter'Access);
205 begin
206 if Element.Assigned then
207 Setter.Corresponding_Generic_Element := Element;
208 Result := Gela.Element_Cloners.Cloner (Self).Clone (Element);
209 Result.Set_Part_Of_Instance;
210 Result.Visit (Visiter);
211 end if;
212
213 return Result;
214 end Clone;
215
216 -------------------------
217 -- Defining_Identifier --
218 -------------------------
219
220 overriding procedure Defining_Identifier
221 (Self : in out Cloner;
222 Node : not null Gela.Elements.Defining_Identifiers.
223 Defining_Identifier_Access)
224 is
225 Source : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
226 Gela.Elements.Defining_Names.Defining_Name_Access (Node);
227 Result : Gela.Elements.Defining_Names.Defining_Name_Access;
228 begin
229 Gela.Element_Cloners.Cloner (Self).Defining_Identifier (Node);
230 Result :=
231 Gela.Elements.Defining_Names.Defining_Name_Access (Self.Result);
232
233 Self.Map.Insert (Source, Result);
234 end Defining_Identifier;
235
236 end Cloners;
237
238 ----------------
239 -- Update_Env --
240 ----------------
241
242 package body Update_Env is
243
244 overriding procedure Full_Type_Declaration
245 (Self : in out Visiter;
246 Node : not null Gela.Elements.Full_Type_Declarations.
247 Full_Type_Declaration_Access)
248 is
249 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
250 Gela.Elements.Defining_Names.Defining_Name_Access (Node.Names);
251 begin
252 Self.Env := Self.Set.Add_Defining_Name
253 (Self.Env, Name.Full_Name, Name);
254 end Full_Type_Declaration;
255
256 overriding procedure Generic_Package_Declaration
257 (Self : in out Visiter;
258 Node : not null Gela.Elements.Generic_Package_Declarations.
259 Generic_Package_Declaration_Access)
260 is
261 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
262 begin
263 if Self.Name.Assigned then
264 Name := Self.Name;
265 Self.Name := null;
266 else
267 Name :=
268 Gela.Elements.Defining_Names.Defining_Name_Access (Node.Names);
269 end if;
270
271 Self.Env := Self.Set.Add_Defining_Name
272 (Self.Env, Name.Full_Name, Name);
273
274 Self.Env := Self.Set.Enter_Declarative_Region (Self.Env, Name);
275
276 declare
277 Item : Gela.Elements.Basic_Declarative_Items
278 .Basic_Declarative_Item_Access;
279 Cursor : Gela.Elements.Basic_Declarative_Items
280 .Basic_Declarative_Item_Sequence_Cursor :=
281 Node.Visible_Part_Declarative_Items.First;
282 begin
283 while Cursor.Has_Element loop
284 Item := Cursor.Element;
285 Item.Visit (Self);
286 Cursor.Next;
287 end loop;
288 end;
289
290 Self.Env := Self.Set.Leave_Declarative_Region (Self.Env);
291 end Generic_Package_Declaration;
292
293 overriding procedure Object_Declaration
294 (Self : in out Visiter;
295 Node : not null Gela.Elements.Object_Declarations.
296 Object_Declaration_Access)
297 is
298 Item : Gela.Elements.Defining_Identifiers.
299 Defining_Identifier_Access;
300 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
301 Cursor : Gela.Elements.Defining_Identifiers.
302 Defining_Identifier_Sequence_Cursor := Node.Names.First;
303 begin
304 while Cursor.Has_Element loop
305 Item := Cursor.Element;
306 Name := Gela.Elements.Defining_Names.Defining_Name_Access (Item);
307 Self.Env := Self.Set.Add_Defining_Name
308 (Self.Env, Name.Full_Name, Name);
309 Cursor.Next;
310 end loop;
311 end Object_Declaration;
312
313 overriding procedure Subtype_Declaration
314 (Self : in out Visiter;
315 Node : not null Gela.Elements.Subtype_Declarations.
316 Subtype_Declaration_Access)
317 is
318 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
319 Gela.Elements.Defining_Names.Defining_Name_Access (Node.Names);
320 begin
321 Self.Env := Self.Set.Add_Defining_Name
322 (Self.Env, Name.Full_Name, Name);
323 end Subtype_Declaration;
324
325 end Update_Env;
326
327 ------------
328 -- Expand --
329 ------------
330
331 procedure Expand
332 (Comp : Gela.Compilations.Compilation_Access;
333 Node : not null Gela.Elements.Package_Instantiations.
334 Package_Instantiation_Access;
335 Expanded : out Gela.Elements.Element_Access)
336 is
337 pragma Unreferenced (Comp);
338
339 Defining_Name : constant Gela.Elements.Defining_Names
340 .Defining_Name_Access := Node.Generic_Unit_Name.Defining_Name;
341
342 begin
343 Expanded := Node.Expanded;
344
345 if not Expanded.Assigned and Defining_Name.Assigned then
346 declare
347 Cloner : Cloners.Cloner
348 (Defining_Name.Enclosing_Compilation.Factory);
349 begin
350 Cloner.Template := Defining_Name.Enclosing_Element;
351 Cloner.Instance_Name := Defining_Name;
352 Expanded := Cloner.Clone (Cloner.Template);
353 Node.Set_Expanded (Expanded);
354 end;
355 end if;
356 end Expand;
357
358 -----------------
359 -- Environment --
360 -----------------
361
362 procedure Environment
363 (Comp : Gela.Compilations.Compilation_Access;
364 Node : not null Gela.Elements.Package_Instantiations.
365 Package_Instantiation_Access;
366 Env_In : Gela.Semantic_Types.Env_Index;
367 Env_Out : out Gela.Semantic_Types.Env_Index)
368 is
369 Visiter : Update_Env.Visiter;
370 Expanded : Gela.Elements.Element_Access := Node.Expanded;
371 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
372 Gela.Elements.Defining_Names.Defining_Name_Access (Node.Names);
373 begin
374 if not Expanded.Assigned then
375 Expand (Comp, Node, Expanded);
376 Node.Set_Expanded (Expanded);
377 end if;
378
379 if Expanded.Assigned then
380 Visiter.Set := Comp.Context.Environment_Set;
381 Visiter.Name := Name;
382 Visiter.Env := Env_In;
383 Expanded.Visit (Visiter);
384 Env_Out := Visiter.Env;
385 else
386 Env_Out := Env_In;
387 end if;
388 end Environment;
389
390end Gela.Instantiation;
Note: See TracBrowser for help on using the repository browser.