source: trunk/ada-2012/src/semantic/gela-resolve.adb@ 358

Last change on this file since 358 was 358, checked in by Maxim Reznik, 6 years ago

Fix regressions

Drop (left) expicit convertions from Interpretation_Index to
Interpretation_Set_Index and replace them with iteration over
cursors.

File size: 22.2 KB
Line 
1with Gela.Defining_Name_Cursors;
2with Gela.Elements.Defining_Names;
3with Gela.Environments;
4with Gela.Type_Managers;
5
6package body Gela.Resolve is
7
8 procedure Get_Subtype
9 (Comp : Gela.Compilations.Compilation_Access;
10 Env : Gela.Semantic_Types.Env_Index;
11 Set : Gela.Interpretations.Interpretation_Set_Index;
12 Index : out Gela.Interpretations.Interpretation_Index;
13 Result : out Gela.Semantic_Types.Type_Index);
14
15 procedure To_Type
16 (Comp : Gela.Compilations.Compilation_Access;
17 Type_Up : Gela.Semantic_Types.Type_Index;
18 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
19 Result : out Gela.Interpretations.Interpretation_Index);
20
21 procedure Each_Expression
22 (Comp : Gela.Compilations.Compilation_Access;
23 Set : Gela.Interpretations.Interpretation_Set_Index;
24 Target : in out Gela.Interpretations.Visiter'Class);
25
26 -------------------------
27 -- Attribute_Reference --
28 -------------------------
29
30 procedure Attribute_Reference
31 (Comp : Gela.Compilations.Compilation_Access;
32 Env : Gela.Semantic_Types.Env_Index;
33 Prefix : Gela.Interpretations.Interpretation_Set_Index;
34 Symbol : Gela.Lexical_Types.Symbol;
35 Token : Gela.Lexical_Types.Token_Count;
36 Set : out Gela.Interpretations.Interpretation_Set_Index)
37 is
38 use type Gela.Lexical_Types.Symbol;
39 use type Gela.Lexical_Types.Token_Count;
40
41 TM : constant Gela.Type_Managers.Type_Manager_Access :=
42 Comp.Context.Types;
43
44 Attr : Gela.Lexical_Types.Predefined_Symbols.Symbol;
45 Type_Index : Gela.Semantic_Types.Type_Index;
46 Index : Gela.Interpretations.Interpretation_Index;
47 begin
48 Set := 0;
49
50 if Token = 0 then
51 Attr := Symbol;
52 else
53 Attr := Gela.Lexical_Types.Predefined_Symbols.Range_Symbol;
54 end if;
55
56 case Attr is
57 when Gela.Lexical_Types.Predefined_Symbols.Last =>
58 Get_Subtype
59 (Comp,
60 Env => Env,
61 Set => Prefix,
62 Index => Index,
63 Result => Type_Index);
64
65 Comp.Context.Interpretation_Manager.Add_Expression
66 (Tipe => Type_Index,
67 Down => (1 => Index),
68 Result => Set);
69 when Gela.Lexical_Types.Predefined_Symbols.Val =>
70 Get_Subtype
71 (Comp,
72 Env => Env,
73 Set => Prefix,
74 Index => Index,
75 Result => Type_Index);
76
77 Comp.Context.Interpretation_Manager.Add_Attr_Function
78 (Kind => Attr,
79 Down => (1 => Index),
80 Result => Set);
81
82 when Gela.Lexical_Types.Predefined_Symbols.Size =>
83 Get_Subtype
84 (Comp,
85 Env => Env,
86 Set => Prefix,
87 Index => Index,
88 Result => Type_Index);
89
90 Comp.Context.Interpretation_Manager.Add_Expression
91 (Tipe => TM.Universal_Integer,
92 Down => (1 => Index),
93 Result => Set);
94
95 when others =>
96 null;
97 end case;
98 end Attribute_Reference;
99
100 -----------------
101 -- Direct_Name --
102 -----------------
103
104 procedure Direct_Name
105 (Comp : Gela.Compilations.Compilation_Access;
106 Env : Gela.Semantic_Types.Env_Index;
107 Symbol : Gela.Lexical_Types.Symbol;
108 Set : out Gela.Interpretations.Interpretation_Set_Index)
109 is
110 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
111 Comp.Context.Interpretation_Manager;
112 ES : constant Gela.Environments.Environment_Set_Access :=
113 Comp.Context.Environment_Set;
114 DV : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
115 ES.Direct_Visible (Env, Symbol);
116
117 Have_Direct_Visible : constant Boolean := DV.Has_Element;
118 begin
119 Set := 0;
120
121 while DV.Has_Element loop
122 IM.Add_Defining_Name
123 (Name => DV.Element,
124 Down => (1 .. 0 => 0),
125 Result => Set);
126
127 DV.Next;
128 end loop;
129
130 if Have_Direct_Visible then
131 return;
132 end if;
133
134 declare
135 UV : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
136 ES.Use_Visible (Env, Symbol);
137 begin
138 while UV.Has_Element loop
139 IM.Add_Defining_Name
140 (Name => UV.Element,
141 Down => (1 .. 0 => 0),
142 Result => Set);
143
144 UV.Next;
145 end loop;
146 end;
147 end Direct_Name;
148
149 procedure Each_Expression
150 (Comp : Gela.Compilations.Compilation_Access;
151 Set : Gela.Interpretations.Interpretation_Set_Index;
152 Target : in out Gela.Interpretations.Visiter'Class)
153 is
154 package Each is
155 type Visiter is new Gela.Interpretations.Visiter with record
156 null;
157 end record;
158
159 overriding procedure On_Defining_Name
160 (Self : in out Visiter;
161 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
162 Down : Gela.Interpretations.Interpretation_Index_Array);
163
164 overriding procedure On_Expression
165 (Self : in out Visiter;
166 Tipe : Gela.Semantic_Types.Type_Index;
167 Down : Gela.Interpretations.Interpretation_Index_Array);
168
169 overriding procedure On_Attr_Function
170 (Self : in out Visiter;
171 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
172 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
173
174 end Each;
175
176 ----------
177 -- Each --
178 ----------
179
180 package body Each is
181
182 overriding procedure On_Defining_Name
183 (Self : in out Visiter;
184 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
185 Down : Gela.Interpretations.Interpretation_Index_Array)
186 is
187 pragma Unreferenced (Self);
188 pragma Unreferenced (Name);
189 pragma Unreferenced (Down);
190 begin
191 null;
192 end On_Defining_Name;
193
194 overriding procedure On_Expression
195 (Self : in out Visiter;
196 Tipe : Gela.Semantic_Types.Type_Index;
197 Down : Gela.Interpretations.Interpretation_Index_Array)
198 is
199 pragma Unreferenced (Self);
200 begin
201 Target.On_Expression (Tipe, Down);
202 end On_Expression;
203
204 end Each;
205
206 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
207 Comp.Context.Interpretation_Manager;
208
209 Visiter : aliased Each.Visiter;
210 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Set);
211 begin
212 while Cursor.Has_Element loop
213 Cursor.Visit (Visiter'Access);
214 Cursor.Next;
215 end loop;
216 end Each_Expression;
217
218 -------------------
219 -- Function_Call --
220 -------------------
221
222 procedure Function_Call
223 (Comp : Gela.Compilations.Compilation_Access;
224 Env : Gela.Semantic_Types.Env_Index;
225 Prefix : Gela.Interpretations.Interpretation_Set_Index;
226 Args : Gela.Interpretations.Interpretation_Set_Index;
227 Set : out Gela.Interpretations.Interpretation_Set_Index)
228 is
229 pragma Unreferenced (Env);
230 pragma Unreferenced (Args);
231
232 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
233 Comp.Context.Interpretation_Manager;
234
235 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
236 begin
237 Set := 0;
238
239 while Cursor.Has_Element loop
240 Comp.Context.Interpretation_Manager.Add_Expression
241 (Tipe => Comp.Context.Types.Universal_Integer,
242 Down => (1 .. 1 => Cursor.Get_Index),
243 Result => Set);
244
245 Cursor.Next;
246 end loop;
247 end Function_Call;
248
249 -----------------
250 -- Get_Subtype --
251 -----------------
252
253 procedure Get_Subtype
254 (Comp : Gela.Compilations.Compilation_Access;
255 Env : Gela.Semantic_Types.Env_Index;
256 Set : Gela.Interpretations.Interpretation_Set_Index;
257 Index : out Gela.Interpretations.Interpretation_Index;
258 Result : out Gela.Semantic_Types.Type_Index)
259 is
260 pragma Unreferenced (Env);
261
262 package Each is
263 type Visiter is new Gela.Interpretations.Visiter with record
264 Index : Gela.Interpretations.Interpretation_Index := 0;
265 Result : Gela.Semantic_Types.Type_Index := 0;
266 end record;
267
268 overriding procedure On_Defining_Name
269 (Self : in out Visiter;
270 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
271 Down : Gela.Interpretations.Interpretation_Index_Array);
272
273 overriding procedure On_Expression
274 (Self : in out Visiter;
275 Tipe : Gela.Semantic_Types.Type_Index;
276 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
277
278 overriding procedure On_Attr_Function
279 (Self : in out Visiter;
280 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
281 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
282
283 end Each;
284
285 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
286 Comp.Context.Interpretation_Manager;
287
288 TM : constant Gela.Type_Managers.Type_Manager_Access :=
289 Comp.Context.Types;
290
291 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Set);
292
293 ----------
294 -- Each --
295 ----------
296
297 package body Each is
298
299 overriding procedure On_Defining_Name
300 (Self : in out Visiter;
301 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
302 Down : Gela.Interpretations.Interpretation_Index_Array)
303 is
304 pragma Unreferenced (Self);
305 pragma Unreferenced (Down);
306 begin
307 Self.Result := TM.Type_By_Name (Name);
308 Self.Index := Cursor.Get_Index;
309 end On_Defining_Name;
310
311 end Each;
312
313 Visiter : aliased Each.Visiter;
314 begin
315 while Cursor.Has_Element loop
316 Cursor.Visit (Visiter'Access);
317 Cursor.Next;
318 end loop;
319
320 Index := Visiter.Index;
321 Result := Visiter.Result;
322 end Get_Subtype;
323
324 procedure Interpretation
325 (Comp : Gela.Compilations.Compilation_Access;
326 Env : Gela.Semantic_Types.Env_Index;
327 Set : Gela.Interpretations.Interpretation_Set_Index;
328 Result : out Gela.Interpretations.Interpretation_Index)
329 is
330 pragma Unreferenced (Env);
331
332 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
333 Comp.Context.Interpretation_Manager;
334
335 Cursor : constant Gela.Interpretations.Cursor'Class :=
336 IM.Get_Cursor (Set);
337
338 begin
339 if Cursor.Has_Element then
340 Result := Cursor.Get_Index;
341 else
342 Result := 0;
343 end if;
344 end Interpretation;
345
346 ---------------------
347 -- Numeric_Literal --
348 ---------------------
349
350 procedure Numeric_Literal
351 (Comp : Gela.Compilations.Compilation_Access;
352 Token : Gela.Lexical_Types.Token_Count;
353 Result : out Gela.Interpretations.Interpretation_Set_Index)
354 is
355 Value : constant Gela.Lexical_Types.Token := Comp.Get_Token (Token);
356 Type_Index : Gela.Semantic_Types.Type_Index;
357 begin
358 Result := 0;
359
360 if Comp.Source.Index (Value.First, Value.Last, '.') = 0 then
361 Type_Index := Comp.Context.Types.Universal_Integer;
362 else
363 Type_Index := Comp.Context.Types.Universal_Real;
364 end if;
365
366 Comp.Context.Interpretation_Manager.Add_Expression
367 (Tipe => Type_Index,
368 Down => (1 .. 0 => 0),
369 Result => Result);
370 end Numeric_Literal;
371
372 ------------------------
373 -- Selected_Component --
374 ------------------------
375
376 procedure Selected_Component
377 (Comp : Gela.Compilations.Compilation_Access;
378 Env : Gela.Semantic_Types.Env_Index;
379 Prefix : Gela.Interpretations.Interpretation_Set_Index;
380 Symbol : Gela.Lexical_Types.Symbol;
381 Set : out Gela.Interpretations.Interpretation_Set_Index)
382 is
383 package Each is
384 type Visiter is new Gela.Interpretations.Visiter with null record;
385
386 overriding procedure On_Defining_Name
387 (Self : in out Visiter;
388 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
389 Down : Gela.Interpretations.Interpretation_Index_Array);
390
391 overriding procedure On_Expression
392 (Self : in out Visiter;
393 Tipe : Gela.Semantic_Types.Type_Index;
394 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
395
396 overriding procedure On_Attr_Function
397 (Self : in out Visiter;
398 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
399 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
400
401 end Each;
402
403 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
404 Comp.Context.Interpretation_Manager;
405
406 ES : constant Gela.Environments.Environment_Set_Access :=
407 Comp.Context.Environment_Set;
408
409 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
410
411 ----------
412 -- Each --
413 ----------
414
415 package body Each is
416
417 overriding procedure On_Defining_Name
418 (Self : in out Visiter;
419 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
420 Down : Gela.Interpretations.Interpretation_Index_Array)
421 is
422 pragma Unreferenced (Self);
423 pragma Unreferenced (Down);
424 Found : aliased Boolean;
425 NC : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
426 := ES.Visible (Env, Name, Symbol, Found'Access);
427 begin
428 while NC.Has_Element loop
429 IM.Add_Defining_Name
430 (Name => NC.Element,
431 Down => (1 => Cursor.Get_Index),
432 Result => Set);
433
434 NC.Next;
435 end loop;
436 end On_Defining_Name;
437
438 end Each;
439
440 Visiter : aliased Each.Visiter;
441 begin
442 Set := 0;
443 while Cursor.Has_Element loop
444 Cursor.Visit (Visiter'Access);
445 Cursor.Next;
446 end loop;
447 end Selected_Component;
448
449 ----------------------
450 -- Shall_Be_Subtype --
451 ----------------------
452
453 procedure Shall_Be_Subtype
454 (Comp : Gela.Compilations.Compilation_Access;
455 Env : Gela.Semantic_Types.Env_Index;
456 Set : Gela.Interpretations.Interpretation_Set_Index;
457 Result : out Gela.Interpretations.Interpretation_Index)
458 is
459 Type_Index : Gela.Semantic_Types.Type_Index;
460 begin
461 Get_Subtype
462 (Comp,
463 Env => Env,
464 Set => Set,
465 Index => Result,
466 Result => Type_Index);
467 end Shall_Be_Subtype;
468
469 -----------------------------
470 -- Simple_Expression_Range --
471 -----------------------------
472
473 procedure Simple_Expression_Range
474 (Comp : Gela.Compilations.Compilation_Access;
475 Env : Gela.Semantic_Types.Env_Index;
476 Left : Gela.Interpretations.Interpretation_Set_Index;
477 Right : Gela.Interpretations.Interpretation_Set_Index;
478 Set : out Gela.Interpretations.Interpretation_Set_Index)
479 is
480 pragma Unreferenced (Env);
481 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
482 Comp.Context.Interpretation_Manager;
483
484 Cursor_Left : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Left);
485 Cursor_Right : Gela.Interpretations.Cursor'Class :=
486 IM.Get_Cursor (Right);
487
488 begin
489 Set := 0;
490 while Cursor_Left.Has_Element loop
491 while Cursor_Right.Has_Element loop
492 -- FIX ME: compare types of left and right interpretation
493 Comp.Context.Interpretation_Manager.Add_Expression
494 (Tipe => 0,
495 Down => (Cursor_Left.Get_Index,
496 Cursor_Right.Get_Index),
497 Result => Set);
498
499 Cursor_Right.Next;
500 end loop;
501
502 Cursor_Left.Next;
503 end loop;
504 end Simple_Expression_Range;
505
506 ----------------------
507 -- To_The_Same_Type --
508 ----------------------
509
510 procedure To_The_Same_Type
511 (Comp : Gela.Compilations.Compilation_Access;
512 Env : Gela.Semantic_Types.Env_Index;
513 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
514 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
515 Result : out Gela.Interpretations.Interpretation_Index)
516 is
517 pragma Unreferenced (Env);
518
519 package Each is
520 type Visiter is new Gela.Interpretations.Visiter with record
521 null;
522 end record;
523
524 overriding procedure On_Defining_Name
525 (Self : in out Visiter;
526 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
527 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
528
529 overriding procedure On_Expression
530 (Self : in out Visiter;
531 Tipe : Gela.Semantic_Types.Type_Index;
532 Down : Gela.Interpretations.Interpretation_Index_Array);
533
534 overriding procedure On_Attr_Function
535 (Self : in out Visiter;
536 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
537 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
538
539 end Each;
540
541 ----------
542 -- Each --
543 ----------
544
545 package body Each is
546
547 overriding procedure On_Expression
548 (Self : in out Visiter;
549 Tipe : Gela.Semantic_Types.Type_Index;
550 Down : Gela.Interpretations.Interpretation_Index_Array)
551 is
552 pragma Unreferenced (Self);
553 pragma Unreferenced (Down);
554 begin
555 To_Type
556 (Comp => Comp,
557 Type_Up => Tipe,
558 Expr_Up => Expr_Up,
559 Result => Result);
560 end On_Expression;
561
562 end Each;
563
564 Visiter : Each.Visiter;
565 begin
566 Result := 0;
567
568 Each_Expression (Comp => Comp,
569 Set => Type_Up,
570 Target => Visiter);
571 end To_The_Same_Type;
572
573 -------------
574 -- To_Type --
575 -------------
576
577 procedure To_Type
578 (Comp : Gela.Compilations.Compilation_Access;
579 Env : Gela.Semantic_Types.Env_Index;
580 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
581 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
582 Result : out Gela.Interpretations.Interpretation_Index)
583 is
584 Index : Gela.Interpretations.Interpretation_Index;
585 Type_Index : Gela.Semantic_Types.Type_Index;
586 begin
587 Get_Subtype
588 (Comp,
589 Env => Env,
590 Set => Type_Up,
591 Index => Index,
592 Result => Type_Index);
593
594 To_Type
595 (Comp => Comp,
596 Type_Up => Type_Index,
597 Expr_Up => Expr_Up,
598 Result => Result);
599 end To_Type;
600
601 -------------
602 -- To_Type --
603 -------------
604
605 procedure To_Type
606 (Comp : Gela.Compilations.Compilation_Access;
607 Type_Up : Gela.Semantic_Types.Type_Index;
608 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
609 Result : out Gela.Interpretations.Interpretation_Index)
610 is
611
612 package Each is
613 type Visiter is new Gela.Interpretations.Visiter with record
614 Type_Index : Gela.Semantic_Types.Type_Index;
615 Index : Gela.Interpretations.Interpretation_Index := 0;
616 end record;
617
618 overriding procedure On_Defining_Name
619 (Self : in out Visiter;
620 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
621 Down : Gela.Interpretations.Interpretation_Index_Array);
622
623 overriding procedure On_Expression
624 (Self : in out Visiter;
625 Tipe : Gela.Semantic_Types.Type_Index;
626 Down : Gela.Interpretations.Interpretation_Index_Array);
627
628 overriding procedure On_Attr_Function
629 (Self : in out Visiter;
630 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
631 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
632
633 end Each;
634
635 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
636 Comp.Context.Interpretation_Manager;
637
638 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Expr_Up);
639
640 ----------
641 -- Each --
642 ----------
643
644 package body Each is
645
646 overriding procedure On_Defining_Name
647 (Self : in out Visiter;
648 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
649 Down : Gela.Interpretations.Interpretation_Index_Array)
650 is
651 pragma Unreferenced (Name);
652 pragma Unreferenced (Down);
653 begin
654 Self.Index := Cursor.Get_Index;
655 end On_Defining_Name;
656
657 overriding procedure On_Expression
658 (Self : in out Visiter;
659 Tipe : Gela.Semantic_Types.Type_Index;
660 Down : Gela.Interpretations.Interpretation_Index_Array)
661 is
662 pragma Unreferenced (Tipe);
663 pragma Unreferenced (Down);
664 begin
665 Self.Index := Cursor.Get_Index;
666 end On_Expression;
667
668 end Each;
669
670 Visiter : aliased Each.Visiter;
671 begin
672 Visiter.Type_Index := Type_Up;
673
674 while Cursor.Has_Element loop
675 Cursor.Visit (Visiter'Access);
676 Cursor.Next;
677 end loop;
678
679 Result := Visiter.Index;
680 end To_Type;
681
682 ------------------------------
683 -- To_Type_Or_The_Same_Type --
684 ------------------------------
685
686 procedure To_Type_Or_The_Same_Type
687 (Comp : Gela.Compilations.Compilation_Access;
688 Env : Gela.Semantic_Types.Env_Index;
689 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
690 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
691 Result : out Gela.Interpretations.Interpretation_Index)
692 is
693 use type Gela.Semantic_Types.Type_Index;
694
695 Index : Gela.Interpretations.Interpretation_Index;
696 Type_Index : Gela.Semantic_Types.Type_Index;
697 begin
698 Get_Subtype
699 (Comp,
700 Env => Env,
701 Set => Type_Up,
702 Index => Index,
703 Result => Type_Index);
704
705 if Type_Index = 0 then
706 To_The_Same_Type
707 (Comp => Comp,
708 Env => Env,
709 Type_Up => Type_Up,
710 Expr_Up => Expr_Up,
711 Result => Result);
712 else
713 To_Type
714 (Comp => Comp,
715 Type_Up => Type_Index,
716 Expr_Up => Expr_Up,
717 Result => Result);
718 end if;
719 end To_Type_Or_The_Same_Type;
720
721end Gela.Resolve;
Note: See TracBrowser for help on using the repository browser.