1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
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;
34 with Namet; use Namet;
36 with Output; use Output;
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;
49 with Uintp; use Uintp;
51 package body Sem_Type is
57 -- The following data structures establish a mapping between nodes and
58 -- their interpretations. An overloaded node has an entry in Interp_Map,
59 -- which in turn contains a pointer into the All_Interp array. The
60 -- interpretations of a given node are contiguous in All_Interp. Each set
61 -- of interpretations is terminated with the marker No_Interp. In order to
62 -- speed up the retrieval of the interpretations of an overloaded node, the
63 -- Interp_Map table is accessed by means of a simple hashing scheme, and
64 -- the entries in Interp_Map are chained. The heads of clash lists are
65 -- stored in array Headers.
67 -- Headers Interp_Map All_Interp
69 -- _ +-----+ +--------+
70 -- |_| |_____| --->|interp1 |
71 -- |_|---------->|node | | |interp2 |
72 -- |_| |index|---------| |nointerp|
77 -- This scheme does not currently reclaim interpretations. In principle,
78 -- after a unit is compiled, all overloadings have been resolved, and the
79 -- candidate interpretations should be deleted. This should be easier
80 -- now than with the previous scheme???
82 package All_Interp is new Table.Table (
83 Table_Component_Type => Interp,
84 Table_Index_Type => Int,
86 Table_Initial => Alloc.All_Interp_Initial,
87 Table_Increment => Alloc.All_Interp_Increment,
88 Table_Name => "All_Interp");
90 type Interp_Ref is record
96 Header_Size : constant Int := 2 ** 12;
97 No_Entry : constant Int := -1;
98 Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
100 package Interp_Map is new Table.Table (
101 Table_Component_Type => Interp_Ref,
102 Table_Index_Type => Int,
103 Table_Low_Bound => 0,
104 Table_Initial => Alloc.Interp_Map_Initial,
105 Table_Increment => Alloc.Interp_Map_Increment,
106 Table_Name => "Interp_Map");
108 function Hash (N : Node_Id) return Int;
109 -- A trivial hashing function for nodes, used to insert an overloaded
110 -- node into the Interp_Map table.
112 -------------------------------------
113 -- Handling of Overload Resolution --
114 -------------------------------------
116 -- Overload resolution uses two passes over the syntax tree of a complete
117 -- context. In the first, bottom-up pass, the types of actuals in calls
118 -- are used to resolve possibly overloaded subprogram and operator names.
119 -- In the second top-down pass, the type of the context (for example the
120 -- condition in a while statement) is used to resolve a possibly ambiguous
121 -- call, and the unique subprogram name in turn imposes a specific context
122 -- on each of its actuals.
124 -- Most expressions are in fact unambiguous, and the bottom-up pass is
125 -- sufficient to resolve most everything. To simplify the common case,
126 -- names and expressions carry a flag Is_Overloaded to indicate whether
127 -- they have more than one interpretation. If the flag is off, then each
128 -- name has already a unique meaning and type, and the bottom-up pass is
129 -- sufficient (and much simpler).
131 --------------------------
132 -- Operator Overloading --
133 --------------------------
135 -- The visibility of operators is handled differently from that of other
136 -- entities. We do not introduce explicit versions of primitive operators
137 -- for each type definition. As a result, there is only one entity
138 -- corresponding to predefined addition on all numeric types, etc. The
139 -- back-end resolves predefined operators according to their type. The
140 -- visibility of primitive operations then reduces to the visibility of the
141 -- resulting type: (a + b) is a legal interpretation of some primitive
142 -- operator + if the type of the result (which must also be the type of a
143 -- and b) is directly visible (either immediately visible or use-visible).
145 -- User-defined operators are treated like other functions, but the
146 -- visibility of these user-defined operations must be special-cased
147 -- to determine whether they hide or are hidden by predefined operators.
148 -- The form P."+" (x, y) requires additional handling.
150 -- Concatenation is treated more conventionally: for every one-dimensional
151 -- array type we introduce a explicit concatenation operator. This is
152 -- necessary to handle the case of (element & element => array) which
153 -- cannot be handled conveniently if there is no explicit instance of
154 -- resulting type of the operation.
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure All_Overloads;
161 pragma Warnings (Off, All_Overloads);
162 -- Debugging procedure: list full contents of Overloads table
164 function Binary_Op_Interp_Has_Abstract_Op
166 E : Entity_Id) return Entity_Id;
167 -- Given the node and entity of a binary operator, determine whether the
168 -- actuals of E contain an abstract interpretation with regards to the
169 -- types of their corresponding formals. Return the abstract operation or
172 function Function_Interp_Has_Abstract_Op
174 E : Entity_Id) return Entity_Id;
175 -- Given the node and entity of a function call, determine whether the
176 -- actuals of E contain an abstract interpretation with regards to the
177 -- types of their corresponding formals. Return the abstract operation or
180 function Has_Abstract_Op
182 Typ : Entity_Id) return Entity_Id;
183 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
184 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
185 -- abstract interpretation which yields type Typ.
187 procedure New_Interps (N : Node_Id);
188 -- Initialize collection of interpretations for the given node, which is
189 -- either an overloaded entity, or an operation whose arguments have
190 -- multiple interpretations. Interpretations can be added to only one
193 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
194 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
195 -- or is not a "class" type (any_character, etc).
201 procedure Add_One_Interp
205 Opnd_Type : Entity_Id := Empty)
207 Vis_Type : Entity_Id;
209 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
210 -- Add one interpretation to an overloaded node. Add a new entry if
211 -- not hidden by previous one, and remove previous one if hidden by
214 function Is_Universal_Operation (Op : Entity_Id) return Boolean;
215 -- True if the entity is a predefined operator and the operands have
216 -- a universal Interpretation.
222 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
223 Abstr_Op : Entity_Id := Empty;
227 -- Start of processing for Add_Entry
230 -- Find out whether the new entry references interpretations that
231 -- are abstract or disabled by abstract operators.
233 if Ada_Version >= Ada_05 then
234 if Nkind (N) in N_Binary_Op then
235 Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
236 elsif Nkind (N) = N_Function_Call then
237 Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
241 Get_First_Interp (N, I, It);
242 while Present (It.Nam) loop
244 -- A user-defined subprogram hides another declared at an outer
245 -- level, or one that is use-visible. So return if previous
246 -- definition hides new one (which is either in an outer
247 -- scope, or use-visible). Note that for functions use-visible
248 -- is the same as potentially use-visible. If new one hides
249 -- previous one, replace entry in table of interpretations.
250 -- If this is a universal operation, retain the operator in case
251 -- preference rule applies.
253 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
254 and then Ekind (Name) = Ekind (It.Nam))
255 or else (Ekind (Name) = E_Operator
256 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)
262 if Is_Universal_Operation (Name) then
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 (Nkind (N) = N_Expanded_Name
273 Nkind (Selector_Name (N)) = N_Operator_Symbol)
277 elsif not In_Open_Scopes (Scope (Name))
278 or else Scope_Depth (Scope (Name)) <=
279 Scope_Depth (Scope (It.Nam))
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)
294 All_Interp.Table (I).Nam := Name;
298 -- Avoid making duplicate entries in overloads
301 and then Base_Type (It.Typ) = Base_Type (T)
305 -- Otherwise keep going
308 Get_Next_Interp (I, It);
313 All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
314 All_Interp.Append (No_Interp);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation (Op : Entity_Id) return Boolean is
325 if Ekind (Op) /= E_Operator then
328 elsif Nkind (N) in N_Binary_Op then
329 return Present (Universal_Interpretation (Left_Opnd (N)))
330 and then Present (Universal_Interpretation (Right_Opnd (N)));
332 elsif Nkind (N) in N_Unary_Op then
333 return Present (Universal_Interpretation (Right_Opnd (N)));
335 elsif Nkind (N) = N_Function_Call then
336 Arg := First_Actual (N);
337 while Present (Arg) loop
338 if No (Universal_Interpretation (Arg)) then
350 end Is_Universal_Operation;
352 -- Start of processing for Add_One_Interp
355 -- If the interpretation is a predefined operator, verify that the
356 -- result type is visible, or that the entity has already been
357 -- resolved (case of an instantiation node that refers to a predefined
358 -- operation, or an internally generated operator node, or an operator
359 -- given as an expanded name). If the operator is a comparison or
360 -- equality, it is the type of the operand that matters to determine
361 -- whether the operator is visible. In an instance, the check is not
362 -- performed, given that the operator was visible in the generic.
364 if Ekind (E) = E_Operator then
365 if Present (Opnd_Type) then
366 Vis_Type := Opnd_Type;
368 Vis_Type := Base_Type (T);
371 if In_Open_Scopes (Scope (Vis_Type))
372 or else Is_Potentially_Use_Visible (Vis_Type)
373 or else In_Use (Vis_Type)
374 or else (In_Use (Scope (Vis_Type))
375 and then not Is_Hidden (Vis_Type))
376 or else Nkind (N) = N_Expanded_Name
377 or else (Nkind (N) in N_Op and then E = Entity (N))
379 or else Ekind (Vis_Type) = E_Anonymous_Access_Type
383 -- If the node is given in functional notation and the prefix
384 -- is an expanded name, then the operator is visible if the
385 -- prefix is the scope of the result type as well. If the
386 -- operator is (implicitly) defined in an extension of system,
387 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
389 elsif Nkind (N) = N_Function_Call
390 and then Nkind (Name (N)) = N_Expanded_Name
391 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
392 or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
393 or else Scope (Vis_Type) = System_Aux_Id)
397 -- Save type for subsequent error message, in case no other
398 -- interpretation is found.
401 Candidate_Type := Vis_Type;
405 -- In an instance, an abstract non-dispatching operation cannot be a
406 -- candidate interpretation, because it could not have been one in the
407 -- generic (it may be a spurious overloading in the instance).
410 and then Is_Overloadable (E)
411 and then Is_Abstract_Subprogram (E)
412 and then not Is_Dispatching_Operation (E)
416 -- An inherited interface operation that is implemented by some derived
417 -- type does not participate in overload resolution, only the
418 -- implementation operation does.
421 and then Is_Subprogram (E)
422 and then Present (Interface_Alias (E))
424 -- Ada 2005 (AI-251): If this primitive operation corresponds with
425 -- an immediate ancestor interface there is no need to add it to the
426 -- list of interpretations. The corresponding aliased primitive is
427 -- also in this list of primitive operations and will be used instead
428 -- because otherwise we have a dummy ambiguity between the two
429 -- subprograms which are in fact the same.
432 (Find_Dispatching_Type (Interface_Alias (E)),
433 Find_Dispatching_Type (E))
435 Add_One_Interp (N, Interface_Alias (E), T);
440 -- Calling stubs for an RACW operation never participate in resolution,
441 -- they are executed only through dispatching calls.
443 elsif Is_RACW_Stub_Type_Operation (E) then
447 -- If this is the first interpretation of N, N has type Any_Type.
448 -- In that case place the new type on the node. If one interpretation
449 -- already exists, indicate that the node is overloaded, and store
450 -- both the previous and the new interpretation in All_Interp. If
451 -- this is a later interpretation, just add it to the set.
453 if Etype (N) = Any_Type then
458 -- Record both the operator or subprogram name, and its type
460 if Nkind (N) in N_Op or else Is_Entity_Name (N) then
467 -- Either there is no current interpretation in the table for any
468 -- node or the interpretation that is present is for a different
469 -- node. In both cases add a new interpretation to the table.
471 elsif Interp_Map.Last < 0
473 (Interp_Map.Table (Interp_Map.Last).Node /= N
474 and then not Is_Overloaded (N))
478 if (Nkind (N) in N_Op or else Is_Entity_Name (N))
479 and then Present (Entity (N))
481 Add_Entry (Entity (N), Etype (N));
483 elsif (Nkind (N) = N_Function_Call
484 or else Nkind (N) = N_Procedure_Call_Statement)
485 and then (Nkind (Name (N)) = N_Operator_Symbol
486 or else Is_Entity_Name (Name (N)))
488 Add_Entry (Entity (Name (N)), Etype (N));
490 -- If this is an indirect call there will be no name associated
491 -- with the previous entry. To make diagnostics clearer, save
492 -- Subprogram_Type of first interpretation, so that the error will
493 -- point to the anonymous access to subprogram, not to the result
494 -- type of the call itself.
496 elsif (Nkind (N)) = N_Function_Call
497 and then Nkind (Name (N)) = N_Explicit_Dereference
498 and then Is_Overloaded (Name (N))
504 pragma Warnings (Off, Itn);
507 Get_First_Interp (Name (N), Itn, It);
508 Add_Entry (It.Nam, Etype (N));
512 -- Overloaded prefix in indexed or selected component, or call
513 -- whose name is an expression or another call.
515 Add_Entry (Etype (N), Etype (N));
529 procedure All_Overloads is
531 for J in All_Interp.First .. All_Interp.Last loop
533 if Present (All_Interp.Table (J).Nam) then
534 Write_Entity_Info (All_Interp.Table (J). Nam, " ");
536 Write_Str ("No Interp");
540 Write_Str ("=================");
545 --------------------------------------
546 -- Binary_Op_Interp_Has_Abstract_Op --
547 --------------------------------------
549 function Binary_Op_Interp_Has_Abstract_Op
551 E : Entity_Id) return Entity_Id
553 Abstr_Op : Entity_Id;
554 E_Left : constant Node_Id := First_Formal (E);
555 E_Right : constant Node_Id := Next_Formal (E_Left);
558 Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
559 if Present (Abstr_Op) then
563 return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
564 end Binary_Op_Interp_Has_Abstract_Op;
566 ---------------------
567 -- Collect_Interps --
568 ---------------------
570 procedure Collect_Interps (N : Node_Id) is
571 Ent : constant Entity_Id := Entity (N);
573 First_Interp : Interp_Index;
578 -- Unconditionally add the entity that was initially matched
580 First_Interp := All_Interp.Last;
581 Add_One_Interp (N, Ent, Etype (N));
583 -- For expanded name, pick up all additional entities from the
584 -- same scope, since these are obviously also visible. Note that
585 -- these are not necessarily contiguous on the homonym chain.
587 if Nkind (N) = N_Expanded_Name then
589 while Present (H) loop
590 if Scope (H) = Scope (Entity (N)) then
591 Add_One_Interp (N, H, Etype (H));
597 -- Case of direct name
600 -- First, search the homonym chain for directly visible entities
602 H := Current_Entity (Ent);
603 while Present (H) loop
604 exit when (not Is_Overloadable (H))
605 and then Is_Immediately_Visible (H);
607 if Is_Immediately_Visible (H)
610 -- Only add interpretation if not hidden by an inner
611 -- immediately visible one.
613 for J in First_Interp .. All_Interp.Last - 1 loop
615 -- Current homograph is not hidden. Add to overloads
617 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
620 -- Homograph is hidden, unless it is a predefined operator
622 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
624 -- A homograph in the same scope can occur within an
625 -- instantiation, the resulting ambiguity has to be
628 if Scope (H) = Scope (Ent)
630 and then not Is_Inherited_Operation (H)
632 All_Interp.Table (All_Interp.Last) :=
633 (H, Etype (H), Empty);
634 All_Interp.Append (No_Interp);
637 elsif Scope (H) /= Standard_Standard then
643 -- On exit, we know that current homograph is not hidden
645 Add_One_Interp (N, H, Etype (H));
648 Write_Str ("Add overloaded interpretation ");
658 -- Scan list of homographs for use-visible entities only
660 H := Current_Entity (Ent);
662 while Present (H) loop
663 if Is_Potentially_Use_Visible (H)
665 and then Is_Overloadable (H)
667 for J in First_Interp .. All_Interp.Last - 1 loop
669 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
672 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
673 goto Next_Use_Homograph;
677 Add_One_Interp (N, H, Etype (H));
680 <<Next_Use_Homograph>>
685 if All_Interp.Last = First_Interp + 1 then
687 -- The final interpretation is in fact not overloaded. Note that the
688 -- unique legal interpretation may or may not be the original one,
689 -- so we need to update N's entity and etype now, because once N
690 -- is marked as not overloaded it is also expected to carry the
691 -- proper interpretation.
693 Set_Is_Overloaded (N, False);
694 Set_Entity (N, All_Interp.Table (First_Interp).Nam);
695 Set_Etype (N, All_Interp.Table (First_Interp).Typ);
703 function Covers (T1, T2 : Entity_Id) return Boolean is
708 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
709 -- In an instance the proper view may not always be correct for
710 -- private types, but private and full view are compatible. This
711 -- removes spurious errors from nested instantiations that involve,
712 -- among other things, types derived from private types.
714 ----------------------
715 -- Full_View_Covers --
716 ----------------------
718 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
721 Is_Private_Type (Typ1)
723 ((Present (Full_View (Typ1))
724 and then Covers (Full_View (Typ1), Typ2))
725 or else Base_Type (Typ1) = Typ2
726 or else Base_Type (Typ2) = Typ1);
727 end Full_View_Covers;
729 -- Start of processing for Covers
732 -- If either operand missing, then this is an error, but ignore it (and
733 -- pretend we have a cover) if errors already detected, since this may
734 -- simply mean we have malformed trees or a semantic error upstream.
736 if No (T1) or else No (T2) then
737 if Total_Errors_Detected /= 0 then
744 BT1 := Base_Type (T1);
745 BT2 := Base_Type (T2);
747 -- Handle underlying view of records with unknown discriminants
748 -- using the original entity that motivated the construction of
749 -- this underlying record view (see Build_Derived_Private_Type).
751 if Is_Underlying_Record_View (BT1) then
752 BT1 := Underlying_Record_View (BT1);
755 if Is_Underlying_Record_View (BT2) then
756 BT2 := Underlying_Record_View (BT2);
760 -- Simplest case: same types are compatible, and types that have the
761 -- same base type and are not generic actuals are compatible. Generic
762 -- actuals belong to their class but are not compatible with other
763 -- types of their class, and in particular with other generic actuals.
764 -- They are however compatible with their own subtypes, and itypes
765 -- with the same base are compatible as well. Similarly, constrained
766 -- subtypes obtained from expressions of an unconstrained nominal type
767 -- are compatible with the base type (may lead to spurious ambiguities
768 -- in obscure cases ???)
770 -- Generic actuals require special treatment to avoid spurious ambi-
771 -- guities in an instance, when two formal types are instantiated with
772 -- the same actual, so that different subprograms end up with the same
773 -- signature in the instance.
782 if not Is_Generic_Actual_Type (T1) then
785 return (not Is_Generic_Actual_Type (T2)
786 or else Is_Itype (T1)
787 or else Is_Itype (T2)
788 or else Is_Constr_Subt_For_U_Nominal (T1)
789 or else Is_Constr_Subt_For_U_Nominal (T2)
790 or else Scope (T1) /= Scope (T2));
793 -- Literals are compatible with types in a given "class"
795 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
796 or else (T2 = Universal_Real and then Is_Real_Type (T1))
797 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
798 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
799 or else (T2 = Any_String and then Is_String_Type (T1))
800 or else (T2 = Any_Character and then Is_Character_Type (T1))
801 or else (T2 = Any_Access and then Is_Access_Type (T1))
805 -- The context may be class wide, and a class-wide type is compatible
806 -- with any member of the class.
808 elsif Is_Class_Wide_Type (T1)
809 and then Is_Ancestor (Root_Type (T1), T2)
813 elsif Is_Class_Wide_Type (T1)
814 and then Is_Class_Wide_Type (T2)
815 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
819 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
820 -- task_type or protected_type that implements the interface.
822 elsif Ada_Version >= Ada_05
823 and then Is_Class_Wide_Type (T1)
824 and then Is_Interface (Etype (T1))
825 and then Is_Concurrent_Type (T2)
826 and then Interface_Present_In_Ancestor
827 (Typ => Base_Type (T2),
832 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
833 -- object T2 implementing T1
835 elsif Ada_Version >= Ada_05
836 and then Is_Class_Wide_Type (T1)
837 and then Is_Interface (Etype (T1))
838 and then Is_Tagged_Type (T2)
840 if Interface_Present_In_Ancestor (Typ => T2,
851 if Is_Concurrent_Type (BT2) then
852 E := Corresponding_Record_Type (BT2);
857 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
858 -- covers an object T2 that implements a direct derivation of T1.
859 -- Note: test for presence of E is defense against previous error.
862 and then Present (Interfaces (E))
864 Elmt := First_Elmt (Interfaces (E));
865 while Present (Elmt) loop
866 if Is_Ancestor (Etype (T1), Node (Elmt)) then
874 -- We should also check the case in which T1 is an ancestor of
875 -- some implemented interface???
880 -- In a dispatching call the actual may be class-wide
882 elsif Is_Class_Wide_Type (T2)
883 and then Base_Type (Root_Type (T2)) = Base_Type (T1)
887 -- Some contexts require a class of types rather than a specific type.
888 -- For example, conditions require any boolean type, fixed point
889 -- attributes require some real type, etc. The built-in types Any_XXX
890 -- represent these classes.
892 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
893 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
894 or else (T1 = Any_Real and then Is_Real_Type (T2))
895 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
896 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
900 -- An aggregate is compatible with an array or record type
902 elsif T2 = Any_Composite
903 and then Is_Aggregate_Type (T1)
907 -- If the expected type is an anonymous access, the designated type must
908 -- cover that of the expression. Use the base type for this check: even
909 -- though access subtypes are rare in sources, they are generated for
910 -- actuals in instantiations.
912 elsif Ekind (BT1) = E_Anonymous_Access_Type
913 and then Is_Access_Type (T2)
914 and then Covers (Designated_Type (T1), Designated_Type (T2))
918 -- An Access_To_Subprogram is compatible with itself, or with an
919 -- anonymous type created for an attribute reference Access.
921 elsif (Ekind (BT1) = E_Access_Subprogram_Type
923 Ekind (BT1) = E_Access_Protected_Subprogram_Type)
924 and then Is_Access_Type (T2)
925 and then (not Comes_From_Source (T1)
926 or else not Comes_From_Source (T2))
927 and then (Is_Overloadable (Designated_Type (T2))
929 Ekind (Designated_Type (T2)) = E_Subprogram_Type)
931 Type_Conformant (Designated_Type (T1), Designated_Type (T2))
933 Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
937 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
938 -- with itself, or with an anonymous type created for an attribute
941 elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type
944 = E_Anonymous_Access_Protected_Subprogram_Type)
945 and then Is_Access_Type (T2)
946 and then (not Comes_From_Source (T1)
947 or else not Comes_From_Source (T2))
948 and then (Is_Overloadable (Designated_Type (T2))
950 Ekind (Designated_Type (T2)) = E_Subprogram_Type)
952 Type_Conformant (Designated_Type (T1), Designated_Type (T2))
954 Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
958 -- The context can be a remote access type, and the expression the
959 -- corresponding source type declared in a categorized package, or
962 elsif Is_Record_Type (T1)
963 and then (Is_Remote_Call_Interface (T1)
964 or else Is_Remote_Types (T1))
965 and then Present (Corresponding_Remote_Type (T1))
967 return Covers (Corresponding_Remote_Type (T1), T2);
971 elsif Is_Record_Type (T2)
972 and then (Is_Remote_Call_Interface (T2)
973 or else Is_Remote_Types (T2))
974 and then Present (Corresponding_Remote_Type (T2))
976 return Covers (Corresponding_Remote_Type (T2), T1);
978 -- Synchronized types are represented at run time by their corresponding
979 -- record type. During expansion one is replaced with the other, but
980 -- they are compatible views of the same type.
982 elsif Is_Record_Type (T1)
983 and then Is_Concurrent_Type (T2)
984 and then Present (Corresponding_Record_Type (T2))
986 return Covers (T1, Corresponding_Record_Type (T2));
988 elsif Is_Concurrent_Type (T1)
989 and then Present (Corresponding_Record_Type (T1))
990 and then Is_Record_Type (T2)
992 return Covers (Corresponding_Record_Type (T1), T2);
994 -- During analysis, an attribute reference 'Access has a special type
995 -- kind: Access_Attribute_Type, to be replaced eventually with the type
996 -- imposed by context.
998 elsif Ekind (T2) = E_Access_Attribute_Type
999 and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
1000 and then Covers (Designated_Type (T1), Designated_Type (T2))
1002 -- If the target type is a RACW type while the source is an access
1003 -- attribute type, we are building a RACW that may be exported.
1005 if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1006 Set_Has_RACW (Current_Sem_Unit);
1011 -- Ditto for allocators, which eventually resolve to the context type
1013 elsif Ekind (T2) = E_Allocator_Type
1014 and then Is_Access_Type (T1)
1016 return Covers (Designated_Type (T1), Designated_Type (T2))
1018 (From_With_Type (Designated_Type (T1))
1019 and then Covers (Designated_Type (T2), Designated_Type (T1)));
1021 -- A boolean operation on integer literals is compatible with modular
1024 elsif T2 = Any_Modular
1025 and then Is_Modular_Integer_Type (T1)
1029 -- The actual type may be the result of a previous error
1031 elsif Base_Type (T2) = Any_Type then
1034 -- A packed array type covers its corresponding non-packed type. This is
1035 -- not legitimate Ada, but allows the omission of a number of otherwise
1036 -- useless unchecked conversions, and since this can only arise in
1037 -- (known correct) expanded code, no harm is done.
1039 elsif Is_Array_Type (T2)
1040 and then Is_Packed (T2)
1041 and then T1 = Packed_Array_Type (T2)
1045 -- Similarly an array type covers its corresponding packed array type
1047 elsif Is_Array_Type (T1)
1048 and then Is_Packed (T1)
1049 and then T2 = Packed_Array_Type (T1)
1053 -- In instances, or with types exported from instantiations, check
1054 -- whether a partial and a full view match. Verify that types are
1055 -- legal, to prevent cascaded errors.
1059 (Full_View_Covers (T1, T2)
1060 or else Full_View_Covers (T2, T1))
1065 and then Is_Generic_Actual_Type (T2)
1066 and then Full_View_Covers (T1, T2)
1071 and then Is_Generic_Actual_Type (T1)
1072 and then Full_View_Covers (T2, T1)
1076 -- In the expansion of inlined bodies, types are compatible if they
1077 -- are structurally equivalent.
1079 elsif In_Inlined_Body
1080 and then (Underlying_Type (T1) = Underlying_Type (T2)
1081 or else (Is_Access_Type (T1)
1082 and then Is_Access_Type (T2)
1084 Designated_Type (T1) = Designated_Type (T2))
1085 or else (T1 = Any_Access
1086 and then Is_Access_Type (Underlying_Type (T2)))
1087 or else (T2 = Any_Composite
1089 Is_Composite_Type (Underlying_Type (T1))))
1093 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1094 -- obtained through a limited_with compatible with its real entity.
1096 elsif From_With_Type (T1) then
1098 -- If the expected type is the non-limited view of a type, the
1099 -- expression may have the limited view. If that one in turn is
1100 -- incomplete, get full view if available.
1102 if Is_Incomplete_Type (T1) then
1103 return Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1105 elsif Ekind (T1) = E_Class_Wide_Type then
1107 Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
1112 elsif From_With_Type (T2) then
1114 -- If units in the context have Limited_With clauses on each other,
1115 -- either type might have a limited view. Checks performed elsewhere
1116 -- verify that the context type is the nonlimited view.
1118 if Is_Incomplete_Type (T2) then
1119 return Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1121 elsif Ekind (T2) = E_Class_Wide_Type then
1123 Present (Non_Limited_View (Etype (T2)))
1125 Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
1130 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1132 elsif Ekind (T1) = E_Incomplete_Subtype then
1133 return Covers (Full_View (Etype (T1)), T2);
1135 elsif Ekind (T2) = E_Incomplete_Subtype then
1136 return Covers (T1, Full_View (Etype (T2)));
1138 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1139 -- and actual anonymous access types in the context of generic
1140 -- instantiations. We have the following situation:
1143 -- type Formal is private;
1144 -- Formal_Obj : access Formal; -- T1
1148 -- type Actual is ...
1149 -- Actual_Obj : access Actual; -- T2
1150 -- package Instance is new G (Formal => Actual,
1151 -- Formal_Obj => Actual_Obj);
1153 elsif Ada_Version >= Ada_05
1154 and then Ekind (T1) = E_Anonymous_Access_Type
1155 and then Ekind (T2) = E_Anonymous_Access_Type
1156 and then Is_Generic_Type (Directly_Designated_Type (T1))
1157 and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1158 Directly_Designated_Type (T2)
1162 -- Otherwise, types are not compatible!
1173 function Disambiguate
1175 I1, I2 : Interp_Index;
1176 Typ : Entity_Id) return Interp
1181 Nam1, Nam2 : Entity_Id;
1182 Predef_Subp : Entity_Id;
1183 User_Subp : Entity_Id;
1185 function Inherited_From_Actual (S : Entity_Id) return Boolean;
1186 -- Determine whether one of the candidates is an operation inherited by
1187 -- a type that is derived from an actual in an instantiation.
1189 function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1190 -- Determine whether a subprogram is an actual in an enclosing instance.
1191 -- An overloading between such a subprogram and one declared outside the
1192 -- instance is resolved in favor of the first, because it resolved in
1195 function Matches (Actual, Formal : Node_Id) return Boolean;
1196 -- Look for exact type match in an instance, to remove spurious
1197 -- ambiguities when two formal types have the same actual.
1199 function Standard_Operator return Boolean;
1200 -- Check whether subprogram is predefined operator declared in Standard.
1201 -- It may given by an operator name, or by an expanded name whose prefix
1204 function Remove_Conversions return Interp;
1205 -- Last chance for pathological cases involving comparisons on literals,
1206 -- and user overloadings of the same operator. Such pathologies have
1207 -- been removed from the ACVC, but still appear in two DEC tests, with
1208 -- the following notable quote from Ben Brosgol:
1210 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1211 -- this example; Robert Dewar brought it to our attention, since it is
1212 -- apparently found in the ACVC 1.5. I did not attempt to find the
1213 -- reason in the Reference Manual that makes the example legal, since I
1214 -- was too nauseated by it to want to pursue it further.]
1216 -- Accordingly, this is not a fully recursive solution, but it handles
1217 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1218 -- pathology in the other direction with calls whose multiple overloaded
1219 -- actuals make them truly unresolvable.
1221 -- The new rules concerning abstract operations create additional need
1222 -- for special handling of expressions with universal operands, see
1223 -- comments to Has_Abstract_Interpretation below.
1225 ---------------------------
1226 -- Inherited_From_Actual --
1227 ---------------------------
1229 function Inherited_From_Actual (S : Entity_Id) return Boolean is
1230 Par : constant Node_Id := Parent (S);
1232 if Nkind (Par) /= N_Full_Type_Declaration
1233 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1237 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1239 Is_Generic_Actual_Type (
1240 Entity (Subtype_Indication (Type_Definition (Par))));
1242 end Inherited_From_Actual;
1244 --------------------------
1245 -- Is_Actual_Subprogram --
1246 --------------------------
1248 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1250 return In_Open_Scopes (Scope (S))
1252 (Is_Generic_Instance (Scope (S))
1253 or else Is_Wrapper_Package (Scope (S)));
1254 end Is_Actual_Subprogram;
1260 function Matches (Actual, Formal : Node_Id) return Boolean is
1261 T1 : constant Entity_Id := Etype (Actual);
1262 T2 : constant Entity_Id := Etype (Formal);
1266 (Is_Numeric_Type (T2)
1267 and then (T1 = Universal_Real or else T1 = Universal_Integer));
1270 ------------------------
1271 -- Remove_Conversions --
1272 ------------------------
1274 function Remove_Conversions return Interp is
1282 function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1283 -- If an operation has universal operands the universal operation
1284 -- is present among its interpretations. If there is an abstract
1285 -- interpretation for the operator, with a numeric result, this
1286 -- interpretation was already removed in sem_ch4, but the universal
1287 -- one is still visible. We must rescan the list of operators and
1288 -- remove the universal interpretation to resolve the ambiguity.
1290 ---------------------------------
1291 -- Has_Abstract_Interpretation --
1292 ---------------------------------
1294 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1298 if Nkind (N) not in N_Op
1299 or else Ada_Version < Ada_05
1300 or else not Is_Overloaded (N)
1301 or else No (Universal_Interpretation (N))
1306 E := Get_Name_Entity_Id (Chars (N));
1307 while Present (E) loop
1308 if Is_Overloadable (E)
1309 and then Is_Abstract_Subprogram (E)
1310 and then Is_Numeric_Type (Etype (E))
1318 -- Finally, if an operand of the binary operator is itself
1319 -- an operator, recurse to see whether its own abstract
1320 -- interpretation is responsible for the spurious ambiguity.
1322 if Nkind (N) in N_Binary_Op then
1323 return Has_Abstract_Interpretation (Left_Opnd (N))
1324 or else Has_Abstract_Interpretation (Right_Opnd (N));
1326 elsif Nkind (N) in N_Unary_Op then
1327 return Has_Abstract_Interpretation (Right_Opnd (N));
1333 end Has_Abstract_Interpretation;
1335 -- Start of processing for Remove_Conversions
1340 Get_First_Interp (N, I, It);
1341 while Present (It.Typ) loop
1342 if not Is_Overloadable (It.Nam) then
1346 F1 := First_Formal (It.Nam);
1352 if Nkind (N) = N_Function_Call
1353 or else Nkind (N) = N_Procedure_Call_Statement
1355 Act1 := First_Actual (N);
1357 if Present (Act1) then
1358 Act2 := Next_Actual (Act1);
1363 elsif Nkind (N) in N_Unary_Op then
1364 Act1 := Right_Opnd (N);
1367 elsif Nkind (N) in N_Binary_Op then
1368 Act1 := Left_Opnd (N);
1369 Act2 := Right_Opnd (N);
1371 -- Use type of second formal, so as to include
1372 -- exponentiation, where the exponent may be
1373 -- ambiguous and the result non-universal.
1381 if Nkind (Act1) in N_Op
1382 and then Is_Overloaded (Act1)
1383 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1384 or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1385 and then Has_Compatible_Type (Act1, Standard_Boolean)
1386 and then Etype (F1) = Standard_Boolean
1388 -- If the two candidates are the original ones, the
1389 -- ambiguity is real. Otherwise keep the original, further
1390 -- calls to Disambiguate will take care of others in the
1391 -- list of candidates.
1393 if It1 /= No_Interp then
1394 if It = Disambiguate.It1
1395 or else It = Disambiguate.It2
1397 if It1 = Disambiguate.It1
1398 or else It1 = Disambiguate.It2
1406 elsif Present (Act2)
1407 and then Nkind (Act2) in N_Op
1408 and then Is_Overloaded (Act2)
1409 and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1411 and then Has_Compatible_Type (Act2, Standard_Boolean)
1413 -- The preference rule on the first actual is not
1414 -- sufficient to disambiguate.
1422 elsif Is_Numeric_Type (Etype (F1))
1423 and then Has_Abstract_Interpretation (Act1)
1425 -- Current interpretation is not the right one because it
1426 -- expects a numeric operand. Examine all the other ones.
1433 Get_First_Interp (N, I, It);
1434 while Present (It.Typ) loop
1436 not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1439 or else not Has_Abstract_Interpretation (Act2)
1442 (Etype (Next_Formal (First_Formal (It.Nam))))
1448 Get_Next_Interp (I, It);
1457 Get_Next_Interp (I, It);
1460 -- After some error, a formal may have Any_Type and yield a spurious
1461 -- match. To avoid cascaded errors if possible, check for such a
1462 -- formal in either candidate.
1464 if Serious_Errors_Detected > 0 then
1469 Formal := First_Formal (Nam1);
1470 while Present (Formal) loop
1471 if Etype (Formal) = Any_Type then
1472 return Disambiguate.It2;
1475 Next_Formal (Formal);
1478 Formal := First_Formal (Nam2);
1479 while Present (Formal) loop
1480 if Etype (Formal) = Any_Type then
1481 return Disambiguate.It1;
1484 Next_Formal (Formal);
1490 end Remove_Conversions;
1492 -----------------------
1493 -- Standard_Operator --
1494 -----------------------
1496 function Standard_Operator return Boolean is
1500 if Nkind (N) in N_Op then
1503 elsif Nkind (N) = N_Function_Call then
1506 if Nkind (Nam) /= N_Expanded_Name then
1509 return Entity (Prefix (Nam)) = Standard_Standard;
1514 end Standard_Operator;
1516 -- Start of processing for Disambiguate
1519 -- Recover the two legal interpretations
1521 Get_First_Interp (N, I, It);
1523 Get_Next_Interp (I, It);
1529 Get_Next_Interp (I, It);
1535 if Ada_Version < Ada_05 then
1537 -- Check whether one of the entities is an Ada 2005 entity and we are
1538 -- operating in an earlier mode, in which case we discard the Ada
1539 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1541 if Is_Ada_2005_Only (Nam1) then
1543 elsif Is_Ada_2005_Only (Nam2) then
1548 -- Check for overloaded CIL convention stuff because the CIL libraries
1549 -- do sick things like Console.Write_Line where it matches two different
1550 -- overloads, so just pick the first ???
1552 if Convention (Nam1) = Convention_CIL
1553 and then Convention (Nam2) = Convention_CIL
1554 and then Ekind (Nam1) = Ekind (Nam2)
1555 and then (Ekind (Nam1) = E_Procedure
1556 or else Ekind (Nam1) = E_Function)
1561 -- If the context is universal, the predefined operator is preferred.
1562 -- This includes bounds in numeric type declarations, and expressions
1563 -- in type conversions. If no interpretation yields a universal type,
1564 -- then we must check whether the user-defined entity hides the prede-
1567 if Chars (Nam1) in Any_Operator_Name
1568 and then Standard_Operator
1570 if Typ = Universal_Integer
1571 or else Typ = Universal_Real
1572 or else Typ = Any_Integer
1573 or else Typ = Any_Discrete
1574 or else Typ = Any_Real
1575 or else Typ = Any_Type
1577 -- Find an interpretation that yields the universal type, or else
1578 -- a predefined operator that yields a predefined numeric type.
1581 Candidate : Interp := No_Interp;
1584 Get_First_Interp (N, I, It);
1585 while Present (It.Typ) loop
1586 if (Covers (Typ, It.Typ)
1587 or else Typ = Any_Type)
1589 (It.Typ = Universal_Integer
1590 or else It.Typ = Universal_Real)
1594 elsif Covers (Typ, It.Typ)
1595 and then Scope (It.Typ) = Standard_Standard
1596 and then Scope (It.Nam) = Standard_Standard
1597 and then Is_Numeric_Type (It.Typ)
1602 Get_Next_Interp (I, It);
1605 if Candidate /= No_Interp then
1610 elsif Chars (Nam1) /= Name_Op_Not
1611 and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1613 -- Equality or comparison operation. Choose predefined operator if
1614 -- arguments are universal. The node may be an operator, name, or
1615 -- a function call, so unpack arguments accordingly.
1618 Arg1, Arg2 : Node_Id;
1621 if Nkind (N) in N_Op then
1622 Arg1 := Left_Opnd (N);
1623 Arg2 := Right_Opnd (N);
1625 elsif Is_Entity_Name (N)
1626 or else Nkind (N) = N_Operator_Symbol
1628 Arg1 := First_Entity (Entity (N));
1629 Arg2 := Next_Entity (Arg1);
1632 Arg1 := First_Actual (N);
1633 Arg2 := Next_Actual (Arg1);
1637 and then Present (Universal_Interpretation (Arg1))
1638 and then Universal_Interpretation (Arg2) =
1639 Universal_Interpretation (Arg1)
1641 Get_First_Interp (N, I, It);
1642 while Scope (It.Nam) /= Standard_Standard loop
1643 Get_Next_Interp (I, It);
1652 -- If no universal interpretation, check whether user-defined operator
1653 -- hides predefined one, as well as other special cases. If the node
1654 -- is a range, then one or both bounds are ambiguous. Each will have
1655 -- to be disambiguated w.r.t. the context type. The type of the range
1656 -- itself is imposed by the context, so we can return either legal
1659 if Ekind (Nam1) = E_Operator then
1660 Predef_Subp := Nam1;
1663 elsif Ekind (Nam2) = E_Operator then
1664 Predef_Subp := Nam2;
1667 elsif Nkind (N) = N_Range then
1670 -- Implement AI05-105: A renaming declaration with an access
1671 -- definition must resolve to an anonymous access type. This
1672 -- is a resolution rule and can be used to disambiguate.
1674 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1675 and then Present (Access_Definition (Parent (N)))
1677 if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
1678 E_Anonymous_Access_Subprogram_Type)
1680 if Ekind (It2.Typ) = Ekind (It1.Typ) then
1690 elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
1691 E_Anonymous_Access_Subprogram_Type)
1695 -- No legal interpretation
1701 -- If two user defined-subprograms are visible, it is a true ambiguity,
1702 -- unless one of them is an entry and the context is a conditional or
1703 -- timed entry call, or unless we are within an instance and this is
1704 -- results from two formals types with the same actual.
1707 if Nkind (N) = N_Procedure_Call_Statement
1708 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1709 and then N = Entry_Call_Statement (Parent (N))
1711 if Ekind (Nam2) = E_Entry then
1713 elsif Ekind (Nam1) = E_Entry then
1719 -- If the ambiguity occurs within an instance, it is due to several
1720 -- formal types with the same actual. Look for an exact match between
1721 -- the types of the formals of the overloadable entities, and the
1722 -- actuals in the call, to recover the unambiguous match in the
1723 -- original generic.
1725 -- The ambiguity can also be due to an overloading between a formal
1726 -- subprogram and a subprogram declared outside the generic. If the
1727 -- node is overloaded, it did not resolve to the global entity in
1728 -- the generic, and we choose the formal subprogram.
1730 -- Finally, the ambiguity can be between an explicit subprogram and
1731 -- one inherited (with different defaults) from an actual. In this
1732 -- case the resolution was to the explicit declaration in the
1733 -- generic, and remains so in the instance.
1736 and then not In_Generic_Actual (N)
1738 if Nkind (N) = N_Function_Call
1739 or else Nkind (N) = N_Procedure_Call_Statement
1744 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1745 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1748 if Is_Act1 and then not Is_Act2 then
1751 elsif Is_Act2 and then not Is_Act1 then
1754 elsif Inherited_From_Actual (Nam1)
1755 and then Comes_From_Source (Nam2)
1759 elsif Inherited_From_Actual (Nam2)
1760 and then Comes_From_Source (Nam1)
1765 Actual := First_Actual (N);
1766 Formal := First_Formal (Nam1);
1767 while Present (Actual) loop
1768 if Etype (Actual) /= Etype (Formal) then
1772 Next_Actual (Actual);
1773 Next_Formal (Formal);
1779 elsif Nkind (N) in N_Binary_Op then
1780 if Matches (Left_Opnd (N), First_Formal (Nam1))
1782 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1789 elsif Nkind (N) in N_Unary_Op then
1790 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1797 return Remove_Conversions;
1800 return Remove_Conversions;
1804 -- An implicit concatenation operator on a string type cannot be
1805 -- disambiguated from the predefined concatenation. This can only
1806 -- happen with concatenation of string literals.
1808 if Chars (User_Subp) = Name_Op_Concat
1809 and then Ekind (User_Subp) = E_Operator
1810 and then Is_String_Type (Etype (First_Formal (User_Subp)))
1814 -- If the user-defined operator is in an open scope, or in the scope
1815 -- of the resulting type, or given by an expanded name that names its
1816 -- scope, it hides the predefined operator for the type. Exponentiation
1817 -- has to be special-cased because the implicit operator does not have
1818 -- a symmetric signature, and may not be hidden by the explicit one.
1820 elsif (Nkind (N) = N_Function_Call
1821 and then Nkind (Name (N)) = N_Expanded_Name
1822 and then (Chars (Predef_Subp) /= Name_Op_Expon
1823 or else Hides_Op (User_Subp, Predef_Subp))
1824 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1825 or else Hides_Op (User_Subp, Predef_Subp)
1827 if It1.Nam = User_Subp then
1833 -- Otherwise, the predefined operator has precedence, or if the user-
1834 -- defined operation is directly visible we have a true ambiguity. If
1835 -- this is a fixed-point multiplication and division in Ada83 mode,
1836 -- exclude the universal_fixed operator, which often causes ambiguities
1840 if (In_Open_Scopes (Scope (User_Subp))
1841 or else Is_Potentially_Use_Visible (User_Subp))
1842 and then not In_Instance
1844 if Is_Fixed_Point_Type (Typ)
1845 and then (Chars (Nam1) = Name_Op_Multiply
1846 or else Chars (Nam1) = Name_Op_Divide)
1847 and then Ada_Version = Ada_83
1849 if It2.Nam = Predef_Subp then
1855 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1856 -- states that the operator defined in Standard is not available
1857 -- if there is a user-defined equality with the proper signature,
1858 -- declared in the same declarative list as the type. The node
1859 -- may be an operator or a function call.
1861 elsif (Chars (Nam1) = Name_Op_Eq
1863 Chars (Nam1) = Name_Op_Ne)
1864 and then Ada_Version >= Ada_05
1865 and then Etype (User_Subp) = Standard_Boolean
1871 if Nkind (N) = N_Function_Call then
1872 Opnd := First_Actual (N);
1874 Opnd := Left_Opnd (N);
1877 if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
1879 In_Same_List (Parent (Designated_Type (Etype (Opnd))),
1880 Unit_Declaration_Node (User_Subp))
1882 if It2.Nam = Predef_Subp then
1888 return Remove_Conversions;
1896 elsif It1.Nam = Predef_Subp then
1905 ---------------------
1906 -- End_Interp_List --
1907 ---------------------
1909 procedure End_Interp_List is
1911 All_Interp.Table (All_Interp.Last) := No_Interp;
1912 All_Interp.Increment_Last;
1913 end End_Interp_List;
1915 -------------------------
1916 -- Entity_Matches_Spec --
1917 -------------------------
1919 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1921 -- Simple case: same entity kinds, type conformance is required. A
1922 -- parameterless function can also rename a literal.
1924 if Ekind (Old_S) = Ekind (New_S)
1925 or else (Ekind (New_S) = E_Function
1926 and then Ekind (Old_S) = E_Enumeration_Literal)
1928 return Type_Conformant (New_S, Old_S);
1930 elsif Ekind (New_S) = E_Function
1931 and then Ekind (Old_S) = E_Operator
1933 return Operator_Matches_Spec (Old_S, New_S);
1935 elsif Ekind (New_S) = E_Procedure
1936 and then Is_Entry (Old_S)
1938 return Type_Conformant (New_S, Old_S);
1943 end Entity_Matches_Spec;
1945 ----------------------
1946 -- Find_Unique_Type --
1947 ----------------------
1949 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1950 T : constant Entity_Id := Etype (L);
1953 TR : Entity_Id := Any_Type;
1956 if Is_Overloaded (R) then
1957 Get_First_Interp (R, I, It);
1958 while Present (It.Typ) loop
1959 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1961 -- If several interpretations are possible and L is universal,
1962 -- apply preference rule.
1964 if TR /= Any_Type then
1966 if (T = Universal_Integer or else T = Universal_Real)
1977 Get_Next_Interp (I, It);
1982 -- In the non-overloaded case, the Etype of R is already set correctly
1988 -- If one of the operands is Universal_Fixed, the type of the other
1989 -- operand provides the context.
1991 if Etype (R) = Universal_Fixed then
1994 elsif T = Universal_Fixed then
1997 -- Ada 2005 (AI-230): Support the following operators:
1999 -- function "=" (L, R : universal_access) return Boolean;
2000 -- function "/=" (L, R : universal_access) return Boolean;
2002 -- Pool specific access types (E_Access_Type) are not covered by these
2003 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2004 -- of the equality operators for universal_access shall be convertible
2005 -- to one another (see 4.6)". For example, considering the type decla-
2006 -- ration "type P is access Integer" and an anonymous access to Integer,
2007 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2008 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2010 elsif Ada_Version >= Ada_05
2012 (Ekind (Etype (L)) = E_Anonymous_Access_Type
2014 Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
2015 and then Is_Access_Type (Etype (R))
2016 and then Ekind (Etype (R)) /= E_Access_Type
2020 elsif Ada_Version >= Ada_05
2022 (Ekind (Etype (R)) = E_Anonymous_Access_Type
2023 or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
2024 and then Is_Access_Type (Etype (L))
2025 and then Ekind (Etype (L)) /= E_Access_Type
2030 return Specific_Type (T, Etype (R));
2032 end Find_Unique_Type;
2034 -------------------------------------
2035 -- Function_Interp_Has_Abstract_Op --
2036 -------------------------------------
2038 function Function_Interp_Has_Abstract_Op
2040 E : Entity_Id) return Entity_Id
2042 Abstr_Op : Entity_Id;
2045 Form_Parm : Node_Id;
2048 -- Why is check on E needed below ???
2049 -- In any case this para needs comments ???
2051 if Is_Overloaded (N) and then Is_Overloadable (E) then
2052 Act_Parm := First_Actual (N);
2053 Form_Parm := First_Formal (E);
2054 while Present (Act_Parm)
2055 and then Present (Form_Parm)
2059 if Nkind (Act) = N_Parameter_Association then
2060 Act := Explicit_Actual_Parameter (Act);
2063 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2065 if Present (Abstr_Op) then
2069 Next_Actual (Act_Parm);
2070 Next_Formal (Form_Parm);
2075 end Function_Interp_Has_Abstract_Op;
2077 ----------------------
2078 -- Get_First_Interp --
2079 ----------------------
2081 procedure Get_First_Interp
2083 I : out Interp_Index;
2086 Int_Ind : Interp_Index;
2091 -- If a selected component is overloaded because the selector has
2092 -- multiple interpretations, the node is a call to a protected
2093 -- operation or an indirect call. Retrieve the interpretation from
2094 -- the selector name. The selected component may be overloaded as well
2095 -- if the prefix is overloaded. That case is unchanged.
2097 if Nkind (N) = N_Selected_Component
2098 and then Is_Overloaded (Selector_Name (N))
2100 O_N := Selector_Name (N);
2105 Map_Ptr := Headers (Hash (O_N));
2106 while Map_Ptr /= No_Entry loop
2107 if Interp_Map.Table (Map_Ptr).Node = O_N then
2108 Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2109 It := All_Interp.Table (Int_Ind);
2113 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2117 -- Procedure should never be called if the node has no interpretations
2119 raise Program_Error;
2120 end Get_First_Interp;
2122 ---------------------
2123 -- Get_Next_Interp --
2124 ---------------------
2126 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2129 It := All_Interp.Table (I);
2130 end Get_Next_Interp;
2132 -------------------------
2133 -- Has_Compatible_Type --
2134 -------------------------
2136 function Has_Compatible_Type
2138 Typ : Entity_Id) return Boolean
2148 if Nkind (N) = N_Subtype_Indication
2149 or else not Is_Overloaded (N)
2152 Covers (Typ, Etype (N))
2154 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2155 -- If the type is already frozen use the corresponding_record
2156 -- to check whether it is a proper descendant.
2159 (Is_Record_Type (Typ)
2160 and then Is_Concurrent_Type (Etype (N))
2161 and then Present (Corresponding_Record_Type (Etype (N)))
2162 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2165 (Is_Concurrent_Type (Typ)
2166 and then Is_Record_Type (Etype (N))
2167 and then Present (Corresponding_Record_Type (Typ))
2168 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2171 (not Is_Tagged_Type (Typ)
2172 and then Ekind (Typ) /= E_Anonymous_Access_Type
2173 and then Covers (Etype (N), Typ));
2176 Get_First_Interp (N, I, It);
2177 while Present (It.Typ) loop
2178 if (Covers (Typ, It.Typ)
2180 (Scope (It.Nam) /= Standard_Standard
2181 or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2183 -- Ada 2005 (AI-345)
2186 (Is_Concurrent_Type (It.Typ)
2187 and then Present (Corresponding_Record_Type
2189 and then Covers (Typ, Corresponding_Record_Type
2192 or else (not Is_Tagged_Type (Typ)
2193 and then Ekind (Typ) /= E_Anonymous_Access_Type
2194 and then Covers (It.Typ, Typ))
2199 Get_Next_Interp (I, It);
2204 end Has_Compatible_Type;
2206 ---------------------
2207 -- Has_Abstract_Op --
2208 ---------------------
2210 function Has_Abstract_Op
2212 Typ : Entity_Id) return Entity_Id
2218 if Is_Overloaded (N) then
2219 Get_First_Interp (N, I, It);
2220 while Present (It.Nam) loop
2221 if Present (It.Abstract_Op)
2222 and then Etype (It.Abstract_Op) = Typ
2224 return It.Abstract_Op;
2227 Get_Next_Interp (I, It);
2232 end Has_Abstract_Op;
2238 function Hash (N : Node_Id) return Int is
2240 -- Nodes have a size that is power of two, so to select significant
2241 -- bits only we remove the low-order bits.
2243 return ((Int (N) / 2 ** 5) mod Header_Size);
2250 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2251 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2253 return Operator_Matches_Spec (Op, F)
2254 and then (In_Open_Scopes (Scope (F))
2255 or else Scope (F) = Scope (Btyp)
2256 or else (not In_Open_Scopes (Scope (Btyp))
2257 and then not In_Use (Btyp)
2258 and then not In_Use (Scope (Btyp))));
2261 ------------------------
2262 -- Init_Interp_Tables --
2263 ------------------------
2265 procedure Init_Interp_Tables is
2269 Headers := (others => No_Entry);
2270 end Init_Interp_Tables;
2272 -----------------------------------
2273 -- Interface_Present_In_Ancestor --
2274 -----------------------------------
2276 function Interface_Present_In_Ancestor
2278 Iface : Entity_Id) return Boolean
2280 Target_Typ : Entity_Id;
2281 Iface_Typ : Entity_Id;
2283 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2284 -- Returns True if Typ or some ancestor of Typ implements Iface
2286 -------------------------------
2287 -- Iface_Present_In_Ancestor --
2288 -------------------------------
2290 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2296 if Typ = Iface_Typ then
2300 -- Handle private types
2302 if Present (Full_View (Typ))
2303 and then not Is_Concurrent_Type (Full_View (Typ))
2305 E := Full_View (Typ);
2311 if Present (Interfaces (E))
2312 and then Present (Interfaces (E))
2313 and then not Is_Empty_Elmt_List (Interfaces (E))
2315 Elmt := First_Elmt (Interfaces (E));
2316 while Present (Elmt) loop
2319 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2327 exit when Etype (E) = E
2329 -- Handle private types
2331 or else (Present (Full_View (Etype (E)))
2332 and then Full_View (Etype (E)) = E);
2334 -- Check if the current type is a direct derivation of the
2337 if Etype (E) = Iface_Typ then
2341 -- Climb to the immediate ancestor handling private types
2343 if Present (Full_View (Etype (E))) then
2344 E := Full_View (Etype (E));
2351 end Iface_Present_In_Ancestor;
2353 -- Start of processing for Interface_Present_In_Ancestor
2356 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2358 if Is_Class_Wide_Type (Iface) then
2359 Iface_Typ := Etype (Base_Type (Iface));
2366 Iface_Typ := Base_Type (Iface_Typ);
2368 if Is_Access_Type (Typ) then
2369 Target_Typ := Etype (Directly_Designated_Type (Typ));
2374 if Is_Concurrent_Record_Type (Target_Typ) then
2375 Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2378 Target_Typ := Base_Type (Target_Typ);
2380 -- In case of concurrent types we can't use the Corresponding Record_Typ
2381 -- to look for the interface because it is built by the expander (and
2382 -- hence it is not always available). For this reason we traverse the
2383 -- list of interfaces (available in the parent of the concurrent type)
2385 if Is_Concurrent_Type (Target_Typ) then
2386 if Present (Interface_List (Parent (Target_Typ))) then
2391 AI := First (Interface_List (Parent (Target_Typ)));
2392 while Present (AI) loop
2393 if Etype (AI) = Iface_Typ then
2396 elsif Present (Interfaces (Etype (AI)))
2397 and then Iface_Present_In_Ancestor (Etype (AI))
2410 if Is_Class_Wide_Type (Target_Typ) then
2411 Target_Typ := Etype (Target_Typ);
2414 if Ekind (Target_Typ) = E_Incomplete_Type then
2415 pragma Assert (Present (Non_Limited_View (Target_Typ)));
2416 Target_Typ := Non_Limited_View (Target_Typ);
2418 -- Protect the frontend against previously detected errors
2420 if Ekind (Target_Typ) = E_Incomplete_Type then
2425 return Iface_Present_In_Ancestor (Target_Typ);
2426 end Interface_Present_In_Ancestor;
2428 ---------------------
2429 -- Intersect_Types --
2430 ---------------------
2432 function Intersect_Types (L, R : Node_Id) return Entity_Id is
2433 Index : Interp_Index;
2437 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2438 -- Find interpretation of right arg that has type compatible with T
2440 --------------------------
2441 -- Check_Right_Argument --
2442 --------------------------
2444 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2445 Index : Interp_Index;
2450 if not Is_Overloaded (R) then
2451 return Specific_Type (T, Etype (R));
2454 Get_First_Interp (R, Index, It);
2456 T2 := Specific_Type (T, It.Typ);
2458 if T2 /= Any_Type then
2462 Get_Next_Interp (Index, It);
2463 exit when No (It.Typ);
2468 end Check_Right_Argument;
2470 -- Start of processing for Intersect_Types
2473 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2477 if not Is_Overloaded (L) then
2478 Typ := Check_Right_Argument (Etype (L));
2482 Get_First_Interp (L, Index, It);
2483 while Present (It.Typ) loop
2484 Typ := Check_Right_Argument (It.Typ);
2485 exit when Typ /= Any_Type;
2486 Get_Next_Interp (Index, It);
2491 -- If Typ is Any_Type, it means no compatible pair of types was found
2493 if Typ = Any_Type then
2494 if Nkind (Parent (L)) in N_Op then
2495 Error_Msg_N ("incompatible types for operator", Parent (L));
2497 elsif Nkind (Parent (L)) = N_Range then
2498 Error_Msg_N ("incompatible types given in constraint", Parent (L));
2500 -- Ada 2005 (AI-251): Complete the error notification
2502 elsif Is_Class_Wide_Type (Etype (R))
2503 and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2505 Error_Msg_NE ("(Ada 2005) does not implement interface }",
2506 L, Etype (Class_Wide_Type (Etype (R))));
2509 Error_Msg_N ("incompatible types", Parent (L));
2514 end Intersect_Types;
2516 -----------------------
2517 -- In_Generic_Actual --
2518 -----------------------
2520 function In_Generic_Actual (Exp : Node_Id) return Boolean is
2521 Par : constant Node_Id := Parent (Exp);
2527 elsif Nkind (Par) in N_Declaration then
2528 if Nkind (Par) = N_Object_Declaration then
2529 return Present (Corresponding_Generic_Association (Par));
2534 elsif Nkind (Par) = N_Object_Renaming_Declaration then
2535 return Present (Corresponding_Generic_Association (Par));
2537 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2541 return In_Generic_Actual (Parent (Par));
2543 end In_Generic_Actual;
2549 function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
2555 BT1 := Base_Type (T1);
2556 BT2 := Base_Type (T2);
2558 -- Handle underlying view of records with unknown discriminants using
2559 -- the original entity that motivated the construction of this
2560 -- underlying record view (see Build_Derived_Private_Type).
2562 if Is_Underlying_Record_View (BT1) then
2563 BT1 := Underlying_Record_View (BT1);
2566 if Is_Underlying_Record_View (BT2) then
2567 BT2 := Underlying_Record_View (BT2);
2573 -- The predicate must look past privacy
2575 elsif Is_Private_Type (T1)
2576 and then Present (Full_View (T1))
2577 and then BT2 = Base_Type (Full_View (T1))
2581 elsif Is_Private_Type (T2)
2582 and then Present (Full_View (T2))
2583 and then BT1 = Base_Type (Full_View (T2))
2591 -- If there was a error on the type declaration, do not recurse
2593 if Error_Posted (Par) then
2596 elsif BT1 = Base_Type (Par)
2597 or else (Is_Private_Type (T1)
2598 and then Present (Full_View (T1))
2599 and then Base_Type (Par) = Base_Type (Full_View (T1)))
2603 elsif Is_Private_Type (Par)
2604 and then Present (Full_View (Par))
2605 and then Full_View (Par) = BT1
2609 elsif Etype (Par) /= Par then
2611 -- If this is a private type and its parent is an interface
2612 -- then use the parent of the full view (which is a type that
2613 -- implements such interface)
2615 if Is_Private_Type (Par)
2616 and then Is_Interface (Etype (Par))
2617 and then Present (Full_View (Par))
2619 Par := Etype (Full_View (Par));
2624 -- For all other cases return False, not an Ancestor
2633 ---------------------------
2634 -- Is_Invisible_Operator --
2635 ---------------------------
2637 function Is_Invisible_Operator
2639 T : Entity_Id) return Boolean
2641 Orig_Node : constant Node_Id := Original_Node (N);
2644 if Nkind (N) not in N_Op then
2647 elsif not Comes_From_Source (N) then
2650 elsif No (Universal_Interpretation (Right_Opnd (N))) then
2653 elsif Nkind (N) in N_Binary_Op
2654 and then No (Universal_Interpretation (Left_Opnd (N)))
2659 return Is_Numeric_Type (T)
2660 and then not In_Open_Scopes (Scope (T))
2661 and then not Is_Potentially_Use_Visible (T)
2662 and then not In_Use (T)
2663 and then not In_Use (Scope (T))
2665 (Nkind (Orig_Node) /= N_Function_Call
2666 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2667 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2668 and then not In_Instance;
2670 end Is_Invisible_Operator;
2672 --------------------
2674 --------------------
2676 function Is_Progenitor
2678 Typ : Entity_Id) return Boolean
2681 return Implements_Interface (Typ, Iface, Exclude_Parents => True);
2688 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2692 S := Ancestor_Subtype (T1);
2693 while Present (S) loop
2697 S := Ancestor_Subtype (S);
2708 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
2709 Index : Interp_Index;
2713 Get_First_Interp (Nam, Index, It);
2714 while Present (It.Nam) loop
2715 if Scope (It.Nam) = Standard_Standard
2716 and then Scope (It.Typ) /= Standard_Standard
2718 Error_Msg_Sloc := Sloc (Parent (It.Typ));
2719 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
2722 Error_Msg_Sloc := Sloc (It.Nam);
2723 Error_Msg_NE ("\\& declared#!", Err, It.Nam);
2726 Get_Next_Interp (Index, It);
2734 procedure New_Interps (N : Node_Id) is
2738 All_Interp.Append (No_Interp);
2740 Map_Ptr := Headers (Hash (N));
2742 if Map_Ptr = No_Entry then
2744 -- Place new node at end of table
2746 Interp_Map.Increment_Last;
2747 Headers (Hash (N)) := Interp_Map.Last;
2750 -- Place node at end of chain, or locate its previous entry
2753 if Interp_Map.Table (Map_Ptr).Node = N then
2755 -- Node is already in the table, and is being rewritten.
2756 -- Start a new interp section, retain hash link.
2758 Interp_Map.Table (Map_Ptr).Node := N;
2759 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
2760 Set_Is_Overloaded (N, True);
2764 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
2765 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2769 -- Chain the new node
2771 Interp_Map.Increment_Last;
2772 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
2775 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
2776 Set_Is_Overloaded (N, True);
2779 ---------------------------
2780 -- Operator_Matches_Spec --
2781 ---------------------------
2783 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
2784 Op_Name : constant Name_Id := Chars (Op);
2785 T : constant Entity_Id := Etype (New_S);
2793 -- To verify that a predefined operator matches a given signature,
2794 -- do a case analysis of the operator classes. Function can have one
2795 -- or two formals and must have the proper result type.
2797 New_F := First_Formal (New_S);
2798 Old_F := First_Formal (Op);
2800 while Present (New_F) and then Present (Old_F) loop
2802 Next_Formal (New_F);
2803 Next_Formal (Old_F);
2806 -- Definite mismatch if different number of parameters
2808 if Present (Old_F) or else Present (New_F) then
2814 T1 := Etype (First_Formal (New_S));
2816 if Op_Name = Name_Op_Subtract
2817 or else Op_Name = Name_Op_Add
2818 or else Op_Name = Name_Op_Abs
2820 return Base_Type (T1) = Base_Type (T)
2821 and then Is_Numeric_Type (T);
2823 elsif Op_Name = Name_Op_Not then
2824 return Base_Type (T1) = Base_Type (T)
2825 and then Valid_Boolean_Arg (Base_Type (T));
2834 T1 := Etype (First_Formal (New_S));
2835 T2 := Etype (Next_Formal (First_Formal (New_S)));
2837 if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
2838 or else Op_Name = Name_Op_Xor
2840 return Base_Type (T1) = Base_Type (T2)
2841 and then Base_Type (T1) = Base_Type (T)
2842 and then Valid_Boolean_Arg (Base_Type (T));
2844 elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
2845 return Base_Type (T1) = Base_Type (T2)
2846 and then not Is_Limited_Type (T1)
2847 and then Is_Boolean_Type (T);
2849 elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
2850 or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
2852 return Base_Type (T1) = Base_Type (T2)
2853 and then Valid_Comparison_Arg (T1)
2854 and then Is_Boolean_Type (T);
2856 elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
2857 return Base_Type (T1) = Base_Type (T2)
2858 and then Base_Type (T1) = Base_Type (T)
2859 and then Is_Numeric_Type (T);
2861 -- For division and multiplication, a user-defined function does not
2862 -- match the predefined universal_fixed operation, except in Ada 83.
2864 elsif Op_Name = Name_Op_Divide then
2865 return (Base_Type (T1) = Base_Type (T2)
2866 and then Base_Type (T1) = Base_Type (T)
2867 and then Is_Numeric_Type (T)
2868 and then (not Is_Fixed_Point_Type (T)
2869 or else Ada_Version = Ada_83))
2871 -- Mixed_Mode operations on fixed-point types
2873 or else (Base_Type (T1) = Base_Type (T)
2874 and then Base_Type (T2) = Base_Type (Standard_Integer)
2875 and then Is_Fixed_Point_Type (T))
2877 -- A user defined operator can also match (and hide) a mixed
2878 -- operation on universal literals.
2880 or else (Is_Integer_Type (T2)
2881 and then Is_Floating_Point_Type (T1)
2882 and then Base_Type (T1) = Base_Type (T));
2884 elsif Op_Name = Name_Op_Multiply then
2885 return (Base_Type (T1) = Base_Type (T2)
2886 and then Base_Type (T1) = Base_Type (T)
2887 and then Is_Numeric_Type (T)
2888 and then (not Is_Fixed_Point_Type (T)
2889 or else Ada_Version = Ada_83))
2891 -- Mixed_Mode operations on fixed-point types
2893 or else (Base_Type (T1) = Base_Type (T)
2894 and then Base_Type (T2) = Base_Type (Standard_Integer)
2895 and then Is_Fixed_Point_Type (T))
2897 or else (Base_Type (T2) = Base_Type (T)
2898 and then Base_Type (T1) = Base_Type (Standard_Integer)
2899 and then Is_Fixed_Point_Type (T))
2901 or else (Is_Integer_Type (T2)
2902 and then Is_Floating_Point_Type (T1)
2903 and then Base_Type (T1) = Base_Type (T))
2905 or else (Is_Integer_Type (T1)
2906 and then Is_Floating_Point_Type (T2)
2907 and then Base_Type (T2) = Base_Type (T));
2909 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
2910 return Base_Type (T1) = Base_Type (T2)
2911 and then Base_Type (T1) = Base_Type (T)
2912 and then Is_Integer_Type (T);
2914 elsif Op_Name = Name_Op_Expon then
2915 return Base_Type (T1) = Base_Type (T)
2916 and then Is_Numeric_Type (T)
2917 and then Base_Type (T2) = Base_Type (Standard_Integer);
2919 elsif Op_Name = Name_Op_Concat then
2920 return Is_Array_Type (T)
2921 and then (Base_Type (T) = Base_Type (Etype (Op)))
2922 and then (Base_Type (T1) = Base_Type (T)
2924 Base_Type (T1) = Base_Type (Component_Type (T)))
2925 and then (Base_Type (T2) = Base_Type (T)
2927 Base_Type (T2) = Base_Type (Component_Type (T)));
2933 end Operator_Matches_Spec;
2939 procedure Remove_Interp (I : in out Interp_Index) is
2943 -- Find end of interp list and copy downward to erase the discarded one
2946 while Present (All_Interp.Table (II).Typ) loop
2950 for J in I + 1 .. II loop
2951 All_Interp.Table (J - 1) := All_Interp.Table (J);
2954 -- Back up interp index to insure that iterator will pick up next
2955 -- available interpretation.
2964 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
2966 O_N : Node_Id := Old_N;
2969 if Is_Overloaded (Old_N) then
2970 if Nkind (Old_N) = N_Selected_Component
2971 and then Is_Overloaded (Selector_Name (Old_N))
2973 O_N := Selector_Name (Old_N);
2976 Map_Ptr := Headers (Hash (O_N));
2978 while Interp_Map.Table (Map_Ptr).Node /= O_N loop
2979 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2980 pragma Assert (Map_Ptr /= No_Entry);
2983 New_Interps (New_N);
2984 Interp_Map.Table (Interp_Map.Last).Index :=
2985 Interp_Map.Table (Map_Ptr).Index;
2993 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
2994 T1 : constant Entity_Id := Available_View (Typ_1);
2995 T2 : constant Entity_Id := Available_View (Typ_2);
2996 B1 : constant Entity_Id := Base_Type (T1);
2997 B2 : constant Entity_Id := Base_Type (T2);
2999 function Is_Remote_Access (T : Entity_Id) return Boolean;
3000 -- Check whether T is the equivalent type of a remote access type.
3001 -- If distribution is enabled, T is a legal context for Null.
3003 ----------------------
3004 -- Is_Remote_Access --
3005 ----------------------
3007 function Is_Remote_Access (T : Entity_Id) return Boolean is
3009 return Is_Record_Type (T)
3010 and then (Is_Remote_Call_Interface (T)
3011 or else Is_Remote_Types (T))
3012 and then Present (Corresponding_Remote_Type (T))
3013 and then Is_Access_Type (Corresponding_Remote_Type (T));
3014 end Is_Remote_Access;
3016 -- Start of processing for Specific_Type
3019 if T1 = Any_Type or else T2 = Any_Type then
3026 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
3027 or else (T1 = Universal_Real and then Is_Real_Type (T2))
3028 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
3029 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
3033 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
3034 or else (T2 = Universal_Real and then Is_Real_Type (T1))
3035 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
3036 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
3040 elsif T2 = Any_String and then Is_String_Type (T1) then
3043 elsif T1 = Any_String and then Is_String_Type (T2) then
3046 elsif T2 = Any_Character and then Is_Character_Type (T1) then
3049 elsif T1 = Any_Character and then Is_Character_Type (T2) then
3052 elsif T1 = Any_Access
3053 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3057 elsif T2 = Any_Access
3058 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3062 elsif T2 = Any_Composite
3063 and then Is_Aggregate_Type (T1)
3067 elsif T1 = Any_Composite
3068 and then Is_Aggregate_Type (T2)
3072 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3075 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3078 -- ----------------------------------------------------------
3079 -- Special cases for equality operators (all other predefined
3080 -- operators can never apply to tagged types)
3081 -- ----------------------------------------------------------
3083 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3086 elsif Is_Class_Wide_Type (T1)
3087 and then Is_Class_Wide_Type (T2)
3088 and then Is_Interface (Etype (T2))
3092 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3093 -- class-wide interface T2
3095 elsif Is_Class_Wide_Type (T2)
3096 and then Is_Interface (Etype (T2))
3097 and then Interface_Present_In_Ancestor (Typ => T1,
3098 Iface => Etype (T2))
3102 elsif Is_Class_Wide_Type (T1)
3103 and then Is_Ancestor (Root_Type (T1), T2)
3107 elsif Is_Class_Wide_Type (T2)
3108 and then Is_Ancestor (Root_Type (T2), T1)
3112 elsif (Ekind (B1) = E_Access_Subprogram_Type
3114 Ekind (B1) = E_Access_Protected_Subprogram_Type)
3115 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3116 and then Is_Access_Type (T2)
3120 elsif (Ekind (B2) = E_Access_Subprogram_Type
3122 Ekind (B2) = E_Access_Protected_Subprogram_Type)
3123 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3124 and then Is_Access_Type (T1)
3128 elsif (Ekind (T1) = E_Allocator_Type
3129 or else Ekind (T1) = E_Access_Attribute_Type
3130 or else Ekind (T1) = E_Anonymous_Access_Type)
3131 and then Is_Access_Type (T2)
3135 elsif (Ekind (T2) = E_Allocator_Type
3136 or else Ekind (T2) = E_Access_Attribute_Type
3137 or else Ekind (T2) = E_Anonymous_Access_Type)
3138 and then Is_Access_Type (T1)
3142 -- If none of the above cases applies, types are not compatible
3149 ---------------------
3150 -- Set_Abstract_Op --
3151 ---------------------
3153 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3155 All_Interp.Table (I).Abstract_Op := V;
3156 end Set_Abstract_Op;
3158 -----------------------
3159 -- Valid_Boolean_Arg --
3160 -----------------------
3162 -- In addition to booleans and arrays of booleans, we must include
3163 -- aggregates as valid boolean arguments, because in the first pass of
3164 -- resolution their components are not examined. If it turns out not to be
3165 -- an aggregate of booleans, this will be diagnosed in Resolve.
3166 -- Any_Composite must be checked for prior to the array type checks because
3167 -- Any_Composite does not have any associated indexes.
3169 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3171 return Is_Boolean_Type (T)
3172 or else T = Any_Composite
3173 or else (Is_Array_Type (T)
3174 and then T /= Any_String
3175 and then Number_Dimensions (T) = 1
3176 and then Is_Boolean_Type (Component_Type (T))
3177 and then (not Is_Private_Composite (T)
3178 or else In_Instance)
3179 and then (not Is_Limited_Composite (T)
3180 or else In_Instance))
3181 or else Is_Modular_Integer_Type (T)
3182 or else T = Universal_Integer;
3183 end Valid_Boolean_Arg;
3185 --------------------------
3186 -- Valid_Comparison_Arg --
3187 --------------------------
3189 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3192 if T = Any_Composite then
3194 elsif Is_Discrete_Type (T)
3195 or else Is_Real_Type (T)
3198 elsif Is_Array_Type (T)
3199 and then Number_Dimensions (T) = 1
3200 and then Is_Discrete_Type (Component_Type (T))
3201 and then (not Is_Private_Composite (T)
3202 or else In_Instance)
3203 and then (not Is_Limited_Composite (T)
3204 or else In_Instance)
3207 elsif Is_String_Type (T) then
3212 end Valid_Comparison_Arg;
3214 ----------------------
3215 -- Write_Interp_Ref --
3216 ----------------------
3218 procedure Write_Interp_Ref (Map_Ptr : Int) is
3220 Write_Str (" Node: ");
3221 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3222 Write_Str (" Index: ");
3223 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3224 Write_Str (" Next: ");
3225 Write_Int (Interp_Map.Table (Map_Ptr).Next);
3227 end Write_Interp_Ref;
3229 ---------------------
3230 -- Write_Overloads --
3231 ---------------------
3233 procedure Write_Overloads (N : Node_Id) is
3239 if not Is_Overloaded (N) then
3240 Write_Str ("Non-overloaded entity ");
3242 Write_Entity_Info (Entity (N), " ");
3245 Get_First_Interp (N, I, It);
3246 Write_Str ("Overloaded entity ");
3248 Write_Str (" Name Type Abstract Op");
3250 Write_Str ("===============================================");
3254 while Present (Nam) loop
3255 Write_Int (Int (Nam));
3257 Write_Name (Chars (Nam));
3259 Write_Int (Int (It.Typ));
3261 Write_Name (Chars (It.Typ));
3263 if Present (It.Abstract_Op) then
3265 Write_Int (Int (It.Abstract_Op));
3267 Write_Name (Chars (It.Abstract_Op));
3271 Get_Next_Interp (I, It);
3275 end Write_Overloads;