source: trunk/ada-2012/src/semantic/gela-plain_type_managers.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: 13.4 KB
Line 
1with Gela.Compilations;
2with Gela.Element_Factories;
3with Gela.Element_Visiters;
4with Gela.Elements.Defining_Identifiers;
5with Gela.Elements.Object_Declarations;
6with Gela.Elements.Object_Definitions;
7with Gela.Elements.Record_Type_Definitions;
8with Gela.Elements.Root_Type_Definitions;
9with Gela.Elements.Subtype_Indications;
10with Gela.Elements.Type_Definitions;
11with Gela.Plain_Type_Views;
12with Gela.Elements.Identifiers;
13with Gela.Elements.Discriminant_Specifications;
14with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
15with Gela.Elements.Component_Declarations;
16with Gela.Elements.Component_Definitions;
17with Gela.Elements.Subtype_Indication_Or_Access_Definitions;
18
19package body Gela.Plain_Type_Managers is
20
21 Universal_Access_Index : constant Gela.Semantic_Types.Type_Index := 1;
22 Universal_Integer_Index : constant Gela.Semantic_Types.Type_Index := 2;
23 Universal_Real_Index : constant Gela.Semantic_Types.Type_Index := 3;
24
25 ---------
26 -- Get --
27 ---------
28
29 not overriding function Get
30 (Self : access Type_Manager;
31 Category : Gela.Type_Views.Category_Kinds;
32 Decl : Gela.Elements.Full_Type_Declarations
33 .Full_Type_Declaration_Access)
34 return Gela.Semantic_Types.Type_Index
35 is
36 use type Gela.Semantic_Types.Type_Index;
37
38 Key : constant Back_Key := (Category, Decl);
39 Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
40 Result : constant Gela.Semantic_Types.Type_Index :=
41 Self.Map.Last_Key + 1;
42 begin
43 if Back_Maps.Has_Element (Pos) then
44 return Back_Maps.Element (Pos);
45 end if;
46
47 Self.Map.Insert
48 (Result,
49 Gela.Plain_Type_Views.Create_Full_Type (Category, Decl));
50
51 Self.Back.Insert (Key, Result);
52
53 return Result;
54 end Get;
55
56 ---------
57 -- Get --
58 ---------
59
60 overriding function Get
61 (Self : access Type_Manager;
62 Index : Gela.Semantic_Types.Type_Index)
63 return Gela.Type_Views.Type_View_Access
64 is
65 use type Gela.Semantic_Types.Type_Index;
66 begin
67 if Index = 0 then
68 return null;
69 else
70 return Self.Map.Element (Index);
71 end if;
72 end Get;
73
74 ----------
75 -- Hash --
76 ----------
77
78 function Hash (Key : Back_Key) return Ada.Containers.Hash_Type is
79 use type Ada.Containers.Hash_Type;
80 begin
81 return Key.Decl.Hash + Gela.Type_Views.Category_Kinds'Pos (Key.Category);
82 end Hash;
83
84 ----------------
85 -- Initialize --
86 ----------------
87
88 procedure Initialize
89 (Self : access Type_Manager;
90 Standard : Gela.Elements.Element_Access)
91 is
92 procedure Create
93 (Category : Gela.Type_Views.Category_Kinds;
94 Index : Gela.Semantic_Types.Type_Index);
95
96 Comp : constant Gela.Compilations.Compilation_Access :=
97 Standard.Enclosing_Compilation;
98 Factory : constant Gela.Element_Factories.Element_Factory_Access :=
99 Comp.Factory;
100
101 procedure Create
102 (Category : Gela.Type_Views.Category_Kinds;
103 Index : Gela.Semantic_Types.Type_Index)
104 is
105 Id : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
106 Def : Gela.Elements.Root_Type_Definitions
107 .Root_Type_Definition_Access;
108 Node : Gela.Elements.Full_Type_Declarations
109 .Full_Type_Declaration_Access;
110 begin
111 Id := Factory.Defining_Identifier (Identifier_Token => 0);
112
113 Def := Factory.Root_Type_Definition (0);
114 Def.Set_Type_Kind (Index);
115
116 Node := Factory.Full_Type_Declaration
117 (Type_Token => 0,
118 Names => Id,
119 Discriminant_Part => null,
120 Is_Token => 0,
121 Type_Declaration_View =>
122 Gela.Elements.Type_Definitions.Type_Definition_Access (Def),
123 Aspect_Specifications => Factory.Aspect_Specification_Sequence,
124 Semicolon_Token => 0);
125
126 Self.Map.Insert
127 (Index,
128 Gela.Plain_Type_Views.Create_Full_Type (Category, Node));
129 end Create;
130
131 begin
132 Create (Gela.Type_Views.An_Universal_Access, Universal_Access_Index);
133 Create (Gela.Type_Views.An_Universal_Integer, Universal_Integer_Index);
134 Create (Gela.Type_Views.An_Universal_Real, Universal_Real_Index);
135 end Initialize;
136
137 ------------------
138 -- Type_By_Name --
139 ------------------
140
141 overriding function Type_By_Name
142 (Self : access Type_Manager;
143 Node : Gela.Elements.Defining_Names.Defining_Name_Access)
144 return Gela.Semantic_Types.Type_Index
145 is
146 Decl : constant Gela.Elements.Element_Access := Node.Enclosing_Element;
147 begin
148 return Self.Type_From_Declaration (Decl);
149 end Type_By_Name;
150
151 ---------------------------
152 -- Type_From_Declaration --
153 ---------------------------
154
155 overriding function Type_From_Declaration
156 (Self : access Type_Manager;
157 Node : Gela.Elements.Element_Access)
158 return Gela.Semantic_Types.Type_Index
159 is
160
161 package Visiters is
162 type Visiter is new Gela.Element_Visiters.Visiter with record
163 Result : Gela.Semantic_Types.Type_Index := 0;
164 end record;
165
166 overriding procedure Full_Type_Declaration
167 (Self : in out Visiter;
168 Node : not null Gela.Elements.Full_Type_Declarations.
169 Full_Type_Declaration_Access);
170
171 overriding procedure Record_Type_Definition
172 (Self : in out Visiter;
173 Node : not null Gela.Elements.Record_Type_Definitions.
174 Record_Type_Definition_Access);
175
176 overriding procedure Root_Type_Definition
177 (Self : in out Visiter;
178 Node : not null Gela.Elements.Root_Type_Definitions.
179 Root_Type_Definition_Access);
180
181 end Visiters;
182
183 --------------
184 -- Visiters --
185 --------------
186
187 package body Visiters is
188
189 ---------------------------
190 -- Full_Type_Declaration --
191 ---------------------------
192
193 overriding procedure Full_Type_Declaration
194 (Self : in out Visiter;
195 Node : not null Gela.Elements.Full_Type_Declarations.
196 Full_Type_Declaration_Access)
197 is
198 View : constant Gela.Elements.Type_Definitions.
199 Type_Definition_Access := Node.Type_Declaration_View;
200 begin
201 View.Visit (Self);
202 end Full_Type_Declaration;
203
204 ----------------------------
205 -- Record_Type_Definition --
206 ----------------------------
207
208 overriding procedure Record_Type_Definition
209 (Self : in out Visiter;
210 Node : not null Gela.Elements.Record_Type_Definitions.
211 Record_Type_Definition_Access) is
212 begin
213 Self.Result := Type_From_Declaration.Self.Get
214 (Category => Gela.Type_Views.A_Untagged_Record,
215 Decl => Gela.Elements.Full_Type_Declarations.
216 Full_Type_Declaration_Access (Node.Enclosing_Element));
217 end Record_Type_Definition;
218
219 --------------------------
220 -- Root_Type_Definition --
221 --------------------------
222
223 overriding procedure Root_Type_Definition
224 (Self : in out Visiter;
225 Node : not null Gela.Elements.Root_Type_Definitions.
226 Root_Type_Definition_Access) is
227 begin
228 Self.Result := Node.Type_Kind;
229 end Root_Type_Definition;
230 end Visiters;
231
232 V : Visiters.Visiter;
233 begin
234 Node.Visit (V);
235
236 return V.Result;
237 end Type_From_Declaration;
238
239 ----------------------------
240 -- Type_From_Subtype_Mark --
241 ----------------------------
242
243 overriding function Type_From_Subtype_Mark
244 (Self : access Type_Manager;
245 Node : Gela.Elements.Subtype_Marks.Subtype_Mark_Access)
246 return Gela.Semantic_Types.Type_Index
247 is
248 package Visiters is
249 type Visiter is new Gela.Element_Visiters.Visiter with record
250 Result : Gela.Semantic_Types.Type_Index := 0;
251 end record;
252
253 overriding procedure Identifier
254 (Self : in out Visiter;
255 Node : not null Gela.Elements.Identifiers.Identifier_Access);
256
257 end Visiters;
258
259 package body Visiters is
260
261 overriding procedure Identifier
262 (Self : in out Visiter;
263 Node : not null Gela.Elements.Identifiers.Identifier_Access)
264 is
265 Defining_Name : constant Gela.Elements.Defining_Names.
266 Defining_Name_Access := Node.Defining_Name;
267 begin
268 if Defining_Name.Assigned then
269 Self.Result :=
270 Type_From_Subtype_Mark.Self.Type_From_Declaration
271 (Defining_Name.Enclosing_Element);
272 end if;
273 end Identifier;
274
275 end Visiters;
276
277 V : Visiters.Visiter;
278 begin
279 Node.Visit (V);
280
281 return V.Result;
282 end Type_From_Subtype_Mark;
283
284 --------------------------------
285 -- Type_Of_Object_Declaration --
286 --------------------------------
287
288 overriding function Type_Of_Object_Declaration
289 (Self : access Type_Manager;
290 Node : Gela.Elements.Element_Access)
291 return Gela.Semantic_Types.Type_Index
292 is
293 package Visiters is
294 type Visiter is new Gela.Element_Visiters.Visiter with record
295 Result : Gela.Semantic_Types.Type_Index := 0;
296 end record;
297
298 overriding procedure Component_Declaration
299 (Self : in out Visiter;
300 Node : not null Gela.Elements.Component_Declarations.
301 Component_Declaration_Access);
302
303 overriding procedure Component_Definition
304 (Self : in out Visiter;
305 Node : not null Gela.Elements.Component_Definitions.
306 Component_Definition_Access);
307
308 overriding procedure Discriminant_Specification
309 (Self : in out Visiter;
310 Node : not null Gela.Elements.Discriminant_Specifications.
311 Discriminant_Specification_Access);
312
313 overriding procedure Object_Declaration
314 (Self : in out Visiter;
315 Node : not null Gela.Elements.Object_Declarations.
316 Object_Declaration_Access);
317
318 overriding procedure Subtype_Indication
319 (Self : in out Visiter;
320 Node : not null Gela.Elements.Subtype_Indications.
321 Subtype_Indication_Access);
322
323 end Visiters;
324
325 package body Visiters is
326
327 overriding procedure Component_Declaration
328 (Self : in out Visiter;
329 Node : not null Gela.Elements.Component_Declarations.
330 Component_Declaration_Access)
331 is
332 X : constant Gela.Elements.Component_Definitions.
333 Component_Definition_Access :=
334 Node.Object_Declaration_Subtype;
335 begin
336 X.Visit (Self);
337 end Component_Declaration;
338
339 overriding procedure Component_Definition
340 (Self : in out Visiter;
341 Node : not null Gela.Elements.Component_Definitions.
342 Component_Definition_Access)
343 is
344 X : constant Gela.Elements.Subtype_Indication_Or_Access_Definitions
345 .Subtype_Indication_Or_Access_Definition_Access :=
346 Node.Component_Subtype_Indication;
347 begin
348 X.Visit (Self);
349 end Component_Definition;
350
351 overriding procedure Discriminant_Specification
352 (Self : in out Visiter;
353 Node : not null Gela.Elements.Discriminant_Specifications.
354 Discriminant_Specification_Access)
355 is
356 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
357 Subtype_Mark_Or_Access_Definition_Access :=
358 Node.Object_Declaration_Subtype;
359 begin
360 X.Visit (Self);
361 end Discriminant_Specification;
362
363 overriding procedure Object_Declaration
364 (Self : in out Visiter;
365 Node : not null Gela.Elements.Object_Declarations.
366 Object_Declaration_Access)
367 is
368 X : constant Gela.Elements.Object_Definitions.
369 Object_Definition_Access := Node.Object_Declaration_Subtype;
370 begin
371 X.Visit (Self);
372 end Object_Declaration;
373
374 overriding procedure Subtype_Indication
375 (Self : in out Visiter;
376 Node : not null Gela.Elements.Subtype_Indications.
377 Subtype_Indication_Access) is
378 begin
379 Self.Result :=
380 Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark
381 (Node.Subtype_Mark);
382 end Subtype_Indication;
383 end Visiters;
384
385 V : Visiters.Visiter;
386 begin
387 Node.Visit (V);
388
389 return V.Result;
390 end Type_Of_Object_Declaration;
391
392 ----------------------
393 -- Universal_Access --
394 ----------------------
395
396 overriding function Universal_Access
397 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
398 is
399 pragma Unreferenced (Self);
400 begin
401 return Universal_Access_Index;
402 end Universal_Access;
403
404 -----------------------
405 -- Universal_Integer --
406 -----------------------
407
408 overriding function Universal_Integer
409 (Self : access Type_Manager)
410 return Gela.Semantic_Types.Type_Index
411 is
412 pragma Unreferenced (Self);
413 begin
414 return Universal_Integer_Index;
415 end Universal_Integer;
416
417 --------------------
418 -- Universal_Real --
419 --------------------
420
421 overriding function Universal_Real
422 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
423 is
424 pragma Unreferenced (Self);
425 begin
426 return Universal_Real_Index;
427 end Universal_Real;
428
429end Gela.Plain_Type_Managers;
Note: See TracBrowser for help on using the repository browser.