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

Last change on this file since 552 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: 49.6 KB
Line 
1with Gela.Array_Type_Views;
2with Gela.Compilations;
3with Gela.Derived_Type_Views;
4with Gela.Element_Factories;
5with Gela.Element_Visiters;
6with Gela.Elements.Access_To_Object_Definitions;
7with Gela.Elements.Basic_Declarative_Items;
8with Gela.Elements.Component_Declarations;
9with Gela.Elements.Component_Definitions;
10with Gela.Elements.Composite_Subtype_Indications;
11with Gela.Elements.Constrained_Array_Definitions;
12with Gela.Elements.Defining_Character_Literals;
13with Gela.Elements.Defining_Enumeration_Names;
14with Gela.Elements.Defining_Identifiers;
15with Gela.Elements.Derived_Type_Definitions;
16with Gela.Elements.Discrete_Simple_Expression_Ranges;
17with Gela.Elements.Discrete_Subtype_Indications;
18with Gela.Elements.Discriminant_Specifications;
19with Gela.Elements.Enumeration_Literal_Specifications;
20with Gela.Elements.Enumeration_Type_Definitions;
21with Gela.Elements.Floating_Point_Definitions;
22with Gela.Elements.Formal_Discrete_Type_Definitions;
23with Gela.Elements.Formal_Object_Declarations;
24with Gela.Elements.Formal_Signed_Integer_Type_Definitions;
25with Gela.Elements.Formal_Type_Definitions;
26with Gela.Elements.Identifiers;
27with Gela.Elements.Loop_Parameter_Specifications;
28with Gela.Elements.Number_Declarations;
29with Gela.Elements.Object_Declarations;
30with Gela.Elements.Package_Declarations;
31with Gela.Elements.Parameter_Specifications;
32with Gela.Elements.Record_Type_Definitions;
33with Gela.Elements.Scalar_Subtype_Indications;
34with Gela.Elements.Selected_Components;
35with Gela.Elements.Selector_Names;
36with Gela.Elements.Signed_Integer_Type_Definitions;
37with Gela.Elements.Subtype_Declarations;
38with Gela.Elements.Subtype_Indication_Or_Access_Definitions;
39with Gela.Elements.Subtype_Indications;
40with Gela.Elements.Subtype_Marks;
41with Gela.Elements.Type_Definitions;
42with Gela.Elements.Unconstrained_Array_Definitions;
43with Gela.Environments;
44with Gela.Plain_Type_Views;
45with Gela.Profiles.Attributes;
46with Gela.Profiles.Names;
47
48package body Gela.Plain_Type_Managers is
49
50 Universal_Access_Index : constant Gela.Semantic_Types.Type_Index := 1;
51 Universal_Integer_Index : constant Gela.Semantic_Types.Type_Index := 2;
52 Universal_Real_Index : constant Gela.Semantic_Types.Type_Index := 3;
53 Boolean_Index : constant Gela.Semantic_Types.Type_Index := 4;
54 Root_Integer_Index : constant Gela.Semantic_Types.Type_Index := 5;
55 Root_Real_Index : constant Gela.Semantic_Types.Type_Index := 6;
56
57 -------------
58 -- Boolean --
59 -------------
60
61 overriding function Boolean
62 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
63 is
64 pragma Unreferenced (Self);
65 begin
66 return Boolean_Index;
67 end Boolean;
68
69 not overriding function Get
70 (Self : access Type_Manager;
71 Category : Gela.Type_Categories.Category_Kinds;
72 Decl : Gela.Elements.Formal_Type_Declarations
73 .Formal_Type_Declaration_Access)
74 return Gela.Semantic_Types.Type_Index
75 is
76 use type Gela.Semantic_Types.Type_Index;
77
78 Key : constant Back_Key := (Category, Decl);
79 Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
80 Result : constant Gela.Semantic_Types.Type_Index :=
81 Self.Map.Last_Key + 1;
82 begin
83 if Back_Maps.Has_Element (Pos) then
84 return Back_Maps.Element (Pos);
85 end if;
86
87 Self.Map.Insert
88 (Result,
89 Gela.Plain_Type_Views.Create_Formal_Type (Category, Decl));
90
91 Self.Back.Insert (Key, Result);
92
93 return Result;
94 end Get;
95
96 ---------
97 -- Get --
98 ---------
99
100 not overriding function Get
101 (Self : access Type_Manager;
102 Category : Gela.Type_Categories.Category_Kinds;
103 Decl : Gela.Elements.Full_Type_Declarations
104 .Full_Type_Declaration_Access)
105 return Gela.Semantic_Types.Type_Index
106 is
107 use type Gela.Semantic_Types.Type_Index;
108
109 Key : constant Back_Key := (Category, Decl);
110 Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
111 Result : constant Gela.Semantic_Types.Type_Index :=
112 Self.Map.Last_Key + 1;
113 Type_View : Gela.Type_Categories.Type_View_Access;
114 begin
115 if Back_Maps.Has_Element (Pos) then
116 return Back_Maps.Element (Pos);
117 end if;
118
119 if Result in Root_Integer_Index | Root_Real_Index then
120 Type_View := Gela.Plain_Type_Views.Create_Root_Type (Category, Decl);
121 else
122 Type_View := Gela.Plain_Type_Views.Create_Full_Type (Category, Decl);
123 end if;
124
125 Self.Map.Insert (Result, Type_View);
126 Self.Back.Insert (Key, Result);
127
128 return Result;
129 end Get;
130
131 ---------
132 -- Get --
133 ---------
134
135 overriding function Get
136 (Self : access Type_Manager;
137 Index : Gela.Semantic_Types.Type_Index)
138 return Gela.Types.Type_View_Access
139 is
140 use type Gela.Semantic_Types.Type_Index;
141 begin
142 if Index = 0 then
143 return null;
144 else
145 return Gela.Types.Type_View_Access (Self.Map.Element (Index));
146 end if;
147 end Get;
148
149 not overriding function Get_Array
150 (Self : access Type_Manager;
151 Category : Gela.Type_Categories.Category_Kinds;
152 Decl : Gela.Elements.Full_Type_Declarations
153 .Full_Type_Declaration_Access;
154 Component : Gela.Semantic_Types.Type_Index;
155 Indexes : Gela.Semantic_Types.Type_Index_Array)
156 return Gela.Semantic_Types.Type_Index
157 is
158 use type Gela.Semantic_Types.Type_Index;
159
160 Key : constant Back_Key := (Category, Decl);
161 Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
162 Result : constant Gela.Semantic_Types.Type_Index :=
163 Self.Map.Last_Key + 1;
164 begin
165 if Back_Maps.Has_Element (Pos) then
166 return Back_Maps.Element (Pos);
167 end if;
168
169 Self.Map.Insert
170 (Result,
171 Gela.Array_Type_Views.Create_Full_Type
172 (Category, Decl, Component, Indexes));
173
174 Self.Back.Insert (Key, Result);
175
176 return Result;
177 end Get_Array;
178
179 -----------------
180 -- Get_Derived --
181 -----------------
182
183 not overriding function Get_Derived
184 (Self : access Type_Manager;
185 Parent : Gela.Type_Categories.Type_View_Access;
186 Decl : Gela.Elements.Full_Type_Declarations
187 .Full_Type_Declaration_Access)
188 return Gela.Semantic_Types.Type_Index
189 is
190 -- FIXME: Use separate maps for derived types
191 use type Gela.Semantic_Types.Type_Index;
192
193 Key : constant Back_Key := (Parent.Category, Decl);
194 Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
195 Result : constant Gela.Semantic_Types.Type_Index :=
196 Self.Map.Last_Key + 1;
197 begin
198 if Back_Maps.Has_Element (Pos) then
199 return Back_Maps.Element (Pos);
200 end if;
201
202 Self.Map.Insert
203 (Result,
204 Gela.Derived_Type_Views.Create_Derived_Type (Parent, Decl));
205
206 Self.Back.Insert (Key, Result);
207
208 return Result;
209 end Get_Derived;
210
211 -----------------
212 -- Get_Profile --
213 -----------------
214
215 overriding function Get_Profile
216 (Self : access Type_Manager;
217 Env : Gela.Semantic_Types.Env_Index;
218 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
219 return Gela.Profiles.Profile_Access
220 is
221 Result : Profile_Access;
222 Cursor : constant Profile_Maps.Cursor := Self.Profiles.Find (Name);
223 begin
224 if Profile_Maps.Has_Element (Cursor) then
225 Result := Profile_Maps.Element (Cursor);
226 else
227 Result := new Gela.Profiles.Profile'Class'
228 (Gela.Profiles.Names.Create (Env, Name));
229 Self.Profiles.Insert (Name, Result);
230 end if;
231
232 return Gela.Profiles.Profile_Access (Result);
233 end Get_Profile;
234
235 -----------------
236 -- Get_Profile --
237 -----------------
238
239 overriding function Get_Profile
240 (Self : access Type_Manager;
241 Tipe : Gela.Semantic_Types.Type_Index;
242 Attribute : Gela.Lexical_Types.Symbol)
243 return Gela.Profiles.Profile_Access
244 is
245 Result : Profile_Access;
246 Key : constant Attribute_Key := (Tipe, Attribute);
247 Cursor : constant Attribute_Maps.Cursor := Self.Attributes.Find (Key);
248 begin
249 if Attribute_Maps.Has_Element (Cursor) then
250 Result := Attribute_Maps.Element (Cursor);
251 else
252 case Attribute is
253 when Gela.Lexical_Types.Predefined_Symbols.Ceiling |
254 Gela.Lexical_Types.Predefined_Symbols.Floor |
255 Gela.Lexical_Types.Predefined_Symbols.Fraction |
256 Gela.Lexical_Types.Predefined_Symbols.Machine |
257 Gela.Lexical_Types.Predefined_Symbols.Machine_Rounding |
258 Gela.Lexical_Types.Predefined_Symbols.Model |
259 Gela.Lexical_Types.Predefined_Symbols.Pred |
260 Gela.Lexical_Types.Predefined_Symbols.Rounding |
261 Gela.Lexical_Types.Predefined_Symbols.Succ |
262 Gela.Lexical_Types.Predefined_Symbols.Truncation |
263 Gela.Lexical_Types.Predefined_Symbols.Unbiased_Rounding =>
264
265 Result := new Gela.Profiles.Profile'Class'
266 (Gela.Profiles.Attributes.Create
267 ((1 => Tipe), Tipe));
268
269 when Gela.Lexical_Types.Predefined_Symbols.Pos =>
270
271 Result := new Gela.Profiles.Profile'Class'
272 (Gela.Profiles.Attributes.Create
273 ((1 => Tipe), Self.Universal_Integer));
274
275 when Gela.Lexical_Types.Predefined_Symbols.Mod_Symbol |
276 Gela.Lexical_Types.Predefined_Symbols.Val =>
277
278 Result := new Gela.Profiles.Profile'Class'
279 (Gela.Profiles.Attributes.Create
280 ((1 => Self.Universal_Integer), Tipe));
281
282 when others =>
283 raise Constraint_Error;
284 end case;
285
286 Self.Attributes.Insert (Key, Result);
287 end if;
288
289 return Gela.Profiles.Profile_Access (Result);
290 end Get_Profile;
291
292 ----------
293 -- Hash --
294 ----------
295
296 function Hash (Key : Back_Key) return Ada.Containers.Hash_Type is
297 use type Ada.Containers.Hash_Type;
298 begin
299 return Key.Decl.Hash
300 + Gela.Type_Categories.Category_Kinds'Pos (Key.Category);
301 end Hash;
302
303 ----------
304 -- Hash --
305 ----------
306
307 function Hash
308 (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
309 return Ada.Containers.Hash_Type is
310 begin
311 return Self.Hash;
312 end Hash;
313
314 ----------
315 -- Hash --
316 ----------
317
318 function Hash
319 (Self : Gela.Elements.Root_Type_Definitions.
320 Root_Type_Definition_Access)
321 return Ada.Containers.Hash_Type is
322 begin
323 return Self.Hash;
324 end Hash;
325
326 ----------
327 -- Hash --
328 ----------
329
330 function Hash (Value : Attribute_Key) return Ada.Containers.Hash_Type is
331 use type Ada.Containers.Hash_Type;
332 begin
333 return Ada.Containers.Hash_Type (Value.Tipe) * 2017
334 + Gela.Lexical_Types.Symbol'Pos (Value.Attribute);
335 end Hash;
336
337 ----------------
338 -- Initialize --
339 ----------------
340
341 package S renames Standard;
342
343 procedure Initialize
344 (Self : access Type_Manager;
345 Standard : Gela.Elements.Element_Access)
346 is
347 procedure Create
348 (Category : Gela.Type_Categories.Category_Kinds;
349 Index : Gela.Semantic_Types.Type_Index);
350
351 procedure Find_Type
352 (Symbol : Gela.Lexical_Types.Symbol;
353 Category : Gela.Type_Categories.Category_Kinds;
354 Expect : Gela.Semantic_Types.Type_Index);
355
356 Comp : constant Gela.Compilations.Compilation_Access :=
357 Standard.Enclosing_Compilation;
358 Factory : constant Gela.Element_Factories.Element_Factory_Access :=
359 Comp.Factory;
360
361 procedure Create
362 (Category : Gela.Type_Categories.Category_Kinds;
363 Index : Gela.Semantic_Types.Type_Index)
364 is
365 Id : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
366 Def : Gela.Elements.Root_Type_Definitions
367 .Root_Type_Definition_Access;
368 Node : Gela.Elements.Full_Type_Declarations
369 .Full_Type_Declaration_Access;
370 begin
371 Id := Factory.Defining_Identifier (Identifier_Token => 0);
372
373 Def := Factory.Root_Type_Definition (0);
374 Self.Roots.Insert (Def, Index);
375
376 Node := Factory.Full_Type_Declaration
377 (Type_Token => 0,
378 Names => Id,
379 Discriminant_Part => null,
380 Is_Token => 0,
381 Type_Declaration_View =>
382 Gela.Elements.Type_Definitions.Type_Definition_Access (Def),
383 Aspect_Specifications => Factory.Aspect_Specification_Sequence,
384 Semicolon_Token => 0);
385
386 Self.Map.Insert
387 (Index,
388 Gela.Plain_Type_Views.Create_Full_Type (Category, Node));
389 end Create;
390
391 ---------------
392 -- Find_Type --
393 ---------------
394
395 procedure Find_Type
396 (Symbol : Gela.Lexical_Types.Symbol;
397 Category : Gela.Type_Categories.Category_Kinds;
398 Expect : Gela.Semantic_Types.Type_Index)
399 is
400 package Visiters is
401 type Visiter is new Gela.Element_Visiters.Visiter with record
402 Stop : S.Boolean := False;
403 Result : Gela.Semantic_Types.Type_Index := 0;
404 end record;
405
406 overriding procedure Full_Type_Declaration
407 (Self : in out Visiter;
408 Node : not null Gela.Elements.Full_Type_Declarations.
409 Full_Type_Declaration_Access);
410 end Visiters;
411
412 package body Visiters is
413
414 overriding procedure Full_Type_Declaration
415 (Self : in out Visiter;
416 Node : not null Gela.Elements.Full_Type_Declarations.
417 Full_Type_Declaration_Access)
418 is
419 use type Gela.Lexical_Types.Symbol;
420 Identifier : constant Gela.Elements.Defining_Identifiers
421 .Defining_Identifier_Access := Node.Names;
422 Name : constant
423 Gela.Elements.Defining_Names.Defining_Name_Access :=
424 Gela.Elements.Defining_Names.Defining_Name_Access
425 (Identifier);
426 Token : constant Gela.Lexical_Types.Token :=
427 Comp.Get_Token (Identifier.Identifier_Token);
428 begin
429 if Token.Symbol = Symbol then
430 Self.Stop := True;
431 Self.Result := Initialize.Self.Get
432 (Category => Category,
433 Decl => Node);
434
435 if Category in Gela.Type_Categories.A_Boolean then
436 Initialize.Self.Boolean := Name;
437 end if;
438 end if;
439 end Full_Type_Declaration;
440 end Visiters;
441
442 use type Gela.Semantic_Types.Type_Index;
443 Seq : constant Gela.Elements.Basic_Declarative_Items
444 .Basic_Declarative_Item_Sequence_Access
445 := Gela.Elements.Package_Declarations
446 .Package_Declaration_Access (Standard)
447 .Visible_Part_Declarative_Items;
448 Cursor : Gela.Elements.Basic_Declarative_Items
449 .Basic_Declarative_Item_Sequence_Cursor := Seq.First;
450 Visiter : aliased Visiters.Visiter;
451 begin
452 while Cursor.Has_Element and not Visiter.Stop loop
453 Cursor.Element.Visit (Visiter);
454 Cursor.Next;
455 end loop;
456
457 pragma Assert (Visiter.Result = Expect);
458 end Find_Type;
459
460 use Gela.Type_Categories;
461 begin
462 Create (An_Universal_Access, Universal_Access_Index);
463 Create (An_Universal_Integer, Universal_Integer_Index);
464 Create (An_Universal_Real, Universal_Real_Index);
465 Find_Type
466 (Gela.Lexical_Types.Predefined_Symbols.Boolean,
467 Gela.Type_Categories.A_Boolean,
468 Boolean_Index);
469 Find_Type
470 (Gela.Lexical_Types.Predefined_Symbols.Root_Integer,
471 Gela.Type_Categories.A_Signed_Integer,
472 Root_Integer_Index);
473 Find_Type
474 (Gela.Lexical_Types.Predefined_Symbols.Root_Real,
475 Gela.Type_Categories.A_Float_Point,
476 Root_Real_Index);
477 end Initialize;
478
479 ------------------
480 -- Root_Integer --
481 ------------------
482
483 overriding function Root_Integer
484 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
485 is
486 pragma Unreferenced (Self);
487 begin
488 return Root_Integer_Index;
489 end Root_Integer;
490
491 ---------------
492 -- Root_Real --
493 ---------------
494
495 overriding function Root_Real
496 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
497 is
498 pragma Unreferenced (Self);
499 begin
500 return Root_Real_Index;
501 end Root_Real;
502
503 ------------------
504 -- Type_By_Name --
505 ------------------
506
507 overriding function Type_By_Name
508 (Self : access Type_Manager;
509 Env : Gela.Semantic_Types.Env_Index;
510 Node : Gela.Elements.Defining_Names.Defining_Name_Access)
511 return Gela.Semantic_Types.Type_Index
512 is
513 ES : constant Gela.Environments.Environment_Set_Access :=
514 Self.Context.Environment_Set;
515 Completions : constant Gela.Environments.Completion_List
516 := ES.Completions (Env, Node);
517
518 Decl : Gela.Elements.Element_Access;
519 begin
520 if Completions.Length > 0 then
521 Decl := Completions.Data (1).Enclosing_Element;
522 else
523 Decl := Node.Enclosing_Element;
524 end if;
525
526 return Self.Type_From_Declaration (Env, Decl);
527 end Type_By_Name;
528
529 ---------------------------
530 -- Type_From_Declaration --
531 ---------------------------
532
533 overriding function Type_From_Declaration
534 (Self : access Type_Manager;
535 Env : Gela.Semantic_Types.Env_Index;
536 Node : Gela.Elements.Element_Access)
537 return Gela.Semantic_Types.Type_Index
538 is
539
540 package Visiters is
541 type Visiter is new Gela.Element_Visiters.Visiter with record
542 Result : Gela.Semantic_Types.Type_Index := 0;
543 Boolean : Gela.Elements.Defining_Names.Defining_Name_Access;
544 end record;
545
546 overriding procedure Access_To_Object_Definition
547 (Self : in out Visiter;
548 Node : not null Gela.Elements.Access_To_Object_Definitions.
549 Access_To_Object_Definition_Access);
550
551 overriding procedure Constrained_Array_Definition
552 (Self : in out Visiter;
553 Node : not null Gela.Elements.Constrained_Array_Definitions.
554 Constrained_Array_Definition_Access);
555
556 overriding procedure Derived_Type_Definition
557 (Self : in out Visiter;
558 Node : not null Gela.Elements.Derived_Type_Definitions.
559 Derived_Type_Definition_Access);
560
561 overriding procedure Enumeration_Type_Definition
562 (Self : in out Visiter;
563 Node : not null Gela.Elements.Enumeration_Type_Definitions.
564 Enumeration_Type_Definition_Access);
565
566 overriding procedure Floating_Point_Definition
567 (Self : in out Visiter;
568 Node : not null Gela.Elements.Floating_Point_Definitions.
569 Floating_Point_Definition_Access);
570
571 overriding procedure Formal_Discrete_Type_Definition
572 (Self : in out Visiter;
573 Node : not null Gela.Elements.Formal_Discrete_Type_Definitions.
574 Formal_Discrete_Type_Definition_Access);
575
576 overriding procedure Formal_Signed_Integer_Type_Definition
577 (Self : in out Visiter;
578 Node : not null Gela.Elements.
579 Formal_Signed_Integer_Type_Definitions.
580 Formal_Signed_Integer_Type_Definition_Access);
581
582 overriding procedure Formal_Type_Declaration
583 (Self : in out Visiter;
584 Node : not null Gela.Elements.Formal_Type_Declarations.
585 Formal_Type_Declaration_Access);
586
587 overriding procedure Full_Type_Declaration
588 (Self : in out Visiter;
589 Node : not null Gela.Elements.Full_Type_Declarations.
590 Full_Type_Declaration_Access);
591
592 overriding procedure Record_Type_Definition
593 (Self : in out Visiter;
594 Node : not null Gela.Elements.Record_Type_Definitions.
595 Record_Type_Definition_Access);
596
597 overriding procedure Root_Type_Definition
598 (Self : in out Visiter;
599 Node : not null Gela.Elements.Root_Type_Definitions.
600 Root_Type_Definition_Access);
601
602 overriding procedure Signed_Integer_Type_Definition
603 (Self : in out Visiter;
604 Node : not null Gela.Elements.Signed_Integer_Type_Definitions.
605 Signed_Integer_Type_Definition_Access);
606
607 overriding procedure Subtype_Declaration
608 (Self : in out Visiter;
609 Node : not null Gela.Elements.Subtype_Declarations.
610 Subtype_Declaration_Access);
611
612 overriding procedure Unconstrained_Array_Definition
613 (Self : in out Visiter;
614 Node : not null Gela.Elements.Unconstrained_Array_Definitions.
615 Unconstrained_Array_Definition_Access);
616
617 end Visiters;
618
619 package Is_Char_Visiters is
620 type Visiter is new Gela.Element_Visiters.Visiter with record
621 Found : Standard.Boolean := False;
622 end record;
623
624 overriding procedure Defining_Character_Literal
625 (Self : in out Visiter;
626 Node : not null Gela.Elements.Defining_Character_Literals.
627 Defining_Character_Literal_Access);
628
629 end Is_Char_Visiters;
630
631 ----------------------
632 -- Is_Char_Visiters --
633 ----------------------
634
635 package body Is_Char_Visiters is
636
637 overriding procedure Defining_Character_Literal
638 (Self : in out Visiter;
639 Node : not null Gela.Elements.Defining_Character_Literals.
640 Defining_Character_Literal_Access)
641 is
642 pragma Unreferenced (Node);
643 begin
644 Self.Found := True;
645 end Defining_Character_Literal;
646
647 end Is_Char_Visiters;
648
649 --------------
650 -- Visiters --
651 --------------
652
653 package body Visiters is
654
655 overriding procedure Access_To_Object_Definition
656 (Self : in out Visiter;
657 Node : not null Gela.Elements.Access_To_Object_Definitions.
658 Access_To_Object_Definition_Access) is
659 begin
660 Self.Result := Type_From_Declaration.Self.Get
661 (Category => Gela.Type_Categories.A_Variable_Access,
662 Decl => Gela.Elements.Full_Type_Declarations.
663 Full_Type_Declaration_Access (Node.Enclosing_Element));
664 end Access_To_Object_Definition;
665
666 overriding procedure Derived_Type_Definition
667 (Self : in out Visiter;
668 Node : not null Gela.Elements.Derived_Type_Definitions.
669 Derived_Type_Definition_Access)
670 is
671 use type Gela.Semantic_Types.Type_Index;
672
673 Parent : constant Gela.Elements.Subtype_Indications.
674 Subtype_Indication_Access := Node.Parent_Subtype_Indication;
675 Tipe : constant Gela.Semantic_Types.Type_Index :=
676 Type_From_Declaration.Self.Type_From_Subtype_Indication
677 (Env, Parent);
678 Type_View : Gela.Type_Categories.Type_View_Access;
679 begin
680 if Tipe /= 0 then
681 Type_View := Gela.Type_Categories.Type_View_Access
682 (Type_From_Declaration.Self.Get (Tipe));
683
684 Self.Result := Type_From_Declaration.Self.Get_Derived
685 (Parent => Type_View,
686 Decl => Gela.Elements.Full_Type_Declarations.
687 Full_Type_Declaration_Access (Node.Enclosing_Element));
688 end if;
689 end Derived_Type_Definition;
690
691 overriding procedure Enumeration_Type_Definition
692 (Self : in out Visiter;
693 Node : not null Gela.Elements.Enumeration_Type_Definitions.
694 Enumeration_Type_Definition_Access)
695 is
696 Enum : Gela.Elements.Defining_Enumeration_Names.
697 Defining_Enumeration_Name_Access;
698 Enums : constant Gela.Elements.Enumeration_Literal_Specifications.
699 Enumeration_Literal_Specification_Sequence_Access :=
700 Node.Enumeration_Literal_Declarations;
701 Cursor : Gela.Elements.Enumeration_Literal_Specifications.
702 Enumeration_Literal_Specification_Sequence_Cursor := Enums.First;
703
704 V : Is_Char_Visiters.Visiter;
705 begin
706 while Cursor.Has_Element loop
707 Enum := Cursor.Element.Names;
708 Enum.Visit (V);
709 exit when V.Found;
710
711 Cursor.Next;
712 end loop;
713
714 if V.Found then
715 Self.Result := Type_From_Declaration.Self.Get
716 (Category => Gela.Type_Categories.A_Character,
717 Decl => Gela.Elements.Full_Type_Declarations.
718 Full_Type_Declaration_Access (Node.Enclosing_Element));
719 else
720 Self.Result := Type_From_Declaration.Self.Get
721 (Category => Gela.Type_Categories.An_Other_Enum,
722 Decl => Gela.Elements.Full_Type_Declarations.
723 Full_Type_Declaration_Access (Node.Enclosing_Element));
724 end if;
725 end Enumeration_Type_Definition;
726
727 overriding procedure Floating_Point_Definition
728 (Self : in out Visiter;
729 Node : not null Gela.Elements.Floating_Point_Definitions.
730 Floating_Point_Definition_Access) is
731 begin
732 Self.Result := Type_From_Declaration.Self.Get
733 (Category => Gela.Type_Categories.A_Float_Point,
734 Decl => Gela.Elements.Full_Type_Declarations.
735 Full_Type_Declaration_Access (Node.Enclosing_Element));
736 end Floating_Point_Definition;
737
738 overriding procedure Formal_Discrete_Type_Definition
739 (Self : in out Visiter;
740 Node : not null Gela.Elements.Formal_Discrete_Type_Definitions.
741 Formal_Discrete_Type_Definition_Access) is
742 begin
743 Self.Result := Type_From_Declaration.Self.Get
744 (Category => Gela.Type_Categories.An_Other_Enum,
745 Decl => Gela.Elements.Formal_Type_Declarations.
746 Formal_Type_Declaration_Access (Node.Enclosing_Element));
747 end Formal_Discrete_Type_Definition;
748
749 overriding procedure Formal_Signed_Integer_Type_Definition
750 (Self : in out Visiter;
751 Node : not null Gela.Elements.
752 Formal_Signed_Integer_Type_Definitions.
753 Formal_Signed_Integer_Type_Definition_Access) is
754 begin
755 Self.Result := Type_From_Declaration.Self.Get
756 (Category => Gela.Type_Categories.A_Signed_Integer,
757 Decl => Gela.Elements.Formal_Type_Declarations.
758 Formal_Type_Declaration_Access (Node.Enclosing_Element));
759 end Formal_Signed_Integer_Type_Definition;
760
761 overriding procedure Formal_Type_Declaration
762 (Self : in out Visiter;
763 Node : not null Gela.Elements.Formal_Type_Declarations.
764 Formal_Type_Declaration_Access)
765 is
766 View : constant Gela.Elements.Formal_Type_Definitions.
767 Formal_Type_Definition_Access := Node.Type_Declaration_View;
768 begin
769 View.Visit (Self);
770 end Formal_Type_Declaration;
771
772 ---------------------------
773 -- Full_Type_Declaration --
774 ---------------------------
775
776 overriding procedure Full_Type_Declaration
777 (Self : in out Visiter;
778 Node : not null Gela.Elements.Full_Type_Declarations.
779 Full_Type_Declaration_Access)
780 is
781 use type Gela.Elements.Defining_Names.Defining_Name_Access;
782
783 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access
784 := Gela.Elements.Defining_Names.Defining_Name_Access
785 (Node.Names);
786 View : constant Gela.Elements.Type_Definitions.
787 Type_Definition_Access := Node.Type_Declaration_View;
788 begin
789 if Name = Self.Boolean then
790 Self.Result := Type_From_Declaration.Self.Get
791 (Category => Gela.Type_Categories.A_Boolean,
792 Decl => Node);
793 else
794 View.Visit (Self);
795 end if;
796 end Full_Type_Declaration;
797
798 ----------------------------
799 -- Record_Type_Definition --
800 ----------------------------
801
802 overriding procedure Record_Type_Definition
803 (Self : in out Visiter;
804 Node : not null Gela.Elements.Record_Type_Definitions.
805 Record_Type_Definition_Access) is
806 begin
807 Self.Result := Type_From_Declaration.Self.Get
808 (Category => Gela.Type_Categories.A_Untagged_Record,
809 Decl => Gela.Elements.Full_Type_Declarations.
810 Full_Type_Declaration_Access (Node.Enclosing_Element));
811 end Record_Type_Definition;
812
813 --------------------------
814 -- Root_Type_Definition --
815 --------------------------
816
817 overriding procedure Root_Type_Definition
818 (Self : in out Visiter;
819 Node : not null Gela.Elements.Root_Type_Definitions.
820 Root_Type_Definition_Access) is
821 begin
822 Self.Result := Type_From_Declaration.Self.Roots.Element (Node);
823 end Root_Type_Definition;
824
825 overriding procedure Signed_Integer_Type_Definition
826 (Self : in out Visiter;
827 Node : not null Gela.Elements.Signed_Integer_Type_Definitions.
828 Signed_Integer_Type_Definition_Access) is
829 begin
830 Self.Result := Type_From_Declaration.Self.Get
831 (Category => Gela.Type_Categories.A_Signed_Integer,
832 Decl => Gela.Elements.Full_Type_Declarations.
833 Full_Type_Declaration_Access (Node.Enclosing_Element));
834 end Signed_Integer_Type_Definition;
835
836 overriding procedure Subtype_Declaration
837 (Self : in out Visiter;
838 Node : not null Gela.Elements.Subtype_Declarations.
839 Subtype_Declaration_Access)
840 is
841 Indication : constant Gela.Elements.Subtype_Indications.
842 Subtype_Indication_Access := Node.Type_Declaration_View;
843 begin
844 Self.Result :=
845 Type_From_Declaration.Self.Type_From_Subtype_Indication
846 (Env, Indication);
847 end Subtype_Declaration;
848
849 overriding procedure Unconstrained_Array_Definition
850 (Self : in out Visiter;
851 Node : not null Gela.Elements.Unconstrained_Array_Definitions.
852 Unconstrained_Array_Definition_Access)
853 is
854 use type Gela.Type_Categories.Category_Kinds;
855
856 Component : constant Gela.Elements.Component_Definitions.
857 Component_Definition_Access := Node.Array_Component_Definition;
858
859 Component_Type : constant Gela.Semantic_Types.Type_Index :=
860 Type_From_Declaration.Self.Type_Of_Object_Declaration
861 (Env, Gela.Elements.Element_Access (Component));
862
863 Component_Type_View : constant Gela.Types.Type_View_Access :=
864 Type_From_Declaration.Self.Get (Component_Type);
865
866 Index_Seq : constant Gela.Elements.Subtype_Marks.
867 Subtype_Mark_Sequence_Access := Node.Index_Subtype_Definitions;
868
869 Indexes : Gela.Semantic_Types.Type_Index_Array
870 (1 .. Index_Seq.Length);
871 begin
872 declare
873 Index : Positive := 1;
874 Cursor : Gela.Elements.Subtype_Marks
875 .Subtype_Mark_Sequence_Cursor := Index_Seq.First;
876 begin
877 while Cursor.Has_Element loop
878 Indexes (Index) :=
879 Type_From_Declaration.Self.Type_From_Subtype_Mark
880 (Env, Cursor.Element);
881
882 Index := Index + 1;
883 Cursor.Next;
884 end loop;
885 end;
886
887 if Component_Type_View.Assigned and then
888 Component_Type_View.Is_Character
889 then
890 Self.Result := Type_From_Declaration.Self.Get_Array
891 (Category => Gela.Type_Categories.A_String,
892 Decl => Gela.Elements.Full_Type_Declarations.
893 Full_Type_Declaration_Access (Node.Enclosing_Element),
894 Component => Component_Type,
895 Indexes => Indexes);
896 else
897 Self.Result := Type_From_Declaration.Self.Get_Array
898 (Category => Gela.Type_Categories.An_Other_Array,
899 Decl => Gela.Elements.Full_Type_Declarations.
900 Full_Type_Declaration_Access (Node.Enclosing_Element),
901 Component => Component_Type,
902 Indexes => Indexes);
903 end if;
904 end Unconstrained_Array_Definition;
905
906 overriding procedure Constrained_Array_Definition
907 (Self : in out Visiter;
908 Node : not null Gela.Elements.Constrained_Array_Definitions.
909 Constrained_Array_Definition_Access)
910 is
911 use type Gela.Type_Categories.Category_Kinds;
912
913 Component : constant Gela.Elements.Component_Definitions.
914 Component_Definition_Access := Node.Array_Component_Definition;
915
916 Component_Type : constant Gela.Semantic_Types.Type_Index :=
917 Type_From_Declaration.Self.Type_Of_Object_Declaration
918 (Env, Gela.Elements.Element_Access (Component));
919
920 Component_Type_View : constant Gela.Types.Type_View_Access :=
921 Type_From_Declaration.Self.Get (Component_Type);
922
923 Index_Seq : constant Gela.Elements.Discrete_Subtype_Definitions.
924 Discrete_Subtype_Definition_Sequence_Access :=
925 Node.Discrete_Subtype_Definitions;
926
927 Indexes : Gela.Semantic_Types.Type_Index_Array
928 (1 .. Index_Seq.Length);
929 begin
930 if Node.Env_In in 0 then
931 -- FIXME Drop this when generic instance issue is resolved
932 return;
933 end if;
934
935 declare
936 Index : Positive := 1;
937 Element : Gela.Elements.Discrete_Subtype_Definitions
938 .Discrete_Subtype_Definition_Access;
939 Cursor : Gela.Elements.Discrete_Subtype_Definitions
940 .Discrete_Subtype_Definition_Sequence_Cursor :=
941 Index_Seq.First;
942 begin
943 while Cursor.Has_Element loop
944 Element := Cursor.Element;
945 Indexes (Index) :=
946 Type_From_Declaration.Self.Type_From_Discrete_Subtype
947 (Element.Env_In, Element);
948
949 Index := Index + 1;
950 Cursor.Next;
951 end loop;
952 end;
953
954 if Component_Type_View.Assigned and then
955 Component_Type_View.Is_Character
956 then
957 Self.Result := Type_From_Declaration.Self.Get_Array
958 (Category => Gela.Type_Categories.A_String,
959 Decl => Gela.Elements.Full_Type_Declarations.
960 Full_Type_Declaration_Access (Node.Enclosing_Element),
961 Component => Component_Type,
962 Indexes => Indexes);
963 else
964 Self.Result := Type_From_Declaration.Self.Get_Array
965 (Category => Gela.Type_Categories.An_Other_Array,
966 Decl => Gela.Elements.Full_Type_Declarations.
967 Full_Type_Declaration_Access (Node.Enclosing_Element),
968 Component => Component_Type,
969 Indexes => Indexes);
970 end if;
971 end Constrained_Array_Definition;
972
973 end Visiters;
974
975 V : Visiters.Visiter := (0, Self.Boolean);
976 begin
977 Node.Visit (V);
978
979 return V.Result;
980 end Type_From_Declaration;
981
982 --------------------------------
983 -- Type_From_Discrete_Subtype --
984 --------------------------------
985
986 overriding function Type_From_Discrete_Subtype
987 (Self : access Type_Manager;
988 Env : Gela.Semantic_Types.Env_Index;
989 Node : access Gela.Elements.Discrete_Subtype_Definitions.
990 Discrete_Subtype_Definition'Class)
991 return Gela.Semantic_Types.Type_Index
992 is
993 package Visiters is
994 type Visiter is new Gela.Element_Visiters.Visiter with record
995 Result : Gela.Semantic_Types.Type_Index := 0;
996 end record;
997
998 overriding procedure Discrete_Simple_Expression_Range
999 (Self : in out Visiter;
1000 Node : not null Gela.Elements.Discrete_Simple_Expression_Ranges.
1001 Discrete_Simple_Expression_Range_Access);
1002
1003 overriding procedure Discrete_Subtype_Indication
1004 (Self : in out Visiter;
1005 Node : not null Gela.Elements.Discrete_Subtype_Indications.
1006 Discrete_Subtype_Indication_Access);
1007
1008 end Visiters;
1009
1010 package body Visiters is
1011
1012 overriding procedure Discrete_Simple_Expression_Range
1013 (Self : in out Visiter;
1014 Node : not null Gela.Elements.Discrete_Simple_Expression_Ranges.
1015 Discrete_Simple_Expression_Range_Access) is
1016 begin
1017 Self.Result := Node.Type_Index;
1018 end Discrete_Simple_Expression_Range;
1019
1020 overriding procedure Discrete_Subtype_Indication
1021 (Self : in out Visiter;
1022 Node : not null Gela.Elements.Discrete_Subtype_Indications.
1023 Discrete_Subtype_Indication_Access) is
1024 begin
1025 Self.Result := Type_From_Discrete_Subtype.Self.
1026 Type_From_Subtype_Mark (Env, Node.Subtype_Mark);
1027 end Discrete_Subtype_Indication;
1028
1029 end Visiters;
1030
1031 V : Visiters.Visiter;
1032 begin
1033 Node.Visit (V);
1034
1035 return V.Result;
1036 end Type_From_Discrete_Subtype;
1037
1038 overriding function Type_From_Subtype_Indication
1039 (Self : access Type_Manager;
1040 Env : Gela.Semantic_Types.Env_Index;
1041 Node : access Gela.Elements.Object_Definitions.Object_Definition'Class)
1042 return Gela.Semantic_Types.Type_Index
1043 is
1044
1045 package Visiters is
1046 type Visiter is new Gela.Element_Visiters.Visiter with record
1047 Result : Gela.Semantic_Types.Type_Index := 0;
1048 end record;
1049
1050 overriding procedure Composite_Subtype_Indication
1051 (Self : in out Visiter;
1052 Node : not null Gela.Elements.Composite_Subtype_Indications.
1053 Composite_Subtype_Indication_Access);
1054
1055 overriding procedure Scalar_Subtype_Indication
1056 (Self : in out Visiter;
1057 Node : not null Gela.Elements.Scalar_Subtype_Indications.
1058 Scalar_Subtype_Indication_Access);
1059
1060 end Visiters;
1061
1062 --------------
1063 -- Visiters --
1064 --------------
1065
1066 package body Visiters is
1067
1068 overriding procedure Composite_Subtype_Indication
1069 (Self : in out Visiter;
1070 Node : not null Gela.Elements.Composite_Subtype_Indications.
1071 Composite_Subtype_Indication_Access) is
1072 begin
1073 Self.Result := Type_From_Subtype_Indication.Self.
1074 Type_From_Subtype_Mark (Env, Node.Subtype_Mark);
1075 end Composite_Subtype_Indication;
1076
1077 overriding procedure Scalar_Subtype_Indication
1078 (Self : in out Visiter;
1079 Node : not null Gela.Elements.Scalar_Subtype_Indications.
1080 Scalar_Subtype_Indication_Access) is
1081 begin
1082 Self.Result := Type_From_Subtype_Indication.Self.
1083 Type_From_Subtype_Mark (Env, Node.Subtype_Mark);
1084 end Scalar_Subtype_Indication;
1085
1086 end Visiters;
1087
1088 V : Visiters.Visiter := (Result => 0);
1089 begin
1090 Node.Visit (V);
1091
1092 return V.Result;
1093 end Type_From_Subtype_Indication;
1094
1095 ----------------------------
1096 -- Type_From_Subtype_Mark --
1097 ----------------------------
1098
1099 overriding function Type_From_Subtype_Mark
1100 (Self : access Type_Manager;
1101 Env : Gela.Semantic_Types.Env_Index;
1102 Node : access Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1103 Subtype_Mark_Or_Access_Definition'Class)
1104 return Gela.Semantic_Types.Type_Index
1105 is
1106 package Visiters is
1107 type Visiter is new Gela.Element_Visiters.Visiter with record
1108 Result : Gela.Semantic_Types.Type_Index := 0;
1109 end record;
1110
1111 overriding procedure Identifier
1112 (Self : in out Visiter;
1113 Node : not null Gela.Elements.Identifiers.Identifier_Access);
1114
1115 overriding procedure Selected_Component
1116 (Self : in out Visiter;
1117 Node : not null Gela.Elements.Selected_Components.
1118 Selected_Component_Access);
1119
1120 end Visiters;
1121
1122 package body Visiters is
1123
1124 overriding procedure Identifier
1125 (Self : in out Visiter;
1126 Node : not null Gela.Elements.Identifiers.Identifier_Access)
1127 is
1128 View : Gela.Elements.Subtype_Marks.Subtype_Mark_Access;
1129 Defining_Name : constant Gela.Elements.Defining_Names.
1130 Defining_Name_Access := Node.Defining_Name;
1131 begin
1132 if not Defining_Name.Assigned then
1133 return;
1134 end if;
1135
1136 View := Gela.Elements.Subtype_Marks.Subtype_Mark_Access
1137 (Defining_Name.Corresponding_View);
1138
1139 if View.Assigned then
1140 Self.Result := Type_From_Subtype_Mark.Self.
1141 Type_From_Subtype_Mark (Env, View);
1142 else
1143 Self.Result :=
1144 Type_From_Subtype_Mark.Self.Type_By_Name (Env, Defining_Name);
1145 end if;
1146 end Identifier;
1147
1148 overriding procedure Selected_Component
1149 (Self : in out Visiter;
1150 Node : not null Gela.Elements.Selected_Components.
1151 Selected_Component_Access)
1152 is
1153 Selector : constant Gela.Elements.Selector_Names.
1154 Selector_Name_Access := Node.Selector;
1155 begin
1156 Selector.Visit (Self);
1157 end Selected_Component;
1158
1159 end Visiters;
1160
1161 V : Visiters.Visiter;
1162 begin
1163 Node.Visit (V);
1164
1165 return V.Result;
1166 end Type_From_Subtype_Mark;
1167
1168 --------------------------------
1169 -- Type_Of_Object_Declaration --
1170 --------------------------------
1171
1172 overriding function Type_Of_Object_Declaration
1173 (Self : access Type_Manager;
1174 Env : Gela.Semantic_Types.Env_Index;
1175 Node : Gela.Elements.Element_Access)
1176 return Gela.Semantic_Types.Type_Index
1177 is
1178 package Visiters is
1179 type Visiter is new Gela.Element_Visiters.Visiter with record
1180 Result : Gela.Semantic_Types.Type_Index := 0;
1181 end record;
1182
1183 overriding procedure Component_Declaration
1184 (Self : in out Visiter;
1185 Node : not null Gela.Elements.Component_Declarations.
1186 Component_Declaration_Access);
1187
1188 overriding procedure Component_Definition
1189 (Self : in out Visiter;
1190 Node : not null Gela.Elements.Component_Definitions.
1191 Component_Definition_Access);
1192
1193 overriding procedure Discriminant_Specification
1194 (Self : in out Visiter;
1195 Node : not null Gela.Elements.Discriminant_Specifications.
1196 Discriminant_Specification_Access);
1197
1198 overriding procedure Enumeration_Literal_Specification
1199 (Self : in out Visiter;
1200 Node : not null Gela.Elements.Enumeration_Literal_Specifications.
1201 Enumeration_Literal_Specification_Access);
1202
1203 overriding procedure Formal_Object_Declaration
1204 (Self : in out Visiter;
1205 Node : not null Gela.Elements.Formal_Object_Declarations.
1206 Formal_Object_Declaration_Access);
1207
1208 overriding procedure Loop_Parameter_Specification
1209 (Self : in out Visiter;
1210 Node : not null Gela.Elements.Loop_Parameter_Specifications.
1211 Loop_Parameter_Specification_Access);
1212
1213 overriding procedure Number_Declaration
1214 (Self : in out Visiter;
1215 Node : not null Gela.Elements.Number_Declarations.
1216 Number_Declaration_Access);
1217
1218 overriding procedure Object_Declaration
1219 (Self : in out Visiter;
1220 Node : not null Gela.Elements.Object_Declarations.
1221 Object_Declaration_Access);
1222
1223 overriding procedure Parameter_Specification
1224 (Self : in out Visiter;
1225 Node : not null Gela.Elements.Parameter_Specifications.
1226 Parameter_Specification_Access);
1227
1228 end Visiters;
1229
1230 package body Visiters is
1231
1232 overriding procedure Component_Declaration
1233 (Self : in out Visiter;
1234 Node : not null Gela.Elements.Component_Declarations.
1235 Component_Declaration_Access)
1236 is
1237 X : constant Gela.Elements.Component_Definitions.
1238 Component_Definition_Access :=
1239 Node.Object_Declaration_Subtype;
1240 begin
1241 X.Visit (Self);
1242 end Component_Declaration;
1243
1244 overriding procedure Component_Definition
1245 (Self : in out Visiter;
1246 Node : not null Gela.Elements.Component_Definitions.
1247 Component_Definition_Access)
1248 is
1249 X : constant Gela.Elements.Subtype_Indication_Or_Access_Definitions
1250 .Subtype_Indication_Or_Access_Definition_Access :=
1251 Node.Component_Subtype_Indication;
1252 begin
1253 Self.Result :=
1254 Type_Of_Object_Declaration.Self.Type_From_Subtype_Indication
1255 (Env,
1256 Gela.Elements.Object_Definitions.Object_Definition_Access
1257 (X));
1258 end Component_Definition;
1259
1260 overriding procedure Discriminant_Specification
1261 (Self : in out Visiter;
1262 Node : not null Gela.Elements.Discriminant_Specifications.
1263 Discriminant_Specification_Access)
1264 is
1265 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1266 Subtype_Mark_Or_Access_Definition_Access :=
1267 Node.Object_Declaration_Subtype;
1268 begin
1269 Self.Result :=
1270 Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (Env, X);
1271 end Discriminant_Specification;
1272
1273 overriding procedure Enumeration_Literal_Specification
1274 (Self : in out Visiter;
1275 Node : not null Gela.Elements.Enumeration_Literal_Specifications.
1276 Enumeration_Literal_Specification_Access)
1277 is
1278 Def : constant Gela.Elements.Element_Access :=
1279 Node.Enclosing_Element;
1280 Decl : constant Gela.Elements.Element_Access :=
1281 Def.Enclosing_Element;
1282 begin
1283 Self.Result := Type_Of_Object_Declaration.Self.
1284 Type_From_Declaration (Env, Decl);
1285 end Enumeration_Literal_Specification;
1286
1287 overriding procedure Formal_Object_Declaration
1288 (Self : in out Visiter;
1289 Node : not null Gela.Elements.Formal_Object_Declarations.
1290 Formal_Object_Declaration_Access)
1291 is
1292 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1293 Subtype_Mark_Or_Access_Definition_Access :=
1294 Node.Object_Declaration_Subtype;
1295 begin
1296 Self.Result :=
1297 Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (Env, X);
1298 end Formal_Object_Declaration;
1299
1300 overriding procedure Loop_Parameter_Specification
1301 (Self : in out Visiter;
1302 Node : not null Gela.Elements.Loop_Parameter_Specifications.
1303 Loop_Parameter_Specification_Access) is
1304 begin
1305 Self.Result :=
1306 Type_Of_Object_Declaration.Self.Type_From_Discrete_Subtype
1307 (Env, Node.Specification_Subtype_Definition);
1308 end Loop_Parameter_Specification;
1309
1310 overriding procedure Number_Declaration
1311 (Self : in out Visiter;
1312 Node : not null Gela.Elements.Number_Declarations.
1313 Number_Declaration_Access)
1314 is
1315 pragma Unreferenced (Node);
1316 begin
1317 -- FIXME!
1318 Self.Result := Type_Of_Object_Declaration.Self.Universal_Integer;
1319 end Number_Declaration;
1320
1321 overriding procedure Object_Declaration
1322 (Self : in out Visiter;
1323 Node : not null Gela.Elements.Object_Declarations.
1324 Object_Declaration_Access)
1325 is
1326 X : constant Gela.Elements.Object_Definitions.
1327 Object_Definition_Access := Node.Object_Declaration_Subtype;
1328 begin
1329 Self.Result :=
1330 Type_Of_Object_Declaration.Self.Type_From_Subtype_Indication
1331 (Env, X);
1332 end Object_Declaration;
1333
1334 overriding procedure Parameter_Specification
1335 (Self : in out Visiter;
1336 Node : not null Gela.Elements.Parameter_Specifications.
1337 Parameter_Specification_Access)
1338 is
1339 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1340 Subtype_Mark_Or_Access_Definition_Access :=
1341 Node.Object_Declaration_Subtype;
1342 begin
1343 Self.Result :=
1344 Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (Env, X);
1345 end Parameter_Specification;
1346
1347 end Visiters;
1348
1349 V : Visiters.Visiter;
1350 begin
1351 Node.Visit (V);
1352
1353 return V.Result;
1354 end Type_Of_Object_Declaration;
1355
1356 ----------------------
1357 -- Universal_Access --
1358 ----------------------
1359
1360 overriding function Universal_Access
1361 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
1362 is
1363 pragma Unreferenced (Self);
1364 begin
1365 return Universal_Access_Index;
1366 end Universal_Access;
1367
1368 -----------------------
1369 -- Universal_Integer --
1370 -----------------------
1371
1372 overriding function Universal_Integer
1373 (Self : access Type_Manager)
1374 return Gela.Semantic_Types.Type_Index
1375 is
1376 pragma Unreferenced (Self);
1377 begin
1378 return Universal_Integer_Index;
1379 end Universal_Integer;
1380
1381 --------------------
1382 -- Universal_Real --
1383 --------------------
1384
1385 overriding function Universal_Real
1386 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index
1387 is
1388 pragma Unreferenced (Self);
1389 begin
1390 return Universal_Real_Index;
1391 end Universal_Real;
1392
1393end Gela.Plain_Type_Managers;
Note: See TracBrowser for help on using the repository browser.