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

File size: 14.3 KB
Line 
1with Gela.Plain_Int_Sets.Cursors;
2with Gela.Types.Simple;
3with Gela.Types.Visitors;
4
5package body Gela.Resolve.Each is
6
7 type Name_As_Expression_Cursor is
8 new Gela.Interpretations.Expression_Cursor with
9 record
10 Name : Gela.Plain_Int_Sets.Cursors.Defining_Name_Cursor;
11 TM : Gela.Type_Managers.Type_Manager_Access;
12 Env : Gela.Semantic_Types.Env_Index;
13 Tipe : Gela.Semantic_Types.Type_Index := 0;
14 end record;
15
16 procedure Step (Self : in out Name_As_Expression_Cursor'Class);
17
18 overriding function Has_Element
19 (Self : Name_As_Expression_Cursor) return Boolean;
20
21 overriding procedure Next (Self : in out Name_As_Expression_Cursor);
22
23 overriding function Get_Index
24 (Self : Name_As_Expression_Cursor)
25 return Gela.Interpretations.Interpretation_Index;
26
27 overriding function Expression_Type
28 (Self : Name_As_Expression_Cursor)
29 return Gela.Semantic_Types.Type_Index;
30
31 type Join_Cursor is
32 new Gela.Interpretations.Expression_Cursor with
33 record
34 Name : Name_As_Expression_Cursor;
35 Exp : Gela.Plain_Int_Sets.Cursors.Expression_Cursor;
36 end record;
37
38 overriding function Has_Element (Self : Join_Cursor) return Boolean;
39
40 overriding procedure Next (Self : in out Join_Cursor);
41
42 overriding function Get_Index
43 (Self : Join_Cursor) return Gela.Interpretations.Interpretation_Index;
44
45 overriding function Expression_Type
46 (Self : Join_Cursor) return Gela.Semantic_Types.Type_Index;
47
48 procedure Initialize
49 (Self : in out Join_Cursor'Class;
50 IM : access Gela.Interpretations.Interpretation_Manager'Class;
51 TM : Gela.Type_Managers.Type_Manager_Access;
52 Env : Gela.Semantic_Types.Env_Index;
53 Set : Gela.Interpretations.Interpretation_Set_Index);
54
55 type Prefix_Cursor is new Join_Cursor with record
56 Is_Implicit_Dereference : Boolean := False;
57 Implicit_Dereference_Type : Gela.Semantic_Types.Type_Index;
58 end record;
59
60 overriding procedure Next (Self : in out Prefix_Cursor);
61
62 overriding function Expression_Type
63 (Self : Prefix_Cursor) return Gela.Semantic_Types.Type_Index;
64
65 procedure Step (Self : in out Prefix_Cursor'Class);
66
67 type Prefer_Root_Cursor is
68 new Gela.Interpretations.Expression_Cursor with
69 record
70 Has_Integer_Root : Boolean := False;
71 Has_Real_Root : Boolean := False;
72 Root_Cursor : Join_Cursor;
73 Exp_Cursor : Join_Cursor;
74 end record;
75
76 procedure Step (Self : in out Prefer_Root_Cursor'Class);
77
78 overriding function Has_Element
79 (Self : Prefer_Root_Cursor) return Boolean;
80
81 overriding procedure Next (Self : in out Prefer_Root_Cursor);
82
83 overriding function Get_Index
84 (Self : Prefer_Root_Cursor)
85 return Gela.Interpretations.Interpretation_Index;
86
87 overriding function Expression_Type
88 (Self : Prefer_Root_Cursor)
89 return Gela.Semantic_Types.Type_Index;
90
91 procedure Initialize
92 (Self : in out Prefer_Root_Cursor'Class;
93 IM : access Gela.Interpretations.Interpretation_Manager'Class;
94 TM : Gela.Type_Managers.Type_Manager_Access;
95 Env : Gela.Semantic_Types.Env_Index;
96 Set : Gela.Interpretations.Interpretation_Set_Index);
97
98 ---------------------
99 -- Expression_Type --
100 ---------------------
101
102 overriding function Expression_Type
103 (Self : Name_As_Expression_Cursor)
104 return Gela.Semantic_Types.Type_Index is
105 begin
106 return Self.Tipe;
107 end Expression_Type;
108
109 ---------------------
110 -- Expression_Type --
111 ---------------------
112
113 overriding function Expression_Type
114 (Self : Join_Cursor)
115 return Gela.Semantic_Types.Type_Index is
116 begin
117 if Self.Name.Has_Element then
118 return Self.Name.Expression_Type;
119 else
120 return Self.Exp.Expression_Type;
121 end if;
122 end Expression_Type;
123
124 ---------------
125 -- Get_Index --
126 ---------------
127
128 overriding function Get_Index
129 (Self : Name_As_Expression_Cursor)
130 return Gela.Interpretations.Interpretation_Index is
131 begin
132 return Self.Name.Get_Index;
133 end Get_Index;
134
135 ---------------
136 -- Get_Index --
137 ---------------
138
139 overriding function Get_Index
140 (Self : Join_Cursor) return Gela.Interpretations.Interpretation_Index is
141 begin
142 if Self.Name.Has_Element then
143 return Self.Name.Get_Index;
144 else
145 return Self.Exp.Get_Index;
146 end if;
147 end Get_Index;
148
149 ---------------
150 -- Get_Index --
151 ---------------
152
153 overriding function Get_Index
154 (Self : Prefer_Root_Cursor)
155 return Gela.Interpretations.Interpretation_Index is
156 begin
157 if Self.Root_Cursor.Has_Element then
158 return Self.Root_Cursor.Get_Index;
159 else
160 return Self.Exp_Cursor.Get_Index;
161 end if;
162 end Get_Index;
163
164 -----------------
165 -- Has_Element --
166 -----------------
167
168 overriding function Has_Element
169 (Self : Name_As_Expression_Cursor) return Boolean is
170 begin
171 return Self.Name.Has_Element;
172 end Has_Element;
173
174 -----------------
175 -- Has_Element --
176 -----------------
177
178 overriding function Has_Element (Self : Join_Cursor) return Boolean is
179 begin
180 return Self.Name.Has_Element or else Self.Exp.Has_Element;
181 end Has_Element;
182
183 -----------------
184 -- Has_Element --
185 -----------------
186
187 overriding function Has_Element
188 (Self : Prefer_Root_Cursor) return Boolean is
189 begin
190 return Self.Root_Cursor.Has_Element or else Self.Exp_Cursor.Has_Element;
191 end Has_Element;
192
193 procedure Initialize
194 (Self : in out Join_Cursor'Class;
195 IM : access Gela.Interpretations.Interpretation_Manager'Class;
196 TM : Gela.Type_Managers.Type_Manager_Access;
197 Env : Gela.Semantic_Types.Env_Index;
198 Set : Gela.Interpretations.Interpretation_Set_Index) is
199 begin
200 Self.Exp := Gela.Plain_Int_Sets.Cursors.Expression_Cursor
201 (IM.Expressions (Set).First);
202
203 Self.Name.Name := Gela.Plain_Int_Sets.Cursors.Defining_Name_Cursor
204 (IM.Defining_Names (Set).First);
205
206 Self.Name.TM := TM;
207 Self.Name.Env := Env;
208 Self.Name.Tipe := 0;
209 Self.Name.Step;
210 end Initialize;
211
212 ----------------
213 -- Initialize --
214 ----------------
215
216 procedure Initialize
217 (Self : in out Prefer_Root_Cursor'Class;
218 IM : access Gela.Interpretations.Interpretation_Manager'Class;
219 TM : Gela.Type_Managers.Type_Manager_Access;
220 Env : Gela.Semantic_Types.Env_Index;
221 Set : Gela.Interpretations.Interpretation_Set_Index) is
222 begin
223 Self.Root_Cursor.Initialize (IM, TM, Env, Set);
224 Self.Exp_Cursor.Initialize (IM, TM, Env, Set);
225 Self.Step;
226 end Initialize;
227
228 ----------
229 -- Next --
230 ----------
231
232 overriding procedure Next (Self : in out Name_As_Expression_Cursor) is
233 begin
234 Self.Name.Next;
235 Self.Step;
236 end Next;
237
238 ----------
239 -- Next --
240 ----------
241
242 overriding procedure Next (Self : in out Join_Cursor) is
243 begin
244 if Self.Name.Has_Element then
245 Self.Name.Next;
246 else
247 Self.Exp.Next;
248 end if;
249 end Next;
250
251 ----------
252 -- Next --
253 ----------
254
255 overriding procedure Next (Self : in out Prefer_Root_Cursor) is
256 begin
257 if Self.Root_Cursor.Has_Element then
258 Self.Root_Cursor.Next;
259 else
260 Self.Exp_Cursor.Next;
261 end if;
262
263 Self.Step;
264 end Next;
265
266 ----------
267 -- Step --
268 ----------
269
270 procedure Step (Self : in out Name_As_Expression_Cursor'Class) is
271 begin
272 Self.Tipe := 0;
273
274 while Self.Name.Has_Element loop
275 declare
276 Name : constant Gela.Elements.Defining_Names.Defining_Name_Access
277 := Self.Name.Defining_Name;
278 Decl : constant Gela.Elements.Element_Access :=
279 Name.Enclosing_Element;
280 begin
281 Self.Tipe := Self.TM.Type_Of_Object_Declaration (Self.Env, Decl);
282 exit when Self.Tipe not in 0;
283 Self.Name.Next;
284 end;
285 end loop;
286 end Step;
287
288 ----------
289 -- Step --
290 ----------
291
292 procedure Step (Self : in out Prefer_Root_Cursor'Class) is
293 TM : constant Gela.Type_Managers.Type_Manager_Access :=
294 Self.Root_Cursor.Name.TM;
295 Type_Index : Gela.Semantic_Types.Type_Index;
296 Type_View : Gela.Types.Type_View_Access;
297 begin
298 -- In the first phase look for root types and return them
299 while Self.Root_Cursor.Has_Element loop
300 Type_Index := Self.Root_Cursor.Expression_Type;
301 Type_View := TM.Get (Type_Index);
302
303 if Type_View in null then
304 null; -- Skip unknown types
305 elsif Type_View.Is_Root then
306 if Type_View.Is_Signed_Integer then
307 Self.Has_Integer_Root := True;
308 else
309 Self.Has_Real_Root := True;
310 end if;
311
312 return;
313 end if;
314
315 Self.Root_Cursor.Next;
316 end loop;
317
318 -- In the second phase look for other types, if not hidden by root
319 while Self.Exp_Cursor.Has_Element loop
320 Type_Index := Self.Exp_Cursor.Expression_Type;
321 Type_View := TM.Get (Type_Index);
322
323 if Type_View in null then
324 null; -- Skip unknown types
325 elsif Type_View.Is_Root then
326 null; -- Skip root types
327 elsif Self.Has_Integer_Root and then Type_View.Is_Signed_Integer then
328 null; -- Skip any integer type if we have integer_root
329 elsif Self.Has_Real_Root and then Type_View.Is_Real then
330 null; -- Skip any real type if we have real_root
331 else
332 -- Found other expression type, return it
333 return;
334 end if;
335
336 Self.Exp_Cursor.Next;
337 end loop;
338 end Step;
339
340 ----------
341 -- Step --
342 ----------
343
344 procedure Step (Self : in out Prefix_Cursor'Class) is
345
346 package Type_Visiters is
347 type Type_Visitor is new Gela.Types.Visitors.Type_Visitor
348 with null record;
349
350 overriding procedure Object_Access_Type
351 (Self : in out Type_Visitor;
352 Value : not null Gela.Types.Simple
353 .Object_Access_Type_Access);
354
355 end Type_Visiters;
356
357 package body Type_Visiters is
358
359 overriding procedure Object_Access_Type
360 (Self : in out Type_Visitor;
361 Value : not null Gela.Types.Simple
362 .Object_Access_Type_Access)
363 is
364 pragma Unreferenced (Self);
365 Index : constant Gela.Semantic_Types.Type_Index :=
366 Step.Self.Name.TM.Type_From_Subtype_Mark
367 (Step.Self.Name.Env, Value.Get_Designated);
368 begin
369 Step.Self.Is_Implicit_Dereference := True;
370 Step.Self.Implicit_Dereference_Type := Index;
371 end Object_Access_Type;
372
373 end Type_Visiters;
374
375 View : Gela.Types.Type_View_Access;
376 Visiter : Type_Visiters.Type_Visitor;
377 begin
378 if Self.Has_Element then
379 View := Self.Name.TM.Get (Join_Cursor (Self).Expression_Type);
380 end if;
381
382 Self.Is_Implicit_Dereference := False;
383 View.Visit_If_Assigned (Visiter);
384 end Step;
385
386 overriding procedure Next (Self : in out Prefix_Cursor) is
387 begin
388 if Self.Is_Implicit_Dereference then
389 Self.Is_Implicit_Dereference := False;
390 else
391 Join_Cursor (Self).Next;
392 Self.Step;
393 end if;
394 end Next;
395
396 overriding function Expression_Type
397 (Self : Prefix_Cursor) return Gela.Semantic_Types.Type_Index is
398 begin
399 if Self.Is_Implicit_Dereference then
400 return Self.Implicit_Dereference_Type;
401 else
402 return Join_Cursor (Self).Expression_Type;
403 end if;
404 end Expression_Type;
405
406 ---------------------
407 -- Expression_Type --
408 ---------------------
409
410 overriding function Expression_Type
411 (Self : Prefer_Root_Cursor)
412 return Gela.Semantic_Types.Type_Index is
413 begin
414 if Self.Root_Cursor.Has_Element then
415 return Self.Root_Cursor.Expression_Type;
416 else
417 return Self.Exp_Cursor.Expression_Type;
418 end if;
419 end Expression_Type;
420
421 package Join_Iterators is
422 new Gela.Plain_Int_Sets.Cursors.Generic_Iterators
423 (Cursor => Gela.Interpretations.Expression_Cursor,
424 Next => Gela.Interpretations.Next,
425 Some_Cursor => Join_Cursor,
426 Iterators => Gela.Interpretations.Expression_Iterators);
427
428 package Prefix_Iterators is
429 new Gela.Plain_Int_Sets.Cursors.Generic_Iterators
430 (Cursor => Gela.Interpretations.Expression_Cursor,
431 Next => Gela.Interpretations.Next,
432 Some_Cursor => Prefix_Cursor,
433 Iterators => Gela.Interpretations.Expression_Iterators);
434
435 package Prefer_Root_Iterators is
436 new Gela.Plain_Int_Sets.Cursors.Generic_Iterators
437 (Cursor => Gela.Interpretations.Expression_Cursor,
438 Next => Gela.Interpretations.Next,
439 Some_Cursor => Prefer_Root_Cursor,
440 Iterators => Gela.Interpretations.Expression_Iterators);
441
442 -----------------
443 -- Prefer_Root --
444 -----------------
445
446 function Prefer_Root
447 (Self : access Gela.Interpretations.Interpretation_Manager'Class;
448 TM : Gela.Type_Managers.Type_Manager_Access;
449 Env : Gela.Semantic_Types.Env_Index;
450 Set : Gela.Interpretations.Interpretation_Set_Index)
451 return Gela.Interpretations.Expression_Iterators.Forward_Iterator'Class
452 is
453 begin
454 return Result : Prefer_Root_Iterators.Iterator do
455 Result.Cursor.Initialize (Self, TM, Env, Set);
456 end return;
457 end Prefer_Root;
458
459 ------------
460 -- Prefix --
461 ------------
462
463 function Prefix
464 (Self : access Gela.Interpretations.Interpretation_Manager'Class;
465 TM : Gela.Type_Managers.Type_Manager_Access;
466 Env : Gela.Semantic_Types.Env_Index;
467 Set : Gela.Interpretations.Interpretation_Set_Index)
468 return Gela.Interpretations.Expression_Iterators.Forward_Iterator'Class
469 is
470 begin
471 return Result : Prefix_Iterators.Iterator do
472 Result.Cursor.Initialize (Self, TM, Env, Set);
473 Result.Cursor.Step;
474 end return;
475 end Prefix;
476
477 ----------------
478 -- Expression --
479 ----------------
480
481 function Expression
482 (Self : access Gela.Interpretations.Interpretation_Manager'Class;
483 TM : Gela.Type_Managers.Type_Manager_Access;
484 Env : Gela.Semantic_Types.Env_Index;
485 Set : Gela.Interpretations.Interpretation_Set_Index)
486 return Gela.Interpretations.Expression_Iterators.Forward_Iterator'Class
487 is
488 begin
489 return Result : Join_Iterators.Iterator do
490 Result.Cursor.Initialize (Self, TM, Env, Set);
491 end return;
492 end Expression;
493
494end Gela.Resolve.Each;
Note: See TracBrowser for help on using the repository browser.