source: trunk/ada-2012/src/semantic/gela-plain_type_views.adb@ 547

Last change on this file since 547 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.

  • Property svn:keywords set to Author Date Revision
File size: 20.0 KB
Line 
1with Gela.Element_Visiters;
2with Gela.Elements.Access_To_Object_Definitions;
3with Gela.Elements.Alt_Record_Definitions;
4with Gela.Elements.Component_Declarations;
5with Gela.Elements.Component_Items;
6with Gela.Elements.Composite_Subtype_Indications;
7with Gela.Elements.Defining_Identifiers;
8with Gela.Elements.Discriminant_Specifications;
9with Gela.Elements.Known_Discriminant_Parts;
10with Gela.Elements.Record_Definitions;
11with Gela.Elements.Record_Type_Definitions;
12with Gela.Elements.Scalar_Subtype_Indications;
13with Gela.Elements.Variant_Parts;
14with Gela.Elements.Variants;
15
16package body Gela.Plain_Type_Views is
17
18 --------------
19 -- Category --
20 --------------
21
22 overriding function Category
23 (Self : Type_View) return Gela.Type_Categories.Category_Kinds
24 is
25 begin
26 return Self.Category;
27 end Category;
28
29 ------------------------
30 -- Create_Formal_Type --
31 ------------------------
32
33 function Create_Formal_Type
34 (Category : Gela.Type_Categories.Category_Kinds;
35 Decl : Gela.Elements.Formal_Type_Declarations
36 .Formal_Type_Declaration_Access)
37 return Gela.Type_Categories.Type_View_Access
38 is
39 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
40 Gela.Elements.Defining_Names.Defining_Name_Access (Decl.Names);
41 Value : constant Type_View_Access :=
42 new Type_View'(Category => Category,
43 Def => Decl.Type_Declaration_View,
44 Discr => Decl.Discriminant_Part,
45 Name => Name);
46 begin
47 return Gela.Type_Categories.Type_View_Access (Value);
48 end Create_Formal_Type;
49
50 ----------------------
51 -- Create_Full_Type --
52 ----------------------
53
54 function Create_Full_Type
55 (Category : Gela.Type_Categories.Category_Kinds;
56 Decl : Gela.Elements.Full_Type_Declarations
57 .Full_Type_Declaration_Access)
58 return Gela.Type_Categories.Type_View_Access
59 is
60 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
61 Gela.Elements.Defining_Names.Defining_Name_Access (Decl.Names);
62 Value : constant Type_View_Access :=
63 new Type_View'(Category => Category,
64 Def => Decl.Type_Declaration_View,
65 Discr => Decl.Discriminant_Part,
66 Name => Name);
67 begin
68 return Gela.Type_Categories.Type_View_Access (Value);
69 end Create_Full_Type;
70
71 ----------------------
72 -- Create_Root_Type --
73 ----------------------
74
75 function Create_Root_Type
76 (Category : Gela.Type_Categories.Category_Kinds;
77 Decl : Gela.Elements.Full_Type_Declarations
78 .Full_Type_Declaration_Access)
79 return Gela.Type_Categories.Type_View_Access
80 is
81 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
82 Gela.Elements.Defining_Names.Defining_Name_Access (Decl.Names);
83 Value : constant Type_View_Access :=
84 new Root_Type_View'(Category => Category,
85 Def => Decl.Type_Declaration_View,
86 Discr => Decl.Discriminant_Part,
87 Name => Name);
88 begin
89 return Gela.Type_Categories.Type_View_Access (Value);
90 end Create_Root_Type;
91
92 -------------------
93 -- Defining_Name --
94 -------------------
95
96 overriding function Defining_Name (Self : Type_View)
97 return Gela.Elements.Defining_Names.Defining_Name_Access is
98 begin
99 return Self.Name;
100 end Defining_Name;
101
102 -------------------
103 -- Get_Component --
104 -------------------
105
106 overriding function Get_Component
107 (Self : Type_View;
108 Symbol : Gela.Lexical_Types.Symbol)
109 return Gela.Elements.Defining_Names.Defining_Name_Access
110 is
111 package Get is
112 type Visiter is new Gela.Element_Visiters.Visiter with record
113 Result : Gela.Elements.Defining_Identifiers.
114 Defining_Identifier_Access;
115 end record;
116
117 overriding procedure Component_Declaration
118 (Self : in out Visiter;
119 Node : not null Gela.Elements.Component_Declarations.
120 Component_Declaration_Access);
121
122 overriding procedure Record_Definition
123 (Self : in out Visiter;
124 Node : not null Gela.Elements.Record_Definitions.
125 Record_Definition_Access);
126
127 overriding procedure Record_Type_Definition
128 (Self : in out Visiter;
129 Node : not null Gela.Elements.Record_Type_Definitions.
130 Record_Type_Definition_Access);
131
132 overriding procedure Variant
133 (Self : in out Visiter;
134 Node : not null Gela.Elements.Variants.Variant_Access);
135
136 overriding procedure Variant_Part
137 (Self : in out Visiter;
138 Node : not null Gela.Elements.Variant_Parts.Variant_Part_Access);
139
140 end Get;
141
142 package body Get is
143
144 overriding procedure Component_Declaration
145 (Self : in out Visiter;
146 Node : not null Gela.Elements.Component_Declarations.
147 Component_Declaration_Access)
148 is
149 use type Gela.Lexical_Types.Symbol;
150 Names : constant Gela.Elements.Defining_Identifiers.
151 Defining_Identifier_Sequence_Access := Node.Names;
152 Pos : Gela.Elements.Defining_Identifiers.
153 Defining_Identifier_Sequence_Cursor := Names.First;
154 begin
155 while Pos.Has_Element loop
156 if Pos.Element.Full_Name = Symbol then
157 Self.Result := Pos.Element;
158
159 return;
160 end if;
161
162 Pos.Next;
163 end loop;
164 end Component_Declaration;
165
166 overriding procedure Record_Type_Definition
167 (Self : in out Visiter;
168 Node : not null Gela.Elements.Record_Type_Definitions.
169 Record_Type_Definition_Access)
170 is
171 X : constant Gela.Elements.Alt_Record_Definitions.
172 Alt_Record_Definition_Access := Node.Record_Definition;
173 begin
174 X.Visit (Self);
175 end Record_Type_Definition;
176
177 overriding procedure Record_Definition
178 (Self : in out Visiter;
179 Node : not null Gela.Elements.Record_Definitions.
180 Record_Definition_Access)
181 is
182 List : constant Gela.Elements.Component_Items.
183 Component_Item_Sequence_Access := Node.Record_Components;
184 Cursor : Gela.Elements.Component_Items.
185 Component_Item_Sequence_Cursor := List.First;
186 begin
187 while Cursor.Has_Element loop
188 Cursor.Element.Visit (Self);
189 Cursor.Next;
190 end loop;
191 end Record_Definition;
192
193 overriding procedure Variant
194 (Self : in out Visiter;
195 Node : not null Gela.Elements.Variants.Variant_Access)
196 is
197 List : constant Gela.Elements.Component_Items.
198 Component_Item_Sequence_Access := Node.Record_Components;
199 Cursor : Gela.Elements.Component_Items.
200 Component_Item_Sequence_Cursor := List.First;
201 begin
202 while Cursor.Has_Element loop
203 Cursor.Element.Visit (Self);
204 Cursor.Next;
205 end loop;
206 end Variant;
207
208 overriding procedure Variant_Part
209 (Self : in out Visiter;
210 Node : not null Gela.Elements.Variant_Parts.Variant_Part_Access)
211 is
212 List : constant Gela.Elements.Variants.Variant_Sequence_Access :=
213 Node.Variants;
214 Cursor : Gela.Elements.Variants.Variant_Sequence_Cursor :=
215 List.First;
216 begin
217 while Cursor.Has_Element loop
218 Cursor.Element.Visit (Self);
219 Cursor.Next;
220 end loop;
221 end Variant_Part;
222 end Get;
223
224 V : Get.Visiter;
225 D : constant Gela.Elements.Defining_Names.Defining_Name_Access :=
226 Self.Get_Discriminant (Symbol);
227 begin
228 if D.Assigned then
229 return D;
230 else
231 Self.Def.Visit (V);
232 return Gela.Elements.Defining_Names.Defining_Name_Access (V.Result);
233 end if;
234 end Get_Component;
235
236 --------------------
237 -- Get_Designated --
238 --------------------
239
240 overriding function Get_Designated
241 (Self : Type_View)
242 return Gela.Elements.Subtype_Marks.Subtype_Mark_Access
243 is
244 package Get is
245 type Visiter is new Gela.Element_Visiters.Visiter with record
246 Result : Gela.Elements.Subtype_Marks. Subtype_Mark_Access;
247 end record;
248
249 overriding procedure Access_To_Object_Definition
250 (Self : in out Visiter;
251 Node : not null Gela.Elements.Access_To_Object_Definitions.
252 Access_To_Object_Definition_Access);
253
254 overriding procedure Composite_Subtype_Indication
255 (Self : in out Visiter;
256 Node : not null Gela.Elements.Composite_Subtype_Indications.
257 Composite_Subtype_Indication_Access);
258
259 overriding procedure Scalar_Subtype_Indication
260 (Self : in out Visiter;
261 Node : not null Gela.Elements.Scalar_Subtype_Indications.
262 Scalar_Subtype_Indication_Access);
263
264 end Get;
265
266 package body Get is
267
268 overriding procedure Access_To_Object_Definition
269 (Self : in out Visiter;
270 Node : not null Gela.Elements.Access_To_Object_Definitions.
271 Access_To_Object_Definition_Access) is
272 begin
273 Node.Subtype_Indication.Visit (Self);
274 end Access_To_Object_Definition;
275
276 overriding procedure Composite_Subtype_Indication
277 (Self : in out Visiter;
278 Node : not null Gela.Elements.Composite_Subtype_Indications.
279 Composite_Subtype_Indication_Access) is
280 begin
281 Self.Result := Node.Subtype_Mark;
282 end Composite_Subtype_Indication;
283
284 overriding procedure Scalar_Subtype_Indication
285 (Self : in out Visiter;
286 Node : not null Gela.Elements.Scalar_Subtype_Indications.
287 Scalar_Subtype_Indication_Access) is
288 begin
289 Self.Result := Node.Subtype_Mark;
290 end Scalar_Subtype_Indication;
291
292 end Get;
293
294 V : Get.Visiter;
295 begin
296 Self.Def.Visit (V);
297 return V.Result;
298 end Get_Designated;
299
300 ----------------------
301 -- Get_Discriminant --
302 ----------------------
303
304 overriding function Get_Discriminant
305 (Self : Type_View;
306 Symbol : Gela.Lexical_Types.Symbol)
307 return Gela.Elements.Defining_Names.Defining_Name_Access
308 is
309 package Get is
310 type Visiter is new Gela.Element_Visiters.Visiter with record
311 Result : Gela.Elements.Defining_Identifiers.
312 Defining_Identifier_Access;
313 end record;
314
315 overriding procedure Known_Discriminant_Part
316 (Self : in out Visiter;
317 Node : not null Gela.Elements.Known_Discriminant_Parts.
318 Known_Discriminant_Part_Access);
319 end Get;
320
321 package body Get is
322
323 overriding procedure Known_Discriminant_Part
324 (Self : in out Visiter;
325 Node : not null Gela.Elements.Known_Discriminant_Parts.
326 Known_Discriminant_Part_Access)
327 is
328 List : constant Gela.Elements.Discriminant_Specifications.
329 Discriminant_Specification_Sequence_Access := Node.Discriminants;
330 Cursor : Gela.Elements.Discriminant_Specifications.
331 Discriminant_Specification_Sequence_Cursor := List.First;
332 begin
333 while Cursor.Has_Element loop
334 declare
335 use type Gela.Lexical_Types.Symbol;
336 Names : constant Gela.Elements.Defining_Identifiers.
337 Defining_Identifier_Sequence_Access :=
338 Cursor.Element.Names;
339 Pos : Gela.Elements.Defining_Identifiers.
340 Defining_Identifier_Sequence_Cursor := Names.First;
341 begin
342 while Pos.Has_Element loop
343 if Pos.Element.Full_Name = Symbol then
344 Self.Result := Pos.Element;
345
346 return;
347 end if;
348
349 Pos.Next;
350 end loop;
351
352 Cursor.Next;
353 end;
354 end loop;
355 end Known_Discriminant_Part;
356 end Get;
357
358 V : Get.Visiter;
359 begin
360 if Self.Discr.Assigned then
361 Self.Discr.Visit (V);
362 return Gela.Elements.Defining_Names.Defining_Name_Access (V.Result);
363 else
364 return null;
365 end if;
366 end Get_Discriminant;
367
368 --------------
369 -- Is_Array --
370 --------------
371
372 overriding function Is_Array (Self : Type_View) return Boolean is
373 begin
374 return Self.Category in Gela.Type_Categories.A_String
375 | Gela.Type_Categories.An_Other_Array;
376 end Is_Array;
377
378 ------------------
379 -- Is_Character --
380 ------------------
381
382 overriding function Is_Character (Self : Type_View) return Boolean is
383 begin
384 return Self.Category in Gela.Type_Categories.A_Character;
385 end Is_Character;
386
387 --------------------
388 -- Is_Enumeration --
389 --------------------
390
391 overriding function Is_Enumeration (Self : Type_View) return Boolean is
392 begin
393 return Self.Category in Gela.Type_Categories.A_Character
394 | Gela.Type_Categories.A_Boolean
395 | Gela.Type_Categories.An_Other_Enum;
396 end Is_Enumeration;
397
398 ----------------------
399 -- Is_Expected_Type --
400 ----------------------
401
402 overriding function Is_Expected_Type
403 (Self : Type_View;
404 Expected : not null Gela.Types.Type_View_Access) return Boolean
405 is
406 package Visitors is
407 type Type_Visitor is new Gela.Types.Visitors.Type_Visitor with record
408 Match_Integer : Boolean := False;
409 Match_Real : Boolean := False;
410 end record;
411
412 overriding procedure Signed_Integer_Type
413 (Self : in out Type_Visitor;
414 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
415
416 overriding procedure Floating_Point_Type
417 (Self : in out Type_Visitor;
418 Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
419
420 end Visitors;
421
422 package body Visitors is
423
424 overriding procedure Signed_Integer_Type
425 (Self : in out Type_Visitor;
426 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access)
427 is
428 pragma Unreferenced (Value);
429 begin
430 Self.Match_Integer := True;
431 end Signed_Integer_Type;
432
433 overriding procedure Floating_Point_Type
434 (Self : in out Type_Visitor;
435 Value : not null Gela.Types.Simple.Floating_Point_Type_Access)
436 is
437 pragma Unreferenced (Value);
438 begin
439 Self.Match_Real := True;
440 end Floating_Point_Type;
441
442 end Visitors;
443
444 Matcher : Visitors.Type_Visitor;
445 begin
446 if Expected.all in Type_View'Class and then
447 Self.Def = Type_View'Class (Expected.all).Def
448 then
449 return True;
450 end if;
451
452 if Expected.Is_Universal then
453 Expected.Visit (Matcher);
454
455 if Matcher.Match_Integer then
456 return Self.Category in Gela.Type_Categories.Any_Integer_Type;
457 elsif Matcher.Match_Real then
458 return Self.Category in Gela.Type_Categories.Any_Real_Type;
459 end if;
460 end if;
461
462 case Self.Category is
463 when Gela.Type_Categories.An_Universal_Integer =>
464 Expected.Visit (Matcher);
465 return Matcher.Match_Integer;
466 when Gela.Type_Categories.An_Universal_Real =>
467 Expected.Visit (Matcher);
468 return Matcher.Match_Real;
469 when others =>
470 null;
471 end case;
472
473 return False;
474 end Is_Expected_Type;
475
476 -----------------------
477 -- Is_Floating_Point --
478 -----------------------
479
480 overriding function Is_Floating_Point (Self : Type_View) return Boolean is
481 begin
482 return Self.Category in Gela.Type_Categories.A_Float_Point
483 | Gela.Type_Categories.An_Universal_Real;
484 end Is_Floating_Point;
485
486 ------------------------
487 -- Is_Modular_Integer --
488 ------------------------
489
490 overriding function Is_Modular_Integer (Self : Type_View) return Boolean is
491 begin
492 return Self.Category in Gela.Type_Categories.A_Modular_Integer
493 | Gela.Type_Categories.An_Universal_Integer;
494 end Is_Modular_Integer;
495
496 ----------------------
497 -- Is_Object_Access --
498 ----------------------
499
500 overriding function Is_Object_Access (Self : Type_View) return Boolean is
501 begin
502 return Self.Category in Gela.Type_Categories.A_Constant_Access
503 | Gela.Type_Categories.A_Variable_Access;
504 end Is_Object_Access;
505
506 ---------------
507 -- Is_Record --
508 ---------------
509
510 overriding function Is_Record (Self : Type_View) return Boolean is
511 begin
512 return Self.Category in Gela.Type_Categories.A_Untagged_Record
513 | Gela.Type_Categories.A_Tagged;
514 end Is_Record;
515
516 -------------
517 -- Is_Root --
518 -------------
519
520 overriding function Is_Root (Self : Type_View) return Boolean is
521 pragma Unreferenced (Self);
522 begin
523 return False;
524 end Is_Root;
525
526 -------------
527 -- Is_Root --
528 -------------
529
530 overriding function Is_Root (Self : Root_Type_View) return Boolean is
531 pragma Unreferenced (Self);
532 begin
533 return True;
534 end Is_Root;
535
536 -----------------------
537 -- Is_Signed_Integer --
538 -----------------------
539
540 overriding function Is_Signed_Integer (Self : Type_View) return Boolean is
541 begin
542 return Self.Category in Gela.Type_Categories.A_Signed_Integer
543 | Gela.Type_Categories.An_Universal_Integer;
544 end Is_Signed_Integer;
545
546 ------------------
547 -- Is_Universal --
548 ------------------
549
550 overriding function Is_Universal (Self : Type_View) return Boolean is
551 begin
552 return Self.Category in Gela.Type_Categories.An_Universal_Integer
553 | Gela.Type_Categories.An_Universal_Real
554 | Gela.Type_Categories.An_Universal_Fixed
555 | Gela.Type_Categories.An_Universal_Access;
556 end Is_Universal;
557
558 -----------
559 -- Visit --
560 -----------
561
562 overriding procedure Visit
563 (Self : not null access Type_View;
564 Visiter : in out Gela.Types.Visitors.Type_Visitor'Class) is
565 begin
566 case Self.Category is
567 when Gela.Type_Categories.A_Character =>
568 Visiter.Character_Type
569 (Gela.Types.Simple.Character_Type_Access (Self));
570 when Gela.Type_Categories.A_Boolean |
571 Gela.Type_Categories.An_Other_Enum =>
572 Visiter.Enumeration_Type
573 (Gela.Types.Simple.Enumeration_Type_Access (Self));
574 when Gela.Type_Categories.A_Signed_Integer |
575 Gela.Type_Categories.An_Universal_Integer =>
576 Visiter.Signed_Integer_Type
577 (Gela.Types.Simple.Signed_Integer_Type_Access (Self));
578 when Gela.Type_Categories.A_Float_Point |
579 Gela.Type_Categories.An_Universal_Real =>
580 Visiter.Floating_Point_Type
581 (Gela.Types.Simple.Floating_Point_Type_Access (Self));
582 when Gela.Type_Categories.A_String |
583 Gela.Type_Categories.An_Other_Array =>
584 raise Constraint_Error with "Unexpected array";
585 when Gela.Type_Categories.A_Untagged_Record =>
586 Visiter.Untagged_Record
587 (Gela.Types.Untagged_Records.Untagged_Record_Type_Access (Self));
588 when Gela.Type_Categories.A_Constant_Access |
589 Gela.Type_Categories.A_Variable_Access =>
590 Visiter.Object_Access_Type
591 (Gela.Types.Simple.Object_Access_Type_Access (Self));
592 when others =>
593 raise Constraint_Error;
594
595-- An_Universal_Integer,
596-- A_Modular_Integer,
597-- An_Universal_Real,
598-- An_Universal_Fixed,
599-- A_Ordinary_Fixed_Point,
600-- A_Decimal_Fixed_Point,
601-- A_Pool_Access,
602-- A_Procedure_Access,
603-- A_Function_Access,
604-- An_Universal_Access,
605-- A_Tagged,
606-- A_Task,
607-- A_Protected,
608-- A_Private,
609-- An_Incomplete);
610 end case;
611 end Visit;
612end Gela.Plain_Type_Views;
613
Note: See TracBrowser for help on using the repository browser.