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

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

Add Is_The_Same_Type function

  • Property svn:keywords set to Author Date Revision
File size: 20.4 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 Self.Is_The_Same_Type (Expected.all) then
447 return True;
448 end if;
449
450 if Expected.Is_Universal then
451 Expected.Visit (Matcher);
452
453 if Matcher.Match_Integer then
454 return Self.Category in Gela.Type_Categories.Any_Integer_Type;
455 elsif Matcher.Match_Real then
456 return Self.Category in Gela.Type_Categories.Any_Real_Type;
457 end if;
458 end if;
459
460 case Self.Category is
461 when Gela.Type_Categories.An_Universal_Integer =>
462 Expected.Visit (Matcher);
463 return Matcher.Match_Integer;
464 when Gela.Type_Categories.An_Universal_Real =>
465 Expected.Visit (Matcher);
466 return Matcher.Match_Real;
467 when others =>
468 null;
469 end case;
470
471 return False;
472 end Is_Expected_Type;
473
474 -----------------------
475 -- Is_Floating_Point --
476 -----------------------
477
478 overriding function Is_Floating_Point (Self : Type_View) return Boolean is
479 begin
480 return Self.Category in Gela.Type_Categories.A_Float_Point
481 | Gela.Type_Categories.An_Universal_Real;
482 end Is_Floating_Point;
483
484 ------------------------
485 -- Is_Modular_Integer --
486 ------------------------
487
488 overriding function Is_Modular_Integer (Self : Type_View) return Boolean is
489 begin
490 return Self.Category in Gela.Type_Categories.A_Modular_Integer
491 | Gela.Type_Categories.An_Universal_Integer;
492 end Is_Modular_Integer;
493
494 ----------------------
495 -- Is_Object_Access --
496 ----------------------
497
498 overriding function Is_Object_Access (Self : Type_View) return Boolean is
499 begin
500 return Self.Category in Gela.Type_Categories.A_Constant_Access
501 | Gela.Type_Categories.A_Variable_Access;
502 end Is_Object_Access;
503
504 ---------------
505 -- Is_Record --
506 ---------------
507
508 overriding function Is_Record (Self : Type_View) return Boolean is
509 begin
510 return Self.Category in Gela.Type_Categories.A_Untagged_Record
511 | Gela.Type_Categories.A_Tagged;
512 end Is_Record;
513
514 -------------
515 -- Is_Root --
516 -------------
517
518 overriding function Is_Root (Self : Type_View) return Boolean is
519 pragma Unreferenced (Self);
520 begin
521 return False;
522 end Is_Root;
523
524 -------------
525 -- Is_Root --
526 -------------
527
528 overriding function Is_Root (Self : Root_Type_View) return Boolean is
529 pragma Unreferenced (Self);
530 begin
531 return True;
532 end Is_Root;
533
534 -----------------------
535 -- Is_Signed_Integer --
536 -----------------------
537
538 overriding function Is_Signed_Integer (Self : Type_View) return Boolean is
539 begin
540 return Self.Category in Gela.Type_Categories.A_Signed_Integer
541 | Gela.Type_Categories.An_Universal_Integer;
542 end Is_Signed_Integer;
543
544 ----------------------
545 -- Is_The_Same_Type --
546 ----------------------
547
548 overriding function Is_The_Same_Type
549 (Left : Type_View;
550 Right : Gela.Types.Type_View'Class) return Boolean
551 is
552 use type Gela.Elements.Defining_Names.Defining_Name_Access;
553 begin
554 if Right in Type_View'Class then
555 return Left.Name = Type_View'Class (Right).Name;
556 end if;
557
558 return False;
559 end Is_The_Same_Type;
560
561 ------------------
562 -- Is_Universal --
563 ------------------
564
565 overriding function Is_Universal (Self : Type_View) return Boolean is
566 begin
567 return Self.Category in Gela.Type_Categories.An_Universal_Integer
568 | Gela.Type_Categories.An_Universal_Real
569 | Gela.Type_Categories.An_Universal_Fixed
570 | Gela.Type_Categories.An_Universal_Access;
571 end Is_Universal;
572
573 -----------
574 -- Visit --
575 -----------
576
577 overriding procedure Visit
578 (Self : not null access Type_View;
579 Visiter : in out Gela.Types.Visitors.Type_Visitor'Class) is
580 begin
581 case Self.Category is
582 when Gela.Type_Categories.A_Character =>
583 Visiter.Character_Type
584 (Gela.Types.Simple.Character_Type_Access (Self));
585 when Gela.Type_Categories.A_Boolean |
586 Gela.Type_Categories.An_Other_Enum =>
587 Visiter.Enumeration_Type
588 (Gela.Types.Simple.Enumeration_Type_Access (Self));
589 when Gela.Type_Categories.A_Signed_Integer |
590 Gela.Type_Categories.An_Universal_Integer =>
591 Visiter.Signed_Integer_Type
592 (Gela.Types.Simple.Signed_Integer_Type_Access (Self));
593 when Gela.Type_Categories.A_Float_Point |
594 Gela.Type_Categories.An_Universal_Real =>
595 Visiter.Floating_Point_Type
596 (Gela.Types.Simple.Floating_Point_Type_Access (Self));
597 when Gela.Type_Categories.A_String |
598 Gela.Type_Categories.An_Other_Array =>
599 raise Constraint_Error with "Unexpected array";
600 when Gela.Type_Categories.A_Untagged_Record =>
601 Visiter.Untagged_Record
602 (Gela.Types.Untagged_Records.Untagged_Record_Type_Access (Self));
603 when Gela.Type_Categories.A_Constant_Access |
604 Gela.Type_Categories.A_Variable_Access =>
605 Visiter.Object_Access_Type
606 (Gela.Types.Simple.Object_Access_Type_Access (Self));
607 when others =>
608 raise Constraint_Error;
609
610-- An_Universal_Integer,
611-- A_Modular_Integer,
612-- An_Universal_Real,
613-- An_Universal_Fixed,
614-- A_Ordinary_Fixed_Point,
615-- A_Decimal_Fixed_Point,
616-- A_Pool_Access,
617-- A_Procedure_Access,
618-- A_Function_Access,
619-- An_Universal_Access,
620-- A_Tagged,
621-- A_Task,
622-- A_Protected,
623-- A_Private,
624-- An_Incomplete);
625 end case;
626 end Visit;
627end Gela.Plain_Type_Views;
628
Note: See TracBrowser for help on using the repository browser.