source: trunk/ada-2012/src/semantic/gela-array_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

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