PR tree-optimization/85699
[official-gcc.git] / gcc / ada / sem_type.adb
blobb499117e743c6d61850a449d87290fd9c96d4789
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ T Y P E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Alloc;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Nlists; use Nlists;
32 with Errout; use Errout;
33 with Lib; use Lib;
34 with Namet; use Namet;
35 with Opt; use Opt;
36 with Output; use Output;
37 with Sem; use Sem;
38 with Sem_Aux; use Sem_Aux;
39 with Sem_Ch6; use Sem_Ch6;
40 with Sem_Ch8; use Sem_Ch8;
41 with Sem_Ch12; use Sem_Ch12;
42 with Sem_Disp; use Sem_Disp;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Util; use Sem_Util;
45 with Stand; use Stand;
46 with Sinfo; use Sinfo;
47 with Snames; use Snames;
48 with Table;
49 with Treepr; use Treepr;
50 with Uintp; use Uintp;
52 package body Sem_Type is
54 ---------------------
55 -- Data Structures --
56 ---------------------
58 -- The following data structures establish a mapping between nodes and
59 -- their interpretations. An overloaded node has an entry in Interp_Map,
60 -- which in turn contains a pointer into the All_Interp array. The
61 -- interpretations of a given node are contiguous in All_Interp. Each set
62 -- of interpretations is terminated with the marker No_Interp. In order to
63 -- speed up the retrieval of the interpretations of an overloaded node, the
64 -- Interp_Map table is accessed by means of a simple hashing scheme, and
65 -- the entries in Interp_Map are chained. The heads of clash lists are
66 -- stored in array Headers.
68 -- Headers Interp_Map All_Interp
70 -- _ +-----+ +--------+
71 -- |_| |_____| --->|interp1 |
72 -- |_|---------->|node | | |interp2 |
73 -- |_| |index|---------| |nointerp|
74 -- |_| |next | | |
75 -- |-----| | |
76 -- +-----+ +--------+
78 -- This scheme does not currently reclaim interpretations. In principle,
79 -- after a unit is compiled, all overloadings have been resolved, and the
80 -- candidate interpretations should be deleted. This should be easier
81 -- now than with the previous scheme???
83 package All_Interp is new Table.Table (
84 Table_Component_Type => Interp,
85 Table_Index_Type => Interp_Index,
86 Table_Low_Bound => 0,
87 Table_Initial => Alloc.All_Interp_Initial,
88 Table_Increment => Alloc.All_Interp_Increment,
89 Table_Name => "All_Interp");
91 type Interp_Ref is record
92 Node : Node_Id;
93 Index : Interp_Index;
94 Next : Int;
95 end record;
97 Header_Size : constant Int := 2 ** 12;
98 No_Entry : constant Int := -1;
99 Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
101 package Interp_Map is new Table.Table (
102 Table_Component_Type => Interp_Ref,
103 Table_Index_Type => Int,
104 Table_Low_Bound => 0,
105 Table_Initial => Alloc.Interp_Map_Initial,
106 Table_Increment => Alloc.Interp_Map_Increment,
107 Table_Name => "Interp_Map");
109 function Hash (N : Node_Id) return Int;
110 -- A trivial hashing function for nodes, used to insert an overloaded
111 -- node into the Interp_Map table.
113 -------------------------------------
114 -- Handling of Overload Resolution --
115 -------------------------------------
117 -- Overload resolution uses two passes over the syntax tree of a complete
118 -- context. In the first, bottom-up pass, the types of actuals in calls
119 -- are used to resolve possibly overloaded subprogram and operator names.
120 -- In the second top-down pass, the type of the context (for example the
121 -- condition in a while statement) is used to resolve a possibly ambiguous
122 -- call, and the unique subprogram name in turn imposes a specific context
123 -- on each of its actuals.
125 -- Most expressions are in fact unambiguous, and the bottom-up pass is
126 -- sufficient to resolve most everything. To simplify the common case,
127 -- names and expressions carry a flag Is_Overloaded to indicate whether
128 -- they have more than one interpretation. If the flag is off, then each
129 -- name has already a unique meaning and type, and the bottom-up pass is
130 -- sufficient (and much simpler).
132 --------------------------
133 -- Operator Overloading --
134 --------------------------
136 -- The visibility of operators is handled differently from that of other
137 -- entities. We do not introduce explicit versions of primitive operators
138 -- for each type definition. As a result, there is only one entity
139 -- corresponding to predefined addition on all numeric types, etc. The
140 -- back end resolves predefined operators according to their type. The
141 -- visibility of primitive operations then reduces to the visibility of the
142 -- resulting type: (a + b) is a legal interpretation of some primitive
143 -- operator + if the type of the result (which must also be the type of a
144 -- and b) is directly visible (either immediately visible or use-visible).
146 -- User-defined operators are treated like other functions, but the
147 -- visibility of these user-defined operations must be special-cased
148 -- to determine whether they hide or are hidden by predefined operators.
149 -- The form P."+" (x, y) requires additional handling.
151 -- Concatenation is treated more conventionally: for every one-dimensional
152 -- array type we introduce a explicit concatenation operator. This is
153 -- necessary to handle the case of (element & element => array) which
154 -- cannot be handled conveniently if there is no explicit instance of
155 -- resulting type of the operation.
157 -----------------------
158 -- Local Subprograms --
159 -----------------------
161 procedure All_Overloads;
162 pragma Warnings (Off, All_Overloads);
163 -- Debugging procedure: list full contents of Overloads table
165 function Binary_Op_Interp_Has_Abstract_Op
166 (N : Node_Id;
167 E : Entity_Id) return Entity_Id;
168 -- Given the node and entity of a binary operator, determine whether the
169 -- actuals of E contain an abstract interpretation with regards to the
170 -- types of their corresponding formals. Return the abstract operation or
171 -- Empty.
173 function Function_Interp_Has_Abstract_Op
174 (N : Node_Id;
175 E : Entity_Id) return Entity_Id;
176 -- Given the node and entity of a function call, determine whether the
177 -- actuals of E contain an abstract interpretation with regards to the
178 -- types of their corresponding formals. Return the abstract operation or
179 -- Empty.
181 function Has_Abstract_Op
182 (N : Node_Id;
183 Typ : Entity_Id) return Entity_Id;
184 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
185 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
186 -- abstract interpretation which yields type Typ.
188 procedure New_Interps (N : Node_Id);
189 -- Initialize collection of interpretations for the given node, which is
190 -- either an overloaded entity, or an operation whose arguments have
191 -- multiple interpretations. Interpretations can be added to only one
192 -- node at a time.
194 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
195 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
196 -- or is not a "class" type (any_character, etc).
198 --------------------
199 -- Add_One_Interp --
200 --------------------
202 procedure Add_One_Interp
203 (N : Node_Id;
204 E : Entity_Id;
205 T : Entity_Id;
206 Opnd_Type : Entity_Id := Empty)
208 Vis_Type : Entity_Id;
210 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
211 -- Add one interpretation to an overloaded node. Add a new entry if
212 -- not hidden by previous one, and remove previous one if hidden by
213 -- new one.
215 function Is_Universal_Operation (Op : Entity_Id) return Boolean;
216 -- True if the entity is a predefined operator and the operands have
217 -- a universal Interpretation.
219 ---------------
220 -- Add_Entry --
221 ---------------
223 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
224 Abstr_Op : Entity_Id := Empty;
225 I : Interp_Index;
226 It : Interp;
228 -- Start of processing for Add_Entry
230 begin
231 -- Find out whether the new entry references interpretations that
232 -- are abstract or disabled by abstract operators.
234 if Ada_Version >= Ada_2005 then
235 if Nkind (N) in N_Binary_Op then
236 Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
237 elsif Nkind (N) = N_Function_Call then
238 Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
239 end if;
240 end if;
242 Get_First_Interp (N, I, It);
243 while Present (It.Nam) loop
245 -- A user-defined subprogram hides another declared at an outer
246 -- level, or one that is use-visible. So return if previous
247 -- definition hides new one (which is either in an outer
248 -- scope, or use-visible). Note that for functions use-visible
249 -- is the same as potentially use-visible. If new one hides
250 -- previous one, replace entry in table of interpretations.
251 -- If this is a universal operation, retain the operator in case
252 -- preference rule applies.
254 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
255 and then Ekind (Name) = Ekind (It.Nam))
256 or else (Ekind (Name) = E_Operator
257 and then Ekind (It.Nam) = E_Function))
258 and then Is_Immediately_Visible (It.Nam)
259 and then Type_Conformant (Name, It.Nam)
260 and then Base_Type (It.Typ) = Base_Type (T)
261 then
262 if Is_Universal_Operation (Name) then
263 exit;
265 -- If node is an operator symbol, we have no actuals with
266 -- which to check hiding, and this is done in full in the
267 -- caller (Analyze_Subprogram_Renaming) so we include the
268 -- predefined operator in any case.
270 elsif Nkind (N) = N_Operator_Symbol
271 or else
272 (Nkind (N) = N_Expanded_Name
273 and then Nkind (Selector_Name (N)) = N_Operator_Symbol)
274 then
275 exit;
277 elsif not In_Open_Scopes (Scope (Name))
278 or else Scope_Depth (Scope (Name)) <=
279 Scope_Depth (Scope (It.Nam))
280 then
281 -- If ambiguity within instance, and entity is not an
282 -- implicit operation, save for later disambiguation.
284 if Scope (Name) = Scope (It.Nam)
285 and then not Is_Inherited_Operation (Name)
286 and then In_Instance
287 then
288 exit;
289 else
290 return;
291 end if;
293 else
294 All_Interp.Table (I).Nam := Name;
295 return;
296 end if;
298 -- Avoid making duplicate entries in overloads
300 elsif Name = It.Nam
301 and then Base_Type (It.Typ) = Base_Type (T)
302 then
303 return;
305 -- Otherwise keep going
307 else
308 Get_Next_Interp (I, It);
309 end if;
310 end loop;
312 All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
313 All_Interp.Append (No_Interp);
314 end Add_Entry;
316 ----------------------------
317 -- Is_Universal_Operation --
318 ----------------------------
320 function Is_Universal_Operation (Op : Entity_Id) return Boolean is
321 Arg : Node_Id;
323 begin
324 if Ekind (Op) /= E_Operator then
325 return False;
327 elsif Nkind (N) in N_Binary_Op then
328 return Present (Universal_Interpretation (Left_Opnd (N)))
329 and then Present (Universal_Interpretation (Right_Opnd (N)));
331 elsif Nkind (N) in N_Unary_Op then
332 return Present (Universal_Interpretation (Right_Opnd (N)));
334 elsif Nkind (N) = N_Function_Call then
335 Arg := First_Actual (N);
336 while Present (Arg) loop
337 if No (Universal_Interpretation (Arg)) then
338 return False;
339 end if;
341 Next_Actual (Arg);
342 end loop;
344 return True;
346 else
347 return False;
348 end if;
349 end Is_Universal_Operation;
351 -- Start of processing for Add_One_Interp
353 begin
354 -- If the interpretation is a predefined operator, verify that the
355 -- result type is visible, or that the entity has already been
356 -- resolved (case of an instantiation node that refers to a predefined
357 -- operation, or an internally generated operator node, or an operator
358 -- given as an expanded name). If the operator is a comparison or
359 -- equality, it is the type of the operand that matters to determine
360 -- whether the operator is visible. In an instance, the check is not
361 -- performed, given that the operator was visible in the generic.
363 if Ekind (E) = E_Operator then
364 if Present (Opnd_Type) then
365 Vis_Type := Opnd_Type;
366 else
367 Vis_Type := Base_Type (T);
368 end if;
370 if In_Open_Scopes (Scope (Vis_Type))
371 or else Is_Potentially_Use_Visible (Vis_Type)
372 or else In_Use (Vis_Type)
373 or else (In_Use (Scope (Vis_Type))
374 and then not Is_Hidden (Vis_Type))
375 or else Nkind (N) = N_Expanded_Name
376 or else (Nkind (N) in N_Op and then E = Entity (N))
377 or else (In_Instance or else In_Inlined_Body)
378 or else Ekind (Vis_Type) = E_Anonymous_Access_Type
379 then
380 null;
382 -- If the node is given in functional notation and the prefix
383 -- is an expanded name, then the operator is visible if the
384 -- prefix is the scope of the result type as well. If the
385 -- operator is (implicitly) defined in an extension of system,
386 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
388 elsif Nkind (N) = N_Function_Call
389 and then Nkind (Name (N)) = N_Expanded_Name
390 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
391 or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
392 or else Scope (Vis_Type) = System_Aux_Id)
393 then
394 null;
396 -- Save type for subsequent error message, in case no other
397 -- interpretation is found.
399 else
400 Candidate_Type := Vis_Type;
401 return;
402 end if;
404 -- In an instance, an abstract non-dispatching operation cannot be a
405 -- candidate interpretation, because it could not have been one in the
406 -- generic (it may be a spurious overloading in the instance).
408 elsif In_Instance
409 and then Is_Overloadable (E)
410 and then Is_Abstract_Subprogram (E)
411 and then not Is_Dispatching_Operation (E)
412 then
413 return;
415 -- An inherited interface operation that is implemented by some derived
416 -- type does not participate in overload resolution, only the
417 -- implementation operation does.
419 elsif Is_Hidden (E)
420 and then Is_Subprogram (E)
421 and then Present (Interface_Alias (E))
422 then
423 -- Ada 2005 (AI-251): If this primitive operation corresponds with
424 -- an immediate ancestor interface there is no need to add it to the
425 -- list of interpretations. The corresponding aliased primitive is
426 -- also in this list of primitive operations and will be used instead
427 -- because otherwise we have a dummy ambiguity between the two
428 -- subprograms which are in fact the same.
430 if not Is_Ancestor
431 (Find_Dispatching_Type (Interface_Alias (E)),
432 Find_Dispatching_Type (E))
433 then
434 Add_One_Interp (N, Interface_Alias (E), T);
435 end if;
437 return;
439 -- Calling stubs for an RACW operation never participate in resolution,
440 -- they are executed only through dispatching calls.
442 elsif Is_RACW_Stub_Type_Operation (E) then
443 return;
444 end if;
446 -- If this is the first interpretation of N, N has type Any_Type.
447 -- In that case place the new type on the node. If one interpretation
448 -- already exists, indicate that the node is overloaded, and store
449 -- both the previous and the new interpretation in All_Interp. If
450 -- this is a later interpretation, just add it to the set.
452 if Etype (N) = Any_Type then
453 if Is_Type (E) then
454 Set_Etype (N, T);
456 else
457 -- Record both the operator or subprogram name, and its type
459 if Nkind (N) in N_Op or else Is_Entity_Name (N) then
460 Set_Entity (N, E);
461 end if;
463 Set_Etype (N, T);
464 end if;
466 -- Either there is no current interpretation in the table for any
467 -- node or the interpretation that is present is for a different
468 -- node. In both cases add a new interpretation to the table.
470 elsif Interp_Map.Last < 0
471 or else
472 (Interp_Map.Table (Interp_Map.Last).Node /= N
473 and then not Is_Overloaded (N))
474 then
475 New_Interps (N);
477 if (Nkind (N) in N_Op or else Is_Entity_Name (N))
478 and then Present (Entity (N))
479 then
480 Add_Entry (Entity (N), Etype (N));
482 elsif Nkind (N) in N_Subprogram_Call
483 and then Is_Entity_Name (Name (N))
484 then
485 Add_Entry (Entity (Name (N)), Etype (N));
487 -- If this is an indirect call there will be no name associated
488 -- with the previous entry. To make diagnostics clearer, save
489 -- Subprogram_Type of first interpretation, so that the error will
490 -- point to the anonymous access to subprogram, not to the result
491 -- type of the call itself.
493 elsif (Nkind (N)) = N_Function_Call
494 and then Nkind (Name (N)) = N_Explicit_Dereference
495 and then Is_Overloaded (Name (N))
496 then
497 declare
498 It : Interp;
500 Itn : Interp_Index;
501 pragma Warnings (Off, Itn);
503 begin
504 Get_First_Interp (Name (N), Itn, It);
505 Add_Entry (It.Nam, Etype (N));
506 end;
508 else
509 -- Overloaded prefix in indexed or selected component, or call
510 -- whose name is an expression or another call.
512 Add_Entry (Etype (N), Etype (N));
513 end if;
515 Add_Entry (E, T);
517 else
518 Add_Entry (E, T);
519 end if;
520 end Add_One_Interp;
522 -------------------
523 -- All_Overloads --
524 -------------------
526 procedure All_Overloads is
527 begin
528 for J in All_Interp.First .. All_Interp.Last loop
530 if Present (All_Interp.Table (J).Nam) then
531 Write_Entity_Info (All_Interp.Table (J). Nam, " ");
532 else
533 Write_Str ("No Interp");
534 Write_Eol;
535 end if;
537 Write_Str ("=================");
538 Write_Eol;
539 end loop;
540 end All_Overloads;
542 --------------------------------------
543 -- Binary_Op_Interp_Has_Abstract_Op --
544 --------------------------------------
546 function Binary_Op_Interp_Has_Abstract_Op
547 (N : Node_Id;
548 E : Entity_Id) return Entity_Id
550 Abstr_Op : Entity_Id;
551 E_Left : constant Node_Id := First_Formal (E);
552 E_Right : constant Node_Id := Next_Formal (E_Left);
554 begin
555 Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
556 if Present (Abstr_Op) then
557 return Abstr_Op;
558 end if;
560 return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
561 end Binary_Op_Interp_Has_Abstract_Op;
563 ---------------------
564 -- Collect_Interps --
565 ---------------------
567 procedure Collect_Interps (N : Node_Id) is
568 Ent : constant Entity_Id := Entity (N);
569 H : Entity_Id;
570 First_Interp : Interp_Index;
572 function Within_Instance (E : Entity_Id) return Boolean;
573 -- Within an instance there can be spurious ambiguities between a local
574 -- entity and one declared outside of the instance. This can only happen
575 -- for subprograms, because otherwise the local entity hides the outer
576 -- one. For an overloadable entity, this predicate determines whether it
577 -- is a candidate within the instance, or must be ignored.
579 ---------------------
580 -- Within_Instance --
581 ---------------------
583 function Within_Instance (E : Entity_Id) return Boolean is
584 Inst : Entity_Id;
585 Scop : Entity_Id;
587 begin
588 if not In_Instance then
589 return False;
590 end if;
592 Inst := Current_Scope;
593 while Present (Inst) and then not Is_Generic_Instance (Inst) loop
594 Inst := Scope (Inst);
595 end loop;
597 Scop := Scope (E);
598 while Present (Scop) and then Scop /= Standard_Standard loop
599 if Scop = Inst then
600 return True;
601 end if;
603 Scop := Scope (Scop);
604 end loop;
606 return False;
607 end Within_Instance;
609 -- Start of processing for Collect_Interps
611 begin
612 New_Interps (N);
614 -- Unconditionally add the entity that was initially matched
616 First_Interp := All_Interp.Last;
617 Add_One_Interp (N, Ent, Etype (N));
619 -- For expanded name, pick up all additional entities from the
620 -- same scope, since these are obviously also visible. Note that
621 -- these are not necessarily contiguous on the homonym chain.
623 if Nkind (N) = N_Expanded_Name then
624 H := Homonym (Ent);
625 while Present (H) loop
626 if Scope (H) = Scope (Entity (N)) then
627 Add_One_Interp (N, H, Etype (H));
628 end if;
630 H := Homonym (H);
631 end loop;
633 -- Case of direct name
635 else
636 -- First, search the homonym chain for directly visible entities
638 H := Current_Entity (Ent);
639 while Present (H) loop
640 exit when
641 not Is_Overloadable (H)
642 and then Is_Immediately_Visible (H);
644 if Is_Immediately_Visible (H) and then H /= Ent then
646 -- Only add interpretation if not hidden by an inner
647 -- immediately visible one.
649 for J in First_Interp .. All_Interp.Last - 1 loop
651 -- Current homograph is not hidden. Add to overloads
653 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
654 exit;
656 -- Homograph is hidden, unless it is a predefined operator
658 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
660 -- A homograph in the same scope can occur within an
661 -- instantiation, the resulting ambiguity has to be
662 -- resolved later. The homographs may both be local
663 -- functions or actuals, or may be declared at different
664 -- levels within the instance. The renaming of an actual
665 -- within the instance must not be included.
667 if Within_Instance (H)
668 and then H /= Renamed_Entity (Ent)
669 and then not Is_Inherited_Operation (H)
670 then
671 All_Interp.Table (All_Interp.Last) :=
672 (H, Etype (H), Empty);
673 All_Interp.Append (No_Interp);
674 goto Next_Homograph;
676 elsif Scope (H) /= Standard_Standard then
677 goto Next_Homograph;
678 end if;
679 end if;
680 end loop;
682 -- On exit, we know that current homograph is not hidden
684 Add_One_Interp (N, H, Etype (H));
686 if Debug_Flag_E then
687 Write_Str ("Add overloaded interpretation ");
688 Write_Int (Int (H));
689 Write_Eol;
690 end if;
691 end if;
693 <<Next_Homograph>>
694 H := Homonym (H);
695 end loop;
697 -- Scan list of homographs for use-visible entities only
699 H := Current_Entity (Ent);
701 while Present (H) loop
702 if Is_Potentially_Use_Visible (H)
703 and then H /= Ent
704 and then Is_Overloadable (H)
705 then
706 for J in First_Interp .. All_Interp.Last - 1 loop
708 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
709 exit;
711 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
712 goto Next_Use_Homograph;
713 end if;
714 end loop;
716 Add_One_Interp (N, H, Etype (H));
717 end if;
719 <<Next_Use_Homograph>>
720 H := Homonym (H);
721 end loop;
722 end if;
724 if All_Interp.Last = First_Interp + 1 then
726 -- The final interpretation is in fact not overloaded. Note that the
727 -- unique legal interpretation may or may not be the original one,
728 -- so we need to update N's entity and etype now, because once N
729 -- is marked as not overloaded it is also expected to carry the
730 -- proper interpretation.
732 Set_Is_Overloaded (N, False);
733 Set_Entity (N, All_Interp.Table (First_Interp).Nam);
734 Set_Etype (N, All_Interp.Table (First_Interp).Typ);
735 end if;
736 end Collect_Interps;
738 ------------
739 -- Covers --
740 ------------
742 function Covers (T1, T2 : Entity_Id) return Boolean is
743 BT1 : Entity_Id;
744 BT2 : Entity_Id;
746 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
747 -- In an instance the proper view may not always be correct for
748 -- private types, but private and full view are compatible. This
749 -- removes spurious errors from nested instantiations that involve,
750 -- among other things, types derived from private types.
752 function Real_Actual (T : Entity_Id) return Entity_Id;
753 -- If an actual in an inner instance is the formal of an enclosing
754 -- generic, the actual in the enclosing instance is the one that can
755 -- create an accidental ambiguity, and the check on compatibily of
756 -- generic actual types must use this enclosing actual.
758 ----------------------
759 -- Full_View_Covers --
760 ----------------------
762 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
763 begin
764 if Present (Full_View (Typ1))
765 and then Covers (Full_View (Typ1), Typ2)
766 then
767 return True;
769 elsif Present (Underlying_Full_View (Typ1))
770 and then Covers (Underlying_Full_View (Typ1), Typ2)
771 then
772 return True;
774 else
775 return False;
776 end if;
777 end Full_View_Covers;
779 -----------------
780 -- Real_Actual --
781 -----------------
783 function Real_Actual (T : Entity_Id) return Entity_Id is
784 Par : constant Node_Id := Parent (T);
785 RA : Entity_Id;
787 begin
788 -- Retrieve parent subtype from subtype declaration for actual
790 if Nkind (Par) = N_Subtype_Declaration
791 and then not Comes_From_Source (Par)
792 and then Is_Entity_Name (Subtype_Indication (Par))
793 then
794 RA := Entity (Subtype_Indication (Par));
796 if Is_Generic_Actual_Type (RA) then
797 return RA;
798 end if;
799 end if;
801 -- Otherwise actual is not the actual of an enclosing instance
803 return T;
804 end Real_Actual;
806 -- Start of processing for Covers
808 begin
809 -- If either operand is missing, then this is an error, but ignore it
810 -- and pretend we have a cover if errors already detected since this may
811 -- simply mean we have malformed trees or a semantic error upstream.
813 if No (T1) or else No (T2) then
814 if Total_Errors_Detected /= 0 then
815 return True;
816 else
817 raise Program_Error;
818 end if;
819 end if;
821 -- Trivial case: same types are always compatible
823 if T1 = T2 then
824 return True;
825 end if;
827 -- First check for Standard_Void_Type, which is special. Subsequent
828 -- processing in this routine assumes T1 and T2 are bona fide types;
829 -- Standard_Void_Type is a special entity that has some, but not all,
830 -- properties of types.
832 if T1 = Standard_Void_Type or else T2 = Standard_Void_Type then
833 return False;
834 end if;
836 BT1 := Base_Type (T1);
837 BT2 := Base_Type (T2);
839 -- Handle underlying view of records with unknown discriminants
840 -- using the original entity that motivated the construction of
841 -- this underlying record view (see Build_Derived_Private_Type).
843 if Is_Underlying_Record_View (BT1) then
844 BT1 := Underlying_Record_View (BT1);
845 end if;
847 if Is_Underlying_Record_View (BT2) then
848 BT2 := Underlying_Record_View (BT2);
849 end if;
851 -- Simplest case: types that have the same base type and are not generic
852 -- actuals are compatible. Generic actuals belong to their class but are
853 -- not compatible with other types of their class, and in particular
854 -- with other generic actuals. They are however compatible with their
855 -- own subtypes, and itypes with the same base are compatible as well.
856 -- Similarly, constrained subtypes obtained from expressions of an
857 -- unconstrained nominal type are compatible with the base type (may
858 -- lead to spurious ambiguities in obscure cases ???)
860 -- Generic actuals require special treatment to avoid spurious ambi-
861 -- guities in an instance, when two formal types are instantiated with
862 -- the same actual, so that different subprograms end up with the same
863 -- signature in the instance. If a generic actual is the actual of an
864 -- enclosing instance, it is that actual that we must compare: generic
865 -- actuals are only incompatible if they appear in the same instance.
867 if BT1 = BT2
868 or else BT1 = T2
869 or else BT2 = T1
870 then
871 if not Is_Generic_Actual_Type (T1)
872 or else
873 not Is_Generic_Actual_Type (T2)
874 then
875 return True;
877 -- Both T1 and T2 are generic actual types
879 else
880 declare
881 RT1 : constant Entity_Id := Real_Actual (T1);
882 RT2 : constant Entity_Id := Real_Actual (T2);
883 begin
884 return RT1 = RT2
885 or else Is_Itype (T1)
886 or else Is_Itype (T2)
887 or else Is_Constr_Subt_For_U_Nominal (T1)
888 or else Is_Constr_Subt_For_U_Nominal (T2)
889 or else Scope (RT1) /= Scope (RT2);
890 end;
891 end if;
893 -- Literals are compatible with types in a given "class"
895 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
896 or else (T2 = Universal_Real and then Is_Real_Type (T1))
897 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
898 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
899 or else (T2 = Any_Character and then Is_Character_Type (T1))
900 or else (T2 = Any_String and then Is_String_Type (T1))
901 or else (T2 = Any_Access and then Is_Access_Type (T1))
902 then
903 return True;
905 -- The context may be class wide, and a class-wide type is compatible
906 -- with any member of the class.
908 elsif Is_Class_Wide_Type (T1)
909 and then Is_Ancestor (Root_Type (T1), T2)
910 then
911 return True;
913 elsif Is_Class_Wide_Type (T1)
914 and then Is_Class_Wide_Type (T2)
915 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
916 then
917 return True;
919 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
920 -- task_type or protected_type that implements the interface.
922 elsif Ada_Version >= Ada_2005
923 and then Is_Concurrent_Type (T2)
924 and then Is_Class_Wide_Type (T1)
925 and then Is_Interface (Etype (T1))
926 and then Interface_Present_In_Ancestor
927 (Typ => BT2, Iface => Etype (T1))
928 then
929 return True;
931 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
932 -- object T2 implementing T1.
934 elsif Ada_Version >= Ada_2005
935 and then Is_Tagged_Type (T2)
936 and then Is_Class_Wide_Type (T1)
937 and then Is_Interface (Etype (T1))
938 then
939 if Interface_Present_In_Ancestor (Typ => T2,
940 Iface => Etype (T1))
941 then
942 return True;
943 end if;
945 declare
946 E : Entity_Id;
947 Elmt : Elmt_Id;
949 begin
950 if Is_Concurrent_Type (BT2) then
951 E := Corresponding_Record_Type (BT2);
952 else
953 E := BT2;
954 end if;
956 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
957 -- covers an object T2 that implements a direct derivation of T1.
958 -- Note: test for presence of E is defense against previous error.
960 if No (E) then
962 -- If expansion is disabled the Corresponding_Record_Type may
963 -- not be available yet, so use the interface list in the
964 -- declaration directly.
966 if ASIS_Mode
967 and then Nkind (Parent (BT2)) = N_Protected_Type_Declaration
968 and then Present (Interface_List (Parent (BT2)))
969 then
970 declare
971 Intf : Node_Id := First (Interface_List (Parent (BT2)));
972 begin
973 while Present (Intf) loop
974 if Is_Ancestor (Etype (T1), Entity (Intf)) then
975 return True;
976 else
977 Next (Intf);
978 end if;
979 end loop;
980 end;
982 return False;
984 else
985 Check_Error_Detected;
986 end if;
988 -- Here we have a corresponding record type
990 elsif Present (Interfaces (E)) then
991 Elmt := First_Elmt (Interfaces (E));
992 while Present (Elmt) loop
993 if Is_Ancestor (Etype (T1), Node (Elmt)) then
994 return True;
995 else
996 Next_Elmt (Elmt);
997 end if;
998 end loop;
999 end if;
1001 -- We should also check the case in which T1 is an ancestor of
1002 -- some implemented interface???
1004 return False;
1005 end;
1007 -- In a dispatching call, the formal is of some specific type, and the
1008 -- actual is of the corresponding class-wide type, including a subtype
1009 -- of the class-wide type.
1011 elsif Is_Class_Wide_Type (T2)
1012 and then
1013 (Class_Wide_Type (T1) = Class_Wide_Type (T2)
1014 or else Base_Type (Root_Type (T2)) = BT1)
1015 then
1016 return True;
1018 -- Some contexts require a class of types rather than a specific type.
1019 -- For example, conditions require any boolean type, fixed point
1020 -- attributes require some real type, etc. The built-in types Any_XXX
1021 -- represent these classes.
1023 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
1024 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
1025 or else (T1 = Any_Real and then Is_Real_Type (T2))
1026 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
1027 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
1028 then
1029 return True;
1031 -- An aggregate is compatible with an array or record type
1033 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
1034 return True;
1036 -- If the expected type is an anonymous access, the designated type must
1037 -- cover that of the expression. Use the base type for this check: even
1038 -- though access subtypes are rare in sources, they are generated for
1039 -- actuals in instantiations.
1041 elsif Ekind (BT1) = E_Anonymous_Access_Type
1042 and then Is_Access_Type (T2)
1043 and then Covers (Designated_Type (T1), Designated_Type (T2))
1044 then
1045 return True;
1047 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1048 -- of a named general access type. An implicit conversion will be
1049 -- applied. For the resolution, one designated type must cover the
1050 -- other.
1052 elsif Ada_Version >= Ada_2012
1053 and then Ekind (BT1) = E_General_Access_Type
1054 and then Ekind (BT2) = E_Anonymous_Access_Type
1055 and then (Covers (Designated_Type (T1), Designated_Type (T2))
1056 or else
1057 Covers (Designated_Type (T2), Designated_Type (T1)))
1058 then
1059 return True;
1061 -- An Access_To_Subprogram is compatible with itself, or with an
1062 -- anonymous type created for an attribute reference Access.
1064 elsif Ekind_In (BT1, E_Access_Subprogram_Type,
1065 E_Access_Protected_Subprogram_Type)
1066 and then Is_Access_Type (T2)
1067 and then (not Comes_From_Source (T1)
1068 or else not Comes_From_Source (T2))
1069 and then (Is_Overloadable (Designated_Type (T2))
1070 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1071 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1072 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1073 then
1074 return True;
1076 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1077 -- with itself, or with an anonymous type created for an attribute
1078 -- reference Access.
1080 elsif Ekind_In (BT1, E_Anonymous_Access_Subprogram_Type,
1081 E_Anonymous_Access_Protected_Subprogram_Type)
1082 and then Is_Access_Type (T2)
1083 and then (not Comes_From_Source (T1)
1084 or else not Comes_From_Source (T2))
1085 and then (Is_Overloadable (Designated_Type (T2))
1086 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1087 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1088 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1089 then
1090 return True;
1092 -- The context can be a remote access type, and the expression the
1093 -- corresponding source type declared in a categorized package, or
1094 -- vice versa.
1096 elsif Is_Record_Type (T1)
1097 and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1))
1098 and then Present (Corresponding_Remote_Type (T1))
1099 then
1100 return Covers (Corresponding_Remote_Type (T1), T2);
1102 -- and conversely.
1104 elsif Is_Record_Type (T2)
1105 and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2))
1106 and then Present (Corresponding_Remote_Type (T2))
1107 then
1108 return Covers (Corresponding_Remote_Type (T2), T1);
1110 -- Synchronized types are represented at run time by their corresponding
1111 -- record type. During expansion one is replaced with the other, but
1112 -- they are compatible views of the same type.
1114 elsif Is_Record_Type (T1)
1115 and then Is_Concurrent_Type (T2)
1116 and then Present (Corresponding_Record_Type (T2))
1117 then
1118 return Covers (T1, Corresponding_Record_Type (T2));
1120 elsif Is_Concurrent_Type (T1)
1121 and then Present (Corresponding_Record_Type (T1))
1122 and then Is_Record_Type (T2)
1123 then
1124 return Covers (Corresponding_Record_Type (T1), T2);
1126 -- During analysis, an attribute reference 'Access has a special type
1127 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1128 -- imposed by context.
1130 elsif Ekind (T2) = E_Access_Attribute_Type
1131 and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
1132 and then Covers (Designated_Type (T1), Designated_Type (T2))
1133 then
1134 -- If the target type is a RACW type while the source is an access
1135 -- attribute type, we are building a RACW that may be exported.
1137 if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1138 Set_Has_RACW (Current_Sem_Unit);
1139 end if;
1141 return True;
1143 -- Ditto for allocators, which eventually resolve to the context type
1145 elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then
1146 return Covers (Designated_Type (T1), Designated_Type (T2))
1147 or else
1148 (From_Limited_With (Designated_Type (T1))
1149 and then Covers (Designated_Type (T2), Designated_Type (T1)));
1151 -- A boolean operation on integer literals is compatible with modular
1152 -- context.
1154 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
1155 return True;
1157 -- The actual type may be the result of a previous error
1159 elsif BT2 = Any_Type then
1160 return True;
1162 -- A Raise_Expressions is legal in any expression context
1164 elsif BT2 = Raise_Type then
1165 return True;
1167 -- A packed array type covers its corresponding non-packed type. This is
1168 -- not legitimate Ada, but allows the omission of a number of otherwise
1169 -- useless unchecked conversions, and since this can only arise in
1170 -- (known correct) expanded code, no harm is done.
1172 elsif Is_Array_Type (T2)
1173 and then Is_Packed (T2)
1174 and then T1 = Packed_Array_Impl_Type (T2)
1175 then
1176 return True;
1178 -- Similarly an array type covers its corresponding packed array type
1180 elsif Is_Array_Type (T1)
1181 and then Is_Packed (T1)
1182 and then T2 = Packed_Array_Impl_Type (T1)
1183 then
1184 return True;
1186 -- In instances, or with types exported from instantiations, check
1187 -- whether a partial and a full view match. Verify that types are
1188 -- legal, to prevent cascaded errors.
1190 elsif Is_Private_Type (T1)
1191 and then (In_Instance
1192 or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2)))
1193 and then Full_View_Covers (T1, T2)
1194 then
1195 return True;
1197 elsif Is_Private_Type (T2)
1198 and then (In_Instance
1199 or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1)))
1200 and then Full_View_Covers (T2, T1)
1201 then
1202 return True;
1204 -- In the expansion of inlined bodies, types are compatible if they
1205 -- are structurally equivalent.
1207 elsif In_Inlined_Body
1208 and then (Underlying_Type (T1) = Underlying_Type (T2)
1209 or else
1210 (Is_Access_Type (T1)
1211 and then Is_Access_Type (T2)
1212 and then Designated_Type (T1) = Designated_Type (T2))
1213 or else
1214 (T1 = Any_Access
1215 and then Is_Access_Type (Underlying_Type (T2)))
1216 or else
1217 (T2 = Any_Composite
1218 and then Is_Composite_Type (Underlying_Type (T1))))
1219 then
1220 return True;
1222 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1223 -- obtained through a limited_with compatible with its real entity.
1225 elsif From_Limited_With (T1) then
1227 -- If the expected type is the nonlimited view of a type, the
1228 -- expression may have the limited view. If that one in turn is
1229 -- incomplete, get full view if available.
1231 return Has_Non_Limited_View (T1)
1232 and then Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1234 elsif From_Limited_With (T2) then
1236 -- If units in the context have Limited_With clauses on each other,
1237 -- either type might have a limited view. Checks performed elsewhere
1238 -- verify that the context type is the nonlimited view.
1240 return Has_Non_Limited_View (T2)
1241 and then Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1243 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1245 elsif Ekind (T1) = E_Incomplete_Subtype then
1246 return Covers (Full_View (Etype (T1)), T2);
1248 elsif Ekind (T2) = E_Incomplete_Subtype then
1249 return Covers (T1, Full_View (Etype (T2)));
1251 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1252 -- and actual anonymous access types in the context of generic
1253 -- instantiations. We have the following situation:
1255 -- generic
1256 -- type Formal is private;
1257 -- Formal_Obj : access Formal; -- T1
1258 -- package G is ...
1260 -- package P is
1261 -- type Actual is ...
1262 -- Actual_Obj : access Actual; -- T2
1263 -- package Instance is new G (Formal => Actual,
1264 -- Formal_Obj => Actual_Obj);
1266 elsif Ada_Version >= Ada_2005
1267 and then Ekind (T1) = E_Anonymous_Access_Type
1268 and then Ekind (T2) = E_Anonymous_Access_Type
1269 and then Is_Generic_Type (Directly_Designated_Type (T1))
1270 and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1271 Directly_Designated_Type (T2)
1272 then
1273 return True;
1275 -- Otherwise, types are not compatible
1277 else
1278 return False;
1279 end if;
1280 end Covers;
1282 ------------------
1283 -- Disambiguate --
1284 ------------------
1286 function Disambiguate
1287 (N : Node_Id;
1288 I1, I2 : Interp_Index;
1289 Typ : Entity_Id) return Interp
1291 I : Interp_Index;
1292 It : Interp;
1293 It1, It2 : Interp;
1294 Nam1, Nam2 : Entity_Id;
1295 Predef_Subp : Entity_Id;
1296 User_Subp : Entity_Id;
1298 function Inherited_From_Actual (S : Entity_Id) return Boolean;
1299 -- Determine whether one of the candidates is an operation inherited by
1300 -- a type that is derived from an actual in an instantiation.
1302 function In_Same_Declaration_List
1303 (Typ : Entity_Id;
1304 Op_Decl : Entity_Id) return Boolean;
1305 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1306 -- access types is declared on the partial view of a designated type, so
1307 -- that the type declaration and equality are not in the same list of
1308 -- declarations. This AI gives a preference rule for the user-defined
1309 -- operation. Same rule applies for arithmetic operations on private
1310 -- types completed with fixed-point types: the predefined operation is
1311 -- hidden; this is already handled properly in GNAT.
1313 function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1314 -- Determine whether a subprogram is an actual in an enclosing instance.
1315 -- An overloading between such a subprogram and one declared outside the
1316 -- instance is resolved in favor of the first, because it resolved in
1317 -- the generic. Within the instance the actual is represented by a
1318 -- constructed subprogram renaming.
1320 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
1321 -- Determine whether function Func_Id is an exact match for binary or
1322 -- unary operator Op.
1324 function Operand_Type return Entity_Id;
1325 -- Determine type of operand for an equality operation, to apply Ada
1326 -- 2005 rules to equality on anonymous access types.
1328 function Standard_Operator return Boolean;
1329 -- Check whether subprogram is predefined operator declared in Standard.
1330 -- It may given by an operator name, or by an expanded name whose prefix
1331 -- is Standard.
1333 function Remove_Conversions return Interp;
1334 -- Last chance for pathological cases involving comparisons on literals,
1335 -- and user overloadings of the same operator. Such pathologies have
1336 -- been removed from the ACVC, but still appear in two DEC tests, with
1337 -- the following notable quote from Ben Brosgol:
1339 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1340 -- this example; Robert Dewar brought it to our attention, since it is
1341 -- apparently found in the ACVC 1.5. I did not attempt to find the
1342 -- reason in the Reference Manual that makes the example legal, since I
1343 -- was too nauseated by it to want to pursue it further.]
1345 -- Accordingly, this is not a fully recursive solution, but it handles
1346 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1347 -- pathology in the other direction with calls whose multiple overloaded
1348 -- actuals make them truly unresolvable.
1350 -- The new rules concerning abstract operations create additional need
1351 -- for special handling of expressions with universal operands, see
1352 -- comments to Has_Abstract_Interpretation below.
1354 ---------------------------
1355 -- Inherited_From_Actual --
1356 ---------------------------
1358 function Inherited_From_Actual (S : Entity_Id) return Boolean is
1359 Par : constant Node_Id := Parent (S);
1360 begin
1361 if Nkind (Par) /= N_Full_Type_Declaration
1362 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1363 then
1364 return False;
1365 else
1366 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1367 and then
1368 Is_Generic_Actual_Type (
1369 Entity (Subtype_Indication (Type_Definition (Par))));
1370 end if;
1371 end Inherited_From_Actual;
1373 ------------------------------
1374 -- In_Same_Declaration_List --
1375 ------------------------------
1377 function In_Same_Declaration_List
1378 (Typ : Entity_Id;
1379 Op_Decl : Entity_Id) return Boolean
1381 Scop : constant Entity_Id := Scope (Typ);
1383 begin
1384 return In_Same_List (Parent (Typ), Op_Decl)
1385 or else
1386 (Ekind_In (Scop, E_Package, E_Generic_Package)
1387 and then List_Containing (Op_Decl) =
1388 Visible_Declarations (Parent (Scop))
1389 and then List_Containing (Parent (Typ)) =
1390 Private_Declarations (Parent (Scop)));
1391 end In_Same_Declaration_List;
1393 --------------------------
1394 -- Is_Actual_Subprogram --
1395 --------------------------
1397 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1398 begin
1399 return In_Open_Scopes (Scope (S))
1400 and then Nkind (Unit_Declaration_Node (S)) =
1401 N_Subprogram_Renaming_Declaration
1403 -- Why the Comes_From_Source test here???
1405 and then not Comes_From_Source (Unit_Declaration_Node (S))
1407 and then
1408 (Is_Generic_Instance (Scope (S))
1409 or else Is_Wrapper_Package (Scope (S)));
1410 end Is_Actual_Subprogram;
1412 -------------
1413 -- Matches --
1414 -------------
1416 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
1417 function Matching_Types
1418 (Opnd_Typ : Entity_Id;
1419 Formal_Typ : Entity_Id) return Boolean;
1420 -- Determine whether operand type Opnd_Typ and formal parameter type
1421 -- Formal_Typ are either the same or compatible.
1423 --------------------
1424 -- Matching_Types --
1425 --------------------
1427 function Matching_Types
1428 (Opnd_Typ : Entity_Id;
1429 Formal_Typ : Entity_Id) return Boolean
1431 begin
1432 -- A direct match
1434 if Opnd_Typ = Formal_Typ then
1435 return True;
1437 -- Any integer type matches universal integer
1439 elsif Opnd_Typ = Universal_Integer
1440 and then Is_Integer_Type (Formal_Typ)
1441 then
1442 return True;
1444 -- Any floating point type matches universal real
1446 elsif Opnd_Typ = Universal_Real
1447 and then Is_Floating_Point_Type (Formal_Typ)
1448 then
1449 return True;
1451 -- The type of the formal parameter maps a generic actual type to
1452 -- a generic formal type. If the operand type is the type being
1453 -- mapped in an instance, then this is a match.
1455 elsif Is_Generic_Actual_Type (Formal_Typ)
1456 and then Etype (Formal_Typ) = Opnd_Typ
1457 then
1458 return True;
1460 -- ??? There are possibly other cases to consider
1462 else
1463 return False;
1464 end if;
1465 end Matching_Types;
1467 -- Local variables
1469 F1 : constant Entity_Id := First_Formal (Func_Id);
1470 F1_Typ : constant Entity_Id := Etype (F1);
1471 F2 : constant Entity_Id := Next_Formal (F1);
1472 F2_Typ : constant Entity_Id := Etype (F2);
1473 Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op));
1474 Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
1476 -- Start of processing for Matches
1478 begin
1479 if Lop_Typ = F1_Typ then
1480 return Matching_Types (Rop_Typ, F2_Typ);
1482 elsif Rop_Typ = F2_Typ then
1483 return Matching_Types (Lop_Typ, F1_Typ);
1485 -- Otherwise this is not a good match because each operand-formal
1486 -- pair is compatible only on base-type basis, which is not specific
1487 -- enough.
1489 else
1490 return False;
1491 end if;
1492 end Matches;
1494 ------------------
1495 -- Operand_Type --
1496 ------------------
1498 function Operand_Type return Entity_Id is
1499 Opnd : Node_Id;
1501 begin
1502 if Nkind (N) = N_Function_Call then
1503 Opnd := First_Actual (N);
1504 else
1505 Opnd := Left_Opnd (N);
1506 end if;
1508 return Etype (Opnd);
1509 end Operand_Type;
1511 ------------------------
1512 -- Remove_Conversions --
1513 ------------------------
1515 function Remove_Conversions return Interp is
1516 I : Interp_Index;
1517 It : Interp;
1518 It1 : Interp;
1519 F1 : Entity_Id;
1520 Act1 : Node_Id;
1521 Act2 : Node_Id;
1523 function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1524 -- If an operation has universal operands the universal operation
1525 -- is present among its interpretations. If there is an abstract
1526 -- interpretation for the operator, with a numeric result, this
1527 -- interpretation was already removed in sem_ch4, but the universal
1528 -- one is still visible. We must rescan the list of operators and
1529 -- remove the universal interpretation to resolve the ambiguity.
1531 ---------------------------------
1532 -- Has_Abstract_Interpretation --
1533 ---------------------------------
1535 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1536 E : Entity_Id;
1538 begin
1539 if Nkind (N) not in N_Op
1540 or else Ada_Version < Ada_2005
1541 or else not Is_Overloaded (N)
1542 or else No (Universal_Interpretation (N))
1543 then
1544 return False;
1546 else
1547 E := Get_Name_Entity_Id (Chars (N));
1548 while Present (E) loop
1549 if Is_Overloadable (E)
1550 and then Is_Abstract_Subprogram (E)
1551 and then Is_Numeric_Type (Etype (E))
1552 then
1553 return True;
1554 else
1555 E := Homonym (E);
1556 end if;
1557 end loop;
1559 -- Finally, if an operand of the binary operator is itself
1560 -- an operator, recurse to see whether its own abstract
1561 -- interpretation is responsible for the spurious ambiguity.
1563 if Nkind (N) in N_Binary_Op then
1564 return Has_Abstract_Interpretation (Left_Opnd (N))
1565 or else Has_Abstract_Interpretation (Right_Opnd (N));
1567 elsif Nkind (N) in N_Unary_Op then
1568 return Has_Abstract_Interpretation (Right_Opnd (N));
1570 else
1571 return False;
1572 end if;
1573 end if;
1574 end Has_Abstract_Interpretation;
1576 -- Start of processing for Remove_Conversions
1578 begin
1579 It1 := No_Interp;
1581 Get_First_Interp (N, I, It);
1582 while Present (It.Typ) loop
1583 if not Is_Overloadable (It.Nam) then
1584 return No_Interp;
1585 end if;
1587 F1 := First_Formal (It.Nam);
1589 if No (F1) then
1590 return It1;
1592 else
1593 if Nkind (N) in N_Subprogram_Call then
1594 Act1 := First_Actual (N);
1596 if Present (Act1) then
1597 Act2 := Next_Actual (Act1);
1598 else
1599 Act2 := Empty;
1600 end if;
1602 elsif Nkind (N) in N_Unary_Op then
1603 Act1 := Right_Opnd (N);
1604 Act2 := Empty;
1606 elsif Nkind (N) in N_Binary_Op then
1607 Act1 := Left_Opnd (N);
1608 Act2 := Right_Opnd (N);
1610 -- Use the type of the second formal, so as to include
1611 -- exponentiation, where the exponent may be ambiguous and
1612 -- the result non-universal.
1614 Next_Formal (F1);
1616 else
1617 return It1;
1618 end if;
1620 if Nkind (Act1) in N_Op
1621 and then Is_Overloaded (Act1)
1622 and then
1623 (Nkind (Act1) in N_Unary_Op
1624 or else Nkind_In (Left_Opnd (Act1), N_Integer_Literal,
1625 N_Real_Literal))
1626 and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal,
1627 N_Real_Literal)
1628 and then Has_Compatible_Type (Act1, Standard_Boolean)
1629 and then Etype (F1) = Standard_Boolean
1630 then
1631 -- If the two candidates are the original ones, the
1632 -- ambiguity is real. Otherwise keep the original, further
1633 -- calls to Disambiguate will take care of others in the
1634 -- list of candidates.
1636 if It1 /= No_Interp then
1637 if It = Disambiguate.It1
1638 or else It = Disambiguate.It2
1639 then
1640 if It1 = Disambiguate.It1
1641 or else It1 = Disambiguate.It2
1642 then
1643 return No_Interp;
1644 else
1645 It1 := It;
1646 end if;
1647 end if;
1649 elsif Present (Act2)
1650 and then Nkind (Act2) in N_Op
1651 and then Is_Overloaded (Act2)
1652 and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1653 N_Real_Literal)
1654 and then Has_Compatible_Type (Act2, Standard_Boolean)
1655 then
1656 -- The preference rule on the first actual is not
1657 -- sufficient to disambiguate.
1659 goto Next_Interp;
1661 else
1662 It1 := It;
1663 end if;
1665 elsif Is_Numeric_Type (Etype (F1))
1666 and then Has_Abstract_Interpretation (Act1)
1667 then
1668 -- Current interpretation is not the right one because it
1669 -- expects a numeric operand. Examine all the other ones.
1671 declare
1672 I : Interp_Index;
1673 It : Interp;
1675 begin
1676 Get_First_Interp (N, I, It);
1677 while Present (It.Typ) loop
1679 not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1680 then
1681 if No (Act2)
1682 or else not Has_Abstract_Interpretation (Act2)
1683 or else not
1684 Is_Numeric_Type
1685 (Etype (Next_Formal (First_Formal (It.Nam))))
1686 then
1687 return It;
1688 end if;
1689 end if;
1691 Get_Next_Interp (I, It);
1692 end loop;
1694 return No_Interp;
1695 end;
1696 end if;
1697 end if;
1699 <<Next_Interp>>
1700 Get_Next_Interp (I, It);
1701 end loop;
1703 -- After some error, a formal may have Any_Type and yield a spurious
1704 -- match. To avoid cascaded errors if possible, check for such a
1705 -- formal in either candidate.
1707 if Serious_Errors_Detected > 0 then
1708 declare
1709 Formal : Entity_Id;
1711 begin
1712 Formal := First_Formal (Nam1);
1713 while Present (Formal) loop
1714 if Etype (Formal) = Any_Type then
1715 return Disambiguate.It2;
1716 end if;
1718 Next_Formal (Formal);
1719 end loop;
1721 Formal := First_Formal (Nam2);
1722 while Present (Formal) loop
1723 if Etype (Formal) = Any_Type then
1724 return Disambiguate.It1;
1725 end if;
1727 Next_Formal (Formal);
1728 end loop;
1729 end;
1730 end if;
1732 return It1;
1733 end Remove_Conversions;
1735 -----------------------
1736 -- Standard_Operator --
1737 -----------------------
1739 function Standard_Operator return Boolean is
1740 Nam : Node_Id;
1742 begin
1743 if Nkind (N) in N_Op then
1744 return True;
1746 elsif Nkind (N) = N_Function_Call then
1747 Nam := Name (N);
1749 if Nkind (Nam) /= N_Expanded_Name then
1750 return True;
1751 else
1752 return Entity (Prefix (Nam)) = Standard_Standard;
1753 end if;
1754 else
1755 return False;
1756 end if;
1757 end Standard_Operator;
1759 -- Start of processing for Disambiguate
1761 begin
1762 -- Recover the two legal interpretations
1764 Get_First_Interp (N, I, It);
1765 while I /= I1 loop
1766 Get_Next_Interp (I, It);
1767 end loop;
1769 It1 := It;
1770 Nam1 := It.Nam;
1772 while I /= I2 loop
1773 Get_Next_Interp (I, It);
1774 end loop;
1776 It2 := It;
1777 Nam2 := It.Nam;
1779 -- Check whether one of the entities is an Ada 2005/2012 and we are
1780 -- operating in an earlier mode, in which case we discard the Ada
1781 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
1783 if Ada_Version < Ada_2005 then
1784 if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
1785 return It2;
1786 elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
1787 return It1;
1788 end if;
1789 end if;
1791 -- Check whether one of the entities is an Ada 2012 entity and we are
1792 -- operating in Ada 2005 mode, in which case we discard the Ada 2012
1793 -- entity, so that we get proper Ada 2005 overload resolution.
1795 if Ada_Version = Ada_2005 then
1796 if Is_Ada_2012_Only (Nam1) then
1797 return It2;
1798 elsif Is_Ada_2012_Only (Nam2) then
1799 return It1;
1800 end if;
1801 end if;
1803 -- If the context is universal, the predefined operator is preferred.
1804 -- This includes bounds in numeric type declarations, and expressions
1805 -- in type conversions. If no interpretation yields a universal type,
1806 -- then we must check whether the user-defined entity hides the prede-
1807 -- fined one.
1809 if Chars (Nam1) in Any_Operator_Name and then Standard_Operator then
1810 if Typ = Universal_Integer
1811 or else Typ = Universal_Real
1812 or else Typ = Any_Integer
1813 or else Typ = Any_Discrete
1814 or else Typ = Any_Real
1815 or else Typ = Any_Type
1816 then
1817 -- Find an interpretation that yields the universal type, or else
1818 -- a predefined operator that yields a predefined numeric type.
1820 declare
1821 Candidate : Interp := No_Interp;
1823 begin
1824 Get_First_Interp (N, I, It);
1825 while Present (It.Typ) loop
1826 if (It.Typ = Universal_Integer
1827 or else It.Typ = Universal_Real)
1828 and then (Typ = Any_Type or else Covers (Typ, It.Typ))
1829 then
1830 return It;
1832 elsif Is_Numeric_Type (It.Typ)
1833 and then Scope (It.Typ) = Standard_Standard
1834 and then Scope (It.Nam) = Standard_Standard
1835 and then Covers (Typ, It.Typ)
1836 then
1837 Candidate := It;
1838 end if;
1840 Get_Next_Interp (I, It);
1841 end loop;
1843 if Candidate /= No_Interp then
1844 return Candidate;
1845 end if;
1846 end;
1848 elsif Chars (Nam1) /= Name_Op_Not
1849 and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1850 then
1851 -- Equality or comparison operation. Choose predefined operator if
1852 -- arguments are universal. The node may be an operator, name, or
1853 -- a function call, so unpack arguments accordingly.
1855 declare
1856 Arg1, Arg2 : Node_Id;
1858 begin
1859 if Nkind (N) in N_Op then
1860 Arg1 := Left_Opnd (N);
1861 Arg2 := Right_Opnd (N);
1863 elsif Is_Entity_Name (N) then
1864 Arg1 := First_Entity (Entity (N));
1865 Arg2 := Next_Entity (Arg1);
1867 else
1868 Arg1 := First_Actual (N);
1869 Arg2 := Next_Actual (Arg1);
1870 end if;
1872 if Present (Arg2)
1873 and then Present (Universal_Interpretation (Arg1))
1874 and then Universal_Interpretation (Arg2) =
1875 Universal_Interpretation (Arg1)
1876 then
1877 Get_First_Interp (N, I, It);
1878 while Scope (It.Nam) /= Standard_Standard loop
1879 Get_Next_Interp (I, It);
1880 end loop;
1882 return It;
1883 end if;
1884 end;
1885 end if;
1886 end if;
1888 -- If no universal interpretation, check whether user-defined operator
1889 -- hides predefined one, as well as other special cases. If the node
1890 -- is a range, then one or both bounds are ambiguous. Each will have
1891 -- to be disambiguated w.r.t. the context type. The type of the range
1892 -- itself is imposed by the context, so we can return either legal
1893 -- interpretation.
1895 if Ekind (Nam1) = E_Operator then
1896 Predef_Subp := Nam1;
1897 User_Subp := Nam2;
1899 elsif Ekind (Nam2) = E_Operator then
1900 Predef_Subp := Nam2;
1901 User_Subp := Nam1;
1903 elsif Nkind (N) = N_Range then
1904 return It1;
1906 -- Implement AI05-105: A renaming declaration with an access
1907 -- definition must resolve to an anonymous access type. This
1908 -- is a resolution rule and can be used to disambiguate.
1910 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1911 and then Present (Access_Definition (Parent (N)))
1912 then
1913 if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
1914 E_Anonymous_Access_Subprogram_Type)
1915 then
1916 if Ekind (It2.Typ) = Ekind (It1.Typ) then
1918 -- True ambiguity
1920 return No_Interp;
1922 else
1923 return It1;
1924 end if;
1926 elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
1927 E_Anonymous_Access_Subprogram_Type)
1928 then
1929 return It2;
1931 -- No legal interpretation
1933 else
1934 return No_Interp;
1935 end if;
1937 -- Two access attribute types may have been created for an expression
1938 -- with an implicit dereference, which is automatically overloaded.
1939 -- If both access attribute types designate the same object type,
1940 -- disambiguation if any will take place elsewhere, so keep any one of
1941 -- the interpretations.
1943 elsif Ekind (It1.Typ) = E_Access_Attribute_Type
1944 and then Ekind (It2.Typ) = E_Access_Attribute_Type
1945 and then Designated_Type (It1.Typ) = Designated_Type (It2.Typ)
1946 then
1947 return It1;
1949 -- If two user defined-subprograms are visible, it is a true ambiguity,
1950 -- unless one of them is an entry and the context is a conditional or
1951 -- timed entry call, or unless we are within an instance and this is
1952 -- results from two formals types with the same actual.
1954 else
1955 if Nkind (N) = N_Procedure_Call_Statement
1956 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1957 and then N = Entry_Call_Statement (Parent (N))
1958 then
1959 if Ekind (Nam2) = E_Entry then
1960 return It2;
1961 elsif Ekind (Nam1) = E_Entry then
1962 return It1;
1963 else
1964 return No_Interp;
1965 end if;
1967 -- If the ambiguity occurs within an instance, it is due to several
1968 -- formal types with the same actual. Look for an exact match between
1969 -- the types of the formals of the overloadable entities, and the
1970 -- actuals in the call, to recover the unambiguous match in the
1971 -- original generic.
1973 -- The ambiguity can also be due to an overloading between a formal
1974 -- subprogram and a subprogram declared outside the generic. If the
1975 -- node is overloaded, it did not resolve to the global entity in
1976 -- the generic, and we choose the formal subprogram.
1978 -- Finally, the ambiguity can be between an explicit subprogram and
1979 -- one inherited (with different defaults) from an actual. In this
1980 -- case the resolution was to the explicit declaration in the
1981 -- generic, and remains so in the instance.
1983 -- The same sort of disambiguation needed for calls is also required
1984 -- for the name given in a subprogram renaming, and that case is
1985 -- handled here as well. We test Comes_From_Source to exclude this
1986 -- treatment for implicit renamings created for formal subprograms.
1988 elsif In_Instance and then not In_Generic_Actual (N) then
1989 if Nkind (N) in N_Subprogram_Call
1990 or else
1991 (Nkind (N) in N_Has_Entity
1992 and then
1993 Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
1994 and then Comes_From_Source (Parent (N)))
1995 then
1996 declare
1997 Actual : Node_Id;
1998 Formal : Entity_Id;
1999 Renam : Entity_Id := Empty;
2000 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
2001 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
2003 begin
2004 if Is_Act1 and then not Is_Act2 then
2005 return It1;
2007 elsif Is_Act2 and then not Is_Act1 then
2008 return It2;
2010 elsif Inherited_From_Actual (Nam1)
2011 and then Comes_From_Source (Nam2)
2012 then
2013 return It2;
2015 elsif Inherited_From_Actual (Nam2)
2016 and then Comes_From_Source (Nam1)
2017 then
2018 return It1;
2019 end if;
2021 -- In the case of a renamed subprogram, pick up the entity
2022 -- of the renaming declaration so we can traverse its
2023 -- formal parameters.
2025 if Nkind (N) in N_Has_Entity then
2026 Renam := Defining_Unit_Name (Specification (Parent (N)));
2027 end if;
2029 if Present (Renam) then
2030 Actual := First_Formal (Renam);
2031 else
2032 Actual := First_Actual (N);
2033 end if;
2035 Formal := First_Formal (Nam1);
2036 while Present (Actual) loop
2037 if Etype (Actual) /= Etype (Formal) then
2038 return It2;
2039 end if;
2041 if Present (Renam) then
2042 Next_Formal (Actual);
2043 else
2044 Next_Actual (Actual);
2045 end if;
2047 Next_Formal (Formal);
2048 end loop;
2050 return It1;
2051 end;
2053 elsif Nkind (N) in N_Binary_Op then
2054 if Matches (N, Nam1) then
2055 return It1;
2056 else
2057 return It2;
2058 end if;
2060 elsif Nkind (N) in N_Unary_Op then
2061 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
2062 return It1;
2063 else
2064 return It2;
2065 end if;
2067 else
2068 return Remove_Conversions;
2069 end if;
2070 else
2071 return Remove_Conversions;
2072 end if;
2073 end if;
2075 -- An implicit concatenation operator on a string type cannot be
2076 -- disambiguated from the predefined concatenation. This can only
2077 -- happen with concatenation of string literals.
2079 if Chars (User_Subp) = Name_Op_Concat
2080 and then Ekind (User_Subp) = E_Operator
2081 and then Is_String_Type (Etype (First_Formal (User_Subp)))
2082 then
2083 return No_Interp;
2085 -- If the user-defined operator is in an open scope, or in the scope
2086 -- of the resulting type, or given by an expanded name that names its
2087 -- scope, it hides the predefined operator for the type. Exponentiation
2088 -- has to be special-cased because the implicit operator does not have
2089 -- a symmetric signature, and may not be hidden by the explicit one.
2091 elsif (Nkind (N) = N_Function_Call
2092 and then Nkind (Name (N)) = N_Expanded_Name
2093 and then (Chars (Predef_Subp) /= Name_Op_Expon
2094 or else Hides_Op (User_Subp, Predef_Subp))
2095 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
2096 or else Hides_Op (User_Subp, Predef_Subp)
2097 then
2098 if It1.Nam = User_Subp then
2099 return It1;
2100 else
2101 return It2;
2102 end if;
2104 -- Otherwise, the predefined operator has precedence, or if the user-
2105 -- defined operation is directly visible we have a true ambiguity.
2107 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2108 -- exclude the universal_fixed operator, which often causes ambiguities
2109 -- in legacy code.
2111 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2112 -- on a partial view that is completed with a fixed point type. See
2113 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2114 -- user-defined type and subprogram, so that a client of the package
2115 -- has the same resolution as the body of the package.
2117 else
2118 if (In_Open_Scopes (Scope (User_Subp))
2119 or else Is_Potentially_Use_Visible (User_Subp))
2120 and then not In_Instance
2121 then
2122 if Is_Fixed_Point_Type (Typ)
2123 and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide)
2124 and then
2125 (Ada_Version = Ada_83
2126 or else (Ada_Version >= Ada_2012
2127 and then In_Same_Declaration_List
2128 (First_Subtype (Typ),
2129 Unit_Declaration_Node (User_Subp))))
2130 then
2131 if It2.Nam = Predef_Subp then
2132 return It1;
2133 else
2134 return It2;
2135 end if;
2137 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
2138 -- states that the operator defined in Standard is not available
2139 -- if there is a user-defined equality with the proper signature,
2140 -- declared in the same declarative list as the type. The node
2141 -- may be an operator or a function call.
2143 elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne)
2144 and then Ada_Version >= Ada_2005
2145 and then Etype (User_Subp) = Standard_Boolean
2146 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
2147 and then
2148 In_Same_Declaration_List
2149 (Designated_Type (Operand_Type),
2150 Unit_Declaration_Node (User_Subp))
2151 then
2152 if It2.Nam = Predef_Subp then
2153 return It1;
2154 else
2155 return It2;
2156 end if;
2158 -- An immediately visible operator hides a use-visible user-
2159 -- defined operation. This disambiguation cannot take place
2160 -- earlier because the visibility of the predefined operator
2161 -- can only be established when operand types are known.
2163 elsif Ekind (User_Subp) = E_Function
2164 and then Ekind (Predef_Subp) = E_Operator
2165 and then Nkind (N) in N_Op
2166 and then not Is_Overloaded (Right_Opnd (N))
2167 and then
2168 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N))))
2169 and then Is_Potentially_Use_Visible (User_Subp)
2170 then
2171 if It2.Nam = Predef_Subp then
2172 return It1;
2173 else
2174 return It2;
2175 end if;
2177 else
2178 return No_Interp;
2179 end if;
2181 elsif It1.Nam = Predef_Subp then
2182 return It1;
2184 else
2185 return It2;
2186 end if;
2187 end if;
2188 end Disambiguate;
2190 ---------------------
2191 -- End_Interp_List --
2192 ---------------------
2194 procedure End_Interp_List is
2195 begin
2196 All_Interp.Table (All_Interp.Last) := No_Interp;
2197 All_Interp.Increment_Last;
2198 end End_Interp_List;
2200 -------------------------
2201 -- Entity_Matches_Spec --
2202 -------------------------
2204 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
2205 begin
2206 -- Simple case: same entity kinds, type conformance is required. A
2207 -- parameterless function can also rename a literal.
2209 if Ekind (Old_S) = Ekind (New_S)
2210 or else (Ekind (New_S) = E_Function
2211 and then Ekind (Old_S) = E_Enumeration_Literal)
2212 then
2213 return Type_Conformant (New_S, Old_S);
2215 elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
2216 return Operator_Matches_Spec (Old_S, New_S);
2218 elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then
2219 return Type_Conformant (New_S, Old_S);
2221 else
2222 return False;
2223 end if;
2224 end Entity_Matches_Spec;
2226 ----------------------
2227 -- Find_Unique_Type --
2228 ----------------------
2230 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
2231 T : constant Entity_Id := Etype (L);
2232 I : Interp_Index;
2233 It : Interp;
2234 TR : Entity_Id := Any_Type;
2236 begin
2237 if Is_Overloaded (R) then
2238 Get_First_Interp (R, I, It);
2239 while Present (It.Typ) loop
2240 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
2242 -- If several interpretations are possible and L is universal,
2243 -- apply preference rule.
2245 if TR /= Any_Type then
2246 if (T = Universal_Integer or else T = Universal_Real)
2247 and then It.Typ = T
2248 then
2249 TR := It.Typ;
2250 end if;
2252 else
2253 TR := It.Typ;
2254 end if;
2255 end if;
2257 Get_Next_Interp (I, It);
2258 end loop;
2260 Set_Etype (R, TR);
2262 -- In the non-overloaded case, the Etype of R is already set correctly
2264 else
2265 null;
2266 end if;
2268 -- If one of the operands is Universal_Fixed, the type of the other
2269 -- operand provides the context.
2271 if Etype (R) = Universal_Fixed then
2272 return T;
2274 elsif T = Universal_Fixed then
2275 return Etype (R);
2277 -- Ada 2005 (AI-230): Support the following operators:
2279 -- function "=" (L, R : universal_access) return Boolean;
2280 -- function "/=" (L, R : universal_access) return Boolean;
2282 -- Pool specific access types (E_Access_Type) are not covered by these
2283 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2284 -- of the equality operators for universal_access shall be convertible
2285 -- to one another (see 4.6)". For example, considering the type decla-
2286 -- ration "type P is access Integer" and an anonymous access to Integer,
2287 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2288 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2290 elsif Ada_Version >= Ada_2005
2291 and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
2292 E_Anonymous_Access_Subprogram_Type)
2293 and then Is_Access_Type (Etype (R))
2294 and then Ekind (Etype (R)) /= E_Access_Type
2295 then
2296 return Etype (L);
2298 elsif Ada_Version >= Ada_2005
2299 and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
2300 E_Anonymous_Access_Subprogram_Type)
2301 and then Is_Access_Type (Etype (L))
2302 and then Ekind (Etype (L)) /= E_Access_Type
2303 then
2304 return Etype (R);
2306 -- If one operand is a raise_expression, use type of other operand
2308 elsif Nkind (L) = N_Raise_Expression then
2309 return Etype (R);
2311 else
2312 return Specific_Type (T, Etype (R));
2313 end if;
2314 end Find_Unique_Type;
2316 -------------------------------------
2317 -- Function_Interp_Has_Abstract_Op --
2318 -------------------------------------
2320 function Function_Interp_Has_Abstract_Op
2321 (N : Node_Id;
2322 E : Entity_Id) return Entity_Id
2324 Abstr_Op : Entity_Id;
2325 Act : Node_Id;
2326 Act_Parm : Node_Id;
2327 Form_Parm : Node_Id;
2329 begin
2330 -- Why is check on E needed below ???
2331 -- In any case this para needs comments ???
2333 if Is_Overloaded (N) and then Is_Overloadable (E) then
2334 Act_Parm := First_Actual (N);
2335 Form_Parm := First_Formal (E);
2336 while Present (Act_Parm) and then Present (Form_Parm) loop
2337 Act := Act_Parm;
2339 if Nkind (Act) = N_Parameter_Association then
2340 Act := Explicit_Actual_Parameter (Act);
2341 end if;
2343 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2345 if Present (Abstr_Op) then
2346 return Abstr_Op;
2347 end if;
2349 Next_Actual (Act_Parm);
2350 Next_Formal (Form_Parm);
2351 end loop;
2352 end if;
2354 return Empty;
2355 end Function_Interp_Has_Abstract_Op;
2357 ----------------------
2358 -- Get_First_Interp --
2359 ----------------------
2361 procedure Get_First_Interp
2362 (N : Node_Id;
2363 I : out Interp_Index;
2364 It : out Interp)
2366 Int_Ind : Interp_Index;
2367 Map_Ptr : Int;
2368 O_N : Node_Id;
2370 begin
2371 -- If a selected component is overloaded because the selector has
2372 -- multiple interpretations, the node is a call to a protected
2373 -- operation or an indirect call. Retrieve the interpretation from
2374 -- the selector name. The selected component may be overloaded as well
2375 -- if the prefix is overloaded. That case is unchanged.
2377 if Nkind (N) = N_Selected_Component
2378 and then Is_Overloaded (Selector_Name (N))
2379 then
2380 O_N := Selector_Name (N);
2381 else
2382 O_N := N;
2383 end if;
2385 Map_Ptr := Headers (Hash (O_N));
2386 while Map_Ptr /= No_Entry loop
2387 if Interp_Map.Table (Map_Ptr).Node = O_N then
2388 Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2389 It := All_Interp.Table (Int_Ind);
2390 I := Int_Ind;
2391 return;
2392 else
2393 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2394 end if;
2395 end loop;
2397 -- Procedure should never be called if the node has no interpretations
2399 raise Program_Error;
2400 end Get_First_Interp;
2402 ---------------------
2403 -- Get_Next_Interp --
2404 ---------------------
2406 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2407 begin
2408 I := I + 1;
2409 It := All_Interp.Table (I);
2410 end Get_Next_Interp;
2412 -------------------------
2413 -- Has_Compatible_Type --
2414 -------------------------
2416 function Has_Compatible_Type
2417 (N : Node_Id;
2418 Typ : Entity_Id) return Boolean
2420 I : Interp_Index;
2421 It : Interp;
2423 begin
2424 if N = Error then
2425 return False;
2426 end if;
2428 if Nkind (N) = N_Subtype_Indication
2429 or else not Is_Overloaded (N)
2430 then
2431 return
2432 Covers (Typ, Etype (N))
2434 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2435 -- If the type is already frozen use the corresponding_record
2436 -- to check whether it is a proper descendant.
2438 or else
2439 (Is_Record_Type (Typ)
2440 and then Is_Concurrent_Type (Etype (N))
2441 and then Present (Corresponding_Record_Type (Etype (N)))
2442 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2444 or else
2445 (Is_Concurrent_Type (Typ)
2446 and then Is_Record_Type (Etype (N))
2447 and then Present (Corresponding_Record_Type (Typ))
2448 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2450 or else
2451 (not Is_Tagged_Type (Typ)
2452 and then Ekind (Typ) /= E_Anonymous_Access_Type
2453 and then Covers (Etype (N), Typ));
2455 -- Overloaded case
2457 else
2458 Get_First_Interp (N, I, It);
2459 while Present (It.Typ) loop
2460 if (Covers (Typ, It.Typ)
2461 and then
2462 (Scope (It.Nam) /= Standard_Standard
2463 or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2465 -- Ada 2005 (AI-345)
2467 or else
2468 (Is_Concurrent_Type (It.Typ)
2469 and then Present (Corresponding_Record_Type
2470 (Etype (It.Typ)))
2471 and then Covers (Typ, Corresponding_Record_Type
2472 (Etype (It.Typ))))
2474 or else (not Is_Tagged_Type (Typ)
2475 and then Ekind (Typ) /= E_Anonymous_Access_Type
2476 and then Covers (It.Typ, Typ))
2477 then
2478 return True;
2479 end if;
2481 Get_Next_Interp (I, It);
2482 end loop;
2484 return False;
2485 end if;
2486 end Has_Compatible_Type;
2488 ---------------------
2489 -- Has_Abstract_Op --
2490 ---------------------
2492 function Has_Abstract_Op
2493 (N : Node_Id;
2494 Typ : Entity_Id) return Entity_Id
2496 I : Interp_Index;
2497 It : Interp;
2499 begin
2500 if Is_Overloaded (N) then
2501 Get_First_Interp (N, I, It);
2502 while Present (It.Nam) loop
2503 if Present (It.Abstract_Op)
2504 and then Etype (It.Abstract_Op) = Typ
2505 then
2506 return It.Abstract_Op;
2507 end if;
2509 Get_Next_Interp (I, It);
2510 end loop;
2511 end if;
2513 return Empty;
2514 end Has_Abstract_Op;
2516 ----------
2517 -- Hash --
2518 ----------
2520 function Hash (N : Node_Id) return Int is
2521 begin
2522 -- Nodes have a size that is power of two, so to select significant
2523 -- bits only we remove the low-order bits.
2525 return ((Int (N) / 2 ** 5) mod Header_Size);
2526 end Hash;
2528 --------------
2529 -- Hides_Op --
2530 --------------
2532 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2533 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2534 begin
2535 return Operator_Matches_Spec (Op, F)
2536 and then (In_Open_Scopes (Scope (F))
2537 or else Scope (F) = Scope (Btyp)
2538 or else (not In_Open_Scopes (Scope (Btyp))
2539 and then not In_Use (Btyp)
2540 and then not In_Use (Scope (Btyp))));
2541 end Hides_Op;
2543 ------------------------
2544 -- Init_Interp_Tables --
2545 ------------------------
2547 procedure Init_Interp_Tables is
2548 begin
2549 All_Interp.Init;
2550 Interp_Map.Init;
2551 Headers := (others => No_Entry);
2552 end Init_Interp_Tables;
2554 -----------------------------------
2555 -- Interface_Present_In_Ancestor --
2556 -----------------------------------
2558 function Interface_Present_In_Ancestor
2559 (Typ : Entity_Id;
2560 Iface : Entity_Id) return Boolean
2562 Target_Typ : Entity_Id;
2563 Iface_Typ : Entity_Id;
2565 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2566 -- Returns True if Typ or some ancestor of Typ implements Iface
2568 -------------------------------
2569 -- Iface_Present_In_Ancestor --
2570 -------------------------------
2572 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2573 E : Entity_Id;
2574 AI : Entity_Id;
2575 Elmt : Elmt_Id;
2577 begin
2578 if Typ = Iface_Typ then
2579 return True;
2580 end if;
2582 -- Handle private types
2584 if Present (Full_View (Typ))
2585 and then not Is_Concurrent_Type (Full_View (Typ))
2586 then
2587 E := Full_View (Typ);
2588 else
2589 E := Typ;
2590 end if;
2592 loop
2593 if Present (Interfaces (E))
2594 and then not Is_Empty_Elmt_List (Interfaces (E))
2595 then
2596 Elmt := First_Elmt (Interfaces (E));
2597 while Present (Elmt) loop
2598 AI := Node (Elmt);
2600 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2601 return True;
2602 end if;
2604 Next_Elmt (Elmt);
2605 end loop;
2606 end if;
2608 exit when Etype (E) = E
2610 -- Handle private types
2612 or else (Present (Full_View (Etype (E)))
2613 and then Full_View (Etype (E)) = E);
2615 -- Check if the current type is a direct derivation of the
2616 -- interface
2618 if Etype (E) = Iface_Typ then
2619 return True;
2620 end if;
2622 -- Climb to the immediate ancestor handling private types
2624 if Present (Full_View (Etype (E))) then
2625 E := Full_View (Etype (E));
2626 else
2627 E := Etype (E);
2628 end if;
2629 end loop;
2631 return False;
2632 end Iface_Present_In_Ancestor;
2634 -- Start of processing for Interface_Present_In_Ancestor
2636 begin
2637 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2639 if Is_Class_Wide_Type (Iface) then
2640 Iface_Typ := Etype (Base_Type (Iface));
2641 else
2642 Iface_Typ := Iface;
2643 end if;
2645 -- Handle subtypes
2647 Iface_Typ := Base_Type (Iface_Typ);
2649 if Is_Access_Type (Typ) then
2650 Target_Typ := Etype (Directly_Designated_Type (Typ));
2651 else
2652 Target_Typ := Typ;
2653 end if;
2655 if Is_Concurrent_Record_Type (Target_Typ) then
2656 Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2657 end if;
2659 Target_Typ := Base_Type (Target_Typ);
2661 -- In case of concurrent types we can't use the Corresponding Record_Typ
2662 -- to look for the interface because it is built by the expander (and
2663 -- hence it is not always available). For this reason we traverse the
2664 -- list of interfaces (available in the parent of the concurrent type)
2666 if Is_Concurrent_Type (Target_Typ) then
2667 if Present (Interface_List (Parent (Target_Typ))) then
2668 declare
2669 AI : Node_Id;
2671 begin
2672 AI := First (Interface_List (Parent (Target_Typ)));
2674 -- The progenitor itself may be a subtype of an interface type.
2676 while Present (AI) loop
2677 if Etype (AI) = Iface_Typ
2678 or else Base_Type (Etype (AI)) = Iface_Typ
2679 then
2680 return True;
2682 elsif Present (Interfaces (Etype (AI)))
2683 and then Iface_Present_In_Ancestor (Etype (AI))
2684 then
2685 return True;
2686 end if;
2688 Next (AI);
2689 end loop;
2690 end;
2691 end if;
2693 return False;
2694 end if;
2696 if Is_Class_Wide_Type (Target_Typ) then
2697 Target_Typ := Etype (Target_Typ);
2698 end if;
2700 if Ekind (Target_Typ) = E_Incomplete_Type then
2702 -- We must have either a full view or a nonlimited view of the type
2703 -- to locate the list of ancestors.
2705 if Present (Full_View (Target_Typ)) then
2706 Target_Typ := Full_View (Target_Typ);
2707 else
2708 -- In a spec expression or in an expression function, the use of
2709 -- an incomplete type is legal; legality of the conversion will be
2710 -- checked at freeze point of related entity.
2712 if In_Spec_Expression then
2713 return True;
2715 else
2716 pragma Assert (Present (Non_Limited_View (Target_Typ)));
2717 Target_Typ := Non_Limited_View (Target_Typ);
2718 end if;
2719 end if;
2721 -- Protect the front end against previously detected errors
2723 if Ekind (Target_Typ) = E_Incomplete_Type then
2724 return False;
2725 end if;
2726 end if;
2728 return Iface_Present_In_Ancestor (Target_Typ);
2729 end Interface_Present_In_Ancestor;
2731 ---------------------
2732 -- Intersect_Types --
2733 ---------------------
2735 function Intersect_Types (L, R : Node_Id) return Entity_Id is
2736 Index : Interp_Index;
2737 It : Interp;
2738 Typ : Entity_Id;
2740 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2741 -- Find interpretation of right arg that has type compatible with T
2743 --------------------------
2744 -- Check_Right_Argument --
2745 --------------------------
2747 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2748 Index : Interp_Index;
2749 It : Interp;
2750 T2 : Entity_Id;
2752 begin
2753 if not Is_Overloaded (R) then
2754 return Specific_Type (T, Etype (R));
2756 else
2757 Get_First_Interp (R, Index, It);
2758 loop
2759 T2 := Specific_Type (T, It.Typ);
2761 if T2 /= Any_Type then
2762 return T2;
2763 end if;
2765 Get_Next_Interp (Index, It);
2766 exit when No (It.Typ);
2767 end loop;
2769 return Any_Type;
2770 end if;
2771 end Check_Right_Argument;
2773 -- Start of processing for Intersect_Types
2775 begin
2776 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2777 return Any_Type;
2778 end if;
2780 if not Is_Overloaded (L) then
2781 Typ := Check_Right_Argument (Etype (L));
2783 else
2784 Typ := Any_Type;
2785 Get_First_Interp (L, Index, It);
2786 while Present (It.Typ) loop
2787 Typ := Check_Right_Argument (It.Typ);
2788 exit when Typ /= Any_Type;
2789 Get_Next_Interp (Index, It);
2790 end loop;
2792 end if;
2794 -- If Typ is Any_Type, it means no compatible pair of types was found
2796 if Typ = Any_Type then
2797 if Nkind (Parent (L)) in N_Op then
2798 Error_Msg_N ("incompatible types for operator", Parent (L));
2800 elsif Nkind (Parent (L)) = N_Range then
2801 Error_Msg_N ("incompatible types given in constraint", Parent (L));
2803 -- Ada 2005 (AI-251): Complete the error notification
2805 elsif Is_Class_Wide_Type (Etype (R))
2806 and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2807 then
2808 Error_Msg_NE ("(Ada 2005) does not implement interface }",
2809 L, Etype (Class_Wide_Type (Etype (R))));
2811 -- Specialize message if one operand is a limited view, a priori
2812 -- unrelated to all other types.
2814 elsif From_Limited_With (Etype (R)) then
2815 Error_Msg_NE ("limited view of& not compatible with context",
2816 R, Etype (R));
2818 elsif From_Limited_With (Etype (L)) then
2819 Error_Msg_NE ("limited view of& not compatible with context",
2820 L, Etype (L));
2821 else
2822 Error_Msg_N ("incompatible types", Parent (L));
2823 end if;
2824 end if;
2826 return Typ;
2827 end Intersect_Types;
2829 -----------------------
2830 -- In_Generic_Actual --
2831 -----------------------
2833 function In_Generic_Actual (Exp : Node_Id) return Boolean is
2834 Par : constant Node_Id := Parent (Exp);
2836 begin
2837 if No (Par) then
2838 return False;
2840 elsif Nkind (Par) in N_Declaration then
2841 return
2842 Nkind (Par) = N_Object_Declaration
2843 and then Present (Corresponding_Generic_Association (Par));
2845 elsif Nkind (Par) = N_Object_Renaming_Declaration then
2846 return Present (Corresponding_Generic_Association (Par));
2848 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2849 return False;
2851 else
2852 return In_Generic_Actual (Parent (Par));
2853 end if;
2854 end In_Generic_Actual;
2856 -----------------
2857 -- Is_Ancestor --
2858 -----------------
2860 function Is_Ancestor
2861 (T1 : Entity_Id;
2862 T2 : Entity_Id;
2863 Use_Full_View : Boolean := False) return Boolean
2865 BT1 : Entity_Id;
2866 BT2 : Entity_Id;
2867 Par : Entity_Id;
2869 begin
2870 BT1 := Base_Type (T1);
2871 BT2 := Base_Type (T2);
2873 -- Handle underlying view of records with unknown discriminants using
2874 -- the original entity that motivated the construction of this
2875 -- underlying record view (see Build_Derived_Private_Type).
2877 if Is_Underlying_Record_View (BT1) then
2878 BT1 := Underlying_Record_View (BT1);
2879 end if;
2881 if Is_Underlying_Record_View (BT2) then
2882 BT2 := Underlying_Record_View (BT2);
2883 end if;
2885 if BT1 = BT2 then
2886 return True;
2888 -- The predicate must look past privacy
2890 elsif Is_Private_Type (T1)
2891 and then Present (Full_View (T1))
2892 and then BT2 = Base_Type (Full_View (T1))
2893 then
2894 return True;
2896 elsif Is_Private_Type (T2)
2897 and then Present (Full_View (T2))
2898 and then BT1 = Base_Type (Full_View (T2))
2899 then
2900 return True;
2902 else
2903 -- Obtain the parent of the base type of T2 (use the full view if
2904 -- allowed).
2906 if Use_Full_View
2907 and then Is_Private_Type (BT2)
2908 and then Present (Full_View (BT2))
2909 then
2910 -- No climbing needed if its full view is the root type
2912 if Full_View (BT2) = Root_Type (Full_View (BT2)) then
2913 return False;
2914 end if;
2916 Par := Etype (Full_View (BT2));
2918 else
2919 Par := Etype (BT2);
2920 end if;
2922 loop
2923 -- If there was a error on the type declaration, do not recurse
2925 if Error_Posted (Par) then
2926 return False;
2928 elsif BT1 = Base_Type (Par)
2929 or else (Is_Private_Type (T1)
2930 and then Present (Full_View (T1))
2931 and then Base_Type (Par) = Base_Type (Full_View (T1)))
2932 then
2933 return True;
2935 elsif Is_Private_Type (Par)
2936 and then Present (Full_View (Par))
2937 and then Full_View (Par) = BT1
2938 then
2939 return True;
2941 -- Root type found
2943 elsif Par = Root_Type (Par) then
2944 return False;
2946 -- Continue climbing
2948 else
2949 -- Use the full-view of private types (if allowed). Guard
2950 -- against infinite loops when full view has same type as
2951 -- parent, as can happen with interface extensions.
2953 if Use_Full_View
2954 and then Is_Private_Type (Par)
2955 and then Present (Full_View (Par))
2956 and then Par /= Etype (Full_View (Par))
2957 then
2958 Par := Etype (Full_View (Par));
2959 else
2960 Par := Etype (Par);
2961 end if;
2962 end if;
2963 end loop;
2964 end if;
2965 end Is_Ancestor;
2967 ---------------------------
2968 -- Is_Invisible_Operator --
2969 ---------------------------
2971 function Is_Invisible_Operator
2972 (N : Node_Id;
2973 T : Entity_Id) return Boolean
2975 Orig_Node : constant Node_Id := Original_Node (N);
2977 begin
2978 if Nkind (N) not in N_Op then
2979 return False;
2981 elsif not Comes_From_Source (N) then
2982 return False;
2984 elsif No (Universal_Interpretation (Right_Opnd (N))) then
2985 return False;
2987 elsif Nkind (N) in N_Binary_Op
2988 and then No (Universal_Interpretation (Left_Opnd (N)))
2989 then
2990 return False;
2992 else
2993 return Is_Numeric_Type (T)
2994 and then not In_Open_Scopes (Scope (T))
2995 and then not Is_Potentially_Use_Visible (T)
2996 and then not In_Use (T)
2997 and then not In_Use (Scope (T))
2998 and then
2999 (Nkind (Orig_Node) /= N_Function_Call
3000 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
3001 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
3002 and then not In_Instance;
3003 end if;
3004 end Is_Invisible_Operator;
3006 --------------------
3007 -- Is_Progenitor --
3008 --------------------
3010 function Is_Progenitor
3011 (Iface : Entity_Id;
3012 Typ : Entity_Id) return Boolean
3014 begin
3015 return Implements_Interface (Typ, Iface, Exclude_Parents => True);
3016 end Is_Progenitor;
3018 -------------------
3019 -- Is_Subtype_Of --
3020 -------------------
3022 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
3023 S : Entity_Id;
3025 begin
3026 S := Ancestor_Subtype (T1);
3027 while Present (S) loop
3028 if S = T2 then
3029 return True;
3030 else
3031 S := Ancestor_Subtype (S);
3032 end if;
3033 end loop;
3035 return False;
3036 end Is_Subtype_Of;
3038 ------------------
3039 -- List_Interps --
3040 ------------------
3042 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
3043 Index : Interp_Index;
3044 It : Interp;
3046 begin
3047 Get_First_Interp (Nam, Index, It);
3048 while Present (It.Nam) loop
3049 if Scope (It.Nam) = Standard_Standard
3050 and then Scope (It.Typ) /= Standard_Standard
3051 then
3052 Error_Msg_Sloc := Sloc (Parent (It.Typ));
3053 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
3055 else
3056 Error_Msg_Sloc := Sloc (It.Nam);
3057 Error_Msg_NE ("\\& declared#!", Err, It.Nam);
3058 end if;
3060 Get_Next_Interp (Index, It);
3061 end loop;
3062 end List_Interps;
3064 -----------------
3065 -- New_Interps --
3066 -----------------
3068 procedure New_Interps (N : Node_Id) is
3069 Map_Ptr : Int;
3071 begin
3072 All_Interp.Append (No_Interp);
3074 Map_Ptr := Headers (Hash (N));
3076 if Map_Ptr = No_Entry then
3078 -- Place new node at end of table
3080 Interp_Map.Increment_Last;
3081 Headers (Hash (N)) := Interp_Map.Last;
3083 else
3084 -- Place node at end of chain, or locate its previous entry
3086 loop
3087 if Interp_Map.Table (Map_Ptr).Node = N then
3089 -- Node is already in the table, and is being rewritten.
3090 -- Start a new interp section, retain hash link.
3092 Interp_Map.Table (Map_Ptr).Node := N;
3093 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
3094 Set_Is_Overloaded (N, True);
3095 return;
3097 else
3098 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
3099 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3100 end if;
3101 end loop;
3103 -- Chain the new node
3105 Interp_Map.Increment_Last;
3106 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
3107 end if;
3109 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
3110 Set_Is_Overloaded (N, True);
3111 end New_Interps;
3113 ---------------------------
3114 -- Operator_Matches_Spec --
3115 ---------------------------
3117 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
3118 New_First_F : constant Entity_Id := First_Formal (New_S);
3119 Op_Name : constant Name_Id := Chars (Op);
3120 T : constant Entity_Id := Etype (New_S);
3121 New_F : Entity_Id;
3122 Num : Nat;
3123 Old_F : Entity_Id;
3124 T1 : Entity_Id;
3125 T2 : Entity_Id;
3127 begin
3128 -- To verify that a predefined operator matches a given signature, do a
3129 -- case analysis of the operator classes. Function can have one or two
3130 -- formals and must have the proper result type.
3132 New_F := New_First_F;
3133 Old_F := First_Formal (Op);
3134 Num := 0;
3135 while Present (New_F) and then Present (Old_F) loop
3136 Num := Num + 1;
3137 Next_Formal (New_F);
3138 Next_Formal (Old_F);
3139 end loop;
3141 -- Definite mismatch if different number of parameters
3143 if Present (Old_F) or else Present (New_F) then
3144 return False;
3146 -- Unary operators
3148 elsif Num = 1 then
3149 T1 := Etype (New_First_F);
3151 if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then
3152 return Base_Type (T1) = Base_Type (T)
3153 and then Is_Numeric_Type (T);
3155 elsif Op_Name = Name_Op_Not then
3156 return Base_Type (T1) = Base_Type (T)
3157 and then Valid_Boolean_Arg (Base_Type (T));
3159 else
3160 return False;
3161 end if;
3163 -- Binary operators
3165 else
3166 T1 := Etype (New_First_F);
3167 T2 := Etype (Next_Formal (New_First_F));
3169 if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then
3170 return Base_Type (T1) = Base_Type (T2)
3171 and then Base_Type (T1) = Base_Type (T)
3172 and then Valid_Boolean_Arg (Base_Type (T));
3174 elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then
3175 return Base_Type (T1) = Base_Type (T2)
3176 and then not Is_Limited_Type (T1)
3177 and then Is_Boolean_Type (T);
3179 elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le,
3180 Name_Op_Gt, Name_Op_Ge)
3181 then
3182 return Base_Type (T1) = Base_Type (T2)
3183 and then Valid_Comparison_Arg (T1)
3184 and then Is_Boolean_Type (T);
3186 elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then
3187 return Base_Type (T1) = Base_Type (T2)
3188 and then Base_Type (T1) = Base_Type (T)
3189 and then Is_Numeric_Type (T);
3191 -- For division and multiplication, a user-defined function does not
3192 -- match the predefined universal_fixed operation, except in Ada 83.
3194 elsif Op_Name = Name_Op_Divide then
3195 return (Base_Type (T1) = Base_Type (T2)
3196 and then Base_Type (T1) = Base_Type (T)
3197 and then Is_Numeric_Type (T)
3198 and then (not Is_Fixed_Point_Type (T)
3199 or else Ada_Version = Ada_83))
3201 -- Mixed_Mode operations on fixed-point types
3203 or else (Base_Type (T1) = Base_Type (T)
3204 and then Base_Type (T2) = Base_Type (Standard_Integer)
3205 and then Is_Fixed_Point_Type (T))
3207 -- A user defined operator can also match (and hide) a mixed
3208 -- operation on universal literals.
3210 or else (Is_Integer_Type (T2)
3211 and then Is_Floating_Point_Type (T1)
3212 and then Base_Type (T1) = Base_Type (T));
3214 elsif Op_Name = Name_Op_Multiply then
3215 return (Base_Type (T1) = Base_Type (T2)
3216 and then Base_Type (T1) = Base_Type (T)
3217 and then Is_Numeric_Type (T)
3218 and then (not Is_Fixed_Point_Type (T)
3219 or else Ada_Version = Ada_83))
3221 -- Mixed_Mode operations on fixed-point types
3223 or else (Base_Type (T1) = Base_Type (T)
3224 and then Base_Type (T2) = Base_Type (Standard_Integer)
3225 and then Is_Fixed_Point_Type (T))
3227 or else (Base_Type (T2) = Base_Type (T)
3228 and then Base_Type (T1) = Base_Type (Standard_Integer)
3229 and then Is_Fixed_Point_Type (T))
3231 or else (Is_Integer_Type (T2)
3232 and then Is_Floating_Point_Type (T1)
3233 and then Base_Type (T1) = Base_Type (T))
3235 or else (Is_Integer_Type (T1)
3236 and then Is_Floating_Point_Type (T2)
3237 and then Base_Type (T2) = Base_Type (T));
3239 elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then
3240 return Base_Type (T1) = Base_Type (T2)
3241 and then Base_Type (T1) = Base_Type (T)
3242 and then Is_Integer_Type (T);
3244 elsif Op_Name = Name_Op_Expon then
3245 return Base_Type (T1) = Base_Type (T)
3246 and then Is_Numeric_Type (T)
3247 and then Base_Type (T2) = Base_Type (Standard_Integer);
3249 elsif Op_Name = Name_Op_Concat then
3250 return Is_Array_Type (T)
3251 and then (Base_Type (T) = Base_Type (Etype (Op)))
3252 and then (Base_Type (T1) = Base_Type (T)
3253 or else
3254 Base_Type (T1) = Base_Type (Component_Type (T)))
3255 and then (Base_Type (T2) = Base_Type (T)
3256 or else
3257 Base_Type (T2) = Base_Type (Component_Type (T)));
3259 else
3260 return False;
3261 end if;
3262 end if;
3263 end Operator_Matches_Spec;
3265 -------------------
3266 -- Remove_Interp --
3267 -------------------
3269 procedure Remove_Interp (I : in out Interp_Index) is
3270 II : Interp_Index;
3272 begin
3273 -- Find end of interp list and copy downward to erase the discarded one
3275 II := I + 1;
3276 while Present (All_Interp.Table (II).Typ) loop
3277 II := II + 1;
3278 end loop;
3280 for J in I + 1 .. II loop
3281 All_Interp.Table (J - 1) := All_Interp.Table (J);
3282 end loop;
3284 -- Back up interp index to insure that iterator will pick up next
3285 -- available interpretation.
3287 I := I - 1;
3288 end Remove_Interp;
3290 ------------------
3291 -- Save_Interps --
3292 ------------------
3294 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
3295 Map_Ptr : Int;
3296 O_N : Node_Id := Old_N;
3298 begin
3299 if Is_Overloaded (Old_N) then
3300 Set_Is_Overloaded (New_N);
3302 if Nkind (Old_N) = N_Selected_Component
3303 and then Is_Overloaded (Selector_Name (Old_N))
3304 then
3305 O_N := Selector_Name (Old_N);
3306 end if;
3308 Map_Ptr := Headers (Hash (O_N));
3310 while Interp_Map.Table (Map_Ptr).Node /= O_N loop
3311 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3312 pragma Assert (Map_Ptr /= No_Entry);
3313 end loop;
3315 New_Interps (New_N);
3316 Interp_Map.Table (Interp_Map.Last).Index :=
3317 Interp_Map.Table (Map_Ptr).Index;
3318 end if;
3319 end Save_Interps;
3321 -------------------
3322 -- Specific_Type --
3323 -------------------
3325 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
3326 T1 : constant Entity_Id := Available_View (Typ_1);
3327 T2 : constant Entity_Id := Available_View (Typ_2);
3328 B1 : constant Entity_Id := Base_Type (T1);
3329 B2 : constant Entity_Id := Base_Type (T2);
3331 function Is_Remote_Access (T : Entity_Id) return Boolean;
3332 -- Check whether T is the equivalent type of a remote access type.
3333 -- If distribution is enabled, T is a legal context for Null.
3335 ----------------------
3336 -- Is_Remote_Access --
3337 ----------------------
3339 function Is_Remote_Access (T : Entity_Id) return Boolean is
3340 begin
3341 return Is_Record_Type (T)
3342 and then (Is_Remote_Call_Interface (T)
3343 or else Is_Remote_Types (T))
3344 and then Present (Corresponding_Remote_Type (T))
3345 and then Is_Access_Type (Corresponding_Remote_Type (T));
3346 end Is_Remote_Access;
3348 -- Start of processing for Specific_Type
3350 begin
3351 if T1 = Any_Type or else T2 = Any_Type then
3352 return Any_Type;
3353 end if;
3355 if B1 = B2 then
3356 return B1;
3358 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
3359 or else (T1 = Universal_Real and then Is_Real_Type (T2))
3360 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
3361 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
3362 then
3363 return B2;
3365 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
3366 or else (T2 = Universal_Real and then Is_Real_Type (T1))
3367 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
3368 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
3369 then
3370 return B1;
3372 elsif T2 = Any_String and then Is_String_Type (T1) then
3373 return B1;
3375 elsif T1 = Any_String and then Is_String_Type (T2) then
3376 return B2;
3378 elsif T2 = Any_Character and then Is_Character_Type (T1) then
3379 return B1;
3381 elsif T1 = Any_Character and then Is_Character_Type (T2) then
3382 return B2;
3384 elsif T1 = Any_Access
3385 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3386 then
3387 return T2;
3389 elsif T2 = Any_Access
3390 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3391 then
3392 return T1;
3394 -- In an instance, the specific type may have a private view. Use full
3395 -- view to check legality.
3397 elsif T2 = Any_Access
3398 and then Is_Private_Type (T1)
3399 and then Present (Full_View (T1))
3400 and then Is_Access_Type (Full_View (T1))
3401 and then In_Instance
3402 then
3403 return T1;
3405 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
3406 return T1;
3408 elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then
3409 return T2;
3411 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3412 return T2;
3414 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3415 return T1;
3417 -- ----------------------------------------------------------
3418 -- Special cases for equality operators (all other predefined
3419 -- operators can never apply to tagged types)
3420 -- ----------------------------------------------------------
3422 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3423 -- interface
3425 elsif Is_Class_Wide_Type (T1)
3426 and then Is_Class_Wide_Type (T2)
3427 and then Is_Interface (Etype (T2))
3428 then
3429 return T1;
3431 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3432 -- class-wide interface T2
3434 elsif Is_Class_Wide_Type (T2)
3435 and then Is_Interface (Etype (T2))
3436 and then Interface_Present_In_Ancestor (Typ => T1,
3437 Iface => Etype (T2))
3438 then
3439 return T1;
3441 elsif Is_Class_Wide_Type (T1)
3442 and then Is_Ancestor (Root_Type (T1), T2)
3443 then
3444 return T1;
3446 elsif Is_Class_Wide_Type (T2)
3447 and then Is_Ancestor (Root_Type (T2), T1)
3448 then
3449 return T2;
3451 elsif Ekind_In (B1, E_Access_Subprogram_Type,
3452 E_Access_Protected_Subprogram_Type)
3453 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3454 and then Is_Access_Type (T2)
3455 then
3456 return T2;
3458 elsif Ekind_In (B2, E_Access_Subprogram_Type,
3459 E_Access_Protected_Subprogram_Type)
3460 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3461 and then Is_Access_Type (T1)
3462 then
3463 return T1;
3465 elsif Ekind_In (T1, E_Allocator_Type,
3466 E_Access_Attribute_Type,
3467 E_Anonymous_Access_Type)
3468 and then Is_Access_Type (T2)
3469 then
3470 return T2;
3472 elsif Ekind_In (T2, E_Allocator_Type,
3473 E_Access_Attribute_Type,
3474 E_Anonymous_Access_Type)
3475 and then Is_Access_Type (T1)
3476 then
3477 return T1;
3479 -- If none of the above cases applies, types are not compatible
3481 else
3482 return Any_Type;
3483 end if;
3484 end Specific_Type;
3486 ---------------------
3487 -- Set_Abstract_Op --
3488 ---------------------
3490 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3491 begin
3492 All_Interp.Table (I).Abstract_Op := V;
3493 end Set_Abstract_Op;
3495 -----------------------
3496 -- Valid_Boolean_Arg --
3497 -----------------------
3499 -- In addition to booleans and arrays of booleans, we must include
3500 -- aggregates as valid boolean arguments, because in the first pass of
3501 -- resolution their components are not examined. If it turns out not to be
3502 -- an aggregate of booleans, this will be diagnosed in Resolve.
3503 -- Any_Composite must be checked for prior to the array type checks because
3504 -- Any_Composite does not have any associated indexes.
3506 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3507 begin
3508 if Is_Boolean_Type (T)
3509 or else Is_Modular_Integer_Type (T)
3510 or else T = Universal_Integer
3511 or else T = Any_Composite
3512 then
3513 return True;
3515 elsif Is_Array_Type (T)
3516 and then T /= Any_String
3517 and then Number_Dimensions (T) = 1
3518 and then Is_Boolean_Type (Component_Type (T))
3519 and then
3520 ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T))
3521 or else In_Instance
3522 or else Available_Full_View_Of_Component (T))
3523 then
3524 return True;
3526 else
3527 return False;
3528 end if;
3529 end Valid_Boolean_Arg;
3531 --------------------------
3532 -- Valid_Comparison_Arg --
3533 --------------------------
3535 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3536 begin
3538 if T = Any_Composite then
3539 return False;
3541 elsif Is_Discrete_Type (T)
3542 or else Is_Real_Type (T)
3543 then
3544 return True;
3546 elsif Is_Array_Type (T)
3547 and then Number_Dimensions (T) = 1
3548 and then Is_Discrete_Type (Component_Type (T))
3549 and then (not Is_Private_Composite (T) or else In_Instance)
3550 and then (not Is_Limited_Composite (T) or else In_Instance)
3551 then
3552 return True;
3554 elsif Is_Array_Type (T)
3555 and then Number_Dimensions (T) = 1
3556 and then Is_Discrete_Type (Component_Type (T))
3557 and then Available_Full_View_Of_Component (T)
3558 then
3559 return True;
3561 elsif Is_String_Type (T) then
3562 return True;
3563 else
3564 return False;
3565 end if;
3566 end Valid_Comparison_Arg;
3568 ------------------
3569 -- Write_Interp --
3570 ------------------
3572 procedure Write_Interp (It : Interp) is
3573 begin
3574 Write_Str ("Nam: ");
3575 Print_Tree_Node (It.Nam);
3576 Write_Str ("Typ: ");
3577 Print_Tree_Node (It.Typ);
3578 Write_Str ("Abstract_Op: ");
3579 Print_Tree_Node (It.Abstract_Op);
3580 end Write_Interp;
3582 ----------------------
3583 -- Write_Interp_Ref --
3584 ----------------------
3586 procedure Write_Interp_Ref (Map_Ptr : Int) is
3587 begin
3588 Write_Str (" Node: ");
3589 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3590 Write_Str (" Index: ");
3591 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3592 Write_Str (" Next: ");
3593 Write_Int (Interp_Map.Table (Map_Ptr).Next);
3594 Write_Eol;
3595 end Write_Interp_Ref;
3597 ---------------------
3598 -- Write_Overloads --
3599 ---------------------
3601 procedure Write_Overloads (N : Node_Id) is
3602 I : Interp_Index;
3603 It : Interp;
3604 Nam : Entity_Id;
3606 begin
3607 Write_Str ("Overloads: ");
3608 Print_Node_Briefly (N);
3610 if not Is_Overloaded (N) then
3611 Write_Line ("Non-overloaded entity ");
3612 Write_Entity_Info (Entity (N), " ");
3614 elsif Nkind (N) not in N_Has_Entity then
3615 Get_First_Interp (N, I, It);
3616 while Present (It.Nam) loop
3617 Write_Int (Int (It.Typ));
3618 Write_Str (" ");
3619 Write_Name (Chars (It.Typ));
3620 Write_Eol;
3621 Get_Next_Interp (I, It);
3622 end loop;
3624 else
3625 Get_First_Interp (N, I, It);
3626 Write_Line ("Overloaded entity ");
3627 Write_Line (" Name Type Abstract Op");
3628 Write_Line ("===============================================");
3629 Nam := It.Nam;
3631 while Present (Nam) loop
3632 Write_Int (Int (Nam));
3633 Write_Str (" ");
3634 Write_Name (Chars (Nam));
3635 Write_Str (" ");
3636 Write_Int (Int (It.Typ));
3637 Write_Str (" ");
3638 Write_Name (Chars (It.Typ));
3640 if Present (It.Abstract_Op) then
3641 Write_Str (" ");
3642 Write_Int (Int (It.Abstract_Op));
3643 Write_Str (" ");
3644 Write_Name (Chars (It.Abstract_Op));
3645 end if;
3647 Write_Eol;
3648 Get_Next_Interp (I, It);
3649 Nam := It.Nam;
3650 end loop;
3651 end if;
3652 end Write_Overloads;
3654 end Sem_Type;