source: trunk/ada-2012/src/semantic/gela-plain_type_managers.ads@ 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: 7.3 KB
Line 
1-- Type manager keeps types found in all compilation units.
2
3with Ada.Containers.Ordered_Maps;
4with Ada.Containers.Hashed_Maps;
5
6with Gela.Contexts;
7with Gela.Elements.Defining_Names;
8with Gela.Elements.Discrete_Subtype_Definitions;
9with Gela.Elements.Formal_Type_Declarations;
10with Gela.Elements.Full_Type_Declarations;
11with Gela.Elements.Object_Definitions;
12with Gela.Elements.Root_Type_Definitions;
13with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
14with Gela.Lexical_Types;
15with Gela.Profiles;
16with Gela.Semantic_Types;
17with Gela.Type_Categories;
18with Gela.Type_Managers;
19with Gela.Types;
20
21package Gela.Plain_Type_Managers is
22 pragma Preelaborate;
23
24 type Type_Manager (Context : Gela.Contexts.Context_Access) is
25 new Gela.Type_Managers.Type_Manager with private;
26
27 type Type_Manager_Access is access all Type_Manager'Class;
28
29 procedure Initialize
30 (Self : access Type_Manager;
31 Standard : Gela.Elements.Element_Access);
32
33private
34
35 package Type_View_Maps is new Ada.Containers.Ordered_Maps
36 (Key_Type => Gela.Semantic_Types.Type_Index,
37 Element_Type => Gela.Type_Categories.Type_View_Access,
38 "<" => Gela.Semantic_Types."<",
39 "=" => Gela.Type_Categories."=");
40
41 type Back_Key is record
42 Category : Gela.Type_Categories.Category_Kinds;
43 Decl : access Gela.Elements.Element'Class;
44 end record;
45
46 function Hash (Key : Back_Key) return Ada.Containers.Hash_Type;
47
48 package Back_Maps is new Ada.Containers.Hashed_Maps
49 (Key_Type => Back_Key,
50 Element_Type => Gela.Semantic_Types.Type_Index,
51 Hash => Hash,
52 Equivalent_Keys => "=",
53 "=" => Gela.Semantic_Types."=");
54
55 function Hash
56 (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
57 return Ada.Containers.Hash_Type;
58
59 type Profile_Access is access all Gela.Profiles.Profile'Class;
60
61 package Profile_Maps is new Ada.Containers.Hashed_Maps
62 (Key_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
63 Element_Type => Profile_Access,
64 Hash => Hash,
65 Equivalent_Keys => Gela.Elements.Defining_Names."=");
66
67 type Attribute_Key is record
68 Tipe : Gela.Semantic_Types.Type_Index;
69 Attribute : Gela.Lexical_Types.Symbol;
70 end record;
71
72 function Hash (Value : Attribute_Key) return Ada.Containers.Hash_Type;
73
74 package Attribute_Maps is new Ada.Containers.Hashed_Maps
75 (Key_Type => Attribute_Key,
76 Element_Type => Profile_Access,
77 Hash => Hash,
78 Equivalent_Keys => "=");
79
80 function Hash
81 (Self : Gela.Elements.Root_Type_Definitions.
82 Root_Type_Definition_Access)
83 return Ada.Containers.Hash_Type;
84
85 package Root_Maps is new Ada.Containers.Hashed_Maps
86 (Key_Type => Gela.Elements.Root_Type_Definitions.
87 Root_Type_Definition_Access,
88 Element_Type => Gela.Semantic_Types.Type_Index,
89 Hash => Hash,
90 Equivalent_Keys => Gela.Elements.Root_Type_Definitions."=",
91 "=" => Gela.Semantic_Types."=");
92
93 type Type_Manager (Context : Gela.Contexts.Context_Access) is
94 new Gela.Type_Managers.Type_Manager with
95 record
96 Map : Type_View_Maps.Map;
97 Back : Back_Maps.Map;
98 Profiles : Profile_Maps.Map;
99 Attributes : Attribute_Maps.Map;
100 Roots : Root_Maps.Map;
101 Boolean : Gela.Elements.Defining_Names.Defining_Name_Access;
102 end record;
103
104 not overriding function Get
105 (Self : access Type_Manager;
106 Category : Gela.Type_Categories.Category_Kinds;
107 Decl : Gela.Elements.Full_Type_Declarations
108 .Full_Type_Declaration_Access)
109 return Gela.Semantic_Types.Type_Index;
110
111 not overriding function Get
112 (Self : access Type_Manager;
113 Category : Gela.Type_Categories.Category_Kinds;
114 Decl : Gela.Elements.Formal_Type_Declarations
115 .Formal_Type_Declaration_Access)
116 return Gela.Semantic_Types.Type_Index;
117
118 not overriding function Get_Derived
119 (Self : access Type_Manager;
120 Parent : Gela.Type_Categories.Type_View_Access;
121 Decl : Gela.Elements.Full_Type_Declarations
122 .Full_Type_Declaration_Access)
123 return Gela.Semantic_Types.Type_Index;
124
125 not overriding function Get_Array
126 (Self : access Type_Manager;
127 Category : Gela.Type_Categories.Category_Kinds;
128 Decl : Gela.Elements.Full_Type_Declarations
129 .Full_Type_Declaration_Access;
130 Component : Gela.Semantic_Types.Type_Index;
131 Indexes : Gela.Semantic_Types.Type_Index_Array)
132 return Gela.Semantic_Types.Type_Index;
133
134 overriding function Get
135 (Self : access Type_Manager;
136 Index : Gela.Semantic_Types.Type_Index)
137 return Gela.Types.Type_View_Access;
138
139 overriding function Type_From_Declaration
140 (Self : access Type_Manager;
141 Env : Gela.Semantic_Types.Env_Index;
142 Node : Gela.Elements.Element_Access)
143 return Gela.Semantic_Types.Type_Index;
144
145 overriding function Type_Of_Object_Declaration
146 (Self : access Type_Manager;
147 Env : Gela.Semantic_Types.Env_Index;
148 Node : Gela.Elements.Element_Access)
149 return Gela.Semantic_Types.Type_Index;
150
151 overriding function Type_From_Subtype_Indication
152 (Self : access Type_Manager;
153 Env : Gela.Semantic_Types.Env_Index;
154 Node : access Gela.Elements.Object_Definitions.Object_Definition'Class)
155 return Gela.Semantic_Types.Type_Index;
156
157 overriding function Type_From_Subtype_Mark
158 (Self : access Type_Manager;
159 Env : Gela.Semantic_Types.Env_Index;
160 Node : access Gela.Elements.Subtype_Mark_Or_Access_Definitions.
161 Subtype_Mark_Or_Access_Definition'Class)
162 return Gela.Semantic_Types.Type_Index;
163
164 overriding function Type_From_Discrete_Subtype
165 (Self : access Type_Manager;
166 Env : Gela.Semantic_Types.Env_Index;
167 Node : access Gela.Elements.Discrete_Subtype_Definitions.
168 Discrete_Subtype_Definition'Class)
169 return Gela.Semantic_Types.Type_Index;
170
171 overriding function Type_By_Name
172 (Self : access Type_Manager;
173 Env : Gela.Semantic_Types.Env_Index;
174 Node : Gela.Elements.Defining_Names.Defining_Name_Access)
175 return Gela.Semantic_Types.Type_Index;
176
177 overriding function Universal_Integer
178 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
179
180 overriding function Universal_Real
181 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
182
183 overriding function Universal_Access
184 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
185
186 overriding function Root_Integer
187 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
188
189 overriding function Root_Real
190 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
191
192 overriding function Get_Profile
193 (Self : access Type_Manager;
194 Env : Gela.Semantic_Types.Env_Index;
195 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
196 return Gela.Profiles.Profile_Access;
197
198 overriding function Get_Profile
199 (Self : access Type_Manager;
200 Tipe : Gela.Semantic_Types.Type_Index;
201 Attribute : Gela.Lexical_Types.Symbol)
202 return Gela.Profiles.Profile_Access;
203
204 overriding function Boolean
205 (Self : access Type_Manager) return Gela.Semantic_Types.Type_Index;
206
207end Gela.Plain_Type_Managers;
Note: See TracBrowser for help on using the repository browser.