PR rtl-optimization/79386
[official-gcc.git] / gcc / ada / sem_type.adb
blob26415ae47dbf23b9a4137029d27f96149f4cde0a
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-2016, 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
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 return
765 Is_Private_Type (Typ1)
766 and then
767 ((Present (Full_View (Typ1))
768 and then Covers (Full_View (Typ1), Typ2))
769 or else (Present (Underlying_Full_View (Typ1))
770 and then Covers (Underlying_Full_View (Typ1), Typ2))
771 or else Base_Type (Typ1) = Typ2
772 or else Base_Type (Typ2) = Typ1);
773 end Full_View_Covers;
775 -----------------
776 -- Real_Actual --
777 -----------------
779 function Real_Actual (T : Entity_Id) return Entity_Id is
780 Par : constant Node_Id := Parent (T);
781 RA : Entity_Id;
783 begin
784 -- Retrieve parent subtype from subtype declaration for actual
786 if Nkind (Par) = N_Subtype_Declaration
787 and then not Comes_From_Source (Par)
788 and then Is_Entity_Name (Subtype_Indication (Par))
789 then
790 RA := Entity (Subtype_Indication (Par));
792 if Is_Generic_Actual_Type (RA) then
793 return RA;
794 end if;
795 end if;
797 -- Otherwise actual is not the actual of an enclosing instance
799 return T;
800 end Real_Actual;
802 -- Start of processing for Covers
804 begin
805 -- If either operand missing, then this is an error, but ignore it (and
806 -- pretend we have a cover) if errors already detected, since this may
807 -- simply mean we have malformed trees or a semantic error upstream.
809 if No (T1) or else No (T2) then
810 if Total_Errors_Detected /= 0 then
811 return True;
812 else
813 raise Program_Error;
814 end if;
815 end if;
817 -- Trivial case: same types are always compatible
819 if T1 = T2 then
820 return True;
821 end if;
823 -- First check for Standard_Void_Type, which is special. Subsequent
824 -- processing in this routine assumes T1 and T2 are bona fide types;
825 -- Standard_Void_Type is a special entity that has some, but not all,
826 -- properties of types.
828 if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
829 return False;
830 end if;
832 BT1 := Base_Type (T1);
833 BT2 := Base_Type (T2);
835 -- Handle underlying view of records with unknown discriminants
836 -- using the original entity that motivated the construction of
837 -- this underlying record view (see Build_Derived_Private_Type).
839 if Is_Underlying_Record_View (BT1) then
840 BT1 := Underlying_Record_View (BT1);
841 end if;
843 if Is_Underlying_Record_View (BT2) then
844 BT2 := Underlying_Record_View (BT2);
845 end if;
847 -- Simplest case: types that have the same base type and are not generic
848 -- actuals are compatible. Generic actuals belong to their class but are
849 -- not compatible with other types of their class, and in particular
850 -- with other generic actuals. They are however compatible with their
851 -- own subtypes, and itypes with the same base are compatible as well.
852 -- Similarly, constrained subtypes obtained from expressions of an
853 -- unconstrained nominal type are compatible with the base type (may
854 -- lead to spurious ambiguities in obscure cases ???)
856 -- Generic actuals require special treatment to avoid spurious ambi-
857 -- guities in an instance, when two formal types are instantiated with
858 -- the same actual, so that different subprograms end up with the same
859 -- signature in the instance. If a generic actual is the actual of an
860 -- enclosing instance, it is that actual that we must compare: generic
861 -- actuals are only incompatible if they appear in the same instance.
863 if BT1 = BT2
864 or else BT1 = T2
865 or else BT2 = T1
866 then
867 if not Is_Generic_Actual_Type (T1)
868 or else
869 not Is_Generic_Actual_Type (T2)
870 then
871 return True;
873 -- Both T1 and T2 are generic actual types
875 else
876 declare
877 RT1 : constant Entity_Id := Real_Actual (T1);
878 RT2 : constant Entity_Id := Real_Actual (T2);
879 begin
880 return RT1 = RT2
881 or else Is_Itype (T1)
882 or else Is_Itype (T2)
883 or else Is_Constr_Subt_For_U_Nominal (T1)
884 or else Is_Constr_Subt_For_U_Nominal (T2)
885 or else Scope (RT1) /= Scope (RT2);
886 end;
887 end if;
889 -- Literals are compatible with types in a given "class"
891 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
892 or else (T2 = Universal_Real and then Is_Real_Type (T1))
893 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
894 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
895 or else (T2 = Any_String and then Is_String_Type (T1))
896 or else (T2 = Any_Character and then Is_Character_Type (T1))
897 or else (T2 = Any_Access and then Is_Access_Type (T1))
898 then
899 return True;
901 -- The context may be class wide, and a class-wide type is compatible
902 -- with any member of the class.
904 elsif Is_Class_Wide_Type (T1)
905 and then Is_Ancestor (Root_Type (T1), T2)
906 then
907 return True;
909 elsif Is_Class_Wide_Type (T1)
910 and then Is_Class_Wide_Type (T2)
911 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
912 then
913 return True;
915 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
916 -- task_type or protected_type that implements the interface.
918 elsif Ada_Version >= Ada_2005
919 and then Is_Class_Wide_Type (T1)
920 and then Is_Interface (Etype (T1))
921 and then Is_Concurrent_Type (T2)
922 and then Interface_Present_In_Ancestor
923 (Typ => BT2, Iface => Etype (T1))
924 then
925 return True;
927 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
928 -- object T2 implementing T1.
930 elsif Ada_Version >= Ada_2005
931 and then Is_Class_Wide_Type (T1)
932 and then Is_Interface (Etype (T1))
933 and then Is_Tagged_Type (T2)
934 then
935 if Interface_Present_In_Ancestor (Typ => T2,
936 Iface => Etype (T1))
937 then
938 return True;
939 end if;
941 declare
942 E : Entity_Id;
943 Elmt : Elmt_Id;
945 begin
946 if Is_Concurrent_Type (BT2) then
947 E := Corresponding_Record_Type (BT2);
948 else
949 E := BT2;
950 end if;
952 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
953 -- covers an object T2 that implements a direct derivation of T1.
954 -- Note: test for presence of E is defense against previous error.
956 if No (E) then
958 -- If expansion is disabled the Corresponding_Record_Type may
959 -- not be available yet, so use the interface list in the
960 -- declaration directly.
962 if ASIS_Mode
963 and then Nkind (Parent (BT2)) = N_Protected_Type_Declaration
964 and then Present (Interface_List (Parent (BT2)))
965 then
966 declare
967 Intf : Node_Id := First (Interface_List (Parent (BT2)));
968 begin
969 while Present (Intf) loop
970 if Is_Ancestor (Etype (T1), Entity (Intf)) then
971 return True;
972 else
973 Next (Intf);
974 end if;
975 end loop;
976 end;
978 return False;
980 else
981 Check_Error_Detected;
982 end if;
984 -- Here we have a corresponding record type
986 elsif Present (Interfaces (E)) then
987 Elmt := First_Elmt (Interfaces (E));
988 while Present (Elmt) loop
989 if Is_Ancestor (Etype (T1), Node (Elmt)) then
990 return True;
991 else
992 Next_Elmt (Elmt);
993 end if;
994 end loop;
995 end if;
997 -- We should also check the case in which T1 is an ancestor of
998 -- some implemented interface???
1000 return False;
1001 end;
1003 -- In a dispatching call, the formal is of some specific type, and the
1004 -- actual is of the corresponding class-wide type, including a subtype
1005 -- of the class-wide type.
1007 elsif Is_Class_Wide_Type (T2)
1008 and then
1009 (Class_Wide_Type (T1) = Class_Wide_Type (T2)
1010 or else Base_Type (Root_Type (T2)) = BT1)
1011 then
1012 return True;
1014 -- Some contexts require a class of types rather than a specific type.
1015 -- For example, conditions require any boolean type, fixed point
1016 -- attributes require some real type, etc. The built-in types Any_XXX
1017 -- represent these classes.
1019 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
1020 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
1021 or else (T1 = Any_Real and then Is_Real_Type (T2))
1022 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
1023 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
1024 then
1025 return True;
1027 -- An aggregate is compatible with an array or record type
1029 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
1030 return True;
1032 -- If the expected type is an anonymous access, the designated type must
1033 -- cover that of the expression. Use the base type for this check: even
1034 -- though access subtypes are rare in sources, they are generated for
1035 -- actuals in instantiations.
1037 elsif Ekind (BT1) = E_Anonymous_Access_Type
1038 and then Is_Access_Type (T2)
1039 and then Covers (Designated_Type (T1), Designated_Type (T2))
1040 then
1041 return True;
1043 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1044 -- of a named general access type. An implicit conversion will be
1045 -- applied. For the resolution, one designated type must cover the
1046 -- other.
1048 elsif Ada_Version >= Ada_2012
1049 and then Ekind (BT1) = E_General_Access_Type
1050 and then Ekind (BT2) = E_Anonymous_Access_Type
1051 and then (Covers (Designated_Type (T1), Designated_Type (T2))
1052 or else
1053 Covers (Designated_Type (T2), Designated_Type (T1)))
1054 then
1055 return True;
1057 -- An Access_To_Subprogram is compatible with itself, or with an
1058 -- anonymous type created for an attribute reference Access.
1060 elsif Ekind_In (BT1, E_Access_Subprogram_Type,
1061 E_Access_Protected_Subprogram_Type)
1062 and then Is_Access_Type (T2)
1063 and then (not Comes_From_Source (T1)
1064 or else not Comes_From_Source (T2))
1065 and then (Is_Overloadable (Designated_Type (T2))
1066 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1067 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1068 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1069 then
1070 return True;
1072 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1073 -- with itself, or with an anonymous type created for an attribute
1074 -- reference Access.
1076 elsif Ekind_In (BT1, E_Anonymous_Access_Subprogram_Type,
1077 E_Anonymous_Access_Protected_Subprogram_Type)
1078 and then Is_Access_Type (T2)
1079 and then (not Comes_From_Source (T1)
1080 or else not Comes_From_Source (T2))
1081 and then (Is_Overloadable (Designated_Type (T2))
1082 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1083 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1084 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1085 then
1086 return True;
1088 -- The context can be a remote access type, and the expression the
1089 -- corresponding source type declared in a categorized package, or
1090 -- vice versa.
1092 elsif Is_Record_Type (T1)
1093 and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1))
1094 and then Present (Corresponding_Remote_Type (T1))
1095 then
1096 return Covers (Corresponding_Remote_Type (T1), T2);
1098 -- and conversely.
1100 elsif Is_Record_Type (T2)
1101 and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2))
1102 and then Present (Corresponding_Remote_Type (T2))
1103 then
1104 return Covers (Corresponding_Remote_Type (T2), T1);
1106 -- Synchronized types are represented at run time by their corresponding
1107 -- record type. During expansion one is replaced with the other, but
1108 -- they are compatible views of the same type.
1110 elsif Is_Record_Type (T1)
1111 and then Is_Concurrent_Type (T2)
1112 and then Present (Corresponding_Record_Type (T2))
1113 then
1114 return Covers (T1, Corresponding_Record_Type (T2));
1116 elsif Is_Concurrent_Type (T1)
1117 and then Present (Corresponding_Record_Type (T1))
1118 and then Is_Record_Type (T2)
1119 then
1120 return Covers (Corresponding_Record_Type (T1), T2);
1122 -- During analysis, an attribute reference 'Access has a special type
1123 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1124 -- imposed by context.
1126 elsif Ekind (T2) = E_Access_Attribute_Type
1127 and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
1128 and then Covers (Designated_Type (T1), Designated_Type (T2))
1129 then
1130 -- If the target type is a RACW type while the source is an access
1131 -- attribute type, we are building a RACW that may be exported.
1133 if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1134 Set_Has_RACW (Current_Sem_Unit);
1135 end if;
1137 return True;
1139 -- Ditto for allocators, which eventually resolve to the context type
1141 elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then
1142 return Covers (Designated_Type (T1), Designated_Type (T2))
1143 or else
1144 (From_Limited_With (Designated_Type (T1))
1145 and then Covers (Designated_Type (T2), Designated_Type (T1)));
1147 -- A boolean operation on integer literals is compatible with modular
1148 -- context.
1150 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
1151 return True;
1153 -- The actual type may be the result of a previous error
1155 elsif BT2 = Any_Type then
1156 return True;
1158 -- A Raise_Expressions is legal in any expression context
1160 elsif BT2 = Raise_Type then
1161 return True;
1163 -- A packed array type covers its corresponding non-packed type. This is
1164 -- not legitimate Ada, but allows the omission of a number of otherwise
1165 -- useless unchecked conversions, and since this can only arise in
1166 -- (known correct) expanded code, no harm is done.
1168 elsif Is_Array_Type (T2)
1169 and then Is_Packed (T2)
1170 and then T1 = Packed_Array_Impl_Type (T2)
1171 then
1172 return True;
1174 -- Similarly an array type covers its corresponding packed array type
1176 elsif Is_Array_Type (T1)
1177 and then Is_Packed (T1)
1178 and then T2 = Packed_Array_Impl_Type (T1)
1179 then
1180 return True;
1182 -- In instances, or with types exported from instantiations, check
1183 -- whether a partial and a full view match. Verify that types are
1184 -- legal, to prevent cascaded errors.
1186 elsif In_Instance
1187 and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1))
1188 then
1189 return True;
1191 elsif Is_Type (T2)
1192 and then Is_Generic_Actual_Type (T2)
1193 and then Full_View_Covers (T1, T2)
1194 then
1195 return True;
1197 elsif Is_Type (T1)
1198 and then Is_Generic_Actual_Type (T1)
1199 and then Full_View_Covers (T2, T1)
1200 then
1201 return True;
1203 -- In the expansion of inlined bodies, types are compatible if they
1204 -- are structurally equivalent.
1206 elsif In_Inlined_Body
1207 and then (Underlying_Type (T1) = Underlying_Type (T2)
1208 or else
1209 (Is_Access_Type (T1)
1210 and then Is_Access_Type (T2)
1211 and then Designated_Type (T1) = Designated_Type (T2))
1212 or else
1213 (T1 = Any_Access
1214 and then Is_Access_Type (Underlying_Type (T2)))
1215 or else
1216 (T2 = Any_Composite
1217 and then Is_Composite_Type (Underlying_Type (T1))))
1218 then
1219 return True;
1221 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1222 -- obtained through a limited_with compatible with its real entity.
1224 elsif From_Limited_With (T1) then
1226 -- If the expected type is the nonlimited view of a type, the
1227 -- expression may have the limited view. If that one in turn is
1228 -- incomplete, get full view if available.
1230 return Has_Non_Limited_View (T1)
1231 and then Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1233 elsif From_Limited_With (T2) then
1235 -- If units in the context have Limited_With clauses on each other,
1236 -- either type might have a limited view. Checks performed elsewhere
1237 -- verify that the context type is the nonlimited view.
1239 return Has_Non_Limited_View (T2)
1240 and then Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1242 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1244 elsif Ekind (T1) = E_Incomplete_Subtype then
1245 return Covers (Full_View (Etype (T1)), T2);
1247 elsif Ekind (T2) = E_Incomplete_Subtype then
1248 return Covers (T1, Full_View (Etype (T2)));
1250 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1251 -- and actual anonymous access types in the context of generic
1252 -- instantiations. We have the following situation:
1254 -- generic
1255 -- type Formal is private;
1256 -- Formal_Obj : access Formal; -- T1
1257 -- package G is ...
1259 -- package P is
1260 -- type Actual is ...
1261 -- Actual_Obj : access Actual; -- T2
1262 -- package Instance is new G (Formal => Actual,
1263 -- Formal_Obj => Actual_Obj);
1265 elsif Ada_Version >= Ada_2005
1266 and then Ekind (T1) = E_Anonymous_Access_Type
1267 and then Ekind (T2) = E_Anonymous_Access_Type
1268 and then Is_Generic_Type (Directly_Designated_Type (T1))
1269 and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1270 Directly_Designated_Type (T2)
1271 then
1272 return True;
1274 -- Otherwise, types are not compatible
1276 else
1277 return False;
1278 end if;
1279 end Covers;
1281 ------------------
1282 -- Disambiguate --
1283 ------------------
1285 function Disambiguate
1286 (N : Node_Id;
1287 I1, I2 : Interp_Index;
1288 Typ : Entity_Id) return Interp
1290 I : Interp_Index;
1291 It : Interp;
1292 It1, It2 : Interp;
1293 Nam1, Nam2 : Entity_Id;
1294 Predef_Subp : Entity_Id;
1295 User_Subp : Entity_Id;
1297 function Inherited_From_Actual (S : Entity_Id) return Boolean;
1298 -- Determine whether one of the candidates is an operation inherited by
1299 -- a type that is derived from an actual in an instantiation.
1301 function In_Same_Declaration_List
1302 (Typ : Entity_Id;
1303 Op_Decl : Entity_Id) return Boolean;
1304 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1305 -- access types is declared on the partial view of a designated type, so
1306 -- that the type declaration and equality are not in the same list of
1307 -- declarations. This AI gives a preference rule for the user-defined
1308 -- operation. Same rule applies for arithmetic operations on private
1309 -- types completed with fixed-point types: the predefined operation is
1310 -- hidden; this is already handled properly in GNAT.
1312 function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1313 -- Determine whether a subprogram is an actual in an enclosing instance.
1314 -- An overloading between such a subprogram and one declared outside the
1315 -- instance is resolved in favor of the first, because it resolved in
1316 -- the generic. Within the instance the actual is represented by a
1317 -- constructed subprogram renaming.
1319 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
1320 -- Determine whether function Func_Id is an exact match for binary or
1321 -- unary operator Op.
1323 function Operand_Type return Entity_Id;
1324 -- Determine type of operand for an equality operation, to apply Ada
1325 -- 2005 rules to equality on anonymous access types.
1327 function Standard_Operator return Boolean;
1328 -- Check whether subprogram is predefined operator declared in Standard.
1329 -- It may given by an operator name, or by an expanded name whose prefix
1330 -- is Standard.
1332 function Remove_Conversions return Interp;
1333 -- Last chance for pathological cases involving comparisons on literals,
1334 -- and user overloadings of the same operator. Such pathologies have
1335 -- been removed from the ACVC, but still appear in two DEC tests, with
1336 -- the following notable quote from Ben Brosgol:
1338 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1339 -- this example; Robert Dewar brought it to our attention, since it is
1340 -- apparently found in the ACVC 1.5. I did not attempt to find the
1341 -- reason in the Reference Manual that makes the example legal, since I
1342 -- was too nauseated by it to want to pursue it further.]
1344 -- Accordingly, this is not a fully recursive solution, but it handles
1345 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1346 -- pathology in the other direction with calls whose multiple overloaded
1347 -- actuals make them truly unresolvable.
1349 -- The new rules concerning abstract operations create additional need
1350 -- for special handling of expressions with universal operands, see
1351 -- comments to Has_Abstract_Interpretation below.
1353 ---------------------------
1354 -- Inherited_From_Actual --
1355 ---------------------------
1357 function Inherited_From_Actual (S : Entity_Id) return Boolean is
1358 Par : constant Node_Id := Parent (S);
1359 begin
1360 if Nkind (Par) /= N_Full_Type_Declaration
1361 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1362 then
1363 return False;
1364 else
1365 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1366 and then
1367 Is_Generic_Actual_Type (
1368 Entity (Subtype_Indication (Type_Definition (Par))));
1369 end if;
1370 end Inherited_From_Actual;
1372 ------------------------------
1373 -- In_Same_Declaration_List --
1374 ------------------------------
1376 function In_Same_Declaration_List
1377 (Typ : Entity_Id;
1378 Op_Decl : Entity_Id) return Boolean
1380 Scop : constant Entity_Id := Scope (Typ);
1382 begin
1383 return In_Same_List (Parent (Typ), Op_Decl)
1384 or else
1385 (Ekind_In (Scop, E_Package, E_Generic_Package)
1386 and then List_Containing (Op_Decl) =
1387 Visible_Declarations (Parent (Scop))
1388 and then List_Containing (Parent (Typ)) =
1389 Private_Declarations (Parent (Scop)));
1390 end In_Same_Declaration_List;
1392 --------------------------
1393 -- Is_Actual_Subprogram --
1394 --------------------------
1396 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1397 begin
1398 return In_Open_Scopes (Scope (S))
1399 and then Nkind (Unit_Declaration_Node (S)) =
1400 N_Subprogram_Renaming_Declaration
1402 -- Why the Comes_From_Source test here???
1404 and then not Comes_From_Source (Unit_Declaration_Node (S))
1406 and then
1407 (Is_Generic_Instance (Scope (S))
1408 or else Is_Wrapper_Package (Scope (S)));
1409 end Is_Actual_Subprogram;
1411 -------------
1412 -- Matches --
1413 -------------
1415 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
1416 function Matching_Types
1417 (Opnd_Typ : Entity_Id;
1418 Formal_Typ : Entity_Id) return Boolean;
1419 -- Determine whether operand type Opnd_Typ and formal parameter type
1420 -- Formal_Typ are either the same or compatible.
1422 --------------------
1423 -- Matching_Types --
1424 --------------------
1426 function Matching_Types
1427 (Opnd_Typ : Entity_Id;
1428 Formal_Typ : Entity_Id) return Boolean
1430 begin
1431 -- A direct match
1433 if Opnd_Typ = Formal_Typ then
1434 return True;
1436 -- Any integer type matches universal integer
1438 elsif Opnd_Typ = Universal_Integer
1439 and then Is_Integer_Type (Formal_Typ)
1440 then
1441 return True;
1443 -- Any floating point type matches universal real
1445 elsif Opnd_Typ = Universal_Real
1446 and then Is_Floating_Point_Type (Formal_Typ)
1447 then
1448 return True;
1450 -- The type of the formal parameter maps a generic actual type to
1451 -- a generic formal type. If the operand type is the type being
1452 -- mapped in an instance, then this is a match.
1454 elsif Is_Generic_Actual_Type (Formal_Typ)
1455 and then Etype (Formal_Typ) = Opnd_Typ
1456 then
1457 return True;
1459 -- ??? There are possibly other cases to consider
1461 else
1462 return False;
1463 end if;
1464 end Matching_Types;
1466 -- Local variables
1468 F1 : constant Entity_Id := First_Formal (Func_Id);
1469 F1_Typ : constant Entity_Id := Etype (F1);
1470 F2 : constant Entity_Id := Next_Formal (F1);
1471 F2_Typ : constant Entity_Id := Etype (F2);
1472 Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op));
1473 Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
1475 -- Start of processing for Matches
1477 begin
1478 if Lop_Typ = F1_Typ then
1479 return Matching_Types (Rop_Typ, F2_Typ);
1481 elsif Rop_Typ = F2_Typ then
1482 return Matching_Types (Lop_Typ, F1_Typ);
1484 -- Otherwise this is not a good match because each operand-formal
1485 -- pair is compatible only on base-type basis, which is not specific
1486 -- enough.
1488 else
1489 return False;
1490 end if;
1491 end Matches;
1493 ------------------
1494 -- Operand_Type --
1495 ------------------
1497 function Operand_Type return Entity_Id is
1498 Opnd : Node_Id;
1500 begin
1501 if Nkind (N) = N_Function_Call then
1502 Opnd := First_Actual (N);
1503 else
1504 Opnd := Left_Opnd (N);
1505 end if;
1507 return Etype (Opnd);
1508 end Operand_Type;
1510 ------------------------
1511 -- Remove_Conversions --
1512 ------------------------
1514 function Remove_Conversions return Interp is
1515 I : Interp_Index;
1516 It : Interp;
1517 It1 : Interp;
1518 F1 : Entity_Id;
1519 Act1 : Node_Id;
1520 Act2 : Node_Id;
1522 function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1523 -- If an operation has universal operands the universal operation
1524 -- is present among its interpretations. If there is an abstract
1525 -- interpretation for the operator, with a numeric result, this
1526 -- interpretation was already removed in sem_ch4, but the universal
1527 -- one is still visible. We must rescan the list of operators and
1528 -- remove the universal interpretation to resolve the ambiguity.
1530 ---------------------------------
1531 -- Has_Abstract_Interpretation --
1532 ---------------------------------
1534 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1535 E : Entity_Id;
1537 begin
1538 if Nkind (N) not in N_Op
1539 or else Ada_Version < Ada_2005
1540 or else not Is_Overloaded (N)
1541 or else No (Universal_Interpretation (N))
1542 then
1543 return False;
1545 else
1546 E := Get_Name_Entity_Id (Chars (N));
1547 while Present (E) loop
1548 if Is_Overloadable (E)
1549 and then Is_Abstract_Subprogram (E)
1550 and then Is_Numeric_Type (Etype (E))
1551 then
1552 return True;
1553 else
1554 E := Homonym (E);
1555 end if;
1556 end loop;
1558 -- Finally, if an operand of the binary operator is itself
1559 -- an operator, recurse to see whether its own abstract
1560 -- interpretation is responsible for the spurious ambiguity.
1562 if Nkind (N) in N_Binary_Op then
1563 return Has_Abstract_Interpretation (Left_Opnd (N))
1564 or else Has_Abstract_Interpretation (Right_Opnd (N));
1566 elsif Nkind (N) in N_Unary_Op then
1567 return Has_Abstract_Interpretation (Right_Opnd (N));
1569 else
1570 return False;
1571 end if;
1572 end if;
1573 end Has_Abstract_Interpretation;
1575 -- Start of processing for Remove_Conversions
1577 begin
1578 It1 := No_Interp;
1580 Get_First_Interp (N, I, It);
1581 while Present (It.Typ) loop
1582 if not Is_Overloadable (It.Nam) then
1583 return No_Interp;
1584 end if;
1586 F1 := First_Formal (It.Nam);
1588 if No (F1) then
1589 return It1;
1591 else
1592 if Nkind (N) in N_Subprogram_Call then
1593 Act1 := First_Actual (N);
1595 if Present (Act1) then
1596 Act2 := Next_Actual (Act1);
1597 else
1598 Act2 := Empty;
1599 end if;
1601 elsif Nkind (N) in N_Unary_Op then
1602 Act1 := Right_Opnd (N);
1603 Act2 := Empty;
1605 elsif Nkind (N) in N_Binary_Op then
1606 Act1 := Left_Opnd (N);
1607 Act2 := Right_Opnd (N);
1609 -- Use the type of the second formal, so as to include
1610 -- exponentiation, where the exponent may be ambiguous and
1611 -- the result non-universal.
1613 Next_Formal (F1);
1615 else
1616 return It1;
1617 end if;
1619 if Nkind (Act1) in N_Op
1620 and then Is_Overloaded (Act1)
1621 and then
1622 (Nkind (Act1) in N_Unary_Op
1623 or else Nkind_In (Left_Opnd (Act1), N_Integer_Literal,
1624 N_Real_Literal))
1625 and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal,
1626 N_Real_Literal)
1627 and then Has_Compatible_Type (Act1, Standard_Boolean)
1628 and then Etype (F1) = Standard_Boolean
1629 then
1630 -- If the two candidates are the original ones, the
1631 -- ambiguity is real. Otherwise keep the original, further
1632 -- calls to Disambiguate will take care of others in the
1633 -- list of candidates.
1635 if It1 /= No_Interp then
1636 if It = Disambiguate.It1
1637 or else It = Disambiguate.It2
1638 then
1639 if It1 = Disambiguate.It1
1640 or else It1 = Disambiguate.It2
1641 then
1642 return No_Interp;
1643 else
1644 It1 := It;
1645 end if;
1646 end if;
1648 elsif Present (Act2)
1649 and then Nkind (Act2) in N_Op
1650 and then Is_Overloaded (Act2)
1651 and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1652 N_Real_Literal)
1653 and then Has_Compatible_Type (Act2, Standard_Boolean)
1654 then
1655 -- The preference rule on the first actual is not
1656 -- sufficient to disambiguate.
1658 goto Next_Interp;
1660 else
1661 It1 := It;
1662 end if;
1664 elsif Is_Numeric_Type (Etype (F1))
1665 and then Has_Abstract_Interpretation (Act1)
1666 then
1667 -- Current interpretation is not the right one because it
1668 -- expects a numeric operand. Examine all the other ones.
1670 declare
1671 I : Interp_Index;
1672 It : Interp;
1674 begin
1675 Get_First_Interp (N, I, It);
1676 while Present (It.Typ) loop
1678 not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1679 then
1680 if No (Act2)
1681 or else not Has_Abstract_Interpretation (Act2)
1682 or else not
1683 Is_Numeric_Type
1684 (Etype (Next_Formal (First_Formal (It.Nam))))
1685 then
1686 return It;
1687 end if;
1688 end if;
1690 Get_Next_Interp (I, It);
1691 end loop;
1693 return No_Interp;
1694 end;
1695 end if;
1696 end if;
1698 <<Next_Interp>>
1699 Get_Next_Interp (I, It);
1700 end loop;
1702 -- After some error, a formal may have Any_Type and yield a spurious
1703 -- match. To avoid cascaded errors if possible, check for such a
1704 -- formal in either candidate.
1706 if Serious_Errors_Detected > 0 then
1707 declare
1708 Formal : Entity_Id;
1710 begin
1711 Formal := First_Formal (Nam1);
1712 while Present (Formal) loop
1713 if Etype (Formal) = Any_Type then
1714 return Disambiguate.It2;
1715 end if;
1717 Next_Formal (Formal);
1718 end loop;
1720 Formal := First_Formal (Nam2);
1721 while Present (Formal) loop
1722 if Etype (Formal) = Any_Type then
1723 return Disambiguate.It1;
1724 end if;
1726 Next_Formal (Formal);
1727 end loop;
1728 end;
1729 end if;
1731 return It1;
1732 end Remove_Conversions;
1734 -----------------------
1735 -- Standard_Operator --
1736 -----------------------
1738 function Standard_Operator return Boolean is
1739 Nam : Node_Id;
1741 begin
1742 if Nkind (N) in N_Op then
1743 return True;
1745 elsif Nkind (N) = N_Function_Call then
1746 Nam := Name (N);
1748 if Nkind (Nam) /= N_Expanded_Name then
1749 return True;
1750 else
1751 return Entity (Prefix (Nam)) = Standard_Standard;
1752 end if;
1753 else
1754 return False;
1755 end if;
1756 end Standard_Operator;
1758 -- Start of processing for Disambiguate
1760 begin
1761 -- Recover the two legal interpretations
1763 Get_First_Interp (N, I, It);
1764 while I /= I1 loop
1765 Get_Next_Interp (I, It);
1766 end loop;
1768 It1 := It;
1769 Nam1 := It.Nam;
1771 while I /= I2 loop
1772 Get_Next_Interp (I, It);
1773 end loop;
1775 It2 := It;
1776 Nam2 := It.Nam;
1778 -- Check whether one of the entities is an Ada 2005/2012 and we are
1779 -- operating in an earlier mode, in which case we discard the Ada
1780 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
1782 if Ada_Version < Ada_2005 then
1783 if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
1784 return It2;
1785 elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
1786 return It1;
1787 end if;
1788 end if;
1790 -- Check whether one of the entities is an Ada 2012 entity and we are
1791 -- operating in Ada 2005 mode, in which case we discard the Ada 2012
1792 -- entity, so that we get proper Ada 2005 overload resolution.
1794 if Ada_Version = Ada_2005 then
1795 if Is_Ada_2012_Only (Nam1) then
1796 return It2;
1797 elsif Is_Ada_2012_Only (Nam2) then
1798 return It1;
1799 end if;
1800 end if;
1802 -- If the context is universal, the predefined operator is preferred.
1803 -- This includes bounds in numeric type declarations, and expressions
1804 -- in type conversions. If no interpretation yields a universal type,
1805 -- then we must check whether the user-defined entity hides the prede-
1806 -- fined one.
1808 if Chars (Nam1) in Any_Operator_Name and then Standard_Operator then
1809 if Typ = Universal_Integer
1810 or else Typ = Universal_Real
1811 or else Typ = Any_Integer
1812 or else Typ = Any_Discrete
1813 or else Typ = Any_Real
1814 or else Typ = Any_Type
1815 then
1816 -- Find an interpretation that yields the universal type, or else
1817 -- a predefined operator that yields a predefined numeric type.
1819 declare
1820 Candidate : Interp := No_Interp;
1822 begin
1823 Get_First_Interp (N, I, It);
1824 while Present (It.Typ) loop
1825 if (It.Typ = Universal_Integer
1826 or else It.Typ = Universal_Real)
1827 and then (Typ = Any_Type or else Covers (Typ, It.Typ))
1828 then
1829 return It;
1831 elsif Is_Numeric_Type (It.Typ)
1832 and then Scope (It.Typ) = Standard_Standard
1833 and then Scope (It.Nam) = Standard_Standard
1834 and then Covers (Typ, It.Typ)
1835 then
1836 Candidate := It;
1837 end if;
1839 Get_Next_Interp (I, It);
1840 end loop;
1842 if Candidate /= No_Interp then
1843 return Candidate;
1844 end if;
1845 end;
1847 elsif Chars (Nam1) /= Name_Op_Not
1848 and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1849 then
1850 -- Equality or comparison operation. Choose predefined operator if
1851 -- arguments are universal. The node may be an operator, name, or
1852 -- a function call, so unpack arguments accordingly.
1854 declare
1855 Arg1, Arg2 : Node_Id;
1857 begin
1858 if Nkind (N) in N_Op then
1859 Arg1 := Left_Opnd (N);
1860 Arg2 := Right_Opnd (N);
1862 elsif Is_Entity_Name (N) then
1863 Arg1 := First_Entity (Entity (N));
1864 Arg2 := Next_Entity (Arg1);
1866 else
1867 Arg1 := First_Actual (N);
1868 Arg2 := Next_Actual (Arg1);
1869 end if;
1871 if Present (Arg2)
1872 and then Present (Universal_Interpretation (Arg1))
1873 and then Universal_Interpretation (Arg2) =
1874 Universal_Interpretation (Arg1)
1875 then
1876 Get_First_Interp (N, I, It);
1877 while Scope (It.Nam) /= Standard_Standard loop
1878 Get_Next_Interp (I, It);
1879 end loop;
1881 return It;
1882 end if;
1883 end;
1884 end if;
1885 end if;
1887 -- If no universal interpretation, check whether user-defined operator
1888 -- hides predefined one, as well as other special cases. If the node
1889 -- is a range, then one or both bounds are ambiguous. Each will have
1890 -- to be disambiguated w.r.t. the context type. The type of the range
1891 -- itself is imposed by the context, so we can return either legal
1892 -- interpretation.
1894 if Ekind (Nam1) = E_Operator then
1895 Predef_Subp := Nam1;
1896 User_Subp := Nam2;
1898 elsif Ekind (Nam2) = E_Operator then
1899 Predef_Subp := Nam2;
1900 User_Subp := Nam1;
1902 elsif Nkind (N) = N_Range then
1903 return It1;
1905 -- Implement AI05-105: A renaming declaration with an access
1906 -- definition must resolve to an anonymous access type. This
1907 -- is a resolution rule and can be used to disambiguate.
1909 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1910 and then Present (Access_Definition (Parent (N)))
1911 then
1912 if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
1913 E_Anonymous_Access_Subprogram_Type)
1914 then
1915 if Ekind (It2.Typ) = Ekind (It1.Typ) then
1917 -- True ambiguity
1919 return No_Interp;
1921 else
1922 return It1;
1923 end if;
1925 elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
1926 E_Anonymous_Access_Subprogram_Type)
1927 then
1928 return It2;
1930 -- No legal interpretation
1932 else
1933 return No_Interp;
1934 end if;
1936 -- If two user defined-subprograms are visible, it is a true ambiguity,
1937 -- unless one of them is an entry and the context is a conditional or
1938 -- timed entry call, or unless we are within an instance and this is
1939 -- results from two formals types with the same actual.
1941 else
1942 if Nkind (N) = N_Procedure_Call_Statement
1943 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1944 and then N = Entry_Call_Statement (Parent (N))
1945 then
1946 if Ekind (Nam2) = E_Entry then
1947 return It2;
1948 elsif Ekind (Nam1) = E_Entry then
1949 return It1;
1950 else
1951 return No_Interp;
1952 end if;
1954 -- If the ambiguity occurs within an instance, it is due to several
1955 -- formal types with the same actual. Look for an exact match between
1956 -- the types of the formals of the overloadable entities, and the
1957 -- actuals in the call, to recover the unambiguous match in the
1958 -- original generic.
1960 -- The ambiguity can also be due to an overloading between a formal
1961 -- subprogram and a subprogram declared outside the generic. If the
1962 -- node is overloaded, it did not resolve to the global entity in
1963 -- the generic, and we choose the formal subprogram.
1965 -- Finally, the ambiguity can be between an explicit subprogram and
1966 -- one inherited (with different defaults) from an actual. In this
1967 -- case the resolution was to the explicit declaration in the
1968 -- generic, and remains so in the instance.
1970 -- The same sort of disambiguation needed for calls is also required
1971 -- for the name given in a subprogram renaming, and that case is
1972 -- handled here as well. We test Comes_From_Source to exclude this
1973 -- treatment for implicit renamings created for formal subprograms.
1975 elsif In_Instance and then not In_Generic_Actual (N) then
1976 if Nkind (N) in N_Subprogram_Call
1977 or else
1978 (Nkind (N) in N_Has_Entity
1979 and then
1980 Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
1981 and then Comes_From_Source (Parent (N)))
1982 then
1983 declare
1984 Actual : Node_Id;
1985 Formal : Entity_Id;
1986 Renam : Entity_Id := Empty;
1987 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1988 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1990 begin
1991 if Is_Act1 and then not Is_Act2 then
1992 return It1;
1994 elsif Is_Act2 and then not Is_Act1 then
1995 return It2;
1997 elsif Inherited_From_Actual (Nam1)
1998 and then Comes_From_Source (Nam2)
1999 then
2000 return It2;
2002 elsif Inherited_From_Actual (Nam2)
2003 and then Comes_From_Source (Nam1)
2004 then
2005 return It1;
2006 end if;
2008 -- In the case of a renamed subprogram, pick up the entity
2009 -- of the renaming declaration so we can traverse its
2010 -- formal parameters.
2012 if Nkind (N) in N_Has_Entity then
2013 Renam := Defining_Unit_Name (Specification (Parent (N)));
2014 end if;
2016 if Present (Renam) then
2017 Actual := First_Formal (Renam);
2018 else
2019 Actual := First_Actual (N);
2020 end if;
2022 Formal := First_Formal (Nam1);
2023 while Present (Actual) loop
2024 if Etype (Actual) /= Etype (Formal) then
2025 return It2;
2026 end if;
2028 if Present (Renam) then
2029 Next_Formal (Actual);
2030 else
2031 Next_Actual (Actual);
2032 end if;
2034 Next_Formal (Formal);
2035 end loop;
2037 return It1;
2038 end;
2040 elsif Nkind (N) in N_Binary_Op then
2041 if Matches (N, Nam1) then
2042 return It1;
2043 else
2044 return It2;
2045 end if;
2047 elsif Nkind (N) in N_Unary_Op then
2048 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
2049 return It1;
2050 else
2051 return It2;
2052 end if;
2054 else
2055 return Remove_Conversions;
2056 end if;
2057 else
2058 return Remove_Conversions;
2059 end if;
2060 end if;
2062 -- An implicit concatenation operator on a string type cannot be
2063 -- disambiguated from the predefined concatenation. This can only
2064 -- happen with concatenation of string literals.
2066 if Chars (User_Subp) = Name_Op_Concat
2067 and then Ekind (User_Subp) = E_Operator
2068 and then Is_String_Type (Etype (First_Formal (User_Subp)))
2069 then
2070 return No_Interp;
2072 -- If the user-defined operator is in an open scope, or in the scope
2073 -- of the resulting type, or given by an expanded name that names its
2074 -- scope, it hides the predefined operator for the type. Exponentiation
2075 -- has to be special-cased because the implicit operator does not have
2076 -- a symmetric signature, and may not be hidden by the explicit one.
2078 elsif (Nkind (N) = N_Function_Call
2079 and then Nkind (Name (N)) = N_Expanded_Name
2080 and then (Chars (Predef_Subp) /= Name_Op_Expon
2081 or else Hides_Op (User_Subp, Predef_Subp))
2082 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
2083 or else Hides_Op (User_Subp, Predef_Subp)
2084 then
2085 if It1.Nam = User_Subp then
2086 return It1;
2087 else
2088 return It2;
2089 end if;
2091 -- Otherwise, the predefined operator has precedence, or if the user-
2092 -- defined operation is directly visible we have a true ambiguity.
2094 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2095 -- exclude the universal_fixed operator, which often causes ambiguities
2096 -- in legacy code.
2098 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2099 -- on a partial view that is completed with a fixed point type. See
2100 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2101 -- user-defined type and subprogram, so that a client of the package
2102 -- has the same resolution as the body of the package.
2104 else
2105 if (In_Open_Scopes (Scope (User_Subp))
2106 or else Is_Potentially_Use_Visible (User_Subp))
2107 and then not In_Instance
2108 then
2109 if Is_Fixed_Point_Type (Typ)
2110 and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide)
2111 and then
2112 (Ada_Version = Ada_83
2113 or else (Ada_Version >= Ada_2012
2114 and then In_Same_Declaration_List
2115 (First_Subtype (Typ),
2116 Unit_Declaration_Node (User_Subp))))
2117 then
2118 if It2.Nam = Predef_Subp then
2119 return It1;
2120 else
2121 return It2;
2122 end if;
2124 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
2125 -- states that the operator defined in Standard is not available
2126 -- if there is a user-defined equality with the proper signature,
2127 -- declared in the same declarative list as the type. The node
2128 -- may be an operator or a function call.
2130 elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne)
2131 and then Ada_Version >= Ada_2005
2132 and then Etype (User_Subp) = Standard_Boolean
2133 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
2134 and then
2135 In_Same_Declaration_List
2136 (Designated_Type (Operand_Type),
2137 Unit_Declaration_Node (User_Subp))
2138 then
2139 if It2.Nam = Predef_Subp then
2140 return It1;
2141 else
2142 return It2;
2143 end if;
2145 -- An immediately visible operator hides a use-visible user-
2146 -- defined operation. This disambiguation cannot take place
2147 -- earlier because the visibility of the predefined operator
2148 -- can only be established when operand types are known.
2150 elsif Ekind (User_Subp) = E_Function
2151 and then Ekind (Predef_Subp) = E_Operator
2152 and then Nkind (N) in N_Op
2153 and then not Is_Overloaded (Right_Opnd (N))
2154 and then
2155 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N))))
2156 and then Is_Potentially_Use_Visible (User_Subp)
2157 then
2158 if It2.Nam = Predef_Subp then
2159 return It1;
2160 else
2161 return It2;
2162 end if;
2164 else
2165 return No_Interp;
2166 end if;
2168 elsif It1.Nam = Predef_Subp then
2169 return It1;
2171 else
2172 return It2;
2173 end if;
2174 end if;
2175 end Disambiguate;
2177 ---------------------
2178 -- End_Interp_List --
2179 ---------------------
2181 procedure End_Interp_List is
2182 begin
2183 All_Interp.Table (All_Interp.Last) := No_Interp;
2184 All_Interp.Increment_Last;
2185 end End_Interp_List;
2187 -------------------------
2188 -- Entity_Matches_Spec --
2189 -------------------------
2191 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
2192 begin
2193 -- Simple case: same entity kinds, type conformance is required. A
2194 -- parameterless function can also rename a literal.
2196 if Ekind (Old_S) = Ekind (New_S)
2197 or else (Ekind (New_S) = E_Function
2198 and then Ekind (Old_S) = E_Enumeration_Literal)
2199 then
2200 return Type_Conformant (New_S, Old_S);
2202 elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
2203 return Operator_Matches_Spec (Old_S, New_S);
2205 elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then
2206 return Type_Conformant (New_S, Old_S);
2208 else
2209 return False;
2210 end if;
2211 end Entity_Matches_Spec;
2213 ----------------------
2214 -- Find_Unique_Type --
2215 ----------------------
2217 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
2218 T : constant Entity_Id := Etype (L);
2219 I : Interp_Index;
2220 It : Interp;
2221 TR : Entity_Id := Any_Type;
2223 begin
2224 if Is_Overloaded (R) then
2225 Get_First_Interp (R, I, It);
2226 while Present (It.Typ) loop
2227 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
2229 -- If several interpretations are possible and L is universal,
2230 -- apply preference rule.
2232 if TR /= Any_Type then
2233 if (T = Universal_Integer or else T = Universal_Real)
2234 and then It.Typ = T
2235 then
2236 TR := It.Typ;
2237 end if;
2239 else
2240 TR := It.Typ;
2241 end if;
2242 end if;
2244 Get_Next_Interp (I, It);
2245 end loop;
2247 Set_Etype (R, TR);
2249 -- In the non-overloaded case, the Etype of R is already set correctly
2251 else
2252 null;
2253 end if;
2255 -- If one of the operands is Universal_Fixed, the type of the other
2256 -- operand provides the context.
2258 if Etype (R) = Universal_Fixed then
2259 return T;
2261 elsif T = Universal_Fixed then
2262 return Etype (R);
2264 -- Ada 2005 (AI-230): Support the following operators:
2266 -- function "=" (L, R : universal_access) return Boolean;
2267 -- function "/=" (L, R : universal_access) return Boolean;
2269 -- Pool specific access types (E_Access_Type) are not covered by these
2270 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2271 -- of the equality operators for universal_access shall be convertible
2272 -- to one another (see 4.6)". For example, considering the type decla-
2273 -- ration "type P is access Integer" and an anonymous access to Integer,
2274 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2275 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2277 elsif Ada_Version >= Ada_2005
2278 and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
2279 E_Anonymous_Access_Subprogram_Type)
2280 and then Is_Access_Type (Etype (R))
2281 and then Ekind (Etype (R)) /= E_Access_Type
2282 then
2283 return Etype (L);
2285 elsif Ada_Version >= Ada_2005
2286 and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
2287 E_Anonymous_Access_Subprogram_Type)
2288 and then Is_Access_Type (Etype (L))
2289 and then Ekind (Etype (L)) /= E_Access_Type
2290 then
2291 return Etype (R);
2293 -- If one operand is a raise_expression, use type of other operand
2295 elsif Nkind (L) = N_Raise_Expression then
2296 return Etype (R);
2298 else
2299 return Specific_Type (T, Etype (R));
2300 end if;
2301 end Find_Unique_Type;
2303 -------------------------------------
2304 -- Function_Interp_Has_Abstract_Op --
2305 -------------------------------------
2307 function Function_Interp_Has_Abstract_Op
2308 (N : Node_Id;
2309 E : Entity_Id) return Entity_Id
2311 Abstr_Op : Entity_Id;
2312 Act : Node_Id;
2313 Act_Parm : Node_Id;
2314 Form_Parm : Node_Id;
2316 begin
2317 -- Why is check on E needed below ???
2318 -- In any case this para needs comments ???
2320 if Is_Overloaded (N) and then Is_Overloadable (E) then
2321 Act_Parm := First_Actual (N);
2322 Form_Parm := First_Formal (E);
2323 while Present (Act_Parm) and then Present (Form_Parm) loop
2324 Act := Act_Parm;
2326 if Nkind (Act) = N_Parameter_Association then
2327 Act := Explicit_Actual_Parameter (Act);
2328 end if;
2330 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2332 if Present (Abstr_Op) then
2333 return Abstr_Op;
2334 end if;
2336 Next_Actual (Act_Parm);
2337 Next_Formal (Form_Parm);
2338 end loop;
2339 end if;
2341 return Empty;
2342 end Function_Interp_Has_Abstract_Op;
2344 ----------------------
2345 -- Get_First_Interp --
2346 ----------------------
2348 procedure Get_First_Interp
2349 (N : Node_Id;
2350 I : out Interp_Index;
2351 It : out Interp)
2353 Int_Ind : Interp_Index;
2354 Map_Ptr : Int;
2355 O_N : Node_Id;
2357 begin
2358 -- If a selected component is overloaded because the selector has
2359 -- multiple interpretations, the node is a call to a protected
2360 -- operation or an indirect call. Retrieve the interpretation from
2361 -- the selector name. The selected component may be overloaded as well
2362 -- if the prefix is overloaded. That case is unchanged.
2364 if Nkind (N) = N_Selected_Component
2365 and then Is_Overloaded (Selector_Name (N))
2366 then
2367 O_N := Selector_Name (N);
2368 else
2369 O_N := N;
2370 end if;
2372 Map_Ptr := Headers (Hash (O_N));
2373 while Map_Ptr /= No_Entry loop
2374 if Interp_Map.Table (Map_Ptr).Node = O_N then
2375 Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2376 It := All_Interp.Table (Int_Ind);
2377 I := Int_Ind;
2378 return;
2379 else
2380 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2381 end if;
2382 end loop;
2384 -- Procedure should never be called if the node has no interpretations
2386 raise Program_Error;
2387 end Get_First_Interp;
2389 ---------------------
2390 -- Get_Next_Interp --
2391 ---------------------
2393 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2394 begin
2395 I := I + 1;
2396 It := All_Interp.Table (I);
2397 end Get_Next_Interp;
2399 -------------------------
2400 -- Has_Compatible_Type --
2401 -------------------------
2403 function Has_Compatible_Type
2404 (N : Node_Id;
2405 Typ : Entity_Id) return Boolean
2407 I : Interp_Index;
2408 It : Interp;
2410 begin
2411 if N = Error then
2412 return False;
2413 end if;
2415 if Nkind (N) = N_Subtype_Indication
2416 or else not Is_Overloaded (N)
2417 then
2418 return
2419 Covers (Typ, Etype (N))
2421 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2422 -- If the type is already frozen use the corresponding_record
2423 -- to check whether it is a proper descendant.
2425 or else
2426 (Is_Record_Type (Typ)
2427 and then Is_Concurrent_Type (Etype (N))
2428 and then Present (Corresponding_Record_Type (Etype (N)))
2429 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2431 or else
2432 (Is_Concurrent_Type (Typ)
2433 and then Is_Record_Type (Etype (N))
2434 and then Present (Corresponding_Record_Type (Typ))
2435 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2437 or else
2438 (not Is_Tagged_Type (Typ)
2439 and then Ekind (Typ) /= E_Anonymous_Access_Type
2440 and then Covers (Etype (N), Typ));
2442 -- Overloaded case
2444 else
2445 Get_First_Interp (N, I, It);
2446 while Present (It.Typ) loop
2447 if (Covers (Typ, It.Typ)
2448 and then
2449 (Scope (It.Nam) /= Standard_Standard
2450 or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2452 -- Ada 2005 (AI-345)
2454 or else
2455 (Is_Concurrent_Type (It.Typ)
2456 and then Present (Corresponding_Record_Type
2457 (Etype (It.Typ)))
2458 and then Covers (Typ, Corresponding_Record_Type
2459 (Etype (It.Typ))))
2461 or else (not Is_Tagged_Type (Typ)
2462 and then Ekind (Typ) /= E_Anonymous_Access_Type
2463 and then Covers (It.Typ, Typ))
2464 then
2465 return True;
2466 end if;
2468 Get_Next_Interp (I, It);
2469 end loop;
2471 return False;
2472 end if;
2473 end Has_Compatible_Type;
2475 ---------------------
2476 -- Has_Abstract_Op --
2477 ---------------------
2479 function Has_Abstract_Op
2480 (N : Node_Id;
2481 Typ : Entity_Id) return Entity_Id
2483 I : Interp_Index;
2484 It : Interp;
2486 begin
2487 if Is_Overloaded (N) then
2488 Get_First_Interp (N, I, It);
2489 while Present (It.Nam) loop
2490 if Present (It.Abstract_Op)
2491 and then Etype (It.Abstract_Op) = Typ
2492 then
2493 return It.Abstract_Op;
2494 end if;
2496 Get_Next_Interp (I, It);
2497 end loop;
2498 end if;
2500 return Empty;
2501 end Has_Abstract_Op;
2503 ----------
2504 -- Hash --
2505 ----------
2507 function Hash (N : Node_Id) return Int is
2508 begin
2509 -- Nodes have a size that is power of two, so to select significant
2510 -- bits only we remove the low-order bits.
2512 return ((Int (N) / 2 ** 5) mod Header_Size);
2513 end Hash;
2515 --------------
2516 -- Hides_Op --
2517 --------------
2519 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2520 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2521 begin
2522 return Operator_Matches_Spec (Op, F)
2523 and then (In_Open_Scopes (Scope (F))
2524 or else Scope (F) = Scope (Btyp)
2525 or else (not In_Open_Scopes (Scope (Btyp))
2526 and then not In_Use (Btyp)
2527 and then not In_Use (Scope (Btyp))));
2528 end Hides_Op;
2530 ------------------------
2531 -- Init_Interp_Tables --
2532 ------------------------
2534 procedure Init_Interp_Tables is
2535 begin
2536 All_Interp.Init;
2537 Interp_Map.Init;
2538 Headers := (others => No_Entry);
2539 end Init_Interp_Tables;
2541 -----------------------------------
2542 -- Interface_Present_In_Ancestor --
2543 -----------------------------------
2545 function Interface_Present_In_Ancestor
2546 (Typ : Entity_Id;
2547 Iface : Entity_Id) return Boolean
2549 Target_Typ : Entity_Id;
2550 Iface_Typ : Entity_Id;
2552 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2553 -- Returns True if Typ or some ancestor of Typ implements Iface
2555 -------------------------------
2556 -- Iface_Present_In_Ancestor --
2557 -------------------------------
2559 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2560 E : Entity_Id;
2561 AI : Entity_Id;
2562 Elmt : Elmt_Id;
2564 begin
2565 if Typ = Iface_Typ then
2566 return True;
2567 end if;
2569 -- Handle private types
2571 if Present (Full_View (Typ))
2572 and then not Is_Concurrent_Type (Full_View (Typ))
2573 then
2574 E := Full_View (Typ);
2575 else
2576 E := Typ;
2577 end if;
2579 loop
2580 if Present (Interfaces (E))
2581 and then not Is_Empty_Elmt_List (Interfaces (E))
2582 then
2583 Elmt := First_Elmt (Interfaces (E));
2584 while Present (Elmt) loop
2585 AI := Node (Elmt);
2587 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2588 return True;
2589 end if;
2591 Next_Elmt (Elmt);
2592 end loop;
2593 end if;
2595 exit when Etype (E) = E
2597 -- Handle private types
2599 or else (Present (Full_View (Etype (E)))
2600 and then Full_View (Etype (E)) = E);
2602 -- Check if the current type is a direct derivation of the
2603 -- interface
2605 if Etype (E) = Iface_Typ then
2606 return True;
2607 end if;
2609 -- Climb to the immediate ancestor handling private types
2611 if Present (Full_View (Etype (E))) then
2612 E := Full_View (Etype (E));
2613 else
2614 E := Etype (E);
2615 end if;
2616 end loop;
2618 return False;
2619 end Iface_Present_In_Ancestor;
2621 -- Start of processing for Interface_Present_In_Ancestor
2623 begin
2624 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2626 if Is_Class_Wide_Type (Iface) then
2627 Iface_Typ := Etype (Base_Type (Iface));
2628 else
2629 Iface_Typ := Iface;
2630 end if;
2632 -- Handle subtypes
2634 Iface_Typ := Base_Type (Iface_Typ);
2636 if Is_Access_Type (Typ) then
2637 Target_Typ := Etype (Directly_Designated_Type (Typ));
2638 else
2639 Target_Typ := Typ;
2640 end if;
2642 if Is_Concurrent_Record_Type (Target_Typ) then
2643 Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2644 end if;
2646 Target_Typ := Base_Type (Target_Typ);
2648 -- In case of concurrent types we can't use the Corresponding Record_Typ
2649 -- to look for the interface because it is built by the expander (and
2650 -- hence it is not always available). For this reason we traverse the
2651 -- list of interfaces (available in the parent of the concurrent type)
2653 if Is_Concurrent_Type (Target_Typ) then
2654 if Present (Interface_List (Parent (Target_Typ))) then
2655 declare
2656 AI : Node_Id;
2658 begin
2659 AI := First (Interface_List (Parent (Target_Typ)));
2661 -- The progenitor itself may be a subtype of an interface type.
2663 while Present (AI) loop
2664 if Etype (AI) = Iface_Typ
2665 or else Base_Type (Etype (AI)) = Iface_Typ
2666 then
2667 return True;
2669 elsif Present (Interfaces (Etype (AI)))
2670 and then Iface_Present_In_Ancestor (Etype (AI))
2671 then
2672 return True;
2673 end if;
2675 Next (AI);
2676 end loop;
2677 end;
2678 end if;
2680 return False;
2681 end if;
2683 if Is_Class_Wide_Type (Target_Typ) then
2684 Target_Typ := Etype (Target_Typ);
2685 end if;
2687 if Ekind (Target_Typ) = E_Incomplete_Type then
2689 -- We must have either a full view or a nonlimited view of the type
2690 -- to locate the list of ancestors.
2692 if Present (Full_View (Target_Typ)) then
2693 Target_Typ := Full_View (Target_Typ);
2694 else
2695 pragma Assert (Present (Non_Limited_View (Target_Typ)));
2696 Target_Typ := Non_Limited_View (Target_Typ);
2697 end if;
2699 -- Protect the front end against previously detected errors
2701 if Ekind (Target_Typ) = E_Incomplete_Type then
2702 return False;
2703 end if;
2704 end if;
2706 return Iface_Present_In_Ancestor (Target_Typ);
2707 end Interface_Present_In_Ancestor;
2709 ---------------------
2710 -- Intersect_Types --
2711 ---------------------
2713 function Intersect_Types (L, R : Node_Id) return Entity_Id is
2714 Index : Interp_Index;
2715 It : Interp;
2716 Typ : Entity_Id;
2718 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2719 -- Find interpretation of right arg that has type compatible with T
2721 --------------------------
2722 -- Check_Right_Argument --
2723 --------------------------
2725 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2726 Index : Interp_Index;
2727 It : Interp;
2728 T2 : Entity_Id;
2730 begin
2731 if not Is_Overloaded (R) then
2732 return Specific_Type (T, Etype (R));
2734 else
2735 Get_First_Interp (R, Index, It);
2736 loop
2737 T2 := Specific_Type (T, It.Typ);
2739 if T2 /= Any_Type then
2740 return T2;
2741 end if;
2743 Get_Next_Interp (Index, It);
2744 exit when No (It.Typ);
2745 end loop;
2747 return Any_Type;
2748 end if;
2749 end Check_Right_Argument;
2751 -- Start of processing for Intersect_Types
2753 begin
2754 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2755 return Any_Type;
2756 end if;
2758 if not Is_Overloaded (L) then
2759 Typ := Check_Right_Argument (Etype (L));
2761 else
2762 Typ := Any_Type;
2763 Get_First_Interp (L, Index, It);
2764 while Present (It.Typ) loop
2765 Typ := Check_Right_Argument (It.Typ);
2766 exit when Typ /= Any_Type;
2767 Get_Next_Interp (Index, It);
2768 end loop;
2770 end if;
2772 -- If Typ is Any_Type, it means no compatible pair of types was found
2774 if Typ = Any_Type then
2775 if Nkind (Parent (L)) in N_Op then
2776 Error_Msg_N ("incompatible types for operator", Parent (L));
2778 elsif Nkind (Parent (L)) = N_Range then
2779 Error_Msg_N ("incompatible types given in constraint", Parent (L));
2781 -- Ada 2005 (AI-251): Complete the error notification
2783 elsif Is_Class_Wide_Type (Etype (R))
2784 and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2785 then
2786 Error_Msg_NE ("(Ada 2005) does not implement interface }",
2787 L, Etype (Class_Wide_Type (Etype (R))));
2789 -- Specialize message if one operand is a limited view, a priori
2790 -- unrelated to all other types.
2792 elsif From_Limited_With (Etype (R)) then
2793 Error_Msg_NE ("limited view of& not compatible with context",
2794 R, Etype (R));
2796 elsif From_Limited_With (Etype (L)) then
2797 Error_Msg_NE ("limited view of& not compatible with context",
2798 L, Etype (L));
2799 else
2800 Error_Msg_N ("incompatible types", Parent (L));
2801 end if;
2802 end if;
2804 return Typ;
2805 end Intersect_Types;
2807 -----------------------
2808 -- In_Generic_Actual --
2809 -----------------------
2811 function In_Generic_Actual (Exp : Node_Id) return Boolean is
2812 Par : constant Node_Id := Parent (Exp);
2814 begin
2815 if No (Par) then
2816 return False;
2818 elsif Nkind (Par) in N_Declaration then
2819 if Nkind (Par) = N_Object_Declaration then
2820 return Present (Corresponding_Generic_Association (Par));
2821 else
2822 return False;
2823 end if;
2825 elsif Nkind (Par) = N_Object_Renaming_Declaration then
2826 return Present (Corresponding_Generic_Association (Par));
2828 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2829 return False;
2831 else
2832 return In_Generic_Actual (Parent (Par));
2833 end if;
2834 end In_Generic_Actual;
2836 -----------------
2837 -- Is_Ancestor --
2838 -----------------
2840 function Is_Ancestor
2841 (T1 : Entity_Id;
2842 T2 : Entity_Id;
2843 Use_Full_View : Boolean := False) return Boolean
2845 BT1 : Entity_Id;
2846 BT2 : Entity_Id;
2847 Par : Entity_Id;
2849 begin
2850 BT1 := Base_Type (T1);
2851 BT2 := Base_Type (T2);
2853 -- Handle underlying view of records with unknown discriminants using
2854 -- the original entity that motivated the construction of this
2855 -- underlying record view (see Build_Derived_Private_Type).
2857 if Is_Underlying_Record_View (BT1) then
2858 BT1 := Underlying_Record_View (BT1);
2859 end if;
2861 if Is_Underlying_Record_View (BT2) then
2862 BT2 := Underlying_Record_View (BT2);
2863 end if;
2865 if BT1 = BT2 then
2866 return True;
2868 -- The predicate must look past privacy
2870 elsif Is_Private_Type (T1)
2871 and then Present (Full_View (T1))
2872 and then BT2 = Base_Type (Full_View (T1))
2873 then
2874 return True;
2876 elsif Is_Private_Type (T2)
2877 and then Present (Full_View (T2))
2878 and then BT1 = Base_Type (Full_View (T2))
2879 then
2880 return True;
2882 else
2883 -- Obtain the parent of the base type of T2 (use the full view if
2884 -- allowed).
2886 if Use_Full_View
2887 and then Is_Private_Type (BT2)
2888 and then Present (Full_View (BT2))
2889 then
2890 -- No climbing needed if its full view is the root type
2892 if Full_View (BT2) = Root_Type (Full_View (BT2)) then
2893 return False;
2894 end if;
2896 Par := Etype (Full_View (BT2));
2898 else
2899 Par := Etype (BT2);
2900 end if;
2902 loop
2903 -- If there was a error on the type declaration, do not recurse
2905 if Error_Posted (Par) then
2906 return False;
2908 elsif BT1 = Base_Type (Par)
2909 or else (Is_Private_Type (T1)
2910 and then Present (Full_View (T1))
2911 and then Base_Type (Par) = Base_Type (Full_View (T1)))
2912 then
2913 return True;
2915 elsif Is_Private_Type (Par)
2916 and then Present (Full_View (Par))
2917 and then Full_View (Par) = BT1
2918 then
2919 return True;
2921 -- Root type found
2923 elsif Par = Root_Type (Par) then
2924 return False;
2926 -- Continue climbing
2928 else
2929 -- Use the full-view of private types (if allowed)
2931 if Use_Full_View
2932 and then Is_Private_Type (Par)
2933 and then Present (Full_View (Par))
2934 then
2935 Par := Etype (Full_View (Par));
2936 else
2937 Par := Etype (Par);
2938 end if;
2939 end if;
2940 end loop;
2941 end if;
2942 end Is_Ancestor;
2944 ---------------------------
2945 -- Is_Invisible_Operator --
2946 ---------------------------
2948 function Is_Invisible_Operator
2949 (N : Node_Id;
2950 T : Entity_Id) return Boolean
2952 Orig_Node : constant Node_Id := Original_Node (N);
2954 begin
2955 if Nkind (N) not in N_Op then
2956 return False;
2958 elsif not Comes_From_Source (N) then
2959 return False;
2961 elsif No (Universal_Interpretation (Right_Opnd (N))) then
2962 return False;
2964 elsif Nkind (N) in N_Binary_Op
2965 and then No (Universal_Interpretation (Left_Opnd (N)))
2966 then
2967 return False;
2969 else
2970 return Is_Numeric_Type (T)
2971 and then not In_Open_Scopes (Scope (T))
2972 and then not Is_Potentially_Use_Visible (T)
2973 and then not In_Use (T)
2974 and then not In_Use (Scope (T))
2975 and then
2976 (Nkind (Orig_Node) /= N_Function_Call
2977 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2978 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2979 and then not In_Instance;
2980 end if;
2981 end Is_Invisible_Operator;
2983 --------------------
2984 -- Is_Progenitor --
2985 --------------------
2987 function Is_Progenitor
2988 (Iface : Entity_Id;
2989 Typ : Entity_Id) return Boolean
2991 begin
2992 return Implements_Interface (Typ, Iface, Exclude_Parents => True);
2993 end Is_Progenitor;
2995 -------------------
2996 -- Is_Subtype_Of --
2997 -------------------
2999 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
3000 S : Entity_Id;
3002 begin
3003 S := Ancestor_Subtype (T1);
3004 while Present (S) loop
3005 if S = T2 then
3006 return True;
3007 else
3008 S := Ancestor_Subtype (S);
3009 end if;
3010 end loop;
3012 return False;
3013 end Is_Subtype_Of;
3015 ------------------
3016 -- List_Interps --
3017 ------------------
3019 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
3020 Index : Interp_Index;
3021 It : Interp;
3023 begin
3024 Get_First_Interp (Nam, Index, It);
3025 while Present (It.Nam) loop
3026 if Scope (It.Nam) = Standard_Standard
3027 and then Scope (It.Typ) /= Standard_Standard
3028 then
3029 Error_Msg_Sloc := Sloc (Parent (It.Typ));
3030 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
3032 else
3033 Error_Msg_Sloc := Sloc (It.Nam);
3034 Error_Msg_NE ("\\& declared#!", Err, It.Nam);
3035 end if;
3037 Get_Next_Interp (Index, It);
3038 end loop;
3039 end List_Interps;
3041 -----------------
3042 -- New_Interps --
3043 -----------------
3045 procedure New_Interps (N : Node_Id) is
3046 Map_Ptr : Int;
3048 begin
3049 All_Interp.Append (No_Interp);
3051 Map_Ptr := Headers (Hash (N));
3053 if Map_Ptr = No_Entry then
3055 -- Place new node at end of table
3057 Interp_Map.Increment_Last;
3058 Headers (Hash (N)) := Interp_Map.Last;
3060 else
3061 -- Place node at end of chain, or locate its previous entry
3063 loop
3064 if Interp_Map.Table (Map_Ptr).Node = N then
3066 -- Node is already in the table, and is being rewritten.
3067 -- Start a new interp section, retain hash link.
3069 Interp_Map.Table (Map_Ptr).Node := N;
3070 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
3071 Set_Is_Overloaded (N, True);
3072 return;
3074 else
3075 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
3076 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3077 end if;
3078 end loop;
3080 -- Chain the new node
3082 Interp_Map.Increment_Last;
3083 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
3084 end if;
3086 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
3087 Set_Is_Overloaded (N, True);
3088 end New_Interps;
3090 ---------------------------
3091 -- Operator_Matches_Spec --
3092 ---------------------------
3094 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
3095 New_First_F : constant Entity_Id := First_Formal (New_S);
3096 Op_Name : constant Name_Id := Chars (Op);
3097 T : constant Entity_Id := Etype (New_S);
3098 New_F : Entity_Id;
3099 Num : Nat;
3100 Old_F : Entity_Id;
3101 T1 : Entity_Id;
3102 T2 : Entity_Id;
3104 begin
3105 -- To verify that a predefined operator matches a given signature, do a
3106 -- case analysis of the operator classes. Function can have one or two
3107 -- formals and must have the proper result type.
3109 New_F := New_First_F;
3110 Old_F := First_Formal (Op);
3111 Num := 0;
3112 while Present (New_F) and then Present (Old_F) loop
3113 Num := Num + 1;
3114 Next_Formal (New_F);
3115 Next_Formal (Old_F);
3116 end loop;
3118 -- Definite mismatch if different number of parameters
3120 if Present (Old_F) or else Present (New_F) then
3121 return False;
3123 -- Unary operators
3125 elsif Num = 1 then
3126 T1 := Etype (New_First_F);
3128 if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then
3129 return Base_Type (T1) = Base_Type (T)
3130 and then Is_Numeric_Type (T);
3132 elsif Op_Name = Name_Op_Not then
3133 return Base_Type (T1) = Base_Type (T)
3134 and then Valid_Boolean_Arg (Base_Type (T));
3136 else
3137 return False;
3138 end if;
3140 -- Binary operators
3142 else
3143 T1 := Etype (New_First_F);
3144 T2 := Etype (Next_Formal (New_First_F));
3146 if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then
3147 return Base_Type (T1) = Base_Type (T2)
3148 and then Base_Type (T1) = Base_Type (T)
3149 and then Valid_Boolean_Arg (Base_Type (T));
3151 elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then
3152 return Base_Type (T1) = Base_Type (T2)
3153 and then not Is_Limited_Type (T1)
3154 and then Is_Boolean_Type (T);
3156 elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le,
3157 Name_Op_Gt, Name_Op_Ge)
3158 then
3159 return Base_Type (T1) = Base_Type (T2)
3160 and then Valid_Comparison_Arg (T1)
3161 and then Is_Boolean_Type (T);
3163 elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then
3164 return Base_Type (T1) = Base_Type (T2)
3165 and then Base_Type (T1) = Base_Type (T)
3166 and then Is_Numeric_Type (T);
3168 -- For division and multiplication, a user-defined function does not
3169 -- match the predefined universal_fixed operation, except in Ada 83.
3171 elsif Op_Name = Name_Op_Divide then
3172 return (Base_Type (T1) = Base_Type (T2)
3173 and then Base_Type (T1) = Base_Type (T)
3174 and then Is_Numeric_Type (T)
3175 and then (not Is_Fixed_Point_Type (T)
3176 or else Ada_Version = Ada_83))
3178 -- Mixed_Mode operations on fixed-point types
3180 or else (Base_Type (T1) = Base_Type (T)
3181 and then Base_Type (T2) = Base_Type (Standard_Integer)
3182 and then Is_Fixed_Point_Type (T))
3184 -- A user defined operator can also match (and hide) a mixed
3185 -- operation on universal literals.
3187 or else (Is_Integer_Type (T2)
3188 and then Is_Floating_Point_Type (T1)
3189 and then Base_Type (T1) = Base_Type (T));
3191 elsif Op_Name = Name_Op_Multiply then
3192 return (Base_Type (T1) = Base_Type (T2)
3193 and then Base_Type (T1) = Base_Type (T)
3194 and then Is_Numeric_Type (T)
3195 and then (not Is_Fixed_Point_Type (T)
3196 or else Ada_Version = Ada_83))
3198 -- Mixed_Mode operations on fixed-point types
3200 or else (Base_Type (T1) = Base_Type (T)
3201 and then Base_Type (T2) = Base_Type (Standard_Integer)
3202 and then Is_Fixed_Point_Type (T))
3204 or else (Base_Type (T2) = Base_Type (T)
3205 and then Base_Type (T1) = Base_Type (Standard_Integer)
3206 and then Is_Fixed_Point_Type (T))
3208 or else (Is_Integer_Type (T2)
3209 and then Is_Floating_Point_Type (T1)
3210 and then Base_Type (T1) = Base_Type (T))
3212 or else (Is_Integer_Type (T1)
3213 and then Is_Floating_Point_Type (T2)
3214 and then Base_Type (T2) = Base_Type (T));
3216 elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then
3217 return Base_Type (T1) = Base_Type (T2)
3218 and then Base_Type (T1) = Base_Type (T)
3219 and then Is_Integer_Type (T);
3221 elsif Op_Name = Name_Op_Expon then
3222 return Base_Type (T1) = Base_Type (T)
3223 and then Is_Numeric_Type (T)
3224 and then Base_Type (T2) = Base_Type (Standard_Integer);
3226 elsif Op_Name = Name_Op_Concat then
3227 return Is_Array_Type (T)
3228 and then (Base_Type (T) = Base_Type (Etype (Op)))
3229 and then (Base_Type (T1) = Base_Type (T)
3230 or else
3231 Base_Type (T1) = Base_Type (Component_Type (T)))
3232 and then (Base_Type (T2) = Base_Type (T)
3233 or else
3234 Base_Type (T2) = Base_Type (Component_Type (T)));
3236 else
3237 return False;
3238 end if;
3239 end if;
3240 end Operator_Matches_Spec;
3242 -------------------
3243 -- Remove_Interp --
3244 -------------------
3246 procedure Remove_Interp (I : in out Interp_Index) is
3247 II : Interp_Index;
3249 begin
3250 -- Find end of interp list and copy downward to erase the discarded one
3252 II := I + 1;
3253 while Present (All_Interp.Table (II).Typ) loop
3254 II := II + 1;
3255 end loop;
3257 for J in I + 1 .. II loop
3258 All_Interp.Table (J - 1) := All_Interp.Table (J);
3259 end loop;
3261 -- Back up interp index to insure that iterator will pick up next
3262 -- available interpretation.
3264 I := I - 1;
3265 end Remove_Interp;
3267 ------------------
3268 -- Save_Interps --
3269 ------------------
3271 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
3272 Map_Ptr : Int;
3273 O_N : Node_Id := Old_N;
3275 begin
3276 if Is_Overloaded (Old_N) then
3277 Set_Is_Overloaded (New_N);
3279 if Nkind (Old_N) = N_Selected_Component
3280 and then Is_Overloaded (Selector_Name (Old_N))
3281 then
3282 O_N := Selector_Name (Old_N);
3283 end if;
3285 Map_Ptr := Headers (Hash (O_N));
3287 while Interp_Map.Table (Map_Ptr).Node /= O_N loop
3288 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3289 pragma Assert (Map_Ptr /= No_Entry);
3290 end loop;
3292 New_Interps (New_N);
3293 Interp_Map.Table (Interp_Map.Last).Index :=
3294 Interp_Map.Table (Map_Ptr).Index;
3295 end if;
3296 end Save_Interps;
3298 -------------------
3299 -- Specific_Type --
3300 -------------------
3302 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
3303 T1 : constant Entity_Id := Available_View (Typ_1);
3304 T2 : constant Entity_Id := Available_View (Typ_2);
3305 B1 : constant Entity_Id := Base_Type (T1);
3306 B2 : constant Entity_Id := Base_Type (T2);
3308 function Is_Remote_Access (T : Entity_Id) return Boolean;
3309 -- Check whether T is the equivalent type of a remote access type.
3310 -- If distribution is enabled, T is a legal context for Null.
3312 ----------------------
3313 -- Is_Remote_Access --
3314 ----------------------
3316 function Is_Remote_Access (T : Entity_Id) return Boolean is
3317 begin
3318 return Is_Record_Type (T)
3319 and then (Is_Remote_Call_Interface (T)
3320 or else Is_Remote_Types (T))
3321 and then Present (Corresponding_Remote_Type (T))
3322 and then Is_Access_Type (Corresponding_Remote_Type (T));
3323 end Is_Remote_Access;
3325 -- Start of processing for Specific_Type
3327 begin
3328 if T1 = Any_Type or else T2 = Any_Type then
3329 return Any_Type;
3330 end if;
3332 if B1 = B2 then
3333 return B1;
3335 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
3336 or else (T1 = Universal_Real and then Is_Real_Type (T2))
3337 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
3338 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
3339 then
3340 return B2;
3342 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
3343 or else (T2 = Universal_Real and then Is_Real_Type (T1))
3344 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
3345 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
3346 then
3347 return B1;
3349 elsif T2 = Any_String and then Is_String_Type (T1) then
3350 return B1;
3352 elsif T1 = Any_String and then Is_String_Type (T2) then
3353 return B2;
3355 elsif T2 = Any_Character and then Is_Character_Type (T1) then
3356 return B1;
3358 elsif T1 = Any_Character and then Is_Character_Type (T2) then
3359 return B2;
3361 elsif T1 = Any_Access
3362 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3363 then
3364 return T2;
3366 elsif T2 = Any_Access
3367 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3368 then
3369 return T1;
3371 -- In an instance, the specific type may have a private view. Use full
3372 -- view to check legality.
3374 elsif T2 = Any_Access
3375 and then Is_Private_Type (T1)
3376 and then Present (Full_View (T1))
3377 and then Is_Access_Type (Full_View (T1))
3378 and then In_Instance
3379 then
3380 return T1;
3382 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
3383 return T1;
3385 elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then
3386 return T2;
3388 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3389 return T2;
3391 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3392 return T1;
3394 -- ----------------------------------------------------------
3395 -- Special cases for equality operators (all other predefined
3396 -- operators can never apply to tagged types)
3397 -- ----------------------------------------------------------
3399 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3400 -- interface
3402 elsif Is_Class_Wide_Type (T1)
3403 and then Is_Class_Wide_Type (T2)
3404 and then Is_Interface (Etype (T2))
3405 then
3406 return T1;
3408 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3409 -- class-wide interface T2
3411 elsif Is_Class_Wide_Type (T2)
3412 and then Is_Interface (Etype (T2))
3413 and then Interface_Present_In_Ancestor (Typ => T1,
3414 Iface => Etype (T2))
3415 then
3416 return T1;
3418 elsif Is_Class_Wide_Type (T1)
3419 and then Is_Ancestor (Root_Type (T1), T2)
3420 then
3421 return T1;
3423 elsif Is_Class_Wide_Type (T2)
3424 and then Is_Ancestor (Root_Type (T2), T1)
3425 then
3426 return T2;
3428 elsif Ekind_In (B1, E_Access_Subprogram_Type,
3429 E_Access_Protected_Subprogram_Type)
3430 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3431 and then Is_Access_Type (T2)
3432 then
3433 return T2;
3435 elsif Ekind_In (B2, E_Access_Subprogram_Type,
3436 E_Access_Protected_Subprogram_Type)
3437 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3438 and then Is_Access_Type (T1)
3439 then
3440 return T1;
3442 elsif Ekind_In (T1, E_Allocator_Type,
3443 E_Access_Attribute_Type,
3444 E_Anonymous_Access_Type)
3445 and then Is_Access_Type (T2)
3446 then
3447 return T2;
3449 elsif Ekind_In (T2, E_Allocator_Type,
3450 E_Access_Attribute_Type,
3451 E_Anonymous_Access_Type)
3452 and then Is_Access_Type (T1)
3453 then
3454 return T1;
3456 -- If none of the above cases applies, types are not compatible
3458 else
3459 return Any_Type;
3460 end if;
3461 end Specific_Type;
3463 ---------------------
3464 -- Set_Abstract_Op --
3465 ---------------------
3467 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3468 begin
3469 All_Interp.Table (I).Abstract_Op := V;
3470 end Set_Abstract_Op;
3472 -----------------------
3473 -- Valid_Boolean_Arg --
3474 -----------------------
3476 -- In addition to booleans and arrays of booleans, we must include
3477 -- aggregates as valid boolean arguments, because in the first pass of
3478 -- resolution their components are not examined. If it turns out not to be
3479 -- an aggregate of booleans, this will be diagnosed in Resolve.
3480 -- Any_Composite must be checked for prior to the array type checks because
3481 -- Any_Composite does not have any associated indexes.
3483 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3484 begin
3485 if Is_Boolean_Type (T)
3486 or else Is_Modular_Integer_Type (T)
3487 or else T = Universal_Integer
3488 or else T = Any_Composite
3489 then
3490 return True;
3492 elsif Is_Array_Type (T)
3493 and then T /= Any_String
3494 and then Number_Dimensions (T) = 1
3495 and then Is_Boolean_Type (Component_Type (T))
3496 and then
3497 ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T))
3498 or else In_Instance
3499 or else Available_Full_View_Of_Component (T))
3500 then
3501 return True;
3503 else
3504 return False;
3505 end if;
3506 end Valid_Boolean_Arg;
3508 --------------------------
3509 -- Valid_Comparison_Arg --
3510 --------------------------
3512 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3513 begin
3515 if T = Any_Composite then
3516 return False;
3518 elsif Is_Discrete_Type (T)
3519 or else Is_Real_Type (T)
3520 then
3521 return True;
3523 elsif Is_Array_Type (T)
3524 and then Number_Dimensions (T) = 1
3525 and then Is_Discrete_Type (Component_Type (T))
3526 and then (not Is_Private_Composite (T) or else In_Instance)
3527 and then (not Is_Limited_Composite (T) or else In_Instance)
3528 then
3529 return True;
3531 elsif Is_Array_Type (T)
3532 and then Number_Dimensions (T) = 1
3533 and then Is_Discrete_Type (Component_Type (T))
3534 and then Available_Full_View_Of_Component (T)
3535 then
3536 return True;
3538 elsif Is_String_Type (T) then
3539 return True;
3540 else
3541 return False;
3542 end if;
3543 end Valid_Comparison_Arg;
3545 ------------------
3546 -- Write_Interp --
3547 ------------------
3549 procedure Write_Interp (It : Interp) is
3550 begin
3551 Write_Str ("Nam: ");
3552 Print_Tree_Node (It.Nam);
3553 Write_Str ("Typ: ");
3554 Print_Tree_Node (It.Typ);
3555 Write_Str ("Abstract_Op: ");
3556 Print_Tree_Node (It.Abstract_Op);
3557 end Write_Interp;
3559 ----------------------
3560 -- Write_Interp_Ref --
3561 ----------------------
3563 procedure Write_Interp_Ref (Map_Ptr : Int) is
3564 begin
3565 Write_Str (" Node: ");
3566 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3567 Write_Str (" Index: ");
3568 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3569 Write_Str (" Next: ");
3570 Write_Int (Interp_Map.Table (Map_Ptr).Next);
3571 Write_Eol;
3572 end Write_Interp_Ref;
3574 ---------------------
3575 -- Write_Overloads --
3576 ---------------------
3578 procedure Write_Overloads (N : Node_Id) is
3579 I : Interp_Index;
3580 It : Interp;
3581 Nam : Entity_Id;
3583 begin
3584 Write_Str ("Overloads: ");
3585 Print_Node_Briefly (N);
3587 if not Is_Overloaded (N) then
3588 Write_Line ("Non-overloaded entity ");
3589 Write_Entity_Info (Entity (N), " ");
3591 elsif Nkind (N) not in N_Has_Entity then
3592 Get_First_Interp (N, I, It);
3593 while Present (It.Nam) loop
3594 Write_Int (Int (It.Typ));
3595 Write_Str (" ");
3596 Write_Name (Chars (It.Typ));
3597 Write_Eol;
3598 Get_Next_Interp (I, It);
3599 end loop;
3601 else
3602 Get_First_Interp (N, I, It);
3603 Write_Line ("Overloaded entity ");
3604 Write_Line (" Name Type Abstract Op");
3605 Write_Line ("===============================================");
3606 Nam := It.Nam;
3608 while Present (Nam) loop
3609 Write_Int (Int (Nam));
3610 Write_Str (" ");
3611 Write_Name (Chars (Nam));
3612 Write_Str (" ");
3613 Write_Int (Int (It.Typ));
3614 Write_Str (" ");
3615 Write_Name (Chars (It.Typ));
3617 if Present (It.Abstract_Op) then
3618 Write_Str (" ");
3619 Write_Int (Int (It.Abstract_Op));
3620 Write_Str (" ");
3621 Write_Name (Chars (It.Abstract_Op));
3622 end if;
3624 Write_Eol;
3625 Get_Next_Interp (I, It);
3626 Nam := It.Nam;
3627 end loop;
3628 end if;
3629 end Write_Overloads;
3631 end Sem_Type;