source: trunk/ada-2012/src/semantic/gela-resolve.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: 75.6 KB
Line 
1with Ada.Containers.Hashed_Maps;
2with Ada.Containers.Vectors;
3
4with Gela.Defining_Name_Cursors;
5with Gela.Element_Visiters;
6with Gela.Elements.Composite_Constraints;
7with Gela.Elements.Defining_Identifiers;
8with Gela.Elements.Formal_Object_Declarations;
9with Gela.Elements.Formal_Type_Declarations;
10with Gela.Elements.Generic_Formals;
11with Gela.Elements.Generic_Package_Declarations;
12with Gela.Elements.Range_Attribute_References;
13with Gela.Elements.Simple_Expression_Ranges;
14with Gela.Environments;
15with Gela.Profiles;
16with Gela.Resolve.Type_Matchers;
17with Gela.Type_Managers;
18with Gela.Types.Arrays;
19with Gela.Types.Simple;
20with Gela.Types.Untagged_Records;
21with Gela.Types.Visitors;
22
23with Gela.Resolve.Each;
24
25package body Gela.Resolve is
26
27 procedure To_Type_Category
28 (Comp : Gela.Compilations.Compilation_Access;
29 Up : Gela.Interpretations.Interpretation_Set_Index;
30 Tipe : Gela.Semantic_Types.Type_Index;
31 Result : out Gela.Interpretations.Interpretation_Index);
32 -- Fetch Type_Category interpretation from Up that match given Tipe.
33
34 procedure Get_Subtype
35 (Comp : Gela.Compilations.Compilation_Access;
36 Env : Gela.Semantic_Types.Env_Index;
37 Set : Gela.Interpretations.Interpretation_Set_Index;
38 Index : out Gela.Interpretations.Interpretation_Index;
39 Result : out Gela.Semantic_Types.Type_Index);
40
41 procedure To_Type
42 (Comp : Gela.Compilations.Compilation_Access;
43 Env : Gela.Semantic_Types.Env_Index;
44 Type_Up : Gela.Semantic_Types.Type_Index;
45 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
46 Result : out Gela.Interpretations.Interpretation_Index);
47
48 procedure Discrete_Range
49 (Comp : Gela.Compilations.Compilation_Access;
50 Env : Gela.Semantic_Types.Env_Index;
51 Left : Gela.Interpretations.Interpretation_Set_Index;
52 Right : Gela.Interpretations.Interpretation_Set_Index;
53 Down_Left : out Gela.Interpretations.Interpretation_Index;
54 Down_Right : out Gela.Interpretations.Interpretation_Index;
55 Tipe : out Gela.Semantic_Types.Type_Index);
56
57 function Array_Matcher
58 return not null Gela.Interpretations.Type_Matcher_Access
59 is
60 Result : constant Type_Matchers.Type_Matcher_Access :=
61 new Type_Matchers.Array_Type_Matcher;
62 begin
63 return Gela.Interpretations.Type_Matcher_Access (Result);
64 end Array_Matcher;
65
66 ----------------------
67 -- Assignment_Right --
68 ----------------------
69
70 procedure Assignment_Right
71 (Comp : Gela.Compilations.Compilation_Access;
72 Env : Gela.Semantic_Types.Env_Index;
73 Left : Gela.Interpretations.Interpretation_Set_Index;
74 Right : Gela.Interpretations.Interpretation_Set_Index;
75 Result : out Gela.Interpretations.Interpretation_Index)
76 is
77 begin
78 -- ARM 5.2 (4/2)
79 To_Type_Or_The_Same_Type
80 (Comp => Comp,
81 Env => Env,
82 Type_Up => Left,
83 Expr_Up => Right,
84 Result => Result);
85 end Assignment_Right;
86
87 -------------------------
88 -- Attribute_Reference --
89 -------------------------
90
91 procedure Attribute_Reference
92 (Comp : Gela.Compilations.Compilation_Access;
93 Env : Gela.Semantic_Types.Env_Index;
94 Prefix : Gela.Interpretations.Interpretation_Set_Index;
95 Symbol : Gela.Lexical_Types.Symbol;
96 Set : out Gela.Interpretations.Interpretation_Set_Index)
97 is
98 use type Gela.Lexical_Types.Symbol;
99 use type Gela.Semantic_Types.Type_Index;
100
101 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
102 Comp.Context.Interpretation_Manager;
103
104 TM : constant Gela.Type_Managers.Type_Manager_Access :=
105 Comp.Context.Types;
106
107 Index : Gela.Interpretations.Interpretation_Index;
108 Is_Length : constant Boolean :=
109 Symbol = Gela.Lexical_Types.Predefined_Symbols.Length;
110 Type_Index : Gela.Semantic_Types.Type_Index;
111 begin
112 Set := 0;
113
114 case Symbol is
115 when Gela.Lexical_Types.Predefined_Symbols.Length |
116 Gela.Lexical_Types.Predefined_Symbols.First |
117 Gela.Lexical_Types.Predefined_Symbols.Range_Symbol |
118 Gela.Lexical_Types.Predefined_Symbols.Last =>
119
120 Get_Subtype
121 (Comp,
122 Env => Env,
123 Set => Prefix,
124 Index => Index,
125 Result => Type_Index);
126
127 if Type_Index = 0 then
128 for J in Each.Prefix (IM, TM, Env, Prefix) loop
129 declare
130 View : constant Gela.Types.Type_View_Access :=
131 TM.Get (J.Expression_Type);
132 Arr : Gela.Types.Arrays.Array_Type_Access;
133 begin
134 if View.Assigned and then View.Is_Array then
135 Arr := Gela.Types.Arrays.Array_Type_Access (View);
136
137 if Is_Length then
138 Comp.Context.Interpretation_Manager.Add_Expression
139 (Tipe => TM.Universal_Integer,
140 Down => (1 => Index),
141 Result => Set);
142 else
143 Comp.Context.Interpretation_Manager.Add_Expression
144 (Tipe => Arr.all.Index_Types (1),
145 Down => (1 => Index),
146 Result => Set);
147 end if;
148 end if;
149 end;
150 end loop;
151 elsif Is_Length then
152 Comp.Context.Interpretation_Manager.Add_Expression
153 (Tipe => TM.Universal_Integer,
154 Down => (1 => Index),
155 Result => Set);
156 else
157 Comp.Context.Interpretation_Manager.Add_Expression
158 (Tipe => Type_Index,
159 Down => (1 => Index),
160 Result => Set);
161 end if;
162 when
163-- Gela.Lexical_Types.Predefined_Symbols.Adjacent |
164 Gela.Lexical_Types.Predefined_Symbols.Ceiling |
165-- Gela.Lexical_Types.Predefined_Symbols.Compose |
166-- Gela.Lexical_Types.Predefined_Symbols.Copy_Sign |
167-- Gela.Lexical_Types.Predefined_Symbols.Exponent |
168 Gela.Lexical_Types.Predefined_Symbols.Floor |
169 Gela.Lexical_Types.Predefined_Symbols.Fraction |
170-- Gela.Lexical_Types.Predefined_Symbols.Image |
171-- Gela.Lexical_Types.Predefined_Symbols.Input |
172-- Gela.Lexical_Types.Predefined_Symbols.Leading_Part |
173 Gela.Lexical_Types.Predefined_Symbols.Machine |
174 Gela.Lexical_Types.Predefined_Symbols.Machine_Rounding |
175-- Gela.Lexical_Types.Predefined_Symbols.Max |
176-- Gela.Lexical_Types.Predefined_Symbols.Min |
177 Gela.Lexical_Types.Predefined_Symbols.Mod_Symbol |
178 Gela.Lexical_Types.Predefined_Symbols.Model |
179 Gela.Lexical_Types.Predefined_Symbols.Pos |
180 Gela.Lexical_Types.Predefined_Symbols.Pred |
181-- Gela.Lexical_Types.Predefined_Symbols.Remainder |
182-- Gela.Lexical_Types.Predefined_Symbols.Round |
183 Gela.Lexical_Types.Predefined_Symbols.Rounding |
184-- Gela.Lexical_Types.Predefined_Symbols.Scaling |
185 Gela.Lexical_Types.Predefined_Symbols.Succ |
186 Gela.Lexical_Types.Predefined_Symbols.Truncation |
187 Gela.Lexical_Types.Predefined_Symbols.Unbiased_Rounding |
188 Gela.Lexical_Types.Predefined_Symbols.Val =>
189-- Gela.Lexical_Types.Predefined_Symbols.Value |
190-- Gela.Lexical_Types.Predefined_Symbols.Wide_Image |
191-- Gela.Lexical_Types.Predefined_Symbols.Wide_Value |
192-- Gela.Lexical_Types.Predefined_Symbols.Wide_Wide_Image |
193-- Gela.Lexical_Types.Predefined_Symbols.Wide_Wide_Value =>
194
195 Get_Subtype
196 (Comp,
197 Env => Env,
198 Set => Prefix,
199 Index => Index,
200 Result => Type_Index);
201
202 Comp.Context.Interpretation_Manager.Add_Attr_Function
203 (Kind => Symbol,
204 Tipe => Type_Index,
205 Down => (1 => Index),
206 Result => Set);
207
208 when Gela.Lexical_Types.Predefined_Symbols.Size =>
209 Get_Subtype
210 (Comp,
211 Env => Env,
212 Set => Prefix,
213 Index => Index,
214 Result => Type_Index);
215
216 Comp.Context.Interpretation_Manager.Add_Expression
217 (Tipe => TM.Universal_Integer,
218 Down => (1 => Index),
219 Result => Set);
220
221 when others =>
222 null;
223 end case;
224 end Attribute_Reference;
225
226 --------------------
227 -- Case_Statement --
228 --------------------
229
230 procedure Case_Statement
231 (Comp : Gela.Compilations.Compilation_Access;
232 Env : Gela.Semantic_Types.Env_Index;
233 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
234 Tuple : Gela.Interpretations.Interpretation_Tuple_List_Index;
235 Result : out Gela.Interpretations.Interpretation_Index)
236 is
237 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
238 Comp.Context.Interpretation_Manager;
239
240 TM : constant Gela.Type_Managers.Type_Manager_Access :=
241 Comp.Context.Types;
242
243 Tuples : constant Gela.Interpretations.Interpretation_Tuple_Index_Array
244 := IM.Get_Tuple_List (Tuple);
245
246 Output : Gela.Interpretations.Interpretation_Index_Array (Tuples'Range);
247 Chosen : Gela.Interpretations.Interpretation_Index := 0;
248 begin
249 Result := 0;
250
251 for X in Each.Expression (IM, TM, Env, Expr_Up) loop
252 for J in Tuples'Range loop
253 declare
254 Value : constant Gela.Interpretations
255 .Interpretation_Set_Index_Array := IM.Get_Tuple (Tuples (J));
256 List : Gela.Interpretations.Interpretation_Index_Array
257 (Value'Range);
258 begin
259 for K in Value'Range loop
260 To_Type
261 (Comp => Comp,
262 Env => Env,
263 Type_Up => X.Expression_Type,
264 Expr_Up => Value (K),
265 Result => List (K));
266 end loop;
267
268 Chosen := 0;
269
270 for K in reverse List'Range loop
271 IM.Get_Tuple_Index (List (K), Chosen, Chosen);
272 end loop;
273
274 Output (J) := Chosen;
275 end;
276 end loop;
277
278 for J in reverse Output'Range loop
279 IM.Get_Tuple_Index (Output (J), Result, Result);
280 end loop;
281
282 exit;
283 end loop;
284 end Case_Statement;
285
286 -----------------------
287 -- Character_Literal --
288 -----------------------
289
290 procedure Character_Literal
291 (Comp : Gela.Compilations.Compilation_Access;
292 Result : out Gela.Interpretations.Interpretation_Set_Index)
293 is
294 Type_Matcher : constant Type_Matchers.Type_Matcher_Access :=
295 new Type_Matchers.Character_Type_Matcher;
296 begin
297 Result := 0;
298
299 Comp.Context.Interpretation_Manager.Add_Expression_Category
300 (Match => Gela.Interpretations.Type_Matcher_Access (Type_Matcher),
301 Down => (1 .. 0 => 0),
302 Result => Result);
303 end Character_Literal;
304
305 ----------------
306 -- Constraint --
307 ----------------
308
309 procedure Constraint
310 (Comp : Gela.Compilations.Compilation_Access;
311 Constraint : access Gela.Elements.Element'Class;
312 Env : Gela.Semantic_Types.Env_Index;
313 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
314 Constr : Gela.Interpretations.Interpretation_Set_Index;
315 Result : out Gela.Interpretations.Interpretation_Index)
316 is
317 package Each_Constraint is
318 type Visiter is new Gela.Element_Visiters.Visiter with null record;
319
320 overriding procedure Range_Attribute_Reference
321 (Self : in out Visiter;
322 Node : not null Gela.Elements.Range_Attribute_References.
323 Range_Attribute_Reference_Access);
324
325 overriding procedure Simple_Expression_Range
326 (Self : in out Visiter;
327 Node : not null Gela.Elements.Simple_Expression_Ranges.
328 Simple_Expression_Range_Access);
329
330 end Each_Constraint;
331
332 package body Each_Constraint is
333
334 overriding procedure Range_Attribute_Reference
335 (Self : in out Visiter;
336 Node : not null Gela.Elements.Range_Attribute_References.
337 Range_Attribute_Reference_Access)
338 is
339 pragma Unreferenced (Node, Self);
340 begin
341 -- 3.5 (5)
342 Gela.Resolve.To_Type
343 (Comp => Comp,
344 Env => Env,
345 Type_Up => Type_Up,
346 Expr_Up => Constr,
347 Result => Result);
348 end Range_Attribute_Reference;
349
350 overriding procedure Simple_Expression_Range
351 (Self : in out Visiter;
352 Node : not null Gela.Elements.Simple_Expression_Ranges.
353 Simple_Expression_Range_Access)
354 is
355 pragma Unreferenced (Node, Self);
356 begin
357 -- 3.5 (5)
358 Gela.Resolve.To_Type
359 (Comp => Comp,
360 Env => Env,
361 Type_Up => Type_Up,
362 Expr_Up => Constr,
363 Result => Result);
364 end Simple_Expression_Range;
365
366 end Each_Constraint;
367
368 V : Each_Constraint.Visiter;
369
370 begin
371 Result := 0;
372
373 if not Constraint.Assigned then
374 return;
375 end if;
376
377 Constraint.Visit (V);
378 end Constraint;
379
380 procedure Constraint
381 (Comp : Gela.Compilations.Compilation_Access;
382 Constraint : access Gela.Elements.Element'Class;
383 Env : Gela.Semantic_Types.Env_Index;
384 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
385 Constr : Gela.Interpretations.Interpretation_Tuple_List_Index;
386 Result : out Gela.Interpretations.Interpretation_Index)
387 is
388 package Each_Constraint is
389 type Visiter is new Gela.Element_Visiters.Visiter with null record;
390
391 overriding procedure Composite_Constraint
392 (Self : in out Visiter;
393 Node : not null Gela.Elements.Composite_Constraints.
394 Composite_Constraint_Access);
395
396 end Each_Constraint;
397
398 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
399 Comp.Context.Interpretation_Manager;
400 TM : constant Gela.Type_Managers.Type_Manager_Access :=
401 Comp.Context.Types;
402
403 Type_Index : Gela.Semantic_Types.Type_Index;
404
405 package body Each_Constraint is
406
407 overriding procedure Composite_Constraint
408 (Self : in out Visiter;
409 Node : not null Gela.Elements.Composite_Constraints.
410 Composite_Constraint_Access)
411 is
412 pragma Unreferenced (Node, Self);
413
414 Tuples : constant Gela.Interpretations
415 .Interpretation_Tuple_Index_Array := IM.Get_Tuple_List (Constr);
416
417 Output : Gela.Interpretations.Interpretation_Index_Array
418 (Tuples'Range);
419
420 package Type_Visiters is
421 type Type_Visitor is new Gela.Types.Visitors.Type_Visitor
422 with null record;
423
424 overriding procedure Array_Type
425 (Self : in out Type_Visitor;
426 Value : not null Gela.Types.Arrays.Array_Type_Access);
427
428 overriding procedure Untagged_Record
429 (Self : in out Type_Visitor;
430 Value : not null Gela.Types.Untagged_Records
431 .Untagged_Record_Type_Access);
432
433 overriding procedure Object_Access_Type
434 (Self : in out Type_Visitor;
435 Value : not null Gela.Types.Simple
436 .Object_Access_Type_Access);
437
438 end Type_Visiters;
439
440 package body Type_Visiters is
441
442 overriding procedure Array_Type
443 (Self : in out Type_Visitor;
444 Value : not null Gela.Types.Arrays.Array_Type_Access)
445 is
446 pragma Unreferenced (Self);
447
448 IT : constant Gela.Semantic_Types.Type_Index_Array :=
449 Value.Index_Types;
450 Count : Natural := 0;
451
452 Chosen : Gela.Interpretations.Interpretation_Index;
453 begin
454 for K in Tuples'Range loop
455 declare
456 Tuple : constant Gela.Interpretations
457 .Interpretation_Set_Index_Array :=
458 IM.Get_Tuple (Tuples (K));
459 begin
460 Count := Count + 1;
461
462 To_Type
463 (Comp => Comp,
464 Env => Env,
465 Type_Up => IT (Count),
466 Expr_Up => Tuple (Tuple'Last),
467 Result => Chosen);
468
469 IM.Get_Tuple_Index (Chosen, 0, Chosen);
470
471 if Tuple'Length = 2 then
472 -- Put some interpretation to placeholder item
473 IM.Get_Tuple_Index (0, Chosen, Chosen);
474 end if;
475
476 Output (K) := Chosen;
477 end;
478 end loop;
479
480 Chosen := 0;
481
482 for J in reverse Output'Range loop
483 IM.Get_Tuple_Index (Output (J), Chosen, Chosen);
484 end loop;
485
486 Result := Chosen;
487 end Array_Type;
488
489 overriding procedure Object_Access_Type
490 (Self : in out Type_Visitor;
491 Value : not null Gela.Types.Simple
492 .Object_Access_Type_Access)
493 is
494 Des_Index : constant Gela.Semantic_Types.Type_Index :=
495 TM.Type_From_Subtype_Mark (Env, Value.Get_Designated);
496 Des_View : constant Gela.Types.Type_View_Access :=
497 TM.Get (Des_Index);
498 begin
499 Des_View.Visit_If_Assigned (Self);
500 end Object_Access_Type;
501
502 overriding procedure Untagged_Record
503 (Self : in out Type_Visitor;
504 Value : not null Gela.Types.Untagged_Records
505 .Untagged_Record_Type_Access)
506 is
507 pragma Unreferenced (Self);
508
509 Chosen : Gela.Interpretations.Interpretation_Index;
510 begin
511 for K in Tuples'Range loop
512 declare
513 use type Gela.Semantic_Types.Type_Index;
514 Tuple : constant Gela.Interpretations.
515 Interpretation_Set_Index_Array :=
516 IM.Get_Tuple (Tuples (K));
517 Exp : Gela.Semantic_Types.Type_Index := 0;
518 List : Gela.Interpretations.Interpretation_Index_Array
519 (Tuple'Range) := (others => 0);
520 Name : Gela.Elements.Defining_Names.
521 Defining_Name_Access;
522 begin
523 -- Resolve choices of association
524 Output (K) := 0;
525
526 for J in List'First + 1 .. List'Last loop
527 for S in IM.Symbols (Tuple (J)) loop
528 Name := Value.Get_Discriminant (S.Symbol);
529
530 if Name.Assigned then
531 IM.Get_Defining_Name_Index (Name, List (J));
532
533 if Exp = 0 then
534 Exp := TM.Type_Of_Object_Declaration
535 (Env, Name.Enclosing_Element);
536 end if;
537 end if;
538 end loop;
539 end loop;
540
541 -- Resolve expression of association
542 To_Type
543 (Comp => Comp,
544 Env => Env,
545 Type_Up => Exp,
546 Expr_Up => Tuple (Tuple'First),
547 Result => List (List'First));
548
549 for J in reverse List'Range loop
550 IM.Get_Tuple_Index
551 (List (J), Output (K), Output (K));
552 end loop;
553 end;
554 end loop;
555
556 Chosen := 0;
557
558 for J in reverse Output'Range loop
559 IM.Get_Tuple_Index (Output (J), Chosen, Chosen);
560 end loop;
561
562 Result := Chosen;
563 end Untagged_Record;
564
565 end Type_Visiters;
566
567 Type_View : Gela.Types.Type_View_Access;
568 Visiter : Type_Visiters.Type_Visitor;
569 Ignore : Gela.Interpretations.Interpretation_Index;
570 begin
571 Get_Subtype
572 (Comp,
573 Env => Env,
574 Set => Type_Up,
575 Index => Ignore,
576 Result => Type_Index);
577
578 Type_View := TM.Get (Type_Index);
579
580 Type_View.Visit_If_Assigned (Visiter);
581 end Composite_Constraint;
582
583 end Each_Constraint;
584
585 V : Each_Constraint.Visiter;
586
587 begin
588 Result := 0;
589
590 if not Constraint.Assigned then
591 return;
592 end if;
593
594 Constraint.Visit (V);
595 end Constraint;
596
597
598 -----------------
599 -- Direct_Name --
600 -----------------
601
602 procedure Direct_Name
603 (Comp : Gela.Compilations.Compilation_Access;
604 Env : Gela.Semantic_Types.Env_Index;
605 Symbol : Gela.Lexical_Types.Symbol;
606 Set : out Gela.Interpretations.Interpretation_Set_Index)
607 is
608 procedure Add_Function
609 (Name : Gela.Elements.Defining_Names.Defining_Name_Access);
610
611 TM : constant Gela.Type_Managers.Type_Manager_Access :=
612 Comp.Context.Types;
613 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
614 Comp.Context.Interpretation_Manager;
615 ES : constant Gela.Environments.Environment_Set_Access :=
616 Comp.Context.Environment_Set;
617
618 ------------------
619 -- Add_Function --
620 ------------------
621
622 procedure Add_Function
623 (Name : Gela.Elements.Defining_Names.Defining_Name_Access)
624 is
625 Index : Gela.Interpretations.Interpretation_Index;
626 Tipe : Gela.Semantic_Types.Type_Index;
627 Profile : constant Gela.Profiles.Profile_Access :=
628 TM.Get_Profile (Env, Name);
629 begin
630 if Profile not in null and then
631 Profile.Is_Function and then
632 Profile.Allow_Empty_Argument_List
633 then
634 Tipe := Profile.Return_Type;
635
636 if Tipe not in 0 then
637 IM.Get_Defining_Name_Index (Name, Index);
638 IM.Add_Expression
639 (Tipe => Tipe,
640 Kind => Gela.Interpretations.Function_Call,
641 Down => (1 => Index),
642 Result => Set);
643 end if;
644 end if;
645 end Add_Function;
646
647 DV : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
648 ES.Direct_Visible (Env, Symbol);
649
650 Have_Direct_Visible : constant Boolean := DV.Has_Element;
651 begin
652 Set := 0;
653 IM.Add_Symbol (Symbol, Set);
654
655 while DV.Has_Element loop
656 IM.Add_Defining_Name
657 (Name => DV.Element,
658 Down => (1 .. 0 => 0),
659 Result => Set);
660
661 Add_Function (DV.Element);
662
663 DV.Next;
664 end loop;
665
666 if Have_Direct_Visible then
667 return;
668 end if;
669
670 declare
671 UV : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
672 ES.Use_Visible (Env, Symbol);
673 begin
674 while UV.Has_Element loop
675 IM.Add_Defining_Name
676 (Name => UV.Element,
677 Down => (1 .. 0 => 0),
678 Result => Set);
679
680 Add_Function (UV.Element);
681
682 UV.Next;
683 end loop;
684 end;
685 end Direct_Name;
686
687 -------------------
688 -- Function_Call --
689 -------------------
690
691 procedure Function_Call
692 (Comp : Gela.Compilations.Compilation_Access;
693 Env : Gela.Semantic_Types.Env_Index;
694 Prefix : Gela.Interpretations.Interpretation_Set_Index;
695 Args : Gela.Interpretations.Interpretation_Tuple_List_Index;
696 Set : out Gela.Interpretations.Interpretation_Set_Index)
697 is
698
699 use type Gela.Interpretations.Interpretation_Index;
700 use type Gela.Interpretations.Interpretation_Index_Array;
701
702 procedure On_Call
703 (Profile : Gela.Profiles.Profile_Access;
704 Cursor : Gela.Interpretations.Abstract_Cursor'Class);
705
706 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
707 Comp.Context.Interpretation_Manager;
708
709 TM : constant Gela.Type_Managers.Type_Manager_Access :=
710 Comp.Context.Types;
711
712 Tuples : constant Gela.Interpretations.Interpretation_Tuple_Index_Array
713 := IM.Get_Tuple_List (Args);
714
715 -------------
716 -- On_Call --
717 -------------
718
719 procedure On_Call
720 (Profile : Gela.Profiles.Profile_Access;
721 Cursor : Gela.Interpretations.Abstract_Cursor'Class)
722 is
723 Chosen : Gela.Interpretations.Interpretation_Index := 0;
724 Count : Natural := 0;
725 Output : Gela.Interpretations.Interpretation_Index_Array
726 (Tuples'Range);
727
728 begin
729 if not Profile.Assigned then
730 return;
731 end if;
732
733 for J in Tuples'Range loop
734 declare
735 Tuple : constant Gela.Interpretations
736 .Interpretation_Set_Index_Array
737 := IM.Get_Tuple (Tuples (J));
738
739 Tipe : Gela.Semantic_Types.Type_Index;
740 List : Gela.Interpretations.Interpretation_Index_Array
741 (Tuple'Range);
742 begin
743 -- Check if this is positional association
744 if Tuple'Length = 1 then
745 if Count < Profile.Length then
746 Count := Count + 1;
747 Tipe := Profile.Get_Type (Count);
748 To_Type (Comp, Env, Tipe, Tuple (Tuple'First), Chosen);
749
750 if Chosen = 0 then
751 return;
752 else
753 List (List'First) := Chosen;
754 end if;
755 else
756 return;
757 end if;
758 else
759 for J in Tuple'Range loop
760 Interpretation
761 (Comp => Comp,
762 Env => Env,
763 Set => Tuple (J),
764 Result => List (J));
765 end loop;
766 end if;
767
768 Chosen := 0;
769
770 for K in reverse List'Range loop
771 IM.Get_Tuple_Index (List (K), Chosen, Chosen);
772 end loop;
773
774 Output (J) := Chosen;
775 end;
776 end loop;
777
778 Chosen := 0;
779
780 for K in reverse Output'Range loop
781 IM.Get_Tuple_Index (Output (K), Chosen, Chosen);
782 end loop;
783
784 if Chosen /= 0 then
785 Comp.Context.Interpretation_Manager.Add_Expression
786 (Tipe => Profile.Return_Type,
787 Kind => Gela.Interpretations.Function_Call,
788 Down => Cursor.Get_Index & Chosen,
789 Result => Set);
790
791 elsif Tuples'Length = 0
792 and then Profile.Allow_Empty_Argument_List
793 then
794 Comp.Context.Interpretation_Manager.Add_Expression
795 (Tipe => Profile.Return_Type,
796 Kind => Gela.Interpretations.Function_Call,
797 Down => Cursor.Get_Index & 0,
798 Result => Set);
799
800 end if;
801 end On_Call;
802
803 Profile : Gela.Profiles.Profile_Access;
804 begin
805 Set := 0;
806
807 for J in IM.Profiles (Prefix) loop
808 Profile := TM.Get_Profile (J.Corresponding_Type, J.Attribute_Kind);
809 On_Call (Profile, J);
810 end loop;
811
812 for J in IM.Defining_Names (Prefix) loop
813 Profile := TM.Get_Profile (Env, J.Defining_Name);
814 On_Call (Profile, J);
815 end loop;
816
817 for J in Each.Prefix (IM, TM, Env, Prefix) loop
818 declare
819 View : constant Gela.Types.Type_View_Access :=
820 TM.Get (J.Expression_Type);
821 Arr : Gela.Types.Arrays.Array_Type_Access;
822 Chosen : Gela.Interpretations.Interpretation_Index := 0;
823 Count : Natural := 0;
824 Output : Gela.Interpretations.Interpretation_Index_Array
825 (Tuples'Range);
826 begin
827 if not View.Assigned or else not View.Is_Array then
828 return;
829 end if;
830
831 Arr := Gela.Types.Arrays.Array_Type_Access (View);
832
833 for J in Tuples'Range loop
834 declare
835 Tuple : constant Gela.Interpretations
836 .Interpretation_Set_Index_Array
837 := IM.Get_Tuple (Tuples (J));
838 Index_Types : constant Gela.Semantic_Types.Type_Index_Array
839 := Arr.all.Index_Types;
840 Index_Type : Gela.Semantic_Types.Type_Index := 0;
841 begin
842 -- Check if this is positional association
843 -- Check agains Constraint_Error in case of slice FIXME
844 if Tuple'Length = 1 and Count + 1 <= Index_Types'Last then
845 Count := Count + 1;
846 Index_Type := Index_Types (Count);
847 To_Type
848 (Comp, Env, Index_Type, Tuple (Tuple'First), Chosen);
849
850 if Chosen = 0 then
851 return;
852 else
853 IM.Get_Tuple_Index (Chosen, 0, Chosen);
854 end if;
855 else
856 return;
857 end if;
858
859 Output (J) := Chosen;
860 end;
861 end loop;
862
863 Chosen := 0;
864
865 for K in reverse Output'Range loop
866 IM.Get_Tuple_Index (Output (K), Chosen, Chosen);
867 end loop;
868
869 if Chosen /= 0 then
870 Comp.Context.Interpretation_Manager.Add_Expression
871 (Tipe => Arr.Component_Type,
872 Kind => Gela.Interpretations.Indexed_Component,
873 Down => J.Get_Index & Chosen,
874 Result => Set);
875 end if;
876 end;
877 end loop;
878
879 -- Type Convertion
880 if Tuples'Length = 1 then
881 declare
882 Tipe : Gela.Interpretations.Interpretation_Index;
883 Chosen : Gela.Interpretations.Interpretation_Index;
884 Type_Index : Gela.Semantic_Types.Type_Index;
885 Tuple : constant Gela.Interpretations
886 .Interpretation_Set_Index_Array
887 := IM.Get_Tuple (Tuples (1));
888 begin
889 if Tuple'Length = 1 then -- Single expression without choices
890 Get_Subtype
891 (Comp => Comp,
892 Env => Env,
893 Set => Prefix,
894 Index => Tipe,
895 Result => Type_Index);
896
897 if Type_Index not in 0 then
898 Interpretation
899 (Comp,
900 Env,
901 Set => Tuple (1),
902 Result => Chosen);
903
904 IM.Get_Tuple_Index (Chosen, 0, Chosen);
905 IM.Get_Tuple_Index (Chosen, 0, Chosen);
906
907 Comp.Context.Interpretation_Manager.Add_Expression
908 (Tipe => Type_Index,
909 Kind => Gela.Interpretations.Type_Convertion,
910 Down => Tipe & Chosen,
911 Result => Set);
912 end if;
913 end if;
914 end;
915 end if;
916 end Function_Call;
917
918 --------------------------
919 -- Qualified_Expression --
920 --------------------------
921
922 procedure Qualified_Expression
923 (Comp : Gela.Compilations.Compilation_Access;
924 Env : Gela.Semantic_Types.Env_Index;
925 Prefix : Gela.Interpretations.Interpretation_Set_Index;
926 Arg : Gela.Interpretations.Interpretation_Set_Index;
927 Set : out Gela.Interpretations.Interpretation_Set_Index)
928 is
929 pragma Unreferenced (Arg);
930 Tipe : Gela.Interpretations.Interpretation_Index;
931 Type_Index : Gela.Semantic_Types.Type_Index;
932 begin
933 Set := 0;
934 Get_Subtype
935 (Comp => Comp,
936 Env => Env,
937 Set => Prefix,
938 Index => Tipe,
939 Result => Type_Index);
940
941 if Type_Index not in 0 then
942 Comp.Context.Interpretation_Manager.Add_Expression
943 (Tipe => Type_Index,
944 Kind => Gela.Interpretations.Type_Convertion,
945 Down => (1 .. 0 => 0),
946 Result => Set);
947 end if;
948 end Qualified_Expression;
949
950
951 -------------------------
952 -- Generic_Association --
953 -------------------------
954
955 procedure Generic_Association
956 (Comp : Gela.Compilations.Compilation_Access;
957 Env : Gela.Semantic_Types.Env_Index;
958-- Actual_Part : Gela.Elements.Generic_Associations.
959-- Generic_Association_Sequence_Access;
960 Up : Gela.Interpretations.Interpretation_Set_Index;
961 Result : out Gela.Interpretations.Interpretation_Index) is
962 begin
963 Interpretation
964 (Comp,
965 Env,
966 Up,
967 Result);
968 end Generic_Association;
969
970 ------------------------------
971 -- Generic_Association_List --
972 ------------------------------
973
974 procedure Generic_Association_List
975 (Comp : Gela.Compilations.Compilation_Access;
976 Env : Gela.Semantic_Types.Env_Index;
977 Instance : Gela.Elements.Element_Access;
978 Generic_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
979 Actual_Part : Gela.Elements.Generic_Associations.
980 Generic_Association_Sequence_Access;
981 Associations : Gela.Interpretations.Interpretation_Tuple_Index;
982 Result : out Gela.Interpretations.Interpretation_Index)
983 is
984 pragma Unreferenced (Env);
985
986 function Hash
987 (Value : Gela.Lexical_Types.Symbol)
988 return Ada.Containers.Hash_Type is
989 (Ada.Containers.Hash_Type (Value));
990
991 type Name_Index is new Positive;
992
993 package Symbol_To_Name_Index_Maps is new Ada.Containers.Hashed_Maps
994 (Key_Type => Gela.Lexical_Types.Symbol,
995 Element_Type => Name_Index,
996 Hash => Hash,
997 Equivalent_Keys => Gela.Lexical_Types."=");
998
999 package Name_Vectors is new Ada.Containers.Vectors
1000 (Index_Type => Name_Index,
1001 Element_Type => Gela.Elements.Defining_Names.Defining_Name_Access,
1002 "=" => Gela.Elements.Defining_Names."=");
1003
1004 type Formal_Defining_Names is record
1005 Names : Name_Vectors.Vector;
1006 Map : Symbol_To_Name_Index_Maps.Map;
1007 end record;
1008
1009 procedure Resolve_Formal
1010 (Formal : Formal_Defining_Names;
1011 Value : Gela.Interpretations.Interpretation_Set_Index;
1012 Name : out Gela.Elements.Defining_Names.Defining_Name_Access);
1013
1014
1015 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1016 Comp.Context.Interpretation_Manager;
1017
1018 package Visiters is
1019 type Visiter is new Gela.Element_Visiters.Visiter with record
1020 Formal : Formal_Defining_Names;
1021 end record;
1022
1023 overriding procedure Formal_Object_Declaration
1024 (Self : in out Visiter;
1025 Node : not null Gela.Elements.Formal_Object_Declarations.
1026 Formal_Object_Declaration_Access);
1027
1028 overriding procedure Formal_Type_Declaration
1029 (Self : in out Visiter;
1030 Node : not null Gela.Elements.Formal_Type_Declarations.
1031 Formal_Type_Declaration_Access);
1032
1033 overriding procedure Generic_Package_Declaration
1034 (Self : in out Visiter;
1035 Node : not null Gela.Elements.Generic_Package_Declarations.
1036 Generic_Package_Declaration_Access);
1037
1038 end Visiters;
1039
1040 package body Visiters is
1041
1042 overriding procedure Formal_Object_Declaration
1043 (Self : in out Visiter;
1044 Node : not null Gela.Elements.Formal_Object_Declarations.
1045 Formal_Object_Declaration_Access)
1046 is
1047 List : constant Gela.Elements.Defining_Identifiers.
1048 Defining_Identifier_Sequence_Access := Node.Names;
1049 Item : Gela.Elements.Defining_Names.Defining_Name_Access;
1050 Cursor : Gela.Elements.Defining_Identifiers.
1051 Defining_Identifier_Sequence_Cursor := List.First;
1052 begin
1053 while Cursor.Has_Element loop
1054 Item := Gela.Elements.Defining_Names.Defining_Name_Access
1055 (Cursor.Element);
1056 Self.Formal.Names.Append (Item);
1057 Self.Formal.Map.Include
1058 (Item.Full_Name, Self.Formal.Names.Last_Index);
1059 Cursor.Next;
1060 end loop;
1061 end Formal_Object_Declaration;
1062
1063 -----------------------------
1064 -- Formal_Type_Declaration --
1065 -----------------------------
1066
1067 overriding procedure Formal_Type_Declaration
1068 (Self : in out Visiter;
1069 Node : not null Gela.Elements.Formal_Type_Declarations.
1070 Formal_Type_Declaration_Access)
1071 is
1072 Name : constant Gela.Elements.Defining_Identifiers.
1073 Defining_Identifier_Access := Node.Names;
1074 Item : constant Gela.Elements.Defining_Names.Defining_Name_Access
1075 := Gela.Elements.Defining_Names.Defining_Name_Access (Name);
1076 begin
1077 Self.Formal.Names.Append (Item);
1078 Self.Formal.Map.Include
1079 (Item.Full_Name, Self.Formal.Names.Last_Index);
1080 end Formal_Type_Declaration;
1081
1082 ---------------------------------
1083 -- Generic_Package_Declaration --
1084 ---------------------------------
1085
1086 overriding procedure Generic_Package_Declaration
1087 (Self : in out Visiter;
1088 Node : not null Gela.Elements.Generic_Package_Declarations.
1089 Generic_Package_Declaration_Access)
1090 is
1091 Formal_Part : constant Gela.Elements.Generic_Formals.
1092 Generic_Formal_Sequence_Access := Node.Generic_Formal_Part;
1093 Cursor : Gela.Elements.Generic_Formals.
1094 Generic_Formal_Sequence_Cursor := Formal_Part.First;
1095 Element : Gela.Elements.Generic_Formals.Generic_Formal_Access;
1096 begin
1097 while Cursor.Has_Element loop
1098 Element := Cursor.Element;
1099 Element.Visit (Self);
1100 Cursor.Next;
1101 end loop;
1102 end Generic_Package_Declaration;
1103
1104 end Visiters;
1105
1106
1107 --------------------
1108 -- Resolve_Formal --
1109 --------------------
1110
1111 procedure Resolve_Formal
1112 (Formal : Formal_Defining_Names;
1113 Value : Gela.Interpretations.Interpretation_Set_Index;
1114 Name : out Gela.Elements.Defining_Names.Defining_Name_Access) is
1115 begin
1116 Result := 0;
1117
1118 for J in IM.Symbols (Value) loop
1119 declare
1120 Found : constant Symbol_To_Name_Index_Maps.Cursor :=
1121 Formal.Map.Find (J.Symbol);
1122 begin
1123 if Symbol_To_Name_Index_Maps.Has_Element (Found) then
1124 Name := Formal.Names
1125 (Symbol_To_Name_Index_Maps.Element (Found));
1126 end if;
1127 end;
1128 end loop;
1129 end Resolve_Formal;
1130
1131 Visitor : Visiters.Visiter;
1132 Tuples : constant Gela.Interpretations.Interpretation_Set_Index_Array
1133 := IM.Get_Tuple (Associations);
1134
1135 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
1136 Formal : Gela.Interpretations.Interpretation_Index_Array (Tuples'Range)
1137 := (others => 0);
1138 Chosen : Gela.Interpretations.Interpretation_Index;
1139 Element : Gela.Elements.Defining_Names.Defining_Name_Access;
1140 Cursor : Gela.Elements.Generic_Associations
1141 .Generic_Association_Sequence_Cursor := Actual_Part.First;
1142 begin
1143 if not Generic_Name.Assigned or not Instance.Assigned then
1144 Result := 0;
1145 return;
1146 end if;
1147 -- Collect defining names of formal declarations in the instance
1148 Instance.Visit (Visitor);
1149
1150 for J in Tuples'Range loop
1151 Resolve_Formal (Visitor.Formal, Tuples (J), Name);
1152
1153 if Name.Assigned then
1154 Name.Set_Corresponding_View
1155 (Gela.Elements.Element_Access
1156 (Cursor.Element.Actual_Parameter));
1157
1158 Element := Gela.Elements.Defining_Names.Defining_Name_Access
1159 (Name.Corresponding_Generic_Element);
1160
1161 IM.Get_Defining_Name_Index (Element, Formal (J));
1162 end if;
1163
1164 Cursor.Next;
1165 end loop;
1166
1167 Chosen := 0;
1168
1169 for K in reverse Formal'Range loop
1170 IM.Get_Tuple_Index (Formal (K), Chosen, Chosen);
1171 end loop;
1172
1173 Result := Chosen;
1174 end Generic_Association_List;
1175
1176 -----------------
1177 -- Get_Subtype --
1178 -----------------
1179
1180 procedure Get_Subtype
1181 (Comp : Gela.Compilations.Compilation_Access;
1182 Env : Gela.Semantic_Types.Env_Index;
1183 Set : Gela.Interpretations.Interpretation_Set_Index;
1184 Index : out Gela.Interpretations.Interpretation_Index;
1185 Result : out Gela.Semantic_Types.Type_Index)
1186 is
1187
1188 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1189 Comp.Context.Interpretation_Manager;
1190
1191 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1192 Comp.Context.Types;
1193
1194 begin
1195 Index := 0;
1196 Result := 0;
1197
1198 for J in IM.Defining_Names (Set) loop
1199 Result := TM.Type_By_Name (Env, J.Defining_Name);
1200 Index := J.Get_Index;
1201 end loop;
1202 end Get_Subtype;
1203
1204 --------------------
1205 -- Interpretation --
1206 --------------------
1207
1208 procedure Interpretation
1209 (Comp : Gela.Compilations.Compilation_Access;
1210 Env : Gela.Semantic_Types.Env_Index;
1211 Set : Gela.Interpretations.Interpretation_Set_Index;
1212 Result : out Gela.Interpretations.Interpretation_Index)
1213 is
1214 pragma Unreferenced (Env);
1215
1216 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1217 Comp.Context.Interpretation_Manager;
1218 begin
1219 Result := 0;
1220
1221 for J in IM.Each (Set) loop
1222 if not J.Is_Symbol then
1223 Result := J.Get_Index;
1224 end if;
1225 end loop;
1226 end Interpretation;
1227
1228 ---------------------
1229 -- Membership_Test --
1230 ---------------------
1231
1232 procedure Membership_Test
1233 (Comp : Gela.Compilations.Compilation_Access;
1234 Env : Gela.Semantic_Types.Env_Index;
1235 Left : Gela.Interpretations.Interpretation_Set_Index;
1236 Right : Gela.Interpretations.Interpretation_Set_Index;
1237 Set : out Gela.Interpretations.Interpretation_Set_Index)
1238 is
1239 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1240 Comp.Context.Interpretation_Manager;
1241
1242 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1243 Comp.Context.Types;
1244
1245 use type Gela.Interpretations.Interpretation_Index_Array;
1246 begin
1247 Set := 0;
1248
1249 for R in Each.Expression (IM, TM, Env, Right) loop
1250 declare
1251 Right_Type : constant Gela.Types.Type_View_Access :=
1252 TM.Get (R.Expression_Type);
1253 begin
1254 for L in Each.Expression (IM, TM, Env, Left) loop
1255 declare
1256 Left_Type : constant Gela.Types.Type_View_Access :=
1257 TM.Get (L.Expression_Type);
1258 begin
1259 if Left_Type.Is_Expected_Type (Expected => Right_Type) then
1260 Comp.Context.Interpretation_Manager.Add_Expression
1261 (Tipe => TM.Boolean,
1262 Down => L.Get_Index & R.Get_Index,
1263 Result => Set);
1264 end if;
1265 end;
1266 end loop;
1267 end;
1268 end loop;
1269 end Membership_Test;
1270
1271 ---------------------
1272 -- Numeric_Literal --
1273 ---------------------
1274
1275 procedure Numeric_Literal
1276 (Comp : Gela.Compilations.Compilation_Access;
1277 Token : Gela.Lexical_Types.Token_Count;
1278 Result : out Gela.Interpretations.Interpretation_Set_Index)
1279 is
1280 Value : constant Gela.Lexical_Types.Token := Comp.Get_Token (Token);
1281 Type_Index : Gela.Semantic_Types.Type_Index;
1282 begin
1283 Result := 0;
1284
1285 if Comp.Source.Index (Value.First, Value.Last, '.') = 0 then
1286 Type_Index := Comp.Context.Types.Universal_Integer;
1287 else
1288 Type_Index := Comp.Context.Types.Universal_Real;
1289 end if;
1290
1291 Comp.Context.Interpretation_Manager.Add_Expression
1292 (Tipe => Type_Index,
1293 Down => (1 .. 0 => 0),
1294 Result => Result);
1295 end Numeric_Literal;
1296
1297 -----------------
1298 -- Placeholder --
1299 -----------------
1300
1301 function Placeholder
1302 (Comp : Gela.Compilations.Compilation_Access)
1303 return Gela.Interpretations.Interpretation_Set_Index
1304 is
1305 Result : Gela.Interpretations.Interpretation_Set_Index := 0;
1306 begin
1307 Comp.Context.Interpretation_Manager.Add_Placeholder
1308 (Kind => Gela.Interpretations.Absent,
1309 Result => Result);
1310
1311 return Result;
1312 end Placeholder;
1313
1314 ---------------
1315 -- Real_Type --
1316 ---------------
1317
1318 procedure Real_Type
1319 (Comp : Gela.Compilations.Compilation_Access;
1320 Up : Gela.Interpretations.Interpretation_Set_Index;
1321 Result : out Gela.Interpretations.Interpretation_Index)
1322 is
1323 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1324 Comp.Context.Types;
1325 begin
1326 To_Type_Category (Comp, Up, TM.Universal_Real, Result);
1327 end Real_Type;
1328
1329 ----------------------
1330 -- Record_Aggregate --
1331 ----------------------
1332
1333 procedure Record_Aggregate
1334 (Comp : Gela.Compilations.Compilation_Access;
1335 Env : Gela.Semantic_Types.Env_Index;
1336 Up : Gela.Interpretations.Interpretation_Index;
1337 Tuple : Gela.Interpretations.Interpretation_Tuple_List_Index;
1338 Result : out Gela.Interpretations.Interpretation_Index)
1339 is
1340
1341 package Each is
1342 type Visiter is new Gela.Interpretations.Down_Visiter with record
1343 Result : Gela.Interpretations.Interpretation_Index := 0;
1344 end record;
1345
1346 overriding procedure On_Expression
1347 (Self : in out Visiter;
1348 Tipe : Gela.Semantic_Types.Type_Index;
1349 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
1350 Down : Gela.Interpretations.Interpretation_Index_Array);
1351
1352 end Each;
1353
1354 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1355 Comp.Context.Interpretation_Manager;
1356
1357 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1358 Comp.Context.Types;
1359
1360 package body Each is
1361
1362 overriding procedure On_Expression
1363 (Self : in out Visiter;
1364 Tipe : Gela.Semantic_Types.Type_Index;
1365 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
1366 Down : Gela.Interpretations.Interpretation_Index_Array)
1367 is
1368 pragma Unreferenced (Down, Kind);
1369
1370 View : constant Gela.Types.Type_View_Access := TM.Get (Tipe);
1371 Tuples : constant Gela.Interpretations
1372 .Interpretation_Tuple_Index_Array :=
1373 IM.Get_Tuple_List (Tuple);
1374 Output : Gela.Interpretations.Interpretation_Index_Array
1375 (Tuples'Range);
1376
1377 Comp_Type : Gela.Semantic_Types.Type_Index := 0;
1378 begin
1379 if View.Is_Array then
1380 declare
1381 Arr : constant Gela.Types.Arrays.Array_Type_Access :=
1382 Gela.Types.Arrays.Array_Type_Access (View);
1383 begin
1384 Comp_Type := Arr.Component_Type;
1385 end;
1386 elsif not View.Is_Record then
1387 return;
1388 end if;
1389
1390 for J in Tuples'Range loop
1391 declare
1392 Exp : Gela.Semantic_Types.Type_Index := 0;
1393 Chosen : Gela.Interpretations.Interpretation_Index := 0;
1394 Value : constant Gela.Interpretations
1395 .Interpretation_Set_Index_Array :=
1396 IM.Get_Tuple (Tuples (J));
1397 List : Gela.Interpretations.Interpretation_Index_Array
1398 (Value'Range);
1399 begin
1400 for K in 2 .. Value'Last loop
1401 declare
1402 Name : Gela.Interpretations.Interpretation_Index := 0;
1403
1404 Component : Gela.Elements.Defining_Names.
1405 Defining_Name_Access;
1406 begin
1407 for S in IM.Symbols (Value (K)) loop
1408 if View.Is_Record then
1409 Component := Gela.Types.Untagged_Records.
1410 Untagged_Record_Type_Access (View).
1411 Get_Component (S.Symbol);
1412 end if;
1413
1414 if Component.Assigned then
1415 IM.Get_Defining_Name_Index (Component, Name);
1416
1417 Exp := TM.Type_Of_Object_Declaration
1418 (Env, Component.Enclosing_Element);
1419 end if;
1420 end loop;
1421
1422 List (K) := Name;
1423 end;
1424 end loop;
1425
1426 if View.Is_Record then
1427 Comp_Type := Exp;
1428 end if;
1429
1430 To_Type
1431 (Comp => Comp,
1432 Env => Env,
1433 Type_Up => Comp_Type,
1434 Expr_Up => Value (Value'First),
1435 Result => List (List'First));
1436
1437 Chosen := 0;
1438
1439 for K in reverse List'Range loop
1440 IM.Get_Tuple_Index (List (K), Chosen, Chosen);
1441 end loop;
1442
1443 Output (J) := Chosen;
1444 end;
1445 end loop;
1446
1447 for J in reverse Output'Range loop
1448 IM.Get_Tuple_Index (Output (J), Self.Result, Self.Result);
1449 end loop;
1450 end On_Expression;
1451
1452 end Each;
1453
1454 V : Each.Visiter;
1455 begin
1456 IM.Visit (Up, V);
1457 Result := V.Result;
1458 end Record_Aggregate;
1459
1460 --------------------
1461 -- Record_Matcher --
1462 --------------------
1463
1464 function Record_Matcher
1465 return not null Gela.Interpretations.Type_Matcher_Access
1466 is
1467 Result : constant Type_Matchers.Type_Matcher_Access :=
1468 new Type_Matchers.Record_Type_Matcher;
1469 begin
1470 return Gela.Interpretations.Type_Matcher_Access (Result);
1471 end Record_Matcher;
1472
1473 ------------------------
1474 -- Selected_Component --
1475 ------------------------
1476
1477 procedure Selected_Component
1478 (Comp : Gela.Compilations.Compilation_Access;
1479 Env : Gela.Semantic_Types.Env_Index;
1480 Prefix : Gela.Interpretations.Interpretation_Set_Index;
1481 Symbol : Gela.Lexical_Types.Symbol;
1482 Set : out Gela.Interpretations.Interpretation_Set_Index)
1483 is
1484 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1485 Comp.Context.Interpretation_Manager;
1486
1487 ES : constant Gela.Environments.Environment_Set_Access :=
1488 Comp.Context.Environment_Set;
1489
1490 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1491 Comp.Context.Types;
1492
1493 Is_Expanded_Name : Boolean := False;
1494
1495 begin
1496 Set := 0;
1497 for Cursor in IM.Defining_Names (Prefix) loop
1498 declare
1499 Found : aliased Boolean := False;
1500 NC : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
1501 ES.Visible (Env, Cursor.Defining_Name, Symbol, Found'Access);
1502 begin
1503 if Found then
1504 -- ARM 4.1.3(4)
1505 Is_Expanded_Name := True;
1506
1507 while NC.Has_Element loop
1508 IM.Add_Defining_Name
1509 (Name => NC.Element,
1510 Down => (1 => Cursor.Get_Index),
1511 Result => Set);
1512
1513 NC.Next;
1514 end loop;
1515 end if;
1516 end;
1517 end loop;
1518
1519 if not Is_Expanded_Name then
1520 for J in Each.Prefix (IM, TM, Env, Prefix) loop
1521 declare
1522 package Type_Visiters is
1523 type Type_Visitor is new Gela.Types.Visitors.Type_Visitor
1524 with null record;
1525
1526 overriding procedure Untagged_Record
1527 (Self : in out Type_Visitor;
1528 Value : not null Gela.Types.Untagged_Records
1529 .Untagged_Record_Type_Access);
1530
1531 end Type_Visiters;
1532
1533 package body Type_Visiters is
1534
1535 overriding procedure Untagged_Record
1536 (Self : in out Type_Visitor;
1537 Value : not null Gela.Types.Untagged_Records
1538 .Untagged_Record_Type_Access)
1539 is
1540 pragma Unreferenced (Self);
1541 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
1542 begin
1543 Name := Value.Get_Component (Symbol);
1544
1545 if Name.Assigned then
1546 IM.Add_Defining_Name
1547 (Name => Name,
1548 Down => (1 => J.Get_Index),
1549 Result => Set);
1550 end if;
1551 end Untagged_Record;
1552
1553 end Type_Visiters;
1554
1555 Type_View : constant Gela.Types.Type_View_Access :=
1556 TM.Get (J.Expression_Type);
1557 Visiter : Type_Visiters.Type_Visitor;
1558 begin
1559 Type_View.Visit_If_Assigned (Visiter);
1560 end;
1561 end loop;
1562 end if;
1563 end Selected_Component;
1564
1565 ----------------------
1566 -- Shall_Be_Subtype --
1567 ----------------------
1568
1569 procedure Shall_Be_Subtype
1570 (Comp : Gela.Compilations.Compilation_Access;
1571 Env : Gela.Semantic_Types.Env_Index;
1572 Set : Gela.Interpretations.Interpretation_Set_Index;
1573 Result : out Gela.Interpretations.Interpretation_Index)
1574 is
1575 Type_Index : Gela.Semantic_Types.Type_Index;
1576 begin
1577 Get_Subtype
1578 (Comp,
1579 Env => Env,
1580 Set => Set,
1581 Index => Result,
1582 Result => Type_Index);
1583 end Shall_Be_Subtype;
1584
1585 -------------------------
1586 -- Signed_Integer_Type --
1587 -------------------------
1588
1589 procedure Signed_Integer_Type
1590 (Comp : Gela.Compilations.Compilation_Access;
1591 Up : Gela.Interpretations.Interpretation_Set_Index;
1592 Result : out Gela.Interpretations.Interpretation_Index)
1593 is
1594 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1595 Comp.Context.Types;
1596 begin
1597 To_Type_Category (Comp, Up, TM.Universal_Integer, Result);
1598 end Signed_Integer_Type;
1599
1600 -----------------------------
1601 -- Simple_Expression_Range --
1602 -----------------------------
1603
1604 procedure Simple_Expression_Range
1605 (Comp : Gela.Compilations.Compilation_Access;
1606 Env : Gela.Semantic_Types.Env_Index;
1607 Left : Gela.Interpretations.Interpretation_Set_Index;
1608 Right : Gela.Interpretations.Interpretation_Set_Index;
1609 Set : out Gela.Interpretations.Interpretation_Set_Index)
1610 is
1611
1612 type Counter is record
1613 Count : Natural := 0;
1614 Index : Gela.Interpretations.Interpretation_Index;
1615 end record;
1616
1617 type Type_Kind is (Integer, Float);
1618 type Counter_By_Type is array (Type_Kind) of Counter;
1619
1620 procedure Increment
1621 (Value : in out Counter_By_Type;
1622 Index : Gela.Interpretations.Interpretation_Index;
1623 Tipe : Type_Kind);
1624
1625 procedure Increment
1626 (L_Val : in out Counter_By_Type;
1627 R_Val : in out Counter_By_Type;
1628 Index : Gela.Interpretations.Interpretation_Index;
1629 Count : Counter_By_Type;
1630 Tipe : Type_Kind);
1631
1632 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1633 Comp.Context.Interpretation_Manager;
1634
1635 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1636 Comp.Context.Types;
1637
1638 ---------------
1639 -- Increment --
1640 ---------------
1641
1642 procedure Increment
1643 (Value : in out Counter_By_Type;
1644 Index : Gela.Interpretations.Interpretation_Index;
1645 Tipe : Type_Kind) is
1646 begin
1647 Value (Tipe).Count := Value (Tipe).Count + 1;
1648 Value (Tipe).Index := Index;
1649 end Increment;
1650
1651 ---------------
1652 -- Increment --
1653 ---------------
1654
1655 procedure Increment
1656 (L_Val : in out Counter_By_Type;
1657 R_Val : in out Counter_By_Type;
1658 Index : Gela.Interpretations.Interpretation_Index;
1659 Count : Counter_By_Type;
1660 Tipe : Type_Kind) is
1661 begin
1662 Increment (L_Val, Index, Tipe);
1663 R_Val (Tipe) := Count (Tipe);
1664 end Increment;
1665
1666 L_Val : Counter_By_Type;
1667 R_Val : Counter_By_Type;
1668
1669 begin
1670 Set := 0;
1671 for L in Each.Expression (IM, TM, Env, Left) loop
1672 declare
1673
1674 L_Tipe : constant Gela.Semantic_Types.Type_Index :=
1675 L.Expression_Type;
1676 L_Type_View : constant Gela.Types.Type_View_Access :=
1677 TM.Get (L_Tipe);
1678
1679 begin
1680 if not L_Type_View.Assigned then
1681 return;
1682 end if;
1683
1684 for R in Each.Expression (IM, TM, Env, Right) loop
1685 declare
1686 Chosen : Gela.Semantic_Types.Type_Index;
1687 Type_View : constant Gela.Types.Type_View_Access :=
1688 TM.Get (R.Expression_Type);
1689 begin
1690 if not Type_View.Assigned then
1691 return;
1692 else -- FIXME Return after implementation of types
1693 null;
1694 end if;
1695
1696 if Type_View.Is_Expected_Type (L_Type_View) then
1697 if Type_View.Is_Universal
1698 and then Type_View.Is_Numeric
1699 then
1700 Chosen := L_Tipe;
1701 else
1702 Chosen := R.Expression_Type;
1703 end if;
1704
1705 Comp.Context.Interpretation_Manager.Add_Expression
1706 (Tipe => Chosen,
1707 Down => (L.Get_Index, R.Get_Index),
1708 Result => Set);
1709 end if;
1710 end;
1711 end loop;
1712
1713 for R in IM.Categories (Right) loop
1714 declare
1715 Match : constant Gela.Interpretations.Type_Matcher_Access :=
1716 R.Matcher;
1717 begin
1718 L_Type_View.Visit (Match.all);
1719
1720 if Match.Is_Matched then
1721 Comp.Context.Interpretation_Manager.Add_Expression
1722 (Tipe => L_Tipe,
1723 Down => (L.Get_Index, R.Get_Index),
1724 Result => Set);
1725 end if;
1726 end;
1727 end loop;
1728 end;
1729 end loop;
1730
1731 for L in IM.Categories (Left) loop
1732 for R in Each.Expression (IM, TM, Env, Right) loop
1733 declare
1734 Match : constant Gela.Interpretations.Type_Matcher_Access :=
1735 L.Matcher;
1736 Type_View : constant Gela.Types.Type_View_Access :=
1737 TM.Get (R.Expression_Type);
1738 begin
1739 Type_View.Visit (Match.all);
1740
1741 if Match.Is_Matched then
1742 Comp.Context.Interpretation_Manager.Add_Expression
1743 (Tipe => R.Expression_Type,
1744 Down => (L.Get_Index, R.Get_Index),
1745 Result => Set);
1746 end if;
1747 end;
1748 end loop;
1749 end loop;
1750
1751 for L in Each.Prefer_Root (IM, TM, Env, Left) loop
1752 declare
1753
1754 R_Counters : Counter_By_Type;
1755 L_Type_View : constant Gela.Types.Type_View_Access :=
1756 TM.Get (L.Expression_Type);
1757
1758 begin
1759 for R in Each.Prefer_Root (IM, TM, Env, Right) loop
1760 declare
1761 Type_View : constant Gela.Types.Type_View_Access :=
1762 TM.Get (R.Expression_Type);
1763 begin
1764 if Type_View.Is_Integer then
1765 Increment (R_Counters, R.Get_Index, Integer);
1766 elsif Type_View.Is_Real then
1767 Increment (R_Counters, R.Get_Index, Float);
1768 else -- FIXME Return after implementation of types
1769 null;
1770 end if;
1771 end;
1772 end loop;
1773
1774 if L_Type_View.Is_Integer then
1775 Increment
1776 (L_Val,
1777 R_Val,
1778 L.Get_Index,
1779 R_Counters,
1780 Integer);
1781 elsif L_Type_View.Is_Real then
1782 Increment
1783 (L_Val,
1784 R_Val,
1785 L.Get_Index,
1786 R_Counters,
1787 Float);
1788 else -- FIXME Drop after implementation of types
1789 null;
1790 end if;
1791 end;
1792 end loop;
1793
1794 if L_Val (Integer).Count = 1 and R_Val (Integer).Count = 1 then
1795 declare
1796 Matcher : constant Type_Matchers.Type_Matcher_Access :=
1797 new Type_Matchers.Integer_Type_Matcher;
1798 begin
1799 Comp.Context.Interpretation_Manager.Add_Expression_Category
1800 (Match => Gela.Interpretations.Type_Matcher_Access (Matcher),
1801 Down => (L_Val (Integer).Index, R_Val (Integer).Index),
1802 Result => Set);
1803 end;
1804 end if;
1805
1806 if L_Val (Float).Count = 1 and R_Val (Float).Count = 1 then
1807 declare
1808 Matcher : constant Type_Matchers.Type_Matcher_Access :=
1809 new Type_Matchers.Float_Type_Matcher;
1810 begin
1811 Comp.Context.Interpretation_Manager.Add_Expression_Category
1812 (Match => Gela.Interpretations.Type_Matcher_Access (Matcher),
1813 Down => (L_Val (Float).Index, R_Val (Float).Index),
1814 Result => Set);
1815 end;
1816 end if;
1817 end Simple_Expression_Range;
1818
1819 --------------------
1820 -- Discrete_Range --
1821 --------------------
1822
1823 procedure Discrete_Range
1824 (Comp : Gela.Compilations.Compilation_Access;
1825 Env : Gela.Semantic_Types.Env_Index;
1826 Left : Gela.Interpretations.Interpretation_Set_Index;
1827 Right : Gela.Interpretations.Interpretation_Set_Index;
1828 Down_Left : out Gela.Interpretations.Interpretation_Index;
1829 Down_Right : out Gela.Interpretations.Interpretation_Index;
1830 Tipe : out Gela.Semantic_Types.Type_Index)
1831 is
1832
1833 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
1834 Comp.Context.Interpretation_Manager;
1835
1836 TM : constant Gela.Type_Managers.Type_Manager_Access :=
1837 Comp.Context.Types;
1838
1839 L_Count : Natural := 0;
1840 begin
1841 for L in Each.Prefer_Root (IM, TM, Env, Left) loop
1842 declare
1843
1844 L_Tipe : constant Gela.Semantic_Types.Type_Index :=
1845 L.Expression_Type;
1846 L_Type_View : constant Gela.Types.Type_View_Access :=
1847 TM.Get (L_Tipe);
1848 R_Count : Natural := 0;
1849 begin
1850 if L_Type_View.Assigned and then L_Type_View.Is_Discrete then
1851 for R in Each.Prefer_Root (IM, TM, Env, Right) loop
1852 declare
1853 use type Gela.Semantic_Types.Type_Index;
1854
1855 R_Tipe : constant Gela.Semantic_Types.Type_Index :=
1856 R.Expression_Type;
1857 Type_View : constant Gela.Types.Type_View_Access :=
1858 TM.Get (R_Tipe);
1859 begin
1860 if not Type_View.Assigned or else
1861 not Type_View.Is_Discrete
1862 then
1863 null;
1864 elsif not Type_View.Is_Universal then
1865 if L_Type_View.Is_Expected_Type (Type_View) then
1866 Tipe := R_Tipe;
1867 R_Count := R_Count + 1;
1868 Down_Right := R.Get_Index;
1869 end if;
1870 elsif L_Type_View.Is_Universal then
1871 if Type_View.Is_Expected_Type (L_Type_View) then
1872 Tipe := L_Tipe;
1873 R_Count := R_Count + 1;
1874 Down_Right := R.Get_Index;
1875 end if;
1876 elsif R_Tipe = L_Tipe and Type_View.Is_Integer then
1877 Tipe := TM.Universal_Integer; -- FIXME Root_Int
1878 R_Count := R_Count + 1;
1879 Down_Right := R.Get_Index;
1880 else
1881 null;
1882 end if;
1883 end;
1884 end loop;
1885 -- FIXME .Is_Discrete
1886
1887 if R_Count > 0 then
1888 L_Count := L_Count + R_Count;
1889 Down_Left := L.Get_Index;
1890 end if;
1891 end if;
1892 end;
1893 end loop;
1894
1895 if L_Count /= 1 then
1896 Down_Left := 0;
1897 Down_Right := 0;
1898 Tipe := 0;
1899 end if;
1900 end Discrete_Range;
1901
1902 --------------------
1903 -- Discrete_Range --
1904 --------------------
1905
1906 procedure Discrete_Range
1907 (Comp : Gela.Compilations.Compilation_Access;
1908 Env : Gela.Semantic_Types.Env_Index;
1909 Left : Gela.Interpretations.Interpretation_Set_Index;
1910 Right : Gela.Interpretations.Interpretation_Set_Index;
1911 Tipe : out Gela.Semantic_Types.Type_Index)
1912 is
1913 Ignore_Left : Gela.Interpretations.Interpretation_Index;
1914 Ignore_Right : Gela.Interpretations.Interpretation_Index;
1915 begin
1916 Discrete_Range
1917 (Comp => Comp,
1918 Env => Env,
1919 Left => Left,
1920 Right => Right,
1921 Tipe => Tipe,
1922 Down_Left => Ignore_Left,
1923 Down_Right => Ignore_Right);
1924 end Discrete_Range;
1925
1926 --------------------------
1927 -- Discrete_Range_Lower --
1928 --------------------------
1929
1930 procedure Discrete_Range_Lower
1931 (Comp : Gela.Compilations.Compilation_Access;
1932 Env : Gela.Semantic_Types.Env_Index;
1933 Left : Gela.Interpretations.Interpretation_Set_Index;
1934 Right : Gela.Interpretations.Interpretation_Set_Index;
1935 Result : out Gela.Interpretations.Interpretation_Index)
1936 is
1937 Ignore_Tipe : Gela.Semantic_Types.Type_Index;
1938 Ignore_Right : Gela.Interpretations.Interpretation_Index;
1939 begin
1940 Discrete_Range
1941 (Comp => Comp,
1942 Env => Env,
1943 Left => Left,
1944 Right => Right,
1945 Tipe => Ignore_Tipe,
1946 Down_Left => Result,
1947 Down_Right => Ignore_Right);
1948 end Discrete_Range_Lower;
1949
1950 --------------------------
1951 -- Discrete_Range_Upper --
1952 --------------------------
1953
1954 procedure Discrete_Range_Upper
1955 (Comp : Gela.Compilations.Compilation_Access;
1956 Env : Gela.Semantic_Types.Env_Index;
1957 Left : Gela.Interpretations.Interpretation_Set_Index;
1958 Right : Gela.Interpretations.Interpretation_Set_Index;
1959 Result : out Gela.Interpretations.Interpretation_Index)
1960 is
1961 Ignore_Tipe : Gela.Semantic_Types.Type_Index;
1962 Ignore_Left : Gela.Interpretations.Interpretation_Index;
1963 begin
1964 Discrete_Range
1965 (Comp => Comp,
1966 Env => Env,
1967 Left => Left,
1968 Right => Right,
1969 Tipe => Ignore_Tipe,
1970 Down_Left => Ignore_Left,
1971 Down_Right => Result);
1972 end Discrete_Range_Upper;
1973
1974 --------------------
1975 -- String_Literal --
1976 --------------------
1977
1978 procedure String_Literal
1979 (Comp : Gela.Compilations.Compilation_Access;
1980 Token : Gela.Lexical_Types.Token_Count;
1981 Result : out Gela.Interpretations.Interpretation_Set_Index)
1982 is
1983 pragma Unreferenced (Token);
1984 Matcher : constant Type_Matchers.Type_Matcher_Access :=
1985 new Type_Matchers.String_Type_Matcher;
1986 begin
1987 Result := 0;
1988
1989 Comp.Context.Interpretation_Manager.Add_Expression_Category
1990 (Match => Gela.Interpretations.Type_Matcher_Access (Matcher),
1991 Down => (1 .. 0 => 0),
1992 Result => Result);
1993
1994 end String_Literal;
1995
1996 ----------------------
1997 -- To_The_Same_Type --
1998 ----------------------
1999
2000 procedure To_The_Same_Type
2001 (Comp : Gela.Compilations.Compilation_Access;
2002 Env : Gela.Semantic_Types.Env_Index;
2003 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
2004 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
2005 Result : out Gela.Interpretations.Interpretation_Index)
2006 is
2007
2008 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
2009 Comp.Context.Interpretation_Manager;
2010
2011 TM : constant Gela.Type_Managers.Type_Manager_Access :=
2012 Comp.Context.Types;
2013
2014 begin
2015 Result := 0;
2016
2017 for J in Each.Expression (IM, TM, Env, Type_Up) loop
2018 To_Type
2019 (Comp => Comp,
2020 Env => Env,
2021 Type_Up => J.Expression_Type,
2022 Expr_Up => Expr_Up,
2023 Result => Result);
2024
2025 exit;
2026 end loop;
2027 end To_The_Same_Type;
2028
2029 -------------
2030 -- To_Type --
2031 -------------
2032
2033 procedure To_Type
2034 (Comp : Gela.Compilations.Compilation_Access;
2035 Env : Gela.Semantic_Types.Env_Index;
2036 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
2037 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
2038 Result : out Gela.Interpretations.Interpretation_Index)
2039 is
2040 Index : Gela.Interpretations.Interpretation_Index;
2041 Type_Index : Gela.Semantic_Types.Type_Index;
2042 begin
2043 Get_Subtype
2044 (Comp,
2045 Env => Env,
2046 Set => Type_Up,
2047 Index => Index,
2048 Result => Type_Index);
2049
2050 To_Type
2051 (Comp => Comp,
2052 Env => Env,
2053 Type_Up => Type_Index,
2054 Expr_Up => Expr_Up,
2055 Result => Result);
2056 end To_Type;
2057
2058 -------------
2059 -- To_Type --
2060 -------------
2061
2062 procedure To_Type
2063 (Comp : Gela.Compilations.Compilation_Access;
2064 Env : Gela.Semantic_Types.Env_Index;
2065 Type_Up : Gela.Semantic_Types.Type_Index;
2066 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
2067 Result : out Gela.Interpretations.Interpretation_Index)
2068 is
2069 pragma Unreferenced (Env);
2070
2071 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
2072 Comp.Context.Interpretation_Manager;
2073
2074 TM : constant Gela.Type_Managers.Type_Manager_Access :=
2075 Comp.Context.Types;
2076
2077 View : constant Gela.Types.Type_View_Access := TM.Get (Type_Up);
2078
2079 begin
2080 Result := 0;
2081
2082 if not View.Assigned then
2083 return;
2084 end if;
2085
2086 for J in IM.Each (Expr_Up) loop
2087 if J.Is_Defining_Name then
2088 Result := J.Get_Index; -- ???
2089 elsif J.Is_Expression then
2090 declare
2091 This_Type : constant Gela.Types.Type_View_Access :=
2092 TM.Get (J.Expression_Type);
2093 begin
2094 if This_Type.Assigned and then
2095 This_Type.Is_Expected_Type (View)
2096 then
2097 Result := J.Get_Index;
2098 end if;
2099 end;
2100 elsif J.Is_Expression_Category then
2101 declare
2102 use type Gela.Interpretations.Interpretation_Index;
2103 Match : constant Gela.Interpretations.Type_Matcher_Access :=
2104 J.Matcher;
2105 begin
2106 View.Visit (Match.all);
2107
2108 if Match.Is_Matched and Result = 0 then
2109 IM.Get_Expression_Index
2110 (Tipe => Type_Up,
2111 Result => Result);
2112 end if;
2113 end;
2114 end if;
2115 end loop;
2116 end To_Type;
2117
2118 ----------------------
2119 -- To_Type_Category --
2120 ----------------------
2121
2122 procedure To_Type_Category
2123 (Comp : Gela.Compilations.Compilation_Access;
2124 Up : Gela.Interpretations.Interpretation_Set_Index;
2125 Tipe : Gela.Semantic_Types.Type_Index;
2126 Result : out Gela.Interpretations.Interpretation_Index)
2127 is
2128
2129 TM : constant Gela.Type_Managers.Type_Manager_Access :=
2130 Comp.Context.Types;
2131
2132 View : constant Gela.Types.Type_View_Access := TM.Get (Tipe);
2133
2134 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
2135 Comp.Context.Interpretation_Manager;
2136
2137 Matcher : Gela.Interpretations.Type_Matcher_Access;
2138 begin
2139 Result := 0;
2140
2141 for J in IM.Categories (Up) loop
2142 Matcher := J.Matcher;
2143 View.Visit (Matcher.all);
2144
2145 if Matcher.Is_Matched then
2146 Result := J.Get_Index;
2147 end if;
2148 end loop;
2149 end To_Type_Category;
2150
2151 ------------------------------
2152 -- To_Type_Or_The_Same_Type --
2153 ------------------------------
2154
2155 procedure To_Type_Or_The_Same_Type
2156 (Comp : Gela.Compilations.Compilation_Access;
2157 Env : Gela.Semantic_Types.Env_Index;
2158 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
2159 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
2160 Result : out Gela.Interpretations.Interpretation_Index)
2161 is
2162 use type Gela.Semantic_Types.Type_Index;
2163
2164 Index : Gela.Interpretations.Interpretation_Index;
2165 Type_Index : Gela.Semantic_Types.Type_Index;
2166 begin
2167 Get_Subtype
2168 (Comp,
2169 Env => Env,
2170 Set => Type_Up,
2171 Index => Index,
2172 Result => Type_Index);
2173
2174 if Type_Index = 0 then
2175 To_The_Same_Type
2176 (Comp => Comp,
2177 Env => Env,
2178 Type_Up => Type_Up,
2179 Expr_Up => Expr_Up,
2180 Result => Result);
2181 else
2182 To_Type
2183 (Comp => Comp,
2184 Env => Env,
2185 Type_Up => Type_Index,
2186 Expr_Up => Expr_Up,
2187 Result => Result);
2188 end if;
2189 end To_Type_Or_The_Same_Type;
2190
2191 ------------------
2192 -- Variant_Part --
2193 ------------------
2194
2195 procedure Variant_Part
2196 (Comp : Gela.Compilations.Compilation_Access;
2197 Env : Gela.Semantic_Types.Env_Index;
2198 Name_Up : Gela.Interpretations.Interpretation_Set_Index;
2199 Variants : Gela.Interpretations.Interpretation_Tuple_List_Index;
2200 Result : out Gela.Interpretations.Interpretation_Index)
2201 is
2202
2203 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
2204 Comp.Context.Interpretation_Manager;
2205
2206 TM : constant Gela.Type_Managers.Type_Manager_Access :=
2207 Comp.Context.Types;
2208
2209 Tuples : constant Gela.Interpretations.Interpretation_Tuple_Index_Array
2210 := IM.Get_Tuple_List (Variants);
2211
2212 Output : Gela.Interpretations.Interpretation_Index_Array (Tuples'Range);
2213 Chosen : Gela.Interpretations.Interpretation_Index := 0;
2214 begin
2215 Result := 0;
2216
2217 for E in Each.Expression (IM, TM, Env, Name_Up) loop
2218 for J in Tuples'Range loop
2219 declare
2220 Tuple : constant Gela.Interpretations
2221 .Interpretation_Set_Index_Array := IM.Get_Tuple (Tuples (J));
2222 List : Gela.Interpretations.Interpretation_Index_Array
2223 (Tuple'Range);
2224 begin
2225 for K in Tuple'Range loop
2226 To_Type
2227 (Comp => Comp,
2228 Env => Env,
2229 Type_Up => E.Expression_Type,
2230 Expr_Up => Tuple (K),
2231 Result => List (K));
2232 end loop;
2233
2234 Chosen := 0;
2235
2236 for K in reverse List'Range loop
2237 IM.Get_Tuple_Index (List (K), Chosen, Chosen);
2238 end loop;
2239
2240 Output (J) := Chosen;
2241 end;
2242 end loop;
2243
2244 Chosen := 0;
2245
2246 for J in reverse Output'Range loop
2247 IM.Get_Tuple_Index (Output (J), Chosen, Chosen);
2248 end loop;
2249
2250 Result := Chosen;
2251 exit;
2252 end loop;
2253 end Variant_Part;
2254
2255end Gela.Resolve;
Note: See TracBrowser for help on using the repository browser.