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

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

Express function_call overload resolution rules

New type of interpretation required for this: Tuple.
This interpretation used to gather interpretations of parameter_associations.
Tuples connect sets of interpretations of each param together.
Then we iterate over them and choose matched for function prefix.
Chosen interpretation them get index by call Get_Tuple_Index function.
This function return linked structure of tuples suitable to unwind
during traverse parameter_associations when propagating Down attribute.

File size: 26.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 overriding procedure On_Tuple
175 (Self : in out Visiter;
176 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
177 Down : Gela.Interpretations.Interpretation_Index_Array)
178 is null;
179
180 end Each;
181
182 ----------
183 -- Each --
184 ----------
185
186 package body Each is
187
188 overriding procedure On_Defining_Name
189 (Self : in out Visiter;
190 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
191 Down : Gela.Interpretations.Interpretation_Index_Array)
192 is
193 pragma Unreferenced (Self);
194 pragma Unreferenced (Name);
195 pragma Unreferenced (Down);
196 begin
197 null;
198 end On_Defining_Name;
199
200 overriding procedure On_Expression
201 (Self : in out Visiter;
202 Tipe : Gela.Semantic_Types.Type_Index;
203 Down : Gela.Interpretations.Interpretation_Index_Array)
204 is
205 pragma Unreferenced (Self);
206 begin
207 Target.On_Expression (Tipe, Down);
208 end On_Expression;
209
210 end Each;
211
212 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
213 Comp.Context.Interpretation_Manager;
214
215 Visiter : aliased Each.Visiter;
216 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Set);
217 begin
218 while Cursor.Has_Element loop
219 Cursor.Visit (Visiter'Access);
220 Cursor.Next;
221 end loop;
222 end Each_Expression;
223
224 -------------------
225 -- Function_Call --
226 -------------------
227
228 procedure Function_Call
229 (Comp : Gela.Compilations.Compilation_Access;
230 Env : Gela.Semantic_Types.Env_Index;
231 Prefix : Gela.Interpretations.Interpretation_Set_Index;
232 Args : Gela.Interpretations.Interpretation_Set_Index;
233 Set : out Gela.Interpretations.Interpretation_Set_Index)
234 is
235 pragma Unreferenced (Env);
236
237 use type Gela.Interpretations.Interpretation_Index_Array;
238
239 No_Args_Allowed : constant Boolean := True;
240 -- FIXME Replace with actual check
241
242 package Each_Arg is
243 type Visiter is new Gela.Interpretations.Visiter with record
244 Index : Gela.Interpretations.Interpretation_Index := 0;
245 end record;
246
247 overriding procedure On_Defining_Name
248 (Self : in out Visiter;
249 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
250 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
251
252 overriding procedure On_Expression
253 (Self : in out Visiter;
254 Tipe : Gela.Semantic_Types.Type_Index;
255 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
256
257 overriding procedure On_Attr_Function
258 (Self : in out Visiter;
259 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
260 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
261
262 overriding procedure On_Tuple
263 (Self : in out Visiter;
264 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
265 Down : Gela.Interpretations.Interpretation_Index_Array);
266
267 end Each_Arg;
268
269 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
270 Comp.Context.Interpretation_Manager;
271
272 package body Each_Arg is
273 overriding procedure On_Tuple
274 (Self : in out Visiter;
275 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
276 Down : Gela.Interpretations.Interpretation_Index_Array)
277 is
278 pragma Unreferenced (Down);
279
280 Chosen : Gela.Interpretations.Interpretation_Index;
281 List : Gela.Interpretations.Interpretation_Index_Array
282 (Value'Range);
283 begin
284 for J in Value'Range loop
285 declare
286 Cursor : constant Gela.Interpretations.Cursor'Class :=
287 IM.Get_Cursor (Value (J));
288 begin
289 List (J) := Cursor.Get_Index;
290 end;
291 end loop;
292
293 Chosen := 0;
294
295 for J in reverse List'Range loop
296 IM.Get_Tuple_Index (List (J), Chosen, Chosen);
297 end loop;
298
299 Comp.Context.Interpretation_Manager.Add_Expression
300 (Tipe => Comp.Context.Types.Universal_Integer,
301 Down => Self.Index & Chosen,
302 Result => Set);
303 end On_Tuple;
304 end Each_Arg;
305
306 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
307 begin
308 Set := 0;
309
310 while Cursor.Has_Element loop
311 declare
312 Visiter : aliased Each_Arg.Visiter := (Index => Cursor.Get_Index);
313 Arg : Gela.Interpretations.Cursor'Class :=
314 IM.Get_Cursor (Args);
315 begin
316 if Arg.Has_Element then
317 while Arg.Has_Element loop
318 Arg.Visit (Visiter'Access);
319 Arg.Next;
320 end loop;
321 elsif No_Args_Allowed then
322 Comp.Context.Interpretation_Manager.Add_Expression
323 (Tipe => Comp.Context.Types.Universal_Integer,
324 Down => Visiter.Index & 0,
325 Result => Set);
326 end if;
327
328 Cursor.Next;
329 end;
330 end loop;
331 end Function_Call;
332
333 -----------------
334 -- Get_Subtype --
335 -----------------
336
337 procedure Get_Subtype
338 (Comp : Gela.Compilations.Compilation_Access;
339 Env : Gela.Semantic_Types.Env_Index;
340 Set : Gela.Interpretations.Interpretation_Set_Index;
341 Index : out Gela.Interpretations.Interpretation_Index;
342 Result : out Gela.Semantic_Types.Type_Index)
343 is
344 pragma Unreferenced (Env);
345
346 package Each is
347 type Visiter is new Gela.Interpretations.Visiter with record
348 Index : Gela.Interpretations.Interpretation_Index := 0;
349 Result : Gela.Semantic_Types.Type_Index := 0;
350 end record;
351
352 overriding procedure On_Defining_Name
353 (Self : in out Visiter;
354 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
355 Down : Gela.Interpretations.Interpretation_Index_Array);
356
357 overriding procedure On_Expression
358 (Self : in out Visiter;
359 Tipe : Gela.Semantic_Types.Type_Index;
360 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
361
362 overriding procedure On_Attr_Function
363 (Self : in out Visiter;
364 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
365 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
366
367 overriding procedure On_Tuple
368 (Self : in out Visiter;
369 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
370 Down : Gela.Interpretations.Interpretation_Index_Array)
371 is null;
372
373 end Each;
374
375 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
376 Comp.Context.Interpretation_Manager;
377
378 TM : constant Gela.Type_Managers.Type_Manager_Access :=
379 Comp.Context.Types;
380
381 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Set);
382
383 ----------
384 -- Each --
385 ----------
386
387 package body Each is
388
389 overriding procedure On_Defining_Name
390 (Self : in out Visiter;
391 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
392 Down : Gela.Interpretations.Interpretation_Index_Array)
393 is
394 pragma Unreferenced (Self);
395 pragma Unreferenced (Down);
396 begin
397 Self.Result := TM.Type_By_Name (Name);
398 Self.Index := Cursor.Get_Index;
399 end On_Defining_Name;
400
401 end Each;
402
403 Visiter : aliased Each.Visiter;
404 begin
405 while Cursor.Has_Element loop
406 Cursor.Visit (Visiter'Access);
407 Cursor.Next;
408 end loop;
409
410 Index := Visiter.Index;
411 Result := Visiter.Result;
412 end Get_Subtype;
413
414 procedure Interpretation
415 (Comp : Gela.Compilations.Compilation_Access;
416 Env : Gela.Semantic_Types.Env_Index;
417 Set : Gela.Interpretations.Interpretation_Set_Index;
418 Result : out Gela.Interpretations.Interpretation_Index)
419 is
420 pragma Unreferenced (Env);
421
422 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
423 Comp.Context.Interpretation_Manager;
424
425 Cursor : constant Gela.Interpretations.Cursor'Class :=
426 IM.Get_Cursor (Set);
427
428 begin
429 if Cursor.Has_Element then
430 Result := Cursor.Get_Index;
431 else
432 Result := 0;
433 end if;
434 end Interpretation;
435
436 ---------------------
437 -- Numeric_Literal --
438 ---------------------
439
440 procedure Numeric_Literal
441 (Comp : Gela.Compilations.Compilation_Access;
442 Token : Gela.Lexical_Types.Token_Count;
443 Result : out Gela.Interpretations.Interpretation_Set_Index)
444 is
445 Value : constant Gela.Lexical_Types.Token := Comp.Get_Token (Token);
446 Type_Index : Gela.Semantic_Types.Type_Index;
447 begin
448 Result := 0;
449
450 if Comp.Source.Index (Value.First, Value.Last, '.') = 0 then
451 Type_Index := Comp.Context.Types.Universal_Integer;
452 else
453 Type_Index := Comp.Context.Types.Universal_Real;
454 end if;
455
456 Comp.Context.Interpretation_Manager.Add_Expression
457 (Tipe => Type_Index,
458 Down => (1 .. 0 => 0),
459 Result => Result);
460 end Numeric_Literal;
461
462 ------------------------
463 -- Selected_Component --
464 ------------------------
465
466 procedure Selected_Component
467 (Comp : Gela.Compilations.Compilation_Access;
468 Env : Gela.Semantic_Types.Env_Index;
469 Prefix : Gela.Interpretations.Interpretation_Set_Index;
470 Symbol : Gela.Lexical_Types.Symbol;
471 Set : out Gela.Interpretations.Interpretation_Set_Index)
472 is
473 package Each is
474 type Visiter is new Gela.Interpretations.Visiter with null record;
475
476 overriding procedure On_Defining_Name
477 (Self : in out Visiter;
478 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
479 Down : Gela.Interpretations.Interpretation_Index_Array);
480
481 overriding procedure On_Expression
482 (Self : in out Visiter;
483 Tipe : Gela.Semantic_Types.Type_Index;
484 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
485
486 overriding procedure On_Attr_Function
487 (Self : in out Visiter;
488 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
489 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
490
491 overriding procedure On_Tuple
492 (Self : in out Visiter;
493 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
494 Down : Gela.Interpretations.Interpretation_Index_Array)
495 is null;
496
497 end Each;
498
499 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
500 Comp.Context.Interpretation_Manager;
501
502 ES : constant Gela.Environments.Environment_Set_Access :=
503 Comp.Context.Environment_Set;
504
505 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
506
507 ----------
508 -- Each --
509 ----------
510
511 package body Each is
512
513 overriding procedure On_Defining_Name
514 (Self : in out Visiter;
515 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
516 Down : Gela.Interpretations.Interpretation_Index_Array)
517 is
518 pragma Unreferenced (Self);
519 pragma Unreferenced (Down);
520 Found : aliased Boolean;
521 NC : Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
522 := ES.Visible (Env, Name, Symbol, Found'Access);
523 begin
524 while NC.Has_Element loop
525 IM.Add_Defining_Name
526 (Name => NC.Element,
527 Down => (1 => Cursor.Get_Index),
528 Result => Set);
529
530 NC.Next;
531 end loop;
532 end On_Defining_Name;
533
534 end Each;
535
536 Visiter : aliased Each.Visiter;
537 begin
538 Set := 0;
539 while Cursor.Has_Element loop
540 Cursor.Visit (Visiter'Access);
541 Cursor.Next;
542 end loop;
543 end Selected_Component;
544
545 ----------------------
546 -- Shall_Be_Subtype --
547 ----------------------
548
549 procedure Shall_Be_Subtype
550 (Comp : Gela.Compilations.Compilation_Access;
551 Env : Gela.Semantic_Types.Env_Index;
552 Set : Gela.Interpretations.Interpretation_Set_Index;
553 Result : out Gela.Interpretations.Interpretation_Index)
554 is
555 Type_Index : Gela.Semantic_Types.Type_Index;
556 begin
557 Get_Subtype
558 (Comp,
559 Env => Env,
560 Set => Set,
561 Index => Result,
562 Result => Type_Index);
563 end Shall_Be_Subtype;
564
565 -----------------------------
566 -- Simple_Expression_Range --
567 -----------------------------
568
569 procedure Simple_Expression_Range
570 (Comp : Gela.Compilations.Compilation_Access;
571 Env : Gela.Semantic_Types.Env_Index;
572 Left : Gela.Interpretations.Interpretation_Set_Index;
573 Right : Gela.Interpretations.Interpretation_Set_Index;
574 Set : out Gela.Interpretations.Interpretation_Set_Index)
575 is
576 pragma Unreferenced (Env);
577 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
578 Comp.Context.Interpretation_Manager;
579
580 Cursor_Left : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Left);
581 Cursor_Right : Gela.Interpretations.Cursor'Class :=
582 IM.Get_Cursor (Right);
583
584 begin
585 Set := 0;
586 while Cursor_Left.Has_Element loop
587 while Cursor_Right.Has_Element loop
588 -- FIX ME: compare types of left and right interpretation
589 Comp.Context.Interpretation_Manager.Add_Expression
590 (Tipe => 0,
591 Down => (Cursor_Left.Get_Index,
592 Cursor_Right.Get_Index),
593 Result => Set);
594
595 Cursor_Right.Next;
596 end loop;
597
598 Cursor_Left.Next;
599 end loop;
600 end Simple_Expression_Range;
601
602 ----------------------
603 -- To_The_Same_Type --
604 ----------------------
605
606 procedure To_The_Same_Type
607 (Comp : Gela.Compilations.Compilation_Access;
608 Env : Gela.Semantic_Types.Env_Index;
609 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
610 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
611 Result : out Gela.Interpretations.Interpretation_Index)
612 is
613 pragma Unreferenced (Env);
614
615 package Each is
616 type Visiter is new Gela.Interpretations.Visiter with record
617 null;
618 end record;
619
620 overriding procedure On_Defining_Name
621 (Self : in out Visiter;
622 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
623 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
624
625 overriding procedure On_Expression
626 (Self : in out Visiter;
627 Tipe : Gela.Semantic_Types.Type_Index;
628 Down : Gela.Interpretations.Interpretation_Index_Array);
629
630 overriding procedure On_Attr_Function
631 (Self : in out Visiter;
632 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
633 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
634
635 overriding procedure On_Tuple
636 (Self : in out Visiter;
637 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
638 Down : Gela.Interpretations.Interpretation_Index_Array)
639 is null;
640
641 end Each;
642
643 ----------
644 -- Each --
645 ----------
646
647 package body Each is
648
649 overriding procedure On_Expression
650 (Self : in out Visiter;
651 Tipe : Gela.Semantic_Types.Type_Index;
652 Down : Gela.Interpretations.Interpretation_Index_Array)
653 is
654 pragma Unreferenced (Self);
655 pragma Unreferenced (Down);
656 begin
657 To_Type
658 (Comp => Comp,
659 Type_Up => Tipe,
660 Expr_Up => Expr_Up,
661 Result => Result);
662 end On_Expression;
663
664 end Each;
665
666 Visiter : Each.Visiter;
667 begin
668 Result := 0;
669
670 Each_Expression (Comp => Comp,
671 Set => Type_Up,
672 Target => Visiter);
673 end To_The_Same_Type;
674
675 -------------
676 -- To_Type --
677 -------------
678
679 procedure To_Type
680 (Comp : Gela.Compilations.Compilation_Access;
681 Env : Gela.Semantic_Types.Env_Index;
682 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
683 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
684 Result : out Gela.Interpretations.Interpretation_Index)
685 is
686 Index : Gela.Interpretations.Interpretation_Index;
687 Type_Index : Gela.Semantic_Types.Type_Index;
688 begin
689 Get_Subtype
690 (Comp,
691 Env => Env,
692 Set => Type_Up,
693 Index => Index,
694 Result => Type_Index);
695
696 To_Type
697 (Comp => Comp,
698 Type_Up => Type_Index,
699 Expr_Up => Expr_Up,
700 Result => Result);
701 end To_Type;
702
703 -------------
704 -- To_Type --
705 -------------
706
707 procedure To_Type
708 (Comp : Gela.Compilations.Compilation_Access;
709 Type_Up : Gela.Semantic_Types.Type_Index;
710 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
711 Result : out Gela.Interpretations.Interpretation_Index)
712 is
713
714 package Each is
715 type Visiter is new Gela.Interpretations.Visiter with record
716 Type_Index : Gela.Semantic_Types.Type_Index;
717 Index : Gela.Interpretations.Interpretation_Index := 0;
718 end record;
719
720 overriding procedure On_Defining_Name
721 (Self : in out Visiter;
722 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
723 Down : Gela.Interpretations.Interpretation_Index_Array);
724
725 overriding procedure On_Expression
726 (Self : in out Visiter;
727 Tipe : Gela.Semantic_Types.Type_Index;
728 Down : Gela.Interpretations.Interpretation_Index_Array);
729
730 overriding procedure On_Attr_Function
731 (Self : in out Visiter;
732 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
733 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
734
735 overriding procedure On_Tuple
736 (Self : in out Visiter;
737 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
738 Down : Gela.Interpretations.Interpretation_Index_Array)
739 is null;
740
741 end Each;
742
743 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
744 Comp.Context.Interpretation_Manager;
745
746 Cursor : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Expr_Up);
747
748 ----------
749 -- Each --
750 ----------
751
752 package body Each is
753
754 overriding procedure On_Defining_Name
755 (Self : in out Visiter;
756 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
757 Down : Gela.Interpretations.Interpretation_Index_Array)
758 is
759 pragma Unreferenced (Name);
760 pragma Unreferenced (Down);
761 begin
762 Self.Index := Cursor.Get_Index;
763 end On_Defining_Name;
764
765 overriding procedure On_Expression
766 (Self : in out Visiter;
767 Tipe : Gela.Semantic_Types.Type_Index;
768 Down : Gela.Interpretations.Interpretation_Index_Array)
769 is
770 pragma Unreferenced (Tipe);
771 pragma Unreferenced (Down);
772 begin
773 Self.Index := Cursor.Get_Index;
774 end On_Expression;
775
776 end Each;
777
778 Visiter : aliased Each.Visiter;
779 begin
780 Visiter.Type_Index := Type_Up;
781
782 while Cursor.Has_Element loop
783 Cursor.Visit (Visiter'Access);
784 Cursor.Next;
785 end loop;
786
787 Result := Visiter.Index;
788 end To_Type;
789
790 ------------------------------
791 -- To_Type_Or_The_Same_Type --
792 ------------------------------
793
794 procedure To_Type_Or_The_Same_Type
795 (Comp : Gela.Compilations.Compilation_Access;
796 Env : Gela.Semantic_Types.Env_Index;
797 Type_Up : Gela.Interpretations.Interpretation_Set_Index;
798 Expr_Up : Gela.Interpretations.Interpretation_Set_Index;
799 Result : out Gela.Interpretations.Interpretation_Index)
800 is
801 use type Gela.Semantic_Types.Type_Index;
802
803 Index : Gela.Interpretations.Interpretation_Index;
804 Type_Index : Gela.Semantic_Types.Type_Index;
805 begin
806 Get_Subtype
807 (Comp,
808 Env => Env,
809 Set => Type_Up,
810 Index => Index,
811 Result => Type_Index);
812
813 if Type_Index = 0 then
814 To_The_Same_Type
815 (Comp => Comp,
816 Env => Env,
817 Type_Up => Type_Up,
818 Expr_Up => Expr_Up,
819 Result => Result);
820 else
821 To_Type
822 (Comp => Comp,
823 Type_Up => Type_Index,
824 Expr_Up => Expr_Up,
825 Result => Result);
826 end if;
827 end To_Type_Or_The_Same_Type;
828
829end Gela.Resolve;
Note: See TracBrowser for help on using the repository browser.