source: trunk/ada-2012/src/semantic/gela-derived_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: 6.8 KB
Line 
1with Gela.Types.Discriminated;
2
3with Gela.Elements.Defining_Identifiers;
4pragma Unreferenced (Gela.Elements.Defining_Identifiers);
5
6package body Gela.Derived_Type_Views is
7
8 -------------------------
9 -- Create_Derived_Type --
10 -------------------------
11
12 function Create_Derived_Type
13 (Parent : not null Gela.Type_Categories.Type_View_Access;
14 Decl : Gela.Elements.Full_Type_Declarations
15 .Full_Type_Declaration_Access)
16 return Gela.Type_Categories.Type_View_Access
17 is
18 Value : constant Type_View_Access := new Type_View'(Parent, Decl);
19 begin
20 return Gela.Type_Categories.Type_View_Access (Value);
21 end Create_Derived_Type;
22
23 --------------
24 -- Category --
25 --------------
26
27 overriding function Category
28 (Self : Type_View) return Gela.Type_Categories.Category_Kinds is
29 begin
30 return Self.Parent.Category;
31 end Category;
32
33 --------------------
34 -- Component_Type --
35 --------------------
36
37 overriding function Component_Type
38 (Self : Type_View) return Gela.Semantic_Types.Type_Index is
39 begin
40 return Gela.Types.Arrays.Array_Type_Access (Self.Parent).Component_Type;
41 end Component_Type;
42
43 ---------------
44 -- Dimension --
45 ---------------
46
47 overriding function Dimension (Self : Type_View) return Positive is
48 begin
49 return Gela.Types.Arrays.Array_Type_Access (Self.Parent).Dimension;
50 end Dimension;
51
52 overriding function Defining_Name (Self : Type_View)
53 return Gela.Elements.Defining_Names.Defining_Name_Access
54 is
55 begin
56 return Gela.Elements.Defining_Names.Defining_Name_Access
57 (Self.Decl.Names);
58 end Defining_Name;
59
60 ----------------------
61 -- Get_Discriminant --
62 ----------------------
63
64 overriding function Get_Discriminant
65 (Self : Type_View;
66 Symbol : Gela.Lexical_Types.Symbol)
67 return Gela.Elements.Defining_Names.Defining_Name_Access is
68 begin
69 return Gela.Types.Discriminated.Discriminated_Type_Access
70 (Self.Parent).Get_Discriminant (Symbol);
71 end Get_Discriminant;
72
73 -------------------
74 -- Get_Component --
75 -------------------
76
77 overriding function Get_Component
78 (Self : Type_View;
79 Symbol : Gela.Lexical_Types.Symbol)
80 return Gela.Elements.Defining_Names.Defining_Name_Access
81 is
82 begin
83 return Gela.Types.Untagged_Records.Untagged_Record_Type_Access
84 (Self.Parent).Get_Component (Symbol);
85 end Get_Component;
86
87 --------------------
88 -- Get_Designated --
89 --------------------
90
91 overriding function Get_Designated
92 (Self : Type_View)
93 return Gela.Elements.Subtype_Marks.Subtype_Mark_Access is
94 begin
95 return Gela.Types.Simple.Object_Access_Type_Access
96 (Self.Parent).Get_Designated;
97 end Get_Designated;
98
99 -----------------
100 -- Index_Types --
101 -----------------
102
103 overriding function Index_Types
104 (Self : Type_View) return Gela.Types.Simple.Discrete_Type_Array is
105 begin
106 return Gela.Types.Arrays.Array_Type_Access (Self.Parent).Index_Types;
107 end Index_Types;
108
109 -----------------
110 -- Index_Types --
111 -----------------
112
113 overriding function Index_Types
114 (Self : Type_View) return Gela.Semantic_Types.Type_Index_Array is
115 begin
116 return Gela.Types.Arrays.Array_Type_Access (Self.Parent).Index_Types;
117 end Index_Types;
118
119 --------------
120 -- Is_Array --
121 --------------
122
123 overriding function Is_Array (Self : Type_View) return Boolean is
124 begin
125 return Self.Parent.Is_Array;
126 end Is_Array;
127
128 ------------------
129 -- Is_Character --
130 ------------------
131
132 overriding function Is_Character (Self : Type_View) return Boolean is
133 begin
134 return Self.Parent.Is_Character;
135 end Is_Character;
136
137 --------------------
138 -- Is_Enumeration --
139 --------------------
140
141 overriding function Is_Enumeration (Self : Type_View) return Boolean is
142 begin
143 return Self.Parent.Is_Enumeration;
144 end Is_Enumeration;
145
146 ----------------------
147 -- Is_Expected_Type --
148 ----------------------
149
150 overriding function Is_Expected_Type
151 (Self : Type_View;
152 Expected : not null Gela.Types.Type_View_Access)
153 return Boolean is
154 begin
155 if Self.Is_The_Same_Type (Expected.all) then
156 return True;
157 end if;
158
159 if Expected.Is_Universal then
160 if Expected.Is_Integer then
161 return Self.Category in Gela.Type_Categories.Any_Integer_Type;
162 elsif Expected.Is_Real then
163 return Self.Category in Gela.Type_Categories.Any_Real_Type;
164 end if;
165 end if;
166
167 return False;
168 end Is_Expected_Type;
169
170 -----------------------
171 -- Is_Floating_Point --
172 -----------------------
173
174 overriding function Is_Floating_Point (Self : Type_View) return Boolean is
175 begin
176 return Self.Parent.Is_Floating_Point;
177 end Is_Floating_Point;
178
179 ------------------------
180 -- Is_Modular_Integer --
181 ------------------------
182
183 overriding function Is_Modular_Integer (Self : Type_View) return Boolean is
184 begin
185 return Self.Parent.Is_Modular_Integer;
186 end Is_Modular_Integer;
187
188 ----------------------
189 -- Is_Object_Access --
190 ----------------------
191
192 overriding function Is_Object_Access (Self : Type_View) return Boolean is
193 begin
194 return Self.Parent.Is_Modular_Integer;
195 end Is_Object_Access;
196
197 ---------------
198 -- Is_Record --
199 ---------------
200
201 overriding function Is_Record (Self : Type_View) return Boolean is
202 begin
203 return Self.Parent.Is_Record;
204 end Is_Record;
205
206 -------------
207 -- Is_Root --
208 -------------
209
210 overriding function Is_Root (Self : Type_View) return Boolean is
211 pragma Unreferenced (Self);
212 begin
213 return False;
214 end Is_Root;
215
216 -----------------------
217 -- Is_Signed_Integer --
218 -----------------------
219
220 overriding function Is_Signed_Integer (Self : Type_View) return Boolean is
221 begin
222 return Self.Parent.Is_Signed_Integer;
223 end Is_Signed_Integer;
224
225 ----------------------
226 -- Is_The_Same_Type --
227 ----------------------
228
229 overriding function Is_The_Same_Type
230 (Left : Type_View;
231 Right : Gela.Types.Type_View'Class) return Boolean
232 is
233 use type Gela.Elements.Full_Type_Declarations
234 .Full_Type_Declaration_Access;
235 begin
236 if Right in Type_View'Class and then
237 Left.Decl = Type_View (Right).Decl
238 then
239 return True;
240 end if;
241
242 return False;
243 end Is_The_Same_Type;
244
245 ------------------
246 -- Is_Universal --
247 ------------------
248
249 overriding function Is_Universal (Self : Type_View) return Boolean is
250 pragma Unreferenced (Self);
251 begin
252 return False;
253 end Is_Universal;
254
255 -----------
256 -- Visit --
257 -----------
258
259 overriding procedure Visit
260 (Self : not null access Type_View;
261 Visiter : in out Gela.Types.Visitors.Type_Visitor'Class) is
262 begin
263 Self.Parent.Visit (Visiter);
264 end Visit;
265
266end Gela.Derived_Type_Views;
Note: See TracBrowser for help on using the repository browser.