source: trunk/ada-2012/src/semantic/gela-plain_type_managers.adb@ 399

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

Make distinction between index and disriminant constraint

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