1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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
61 -- set of interpretations is terminated with the marker No_Interp.
62 -- In order to speed up the retrieval of the interpretations of an
63 -- overloaded node, the Interp_Map table is accessed by means of a simple
64 -- hashing scheme, and the entries in Interp_Map are chained. The heads
65 -- of clash lists are 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
136 -- other entities. We do not introduce explicit versions of primitive
137 -- operators for each type definition. As a result, there is only one
138 -- entity corresponding to predefined addition on all numeric types, etc.
139 -- The back-end resolves predefined operators according to their type.
140 -- The visibility of primitive operations then reduces to the visibility
141 -- of the resulting type: (a + b) is a legal interpretation of some
142 -- primitive operator + if the type of the result (which must also be
143 -- the type of a and b) is directly visible (i.e. either immediately
144 -- 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
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
173 function Function_Interp_Has_Abstract_Op
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
181 function Has_Abstract_Op
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
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).
202 procedure Add_One_Interp
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
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.
223 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
224 Abstr_Op
: Entity_Id
:= Empty
;
228 -- Start of processing for Add_Entry
231 -- Find out whether the new entry references interpretations that
232 -- are abstract or disabled by abstract operators.
234 if Ada_Version
>= Ada_05
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
);
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
))
259 and then Is_Immediately_Visible
(It
.Nam
)
260 and then Type_Conformant
(Name
, It
.Nam
)
261 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
263 if Is_Universal_Operation
(Name
) then
266 -- If node is an operator symbol, we have no actuals with
267 -- which to check hiding, and this is done in full in the
268 -- caller (Analyze_Subprogram_Renaming) so we include the
269 -- predefined operator in any case.
271 elsif Nkind
(N
) = N_Operator_Symbol
272 or else (Nkind
(N
) = N_Expanded_Name
274 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
278 elsif not In_Open_Scopes
(Scope
(Name
))
279 or else Scope_Depth
(Scope
(Name
)) <=
280 Scope_Depth
(Scope
(It
.Nam
))
282 -- If ambiguity within instance, and entity is not an
283 -- implicit operation, save for later disambiguation.
285 if Scope
(Name
) = Scope
(It
.Nam
)
286 and then not Is_Inherited_Operation
(Name
)
295 All_Interp
.Table
(I
).Nam
:= Name
;
299 -- Avoid making duplicate entries in overloads
302 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
306 -- Otherwise keep going
309 Get_Next_Interp
(I
, It
);
314 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
315 All_Interp
.Append
(No_Interp
);
318 ----------------------------
319 -- Is_Universal_Operation --
320 ----------------------------
322 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
326 if Ekind
(Op
) /= E_Operator
then
329 elsif Nkind
(N
) in N_Binary_Op
then
330 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
331 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
333 elsif Nkind
(N
) in N_Unary_Op
then
334 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
336 elsif Nkind
(N
) = N_Function_Call
then
337 Arg
:= First_Actual
(N
);
338 while Present
(Arg
) loop
339 if No
(Universal_Interpretation
(Arg
)) then
351 end Is_Universal_Operation
;
353 -- Start of processing for Add_One_Interp
356 -- If the interpretation is a predefined operator, verify that the
357 -- result type is visible, or that the entity has already been
358 -- resolved (case of an instantiation node that refers to a predefined
359 -- operation, or an internally generated operator node, or an operator
360 -- given as an expanded name). If the operator is a comparison or
361 -- equality, it is the type of the operand that matters to determine
362 -- whether the operator is visible. In an instance, the check is not
363 -- performed, given that the operator was visible in the generic.
365 if Ekind
(E
) = E_Operator
then
367 if Present
(Opnd_Type
) then
368 Vis_Type
:= Opnd_Type
;
370 Vis_Type
:= Base_Type
(T
);
373 if In_Open_Scopes
(Scope
(Vis_Type
))
374 or else Is_Potentially_Use_Visible
(Vis_Type
)
375 or else In_Use
(Vis_Type
)
376 or else (In_Use
(Scope
(Vis_Type
))
377 and then not Is_Hidden
(Vis_Type
))
378 or else Nkind
(N
) = N_Expanded_Name
379 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
381 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
385 -- If the node is given in functional notation and the prefix
386 -- is an expanded name, then the operator is visible if the
387 -- prefix is the scope of the result type as well. If the
388 -- operator is (implicitly) defined in an extension of system,
389 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
391 elsif Nkind
(N
) = N_Function_Call
392 and then Nkind
(Name
(N
)) = N_Expanded_Name
393 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
394 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
395 or else Scope
(Vis_Type
) = System_Aux_Id
)
399 -- Save type for subsequent error message, in case no other
400 -- interpretation is found.
403 Candidate_Type
:= Vis_Type
;
407 -- In an instance, an abstract non-dispatching operation cannot be a
408 -- candidate interpretation, because it could not have been one in the
409 -- generic (it may be a spurious overloading in the instance).
412 and then Is_Overloadable
(E
)
413 and then Is_Abstract_Subprogram
(E
)
414 and then not Is_Dispatching_Operation
(E
)
418 -- An inherited interface operation that is implemented by some derived
419 -- type does not participate in overload resolution, only the
420 -- implementation operation does.
423 and then Is_Subprogram
(E
)
424 and then Present
(Interface_Alias
(E
))
426 -- Ada 2005 (AI-251): If this primitive operation corresponds with
427 -- an immediate ancestor interface there is no need to add it to the
428 -- list of interpretations. The corresponding aliased primitive is
429 -- also in this list of primitive operations and will be used instead
430 -- because otherwise we have a dummy ambiguity between the two
431 -- subprograms which are in fact the same.
434 (Find_Dispatching_Type
(Interface_Alias
(E
)),
435 Find_Dispatching_Type
(E
))
437 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
442 -- Calling stubs for an RACW operation never participate in resolution,
443 -- they are executed only through dispatching calls.
445 elsif Is_RACW_Stub_Type_Operation
(E
) then
449 -- If this is the first interpretation of N, N has type Any_Type.
450 -- In that case place the new type on the node. If one interpretation
451 -- already exists, indicate that the node is overloaded, and store
452 -- both the previous and the new interpretation in All_Interp. If
453 -- this is a later interpretation, just add it to the set.
455 if Etype
(N
) = Any_Type
then
460 -- Record both the operator or subprogram name, and its type
462 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
469 -- Either there is no current interpretation in the table for any
470 -- node or the interpretation that is present is for a different
471 -- node. In both cases add a new interpretation to the table.
473 elsif Interp_Map
.Last
< 0
475 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
476 and then not Is_Overloaded
(N
))
480 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
481 and then Present
(Entity
(N
))
483 Add_Entry
(Entity
(N
), Etype
(N
));
485 elsif (Nkind
(N
) = N_Function_Call
486 or else Nkind
(N
) = N_Procedure_Call_Statement
)
487 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
488 or else Is_Entity_Name
(Name
(N
)))
490 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
492 -- If this is an indirect call there will be no name associated
493 -- with the previous entry. To make diagnostics clearer, save
494 -- Subprogram_Type of first interpretation, so that the error will
495 -- point to the anonymous access to subprogram, not to the result
496 -- type of the call itself.
498 elsif (Nkind
(N
)) = N_Function_Call
499 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
500 and then Is_Overloaded
(Name
(N
))
506 pragma Warnings
(Off
, Itn
);
509 Get_First_Interp
(Name
(N
), Itn
, It
);
510 Add_Entry
(It
.Nam
, Etype
(N
));
514 -- Overloaded prefix in indexed or selected component, or call
515 -- whose name is an expression or another call.
517 Add_Entry
(Etype
(N
), Etype
(N
));
531 procedure All_Overloads
is
533 for J
in All_Interp
.First
.. All_Interp
.Last
loop
535 if Present
(All_Interp
.Table
(J
).Nam
) then
536 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
538 Write_Str
("No Interp");
542 Write_Str
("=================");
547 --------------------------------------
548 -- Binary_Op_Interp_Has_Abstract_Op --
549 --------------------------------------
551 function Binary_Op_Interp_Has_Abstract_Op
553 E
: Entity_Id
) return Entity_Id
555 Abstr_Op
: Entity_Id
;
556 E_Left
: constant Node_Id
:= First_Formal
(E
);
557 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
560 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
561 if Present
(Abstr_Op
) then
565 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
566 end Binary_Op_Interp_Has_Abstract_Op
;
568 ---------------------
569 -- Collect_Interps --
570 ---------------------
572 procedure Collect_Interps
(N
: Node_Id
) is
573 Ent
: constant Entity_Id
:= Entity
(N
);
575 First_Interp
: Interp_Index
;
580 -- Unconditionally add the entity that was initially matched
582 First_Interp
:= All_Interp
.Last
;
583 Add_One_Interp
(N
, Ent
, Etype
(N
));
585 -- For expanded name, pick up all additional entities from the
586 -- same scope, since these are obviously also visible. Note that
587 -- these are not necessarily contiguous on the homonym chain.
589 if Nkind
(N
) = N_Expanded_Name
then
591 while Present
(H
) loop
592 if Scope
(H
) = Scope
(Entity
(N
)) then
593 Add_One_Interp
(N
, H
, Etype
(H
));
599 -- Case of direct name
602 -- First, search the homonym chain for directly visible entities
604 H
:= Current_Entity
(Ent
);
605 while Present
(H
) loop
606 exit when (not Is_Overloadable
(H
))
607 and then Is_Immediately_Visible
(H
);
609 if Is_Immediately_Visible
(H
)
612 -- Only add interpretation if not hidden by an inner
613 -- immediately visible one.
615 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
617 -- Current homograph is not hidden. Add to overloads
619 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
622 -- Homograph is hidden, unless it is a predefined operator
624 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
626 -- A homograph in the same scope can occur within an
627 -- instantiation, the resulting ambiguity has to be
630 if Scope
(H
) = Scope
(Ent
)
632 and then not Is_Inherited_Operation
(H
)
634 All_Interp
.Table
(All_Interp
.Last
) :=
635 (H
, Etype
(H
), Empty
);
636 All_Interp
.Append
(No_Interp
);
639 elsif Scope
(H
) /= Standard_Standard
then
645 -- On exit, we know that current homograph is not hidden
647 Add_One_Interp
(N
, H
, Etype
(H
));
650 Write_Str
("Add overloaded interpretation ");
660 -- Scan list of homographs for use-visible entities only
662 H
:= Current_Entity
(Ent
);
664 while Present
(H
) loop
665 if Is_Potentially_Use_Visible
(H
)
667 and then Is_Overloadable
(H
)
669 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
671 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
674 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
675 goto Next_Use_Homograph
;
679 Add_One_Interp
(N
, H
, Etype
(H
));
682 <<Next_Use_Homograph
>>
687 if All_Interp
.Last
= First_Interp
+ 1 then
689 -- The final interpretation is in fact not overloaded. Note that the
690 -- unique legal interpretation may or may not be the original one,
691 -- so we need to update N's entity and etype now, because once N
692 -- is marked as not overloaded it is also expected to carry the
693 -- proper interpretation.
695 Set_Is_Overloaded
(N
, False);
696 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
697 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
705 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
710 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
711 -- In an instance the proper view may not always be correct for
712 -- private types, but private and full view are compatible. This
713 -- removes spurious errors from nested instantiations that involve,
714 -- among other things, types derived from private types.
716 ----------------------
717 -- Full_View_Covers --
718 ----------------------
720 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
723 Is_Private_Type
(Typ1
)
725 ((Present
(Full_View
(Typ1
))
726 and then Covers
(Full_View
(Typ1
), Typ2
))
727 or else Base_Type
(Typ1
) = Typ2
728 or else Base_Type
(Typ2
) = Typ1
);
729 end Full_View_Covers
;
731 -- Start of processing for Covers
734 -- If either operand missing, then this is an error, but ignore it (and
735 -- pretend we have a cover) if errors already detected, since this may
736 -- simply mean we have malformed trees.
738 if No
(T1
) or else No
(T2
) then
739 if Total_Errors_Detected
/= 0 then
746 BT1
:= Base_Type
(T1
);
747 BT2
:= Base_Type
(T2
);
749 -- Handle underlying view of records with unknown discriminants
750 -- using the original entity that motivated the construction of
751 -- this underlying record view (see Build_Derived_Private_Type).
753 if Is_Underlying_Record_View
(BT1
) then
754 BT1
:= Underlying_Record_View
(BT1
);
757 if Is_Underlying_Record_View
(BT2
) then
758 BT2
:= Underlying_Record_View
(BT2
);
762 -- Simplest case: same types are compatible, and types that have the
763 -- same base type and are not generic actuals are compatible. Generic
764 -- actuals belong to their class but are not compatible with other
765 -- types of their class, and in particular with other generic actuals.
766 -- They are however compatible with their own subtypes, and itypes
767 -- with the same base are compatible as well. Similarly, constrained
768 -- subtypes obtained from expressions of an unconstrained nominal type
769 -- are compatible with the base type (may lead to spurious ambiguities
770 -- in obscure cases ???)
772 -- Generic actuals require special treatment to avoid spurious ambi-
773 -- guities in an instance, when two formal types are instantiated with
774 -- the same actual, so that different subprograms end up with the same
775 -- signature in the instance.
784 if not Is_Generic_Actual_Type
(T1
) then
787 return (not Is_Generic_Actual_Type
(T2
)
788 or else Is_Itype
(T1
)
789 or else Is_Itype
(T2
)
790 or else Is_Constr_Subt_For_U_Nominal
(T1
)
791 or else Is_Constr_Subt_For_U_Nominal
(T2
)
792 or else Scope
(T1
) /= Scope
(T2
));
795 -- Literals are compatible with types in a given "class"
797 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
798 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
799 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
800 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
801 or else (T2
= Any_String
and then Is_String_Type
(T1
))
802 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
803 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
807 -- The context may be class wide
809 elsif Is_Class_Wide_Type
(T1
)
810 and then Is_Ancestor
(Root_Type
(T1
), T2
)
814 elsif Is_Class_Wide_Type
(T1
)
815 and then Is_Class_Wide_Type
(T2
)
816 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
820 -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
821 -- task_type or protected_type implementing T1
823 elsif Ada_Version
>= Ada_05
824 and then Is_Class_Wide_Type
(T1
)
825 and then Is_Interface
(Etype
(T1
))
826 and then Is_Concurrent_Type
(T2
)
827 and then Interface_Present_In_Ancestor
828 (Typ
=> Base_Type
(T2
),
833 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
834 -- object T2 implementing T1
836 elsif Ada_Version
>= Ada_05
837 and then Is_Class_Wide_Type
(T1
)
838 and then Is_Interface
(Etype
(T1
))
839 and then Is_Tagged_Type
(T2
)
841 if Interface_Present_In_Ancestor
(Typ
=> T2
,
852 if Is_Concurrent_Type
(BT2
) then
853 E
:= Corresponding_Record_Type
(BT2
);
858 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
859 -- covers an object T2 that implements a direct derivation of T1.
860 -- Note: test for presence of E is defense against previous error.
863 and then Present
(Interfaces
(E
))
865 Elmt
:= First_Elmt
(Interfaces
(E
));
866 while Present
(Elmt
) loop
867 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
875 -- We should also check the case in which T1 is an ancestor of
876 -- some implemented interface???
881 -- In a dispatching call the actual may be class-wide
883 elsif Is_Class_Wide_Type
(T2
)
884 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
888 -- Some contexts require a class of types rather than a specific type
890 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
891 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
892 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
893 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
894 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
898 -- An aggregate is compatible with an array or record type
900 elsif T2
= Any_Composite
901 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
905 -- If the expected type is an anonymous access, the designated type must
906 -- cover that of the expression. Use the base type for this check: even
907 -- though access subtypes are rare in sources, they are generated for
908 -- actuals in instantiations.
910 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
911 and then Is_Access_Type
(T2
)
912 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
916 -- An Access_To_Subprogram is compatible with itself, or with an
917 -- anonymous type created for an attribute reference Access.
919 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
921 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
922 and then Is_Access_Type
(T2
)
923 and then (not Comes_From_Source
(T1
)
924 or else not Comes_From_Source
(T2
))
925 and then (Is_Overloadable
(Designated_Type
(T2
))
927 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
929 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
931 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
935 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
936 -- with itself, or with an anonymous type created for an attribute
939 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
942 = E_Anonymous_Access_Protected_Subprogram_Type
)
943 and then Is_Access_Type
(T2
)
944 and then (not Comes_From_Source
(T1
)
945 or else not Comes_From_Source
(T2
))
946 and then (Is_Overloadable
(Designated_Type
(T2
))
948 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
950 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
952 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
956 -- The context can be a remote access type, and the expression the
957 -- corresponding source type declared in a categorized package, or
960 elsif Is_Record_Type
(T1
)
961 and then (Is_Remote_Call_Interface
(T1
)
962 or else Is_Remote_Types
(T1
))
963 and then Present
(Corresponding_Remote_Type
(T1
))
965 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
967 elsif Is_Record_Type
(T2
)
968 and then (Is_Remote_Call_Interface
(T2
)
969 or else Is_Remote_Types
(T2
))
970 and then Present
(Corresponding_Remote_Type
(T2
))
972 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
974 elsif Ekind
(T2
) = E_Access_Attribute_Type
975 and then (Ekind
(BT1
) = E_General_Access_Type
976 or else Ekind
(BT1
) = E_Access_Type
)
977 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
979 -- If the target type is a RACW type while the source is an access
980 -- attribute type, we are building a RACW that may be exported.
982 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
983 Set_Has_RACW
(Current_Sem_Unit
);
988 elsif Ekind
(T2
) = E_Allocator_Type
989 and then Is_Access_Type
(T1
)
991 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
993 (From_With_Type
(Designated_Type
(T1
))
994 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
996 -- A boolean operation on integer literals is compatible with modular
999 elsif T2
= Any_Modular
1000 and then Is_Modular_Integer_Type
(T1
)
1004 -- The actual type may be the result of a previous error
1006 elsif Base_Type
(T2
) = Any_Type
then
1009 -- A packed array type covers its corresponding non-packed type. This is
1010 -- not legitimate Ada, but allows the omission of a number of otherwise
1011 -- useless unchecked conversions, and since this can only arise in
1012 -- (known correct) expanded code, no harm is done
1014 elsif Is_Array_Type
(T2
)
1015 and then Is_Packed
(T2
)
1016 and then T1
= Packed_Array_Type
(T2
)
1020 -- Similarly an array type covers its corresponding packed array type
1022 elsif Is_Array_Type
(T1
)
1023 and then Is_Packed
(T1
)
1024 and then T2
= Packed_Array_Type
(T1
)
1028 -- In instances, or with types exported from instantiations, check
1029 -- whether a partial and a full view match. Verify that types are
1030 -- legal, to prevent cascaded errors.
1034 (Full_View_Covers
(T1
, T2
)
1035 or else Full_View_Covers
(T2
, T1
))
1040 and then Is_Generic_Actual_Type
(T2
)
1041 and then Full_View_Covers
(T1
, T2
)
1046 and then Is_Generic_Actual_Type
(T1
)
1047 and then Full_View_Covers
(T2
, T1
)
1051 -- In the expansion of inlined bodies, types are compatible if they
1052 -- are structurally equivalent.
1054 elsif In_Inlined_Body
1055 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1056 or else (Is_Access_Type
(T1
)
1057 and then Is_Access_Type
(T2
)
1059 Designated_Type
(T1
) = Designated_Type
(T2
))
1060 or else (T1
= Any_Access
1061 and then Is_Access_Type
(Underlying_Type
(T2
)))
1062 or else (T2
= Any_Composite
1064 Is_Composite_Type
(Underlying_Type
(T1
))))
1068 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1069 -- compatible with its real entity.
1071 elsif From_With_Type
(T1
) then
1073 -- If the expected type is the non-limited view of a type, the
1074 -- expression may have the limited view. If that one in turn is
1075 -- incomplete, get full view if available.
1077 if Is_Incomplete_Type
(T1
) then
1078 return Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1080 elsif Ekind
(T1
) = E_Class_Wide_Type
then
1082 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1087 elsif From_With_Type
(T2
) then
1089 -- If units in the context have Limited_With clauses on each other,
1090 -- either type might have a limited view. Checks performed elsewhere
1091 -- verify that the context type is the non-limited view.
1093 if Is_Incomplete_Type
(T2
) then
1094 return Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1096 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1098 Present
(Non_Limited_View
(Etype
(T2
)))
1100 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1105 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1107 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1108 return Covers
(Full_View
(Etype
(T1
)), T2
);
1110 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1111 return Covers
(T1
, Full_View
(Etype
(T2
)));
1113 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1114 -- and actual anonymous access types in the context of generic
1115 -- instantiation. We have the following situation:
1118 -- type Formal is private;
1119 -- Formal_Obj : access Formal; -- T1
1123 -- type Actual is ...
1124 -- Actual_Obj : access Actual; -- T2
1125 -- package Instance is new G (Formal => Actual,
1126 -- Formal_Obj => Actual_Obj);
1128 elsif Ada_Version
>= Ada_05
1129 and then Ekind
(T1
) = E_Anonymous_Access_Type
1130 and then Ekind
(T2
) = E_Anonymous_Access_Type
1131 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1132 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1133 Directly_Designated_Type
(T2
)
1137 -- Otherwise it doesn't cover!
1148 function Disambiguate
1150 I1
, I2
: Interp_Index
;
1157 Nam1
, Nam2
: Entity_Id
;
1158 Predef_Subp
: Entity_Id
;
1159 User_Subp
: Entity_Id
;
1161 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1162 -- Determine whether one of the candidates is an operation inherited by
1163 -- a type that is derived from an actual in an instantiation.
1165 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean;
1166 -- Determine whether the expression is part of a generic actual. At
1167 -- the time the actual is resolved the scope is already that of the
1168 -- instance, but conceptually the resolution of the actual takes place
1169 -- in the enclosing context, and no special disambiguation rules should
1172 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1173 -- Determine whether a subprogram is an actual in an enclosing instance.
1174 -- An overloading between such a subprogram and one declared outside the
1175 -- instance is resolved in favor of the first, because it resolved in
1178 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1179 -- Look for exact type match in an instance, to remove spurious
1180 -- ambiguities when two formal types have the same actual.
1182 function Standard_Operator
return Boolean;
1183 -- Check whether subprogram is predefined operator declared in Standard.
1184 -- It may given by an operator name, or by an expanded name whose prefix
1187 function Remove_Conversions
return Interp
;
1188 -- Last chance for pathological cases involving comparisons on literals,
1189 -- and user overloadings of the same operator. Such pathologies have
1190 -- been removed from the ACVC, but still appear in two DEC tests, with
1191 -- the following notable quote from Ben Brosgol:
1193 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1194 -- this example; Robert Dewar brought it to our attention, since it is
1195 -- apparently found in the ACVC 1.5. I did not attempt to find the
1196 -- reason in the Reference Manual that makes the example legal, since I
1197 -- was too nauseated by it to want to pursue it further.]
1199 -- Accordingly, this is not a fully recursive solution, but it handles
1200 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1201 -- pathology in the other direction with calls whose multiple overloaded
1202 -- actuals make them truly unresolvable.
1204 -- The new rules concerning abstract operations create additional need
1205 -- for special handling of expressions with universal operands, see
1206 -- comments to Has_Abstract_Interpretation below.
1208 ------------------------
1209 -- In_Generic_Actual --
1210 ------------------------
1212 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
1213 Par
: constant Node_Id
:= Parent
(Exp
);
1219 elsif Nkind
(Par
) in N_Declaration
then
1220 if Nkind
(Par
) = N_Object_Declaration
1221 or else Nkind
(Par
) = N_Object_Renaming_Declaration
1223 return Present
(Corresponding_Generic_Association
(Par
));
1228 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
1232 return In_Generic_Actual
(Parent
(Par
));
1234 end In_Generic_Actual
;
1236 ---------------------------
1237 -- Inherited_From_Actual --
1238 ---------------------------
1240 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1241 Par
: constant Node_Id
:= Parent
(S
);
1243 if Nkind
(Par
) /= N_Full_Type_Declaration
1244 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1248 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1250 Is_Generic_Actual_Type
(
1251 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1253 end Inherited_From_Actual
;
1255 --------------------------
1256 -- Is_Actual_Subprogram --
1257 --------------------------
1259 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1261 return In_Open_Scopes
(Scope
(S
))
1263 (Is_Generic_Instance
(Scope
(S
))
1264 or else Is_Wrapper_Package
(Scope
(S
)));
1265 end Is_Actual_Subprogram
;
1271 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1272 T1
: constant Entity_Id
:= Etype
(Actual
);
1273 T2
: constant Entity_Id
:= Etype
(Formal
);
1277 (Is_Numeric_Type
(T2
)
1279 (T1
= Universal_Real
or else T1
= Universal_Integer
));
1282 ------------------------
1283 -- Remove_Conversions --
1284 ------------------------
1286 function Remove_Conversions
return Interp
is
1294 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1295 -- If an operation has universal operands the universal operation
1296 -- is present among its interpretations. If there is an abstract
1297 -- interpretation for the operator, with a numeric result, this
1298 -- interpretation was already removed in sem_ch4, but the universal
1299 -- one is still visible. We must rescan the list of operators and
1300 -- remove the universal interpretation to resolve the ambiguity.
1302 ---------------------------------
1303 -- Has_Abstract_Interpretation --
1304 ---------------------------------
1306 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1310 if Nkind
(N
) not in N_Op
1311 or else Ada_Version
< Ada_05
1312 or else not Is_Overloaded
(N
)
1313 or else No
(Universal_Interpretation
(N
))
1318 E
:= Get_Name_Entity_Id
(Chars
(N
));
1319 while Present
(E
) loop
1320 if Is_Overloadable
(E
)
1321 and then Is_Abstract_Subprogram
(E
)
1322 and then Is_Numeric_Type
(Etype
(E
))
1330 -- Finally, if an operand of the binary operator is itself
1331 -- an operator, recurse to see whether its own abstract
1332 -- interpretation is responsible for the spurious ambiguity.
1334 if Nkind
(N
) in N_Binary_Op
then
1335 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1336 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1338 elsif Nkind
(N
) in N_Unary_Op
then
1339 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1345 end Has_Abstract_Interpretation
;
1347 -- Start of processing for Remove_Conversions
1352 Get_First_Interp
(N
, I
, It
);
1353 while Present
(It
.Typ
) loop
1354 if not Is_Overloadable
(It
.Nam
) then
1358 F1
:= First_Formal
(It
.Nam
);
1364 if Nkind
(N
) = N_Function_Call
1365 or else Nkind
(N
) = N_Procedure_Call_Statement
1367 Act1
:= First_Actual
(N
);
1369 if Present
(Act1
) then
1370 Act2
:= Next_Actual
(Act1
);
1375 elsif Nkind
(N
) in N_Unary_Op
then
1376 Act1
:= Right_Opnd
(N
);
1379 elsif Nkind
(N
) in N_Binary_Op
then
1380 Act1
:= Left_Opnd
(N
);
1381 Act2
:= Right_Opnd
(N
);
1383 -- Use type of second formal, so as to include
1384 -- exponentiation, where the exponent may be
1385 -- ambiguous and the result non-universal.
1393 if Nkind
(Act1
) in N_Op
1394 and then Is_Overloaded
(Act1
)
1395 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1396 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1397 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1398 and then Etype
(F1
) = Standard_Boolean
1400 -- If the two candidates are the original ones, the
1401 -- ambiguity is real. Otherwise keep the original, further
1402 -- calls to Disambiguate will take care of others in the
1403 -- list of candidates.
1405 if It1
/= No_Interp
then
1406 if It
= Disambiguate
.It1
1407 or else It
= Disambiguate
.It2
1409 if It1
= Disambiguate
.It1
1410 or else It1
= Disambiguate
.It2
1418 elsif Present
(Act2
)
1419 and then Nkind
(Act2
) in N_Op
1420 and then Is_Overloaded
(Act2
)
1421 and then (Nkind
(Right_Opnd
(Act2
)) = N_Integer_Literal
1423 Nkind
(Right_Opnd
(Act2
)) = N_Real_Literal
)
1424 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1426 -- The preference rule on the first actual is not
1427 -- sufficient to disambiguate.
1435 elsif Is_Numeric_Type
(Etype
(F1
))
1436 and then Has_Abstract_Interpretation
(Act1
)
1438 -- Current interpretation is not the right one because it
1439 -- expects a numeric operand. Examine all the other ones.
1446 Get_First_Interp
(N
, I
, It
);
1447 while Present
(It
.Typ
) loop
1449 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1452 or else not Has_Abstract_Interpretation
(Act2
)
1455 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1461 Get_Next_Interp
(I
, It
);
1470 Get_Next_Interp
(I
, It
);
1473 -- After some error, a formal may have Any_Type and yield a spurious
1474 -- match. To avoid cascaded errors if possible, check for such a
1475 -- formal in either candidate.
1477 if Serious_Errors_Detected
> 0 then
1482 Formal
:= First_Formal
(Nam1
);
1483 while Present
(Formal
) loop
1484 if Etype
(Formal
) = Any_Type
then
1485 return Disambiguate
.It2
;
1488 Next_Formal
(Formal
);
1491 Formal
:= First_Formal
(Nam2
);
1492 while Present
(Formal
) loop
1493 if Etype
(Formal
) = Any_Type
then
1494 return Disambiguate
.It1
;
1497 Next_Formal
(Formal
);
1503 end Remove_Conversions
;
1505 -----------------------
1506 -- Standard_Operator --
1507 -----------------------
1509 function Standard_Operator
return Boolean is
1513 if Nkind
(N
) in N_Op
then
1516 elsif Nkind
(N
) = N_Function_Call
then
1519 if Nkind
(Nam
) /= N_Expanded_Name
then
1522 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1527 end Standard_Operator
;
1529 -- Start of processing for Disambiguate
1532 -- Recover the two legal interpretations
1534 Get_First_Interp
(N
, I
, It
);
1536 Get_Next_Interp
(I
, It
);
1542 Get_Next_Interp
(I
, It
);
1548 if Ada_Version
< Ada_05
then
1550 -- Check whether one of the entities is an Ada 2005 entity and we are
1551 -- operating in an earlier mode, in which case we discard the Ada
1552 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1554 if Is_Ada_2005_Only
(Nam1
) then
1556 elsif Is_Ada_2005_Only
(Nam2
) then
1561 -- Check for overloaded CIL convention stuff because the CIL libraries
1562 -- do sick things like Console.Write_Line where it matches two different
1563 -- overloads, so just pick the first ???
1565 if Convention
(Nam1
) = Convention_CIL
1566 and then Convention
(Nam2
) = Convention_CIL
1567 and then Ekind
(Nam1
) = Ekind
(Nam2
)
1568 and then (Ekind
(Nam1
) = E_Procedure
1569 or else Ekind
(Nam1
) = E_Function
)
1574 -- If the context is universal, the predefined operator is preferred.
1575 -- This includes bounds in numeric type declarations, and expressions
1576 -- in type conversions. If no interpretation yields a universal type,
1577 -- then we must check whether the user-defined entity hides the prede-
1580 if Chars
(Nam1
) in Any_Operator_Name
1581 and then Standard_Operator
1583 if Typ
= Universal_Integer
1584 or else Typ
= Universal_Real
1585 or else Typ
= Any_Integer
1586 or else Typ
= Any_Discrete
1587 or else Typ
= Any_Real
1588 or else Typ
= Any_Type
1590 -- Find an interpretation that yields the universal type, or else
1591 -- a predefined operator that yields a predefined numeric type.
1594 Candidate
: Interp
:= No_Interp
;
1597 Get_First_Interp
(N
, I
, It
);
1598 while Present
(It
.Typ
) loop
1599 if (Covers
(Typ
, It
.Typ
)
1600 or else Typ
= Any_Type
)
1602 (It
.Typ
= Universal_Integer
1603 or else It
.Typ
= Universal_Real
)
1607 elsif Covers
(Typ
, It
.Typ
)
1608 and then Scope
(It
.Typ
) = Standard_Standard
1609 and then Scope
(It
.Nam
) = Standard_Standard
1610 and then Is_Numeric_Type
(It
.Typ
)
1615 Get_Next_Interp
(I
, It
);
1618 if Candidate
/= No_Interp
then
1623 elsif Chars
(Nam1
) /= Name_Op_Not
1624 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1626 -- Equality or comparison operation. Choose predefined operator if
1627 -- arguments are universal. The node may be an operator, name, or
1628 -- a function call, so unpack arguments accordingly.
1631 Arg1
, Arg2
: Node_Id
;
1634 if Nkind
(N
) in N_Op
then
1635 Arg1
:= Left_Opnd
(N
);
1636 Arg2
:= Right_Opnd
(N
);
1638 elsif Is_Entity_Name
(N
)
1639 or else Nkind
(N
) = N_Operator_Symbol
1641 Arg1
:= First_Entity
(Entity
(N
));
1642 Arg2
:= Next_Entity
(Arg1
);
1645 Arg1
:= First_Actual
(N
);
1646 Arg2
:= Next_Actual
(Arg1
);
1650 and then Present
(Universal_Interpretation
(Arg1
))
1651 and then Universal_Interpretation
(Arg2
) =
1652 Universal_Interpretation
(Arg1
)
1654 Get_First_Interp
(N
, I
, It
);
1655 while Scope
(It
.Nam
) /= Standard_Standard
loop
1656 Get_Next_Interp
(I
, It
);
1665 -- If no universal interpretation, check whether user-defined operator
1666 -- hides predefined one, as well as other special cases. If the node
1667 -- is a range, then one or both bounds are ambiguous. Each will have
1668 -- to be disambiguated w.r.t. the context type. The type of the range
1669 -- itself is imposed by the context, so we can return either legal
1672 if Ekind
(Nam1
) = E_Operator
then
1673 Predef_Subp
:= Nam1
;
1676 elsif Ekind
(Nam2
) = E_Operator
then
1677 Predef_Subp
:= Nam2
;
1680 elsif Nkind
(N
) = N_Range
then
1683 -- Implement AI05-105: A renaming declaration with an access
1684 -- definition must resolve to an anonymous access type. This
1685 -- is a resolution rule and can be used to disambiguate.
1687 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1688 and then Present
(Access_Definition
(Parent
(N
)))
1690 if Ekind
(It1
.Typ
) = E_Anonymous_Access_Type
1691 or else Ekind
(It1
.Typ
) = E_Anonymous_Access_Subprogram_Type
1693 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1702 elsif Ekind
(It2
.Typ
) = E_Anonymous_Access_Type
1703 or else Ekind
(It2
.Typ
) = E_Anonymous_Access_Subprogram_Type
1709 -- No legal interpretation.
1714 -- If two user defined-subprograms are visible, it is a true ambiguity,
1715 -- unless one of them is an entry and the context is a conditional or
1716 -- timed entry call, or unless we are within an instance and this is
1717 -- results from two formals types with the same actual.
1720 if Nkind
(N
) = N_Procedure_Call_Statement
1721 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1722 and then N
= Entry_Call_Statement
(Parent
(N
))
1724 if Ekind
(Nam2
) = E_Entry
then
1726 elsif Ekind
(Nam1
) = E_Entry
then
1732 -- If the ambiguity occurs within an instance, it is due to several
1733 -- formal types with the same actual. Look for an exact match between
1734 -- the types of the formals of the overloadable entities, and the
1735 -- actuals in the call, to recover the unambiguous match in the
1736 -- original generic.
1738 -- The ambiguity can also be due to an overloading between a formal
1739 -- subprogram and a subprogram declared outside the generic. If the
1740 -- node is overloaded, it did not resolve to the global entity in
1741 -- the generic, and we choose the formal subprogram.
1743 -- Finally, the ambiguity can be between an explicit subprogram and
1744 -- one inherited (with different defaults) from an actual. In this
1745 -- case the resolution was to the explicit declaration in the
1746 -- generic, and remains so in the instance.
1749 and then not In_Generic_Actual
(N
)
1751 if Nkind
(N
) = N_Function_Call
1752 or else Nkind
(N
) = N_Procedure_Call_Statement
1757 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1758 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1761 if Is_Act1
and then not Is_Act2
then
1764 elsif Is_Act2
and then not Is_Act1
then
1767 elsif Inherited_From_Actual
(Nam1
)
1768 and then Comes_From_Source
(Nam2
)
1772 elsif Inherited_From_Actual
(Nam2
)
1773 and then Comes_From_Source
(Nam1
)
1778 Actual
:= First_Actual
(N
);
1779 Formal
:= First_Formal
(Nam1
);
1780 while Present
(Actual
) loop
1781 if Etype
(Actual
) /= Etype
(Formal
) then
1785 Next_Actual
(Actual
);
1786 Next_Formal
(Formal
);
1792 elsif Nkind
(N
) in N_Binary_Op
then
1793 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1795 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1802 elsif Nkind
(N
) in N_Unary_Op
then
1803 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1810 return Remove_Conversions
;
1813 return Remove_Conversions
;
1817 -- An implicit concatenation operator on a string type cannot be
1818 -- disambiguated from the predefined concatenation. This can only
1819 -- happen with concatenation of string literals.
1821 if Chars
(User_Subp
) = Name_Op_Concat
1822 and then Ekind
(User_Subp
) = E_Operator
1823 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1827 -- If the user-defined operator is in an open scope, or in the scope
1828 -- of the resulting type, or given by an expanded name that names its
1829 -- scope, it hides the predefined operator for the type. Exponentiation
1830 -- has to be special-cased because the implicit operator does not have
1831 -- a symmetric signature, and may not be hidden by the explicit one.
1833 elsif (Nkind
(N
) = N_Function_Call
1834 and then Nkind
(Name
(N
)) = N_Expanded_Name
1835 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1836 or else Hides_Op
(User_Subp
, Predef_Subp
))
1837 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1838 or else Hides_Op
(User_Subp
, Predef_Subp
)
1840 if It1
.Nam
= User_Subp
then
1846 -- Otherwise, the predefined operator has precedence, or if the user-
1847 -- defined operation is directly visible we have a true ambiguity. If
1848 -- this is a fixed-point multiplication and division in Ada83 mode,
1849 -- exclude the universal_fixed operator, which often causes ambiguities
1853 if (In_Open_Scopes
(Scope
(User_Subp
))
1854 or else Is_Potentially_Use_Visible
(User_Subp
))
1855 and then not In_Instance
1857 if Is_Fixed_Point_Type
(Typ
)
1858 and then (Chars
(Nam1
) = Name_Op_Multiply
1859 or else Chars
(Nam1
) = Name_Op_Divide
)
1860 and then Ada_Version
= Ada_83
1862 if It2
.Nam
= Predef_Subp
then
1868 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1869 -- states that the operator defined in Standard is not available
1870 -- if there is a user-defined equality with the proper signature,
1871 -- declared in the same declarative list as the type. The node
1872 -- may be an operator or a function call.
1874 elsif (Chars
(Nam1
) = Name_Op_Eq
1876 Chars
(Nam1
) = Name_Op_Ne
)
1877 and then Ada_Version
>= Ada_05
1878 and then Etype
(User_Subp
) = Standard_Boolean
1883 if Nkind
(N
) = N_Function_Call
then
1884 Opnd
:= First_Actual
(N
);
1886 Opnd
:= Left_Opnd
(N
);
1889 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1891 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1892 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1894 if It2
.Nam
= Predef_Subp
then
1900 return Remove_Conversions
;
1908 elsif It1
.Nam
= Predef_Subp
then
1917 ---------------------
1918 -- End_Interp_List --
1919 ---------------------
1921 procedure End_Interp_List
is
1923 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1924 All_Interp
.Increment_Last
;
1925 end End_Interp_List
;
1927 -------------------------
1928 -- Entity_Matches_Spec --
1929 -------------------------
1931 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1933 -- Simple case: same entity kinds, type conformance is required. A
1934 -- parameterless function can also rename a literal.
1936 if Ekind
(Old_S
) = Ekind
(New_S
)
1937 or else (Ekind
(New_S
) = E_Function
1938 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1940 return Type_Conformant
(New_S
, Old_S
);
1942 elsif Ekind
(New_S
) = E_Function
1943 and then Ekind
(Old_S
) = E_Operator
1945 return Operator_Matches_Spec
(Old_S
, New_S
);
1947 elsif Ekind
(New_S
) = E_Procedure
1948 and then Is_Entry
(Old_S
)
1950 return Type_Conformant
(New_S
, Old_S
);
1955 end Entity_Matches_Spec
;
1957 ----------------------
1958 -- Find_Unique_Type --
1959 ----------------------
1961 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1962 T
: constant Entity_Id
:= Etype
(L
);
1965 TR
: Entity_Id
:= Any_Type
;
1968 if Is_Overloaded
(R
) then
1969 Get_First_Interp
(R
, I
, It
);
1970 while Present
(It
.Typ
) loop
1971 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1973 -- If several interpretations are possible and L is universal,
1974 -- apply preference rule.
1976 if TR
/= Any_Type
then
1978 if (T
= Universal_Integer
or else T
= Universal_Real
)
1989 Get_Next_Interp
(I
, It
);
1994 -- In the non-overloaded case, the Etype of R is already set correctly
2000 -- If one of the operands is Universal_Fixed, the type of the other
2001 -- operand provides the context.
2003 if Etype
(R
) = Universal_Fixed
then
2006 elsif T
= Universal_Fixed
then
2009 -- Ada 2005 (AI-230): Support the following operators:
2011 -- function "=" (L, R : universal_access) return Boolean;
2012 -- function "/=" (L, R : universal_access) return Boolean;
2014 -- Pool specific access types (E_Access_Type) are not covered by these
2015 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2016 -- of the equality operators for universal_access shall be convertible
2017 -- to one another (see 4.6)". For example, considering the type decla-
2018 -- ration "type P is access Integer" and an anonymous access to Integer,
2019 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2020 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2022 elsif Ada_Version
>= Ada_05
2024 (Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
2026 Ekind
(Etype
(L
)) = E_Anonymous_Access_Subprogram_Type
)
2027 and then Is_Access_Type
(Etype
(R
))
2028 and then Ekind
(Etype
(R
)) /= E_Access_Type
2032 elsif Ada_Version
>= Ada_05
2034 (Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
2035 or else Ekind
(Etype
(R
)) = E_Anonymous_Access_Subprogram_Type
)
2036 and then Is_Access_Type
(Etype
(L
))
2037 and then Ekind
(Etype
(L
)) /= E_Access_Type
2042 return Specific_Type
(T
, Etype
(R
));
2044 end Find_Unique_Type
;
2046 -------------------------------------
2047 -- Function_Interp_Has_Abstract_Op --
2048 -------------------------------------
2050 function Function_Interp_Has_Abstract_Op
2052 E
: Entity_Id
) return Entity_Id
2054 Abstr_Op
: Entity_Id
;
2057 Form_Parm
: Node_Id
;
2060 -- Why is check on E needed below ???
2061 -- In any case this para needs comments ???
2063 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2064 Act_Parm
:= First_Actual
(N
);
2065 Form_Parm
:= First_Formal
(E
);
2066 while Present
(Act_Parm
)
2067 and then Present
(Form_Parm
)
2071 if Nkind
(Act
) = N_Parameter_Association
then
2072 Act
:= Explicit_Actual_Parameter
(Act
);
2075 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2077 if Present
(Abstr_Op
) then
2081 Next_Actual
(Act_Parm
);
2082 Next_Formal
(Form_Parm
);
2087 end Function_Interp_Has_Abstract_Op
;
2089 ----------------------
2090 -- Get_First_Interp --
2091 ----------------------
2093 procedure Get_First_Interp
2095 I
: out Interp_Index
;
2098 Int_Ind
: Interp_Index
;
2103 -- If a selected component is overloaded because the selector has
2104 -- multiple interpretations, the node is a call to a protected
2105 -- operation or an indirect call. Retrieve the interpretation from
2106 -- the selector name. The selected component may be overloaded as well
2107 -- if the prefix is overloaded. That case is unchanged.
2109 if Nkind
(N
) = N_Selected_Component
2110 and then Is_Overloaded
(Selector_Name
(N
))
2112 O_N
:= Selector_Name
(N
);
2117 Map_Ptr
:= Headers
(Hash
(O_N
));
2118 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
2119 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2120 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2121 It
:= All_Interp
.Table
(Int_Ind
);
2125 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2129 -- Procedure should never be called if the node has no interpretations
2131 raise Program_Error
;
2132 end Get_First_Interp
;
2134 ---------------------
2135 -- Get_Next_Interp --
2136 ---------------------
2138 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2141 It
:= All_Interp
.Table
(I
);
2142 end Get_Next_Interp
;
2144 -------------------------
2145 -- Has_Compatible_Type --
2146 -------------------------
2148 function Has_Compatible_Type
2161 if Nkind
(N
) = N_Subtype_Indication
2162 or else not Is_Overloaded
(N
)
2165 Covers
(Typ
, Etype
(N
))
2167 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2168 -- If the type is already frozen use the corresponding_record
2169 -- to check whether it is a proper descendant.
2172 (Is_Record_Type
(Typ
)
2173 and then Is_Concurrent_Type
(Etype
(N
))
2174 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2175 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2178 (Is_Concurrent_Type
(Typ
)
2179 and then Is_Record_Type
(Etype
(N
))
2180 and then Present
(Corresponding_Record_Type
(Typ
))
2181 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2184 (not Is_Tagged_Type
(Typ
)
2185 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2186 and then Covers
(Etype
(N
), Typ
));
2189 Get_First_Interp
(N
, I
, It
);
2190 while Present
(It
.Typ
) loop
2191 if (Covers
(Typ
, It
.Typ
)
2193 (Scope
(It
.Nam
) /= Standard_Standard
2194 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2196 -- Ada 2005 (AI-345)
2199 (Is_Concurrent_Type
(It
.Typ
)
2200 and then Present
(Corresponding_Record_Type
2202 and then Covers
(Typ
, Corresponding_Record_Type
2205 or else (not Is_Tagged_Type
(Typ
)
2206 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2207 and then Covers
(It
.Typ
, Typ
))
2212 Get_Next_Interp
(I
, It
);
2217 end Has_Compatible_Type
;
2219 ---------------------
2220 -- Has_Abstract_Op --
2221 ---------------------
2223 function Has_Abstract_Op
2225 Typ
: Entity_Id
) return Entity_Id
2231 if Is_Overloaded
(N
) then
2232 Get_First_Interp
(N
, I
, It
);
2233 while Present
(It
.Nam
) loop
2234 if Present
(It
.Abstract_Op
)
2235 and then Etype
(It
.Abstract_Op
) = Typ
2237 return It
.Abstract_Op
;
2240 Get_Next_Interp
(I
, It
);
2245 end Has_Abstract_Op
;
2251 function Hash
(N
: Node_Id
) return Int
is
2253 -- Nodes have a size that is power of two, so to select significant
2254 -- bits only we remove the low-order bits.
2256 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2263 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2264 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2266 return Operator_Matches_Spec
(Op
, F
)
2267 and then (In_Open_Scopes
(Scope
(F
))
2268 or else Scope
(F
) = Scope
(Btyp
)
2269 or else (not In_Open_Scopes
(Scope
(Btyp
))
2270 and then not In_Use
(Btyp
)
2271 and then not In_Use
(Scope
(Btyp
))));
2274 ------------------------
2275 -- Init_Interp_Tables --
2276 ------------------------
2278 procedure Init_Interp_Tables
is
2282 Headers
:= (others => No_Entry
);
2283 end Init_Interp_Tables
;
2285 -----------------------------------
2286 -- Interface_Present_In_Ancestor --
2287 -----------------------------------
2289 function Interface_Present_In_Ancestor
2291 Iface
: Entity_Id
) return Boolean
2293 Target_Typ
: Entity_Id
;
2294 Iface_Typ
: Entity_Id
;
2296 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2297 -- Returns True if Typ or some ancestor of Typ implements Iface
2299 -------------------------------
2300 -- Iface_Present_In_Ancestor --
2301 -------------------------------
2303 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2309 if Typ
= Iface_Typ
then
2313 -- Handle private types
2315 if Present
(Full_View
(Typ
))
2316 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2318 E
:= Full_View
(Typ
);
2324 if Present
(Interfaces
(E
))
2325 and then Present
(Interfaces
(E
))
2326 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2328 Elmt
:= First_Elmt
(Interfaces
(E
));
2329 while Present
(Elmt
) loop
2332 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2340 exit when Etype
(E
) = E
2342 -- Handle private types
2344 or else (Present
(Full_View
(Etype
(E
)))
2345 and then Full_View
(Etype
(E
)) = E
);
2347 -- Check if the current type is a direct derivation of the
2350 if Etype
(E
) = Iface_Typ
then
2354 -- Climb to the immediate ancestor handling private types
2356 if Present
(Full_View
(Etype
(E
))) then
2357 E
:= Full_View
(Etype
(E
));
2364 end Iface_Present_In_Ancestor
;
2366 -- Start of processing for Interface_Present_In_Ancestor
2369 if Is_Class_Wide_Type
(Iface
) then
2370 Iface_Typ
:= Etype
(Iface
);
2377 Iface_Typ
:= Base_Type
(Iface_Typ
);
2379 if Is_Access_Type
(Typ
) then
2380 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2385 if Is_Concurrent_Record_Type
(Target_Typ
) then
2386 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2389 Target_Typ
:= Base_Type
(Target_Typ
);
2391 -- In case of concurrent types we can't use the Corresponding Record_Typ
2392 -- to look for the interface because it is built by the expander (and
2393 -- hence it is not always available). For this reason we traverse the
2394 -- list of interfaces (available in the parent of the concurrent type)
2396 if Is_Concurrent_Type
(Target_Typ
) then
2397 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2402 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2403 while Present
(AI
) loop
2404 if Etype
(AI
) = Iface_Typ
then
2407 elsif Present
(Interfaces
(Etype
(AI
)))
2408 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2421 if Is_Class_Wide_Type
(Target_Typ
) then
2422 Target_Typ
:= Etype
(Target_Typ
);
2425 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2426 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2427 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2429 -- Protect the frontend against previously detected errors
2431 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2436 return Iface_Present_In_Ancestor
(Target_Typ
);
2437 end Interface_Present_In_Ancestor
;
2439 ---------------------
2440 -- Intersect_Types --
2441 ---------------------
2443 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2444 Index
: Interp_Index
;
2448 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2449 -- Find interpretation of right arg that has type compatible with T
2451 --------------------------
2452 -- Check_Right_Argument --
2453 --------------------------
2455 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2456 Index
: Interp_Index
;
2461 if not Is_Overloaded
(R
) then
2462 return Specific_Type
(T
, Etype
(R
));
2465 Get_First_Interp
(R
, Index
, It
);
2467 T2
:= Specific_Type
(T
, It
.Typ
);
2469 if T2
/= Any_Type
then
2473 Get_Next_Interp
(Index
, It
);
2474 exit when No
(It
.Typ
);
2479 end Check_Right_Argument
;
2481 -- Start of processing for Intersect_Types
2484 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2488 if not Is_Overloaded
(L
) then
2489 Typ
:= Check_Right_Argument
(Etype
(L
));
2493 Get_First_Interp
(L
, Index
, It
);
2494 while Present
(It
.Typ
) loop
2495 Typ
:= Check_Right_Argument
(It
.Typ
);
2496 exit when Typ
/= Any_Type
;
2497 Get_Next_Interp
(Index
, It
);
2502 -- If Typ is Any_Type, it means no compatible pair of types was found
2504 if Typ
= Any_Type
then
2505 if Nkind
(Parent
(L
)) in N_Op
then
2506 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2508 elsif Nkind
(Parent
(L
)) = N_Range
then
2509 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2511 -- Ada 2005 (AI-251): Complete the error notification
2513 elsif Is_Class_Wide_Type
(Etype
(R
))
2514 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2516 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2517 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2520 Error_Msg_N
("incompatible types", Parent
(L
));
2525 end Intersect_Types
;
2531 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2537 BT1
:= Base_Type
(T1
);
2538 BT2
:= Base_Type
(T2
);
2540 -- Handle underlying view of records with unknown discriminants
2541 -- using the original entity that motivated the construction of
2542 -- this underlying record view (see Build_Derived_Private_Type).
2544 if Is_Underlying_Record_View
(BT1
) then
2545 BT1
:= Underlying_Record_View
(BT1
);
2548 if Is_Underlying_Record_View
(BT2
) then
2549 BT2
:= Underlying_Record_View
(BT2
);
2555 elsif Is_Private_Type
(T1
)
2556 and then Present
(Full_View
(T1
))
2557 and then BT2
= Base_Type
(Full_View
(T1
))
2565 -- If there was a error on the type declaration, do not recurse
2567 if Error_Posted
(Par
) then
2570 elsif BT1
= Base_Type
(Par
)
2571 or else (Is_Private_Type
(T1
)
2572 and then Present
(Full_View
(T1
))
2573 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2577 elsif Is_Private_Type
(Par
)
2578 and then Present
(Full_View
(Par
))
2579 and then Full_View
(Par
) = BT1
2583 elsif Etype
(Par
) /= Par
then
2592 ---------------------------
2593 -- Is_Invisible_Operator --
2594 ---------------------------
2596 function Is_Invisible_Operator
2601 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2604 if Nkind
(N
) not in N_Op
then
2607 elsif not Comes_From_Source
(N
) then
2610 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2613 elsif Nkind
(N
) in N_Binary_Op
2614 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2619 return Is_Numeric_Type
(T
)
2620 and then not In_Open_Scopes
(Scope
(T
))
2621 and then not Is_Potentially_Use_Visible
(T
)
2622 and then not In_Use
(T
)
2623 and then not In_Use
(Scope
(T
))
2625 (Nkind
(Orig_Node
) /= N_Function_Call
2626 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2627 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2628 and then not In_Instance
;
2630 end Is_Invisible_Operator
;
2636 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2640 S
:= Ancestor_Subtype
(T1
);
2641 while Present
(S
) loop
2645 S
:= Ancestor_Subtype
(S
);
2656 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2657 Index
: Interp_Index
;
2661 Get_First_Interp
(Nam
, Index
, It
);
2662 while Present
(It
.Nam
) loop
2663 if Scope
(It
.Nam
) = Standard_Standard
2664 and then Scope
(It
.Typ
) /= Standard_Standard
2666 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2667 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2670 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2671 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2674 Get_Next_Interp
(Index
, It
);
2682 procedure New_Interps
(N
: Node_Id
) is
2686 All_Interp
.Append
(No_Interp
);
2688 Map_Ptr
:= Headers
(Hash
(N
));
2690 if Map_Ptr
= No_Entry
then
2692 -- Place new node at end of table
2694 Interp_Map
.Increment_Last
;
2695 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2698 -- Place node at end of chain, or locate its previous entry
2701 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2703 -- Node is already in the table, and is being rewritten.
2704 -- Start a new interp section, retain hash link.
2706 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2707 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2708 Set_Is_Overloaded
(N
, True);
2712 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2713 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2717 -- Chain the new node
2719 Interp_Map
.Increment_Last
;
2720 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2723 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2724 Set_Is_Overloaded
(N
, True);
2727 ---------------------------
2728 -- Operator_Matches_Spec --
2729 ---------------------------
2731 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2732 Op_Name
: constant Name_Id
:= Chars
(Op
);
2733 T
: constant Entity_Id
:= Etype
(New_S
);
2741 -- To verify that a predefined operator matches a given signature,
2742 -- do a case analysis of the operator classes. Function can have one
2743 -- or two formals and must have the proper result type.
2745 New_F
:= First_Formal
(New_S
);
2746 Old_F
:= First_Formal
(Op
);
2748 while Present
(New_F
) and then Present
(Old_F
) loop
2750 Next_Formal
(New_F
);
2751 Next_Formal
(Old_F
);
2754 -- Definite mismatch if different number of parameters
2756 if Present
(Old_F
) or else Present
(New_F
) then
2762 T1
:= Etype
(First_Formal
(New_S
));
2764 if Op_Name
= Name_Op_Subtract
2765 or else Op_Name
= Name_Op_Add
2766 or else Op_Name
= Name_Op_Abs
2768 return Base_Type
(T1
) = Base_Type
(T
)
2769 and then Is_Numeric_Type
(T
);
2771 elsif Op_Name
= Name_Op_Not
then
2772 return Base_Type
(T1
) = Base_Type
(T
)
2773 and then Valid_Boolean_Arg
(Base_Type
(T
));
2782 T1
:= Etype
(First_Formal
(New_S
));
2783 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2785 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2786 or else Op_Name
= Name_Op_Xor
2788 return Base_Type
(T1
) = Base_Type
(T2
)
2789 and then Base_Type
(T1
) = Base_Type
(T
)
2790 and then Valid_Boolean_Arg
(Base_Type
(T
));
2792 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2793 return Base_Type
(T1
) = Base_Type
(T2
)
2794 and then not Is_Limited_Type
(T1
)
2795 and then Is_Boolean_Type
(T
);
2797 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2798 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2800 return Base_Type
(T1
) = Base_Type
(T2
)
2801 and then Valid_Comparison_Arg
(T1
)
2802 and then Is_Boolean_Type
(T
);
2804 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2805 return Base_Type
(T1
) = Base_Type
(T2
)
2806 and then Base_Type
(T1
) = Base_Type
(T
)
2807 and then Is_Numeric_Type
(T
);
2809 -- for division and multiplication, a user-defined function does
2810 -- not match the predefined universal_fixed operation, except in
2813 elsif Op_Name
= Name_Op_Divide
then
2814 return (Base_Type
(T1
) = Base_Type
(T2
)
2815 and then Base_Type
(T1
) = Base_Type
(T
)
2816 and then Is_Numeric_Type
(T
)
2817 and then (not Is_Fixed_Point_Type
(T
)
2818 or else Ada_Version
= Ada_83
))
2820 -- Mixed_Mode operations on fixed-point types
2822 or else (Base_Type
(T1
) = Base_Type
(T
)
2823 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2824 and then Is_Fixed_Point_Type
(T
))
2826 -- A user defined operator can also match (and hide) a mixed
2827 -- operation on universal literals.
2829 or else (Is_Integer_Type
(T2
)
2830 and then Is_Floating_Point_Type
(T1
)
2831 and then Base_Type
(T1
) = Base_Type
(T
));
2833 elsif Op_Name
= Name_Op_Multiply
then
2834 return (Base_Type
(T1
) = Base_Type
(T2
)
2835 and then Base_Type
(T1
) = Base_Type
(T
)
2836 and then Is_Numeric_Type
(T
)
2837 and then (not Is_Fixed_Point_Type
(T
)
2838 or else Ada_Version
= Ada_83
))
2840 -- Mixed_Mode operations on fixed-point types
2842 or else (Base_Type
(T1
) = Base_Type
(T
)
2843 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2844 and then Is_Fixed_Point_Type
(T
))
2846 or else (Base_Type
(T2
) = Base_Type
(T
)
2847 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2848 and then Is_Fixed_Point_Type
(T
))
2850 or else (Is_Integer_Type
(T2
)
2851 and then Is_Floating_Point_Type
(T1
)
2852 and then Base_Type
(T1
) = Base_Type
(T
))
2854 or else (Is_Integer_Type
(T1
)
2855 and then Is_Floating_Point_Type
(T2
)
2856 and then Base_Type
(T2
) = Base_Type
(T
));
2858 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2859 return Base_Type
(T1
) = Base_Type
(T2
)
2860 and then Base_Type
(T1
) = Base_Type
(T
)
2861 and then Is_Integer_Type
(T
);
2863 elsif Op_Name
= Name_Op_Expon
then
2864 return Base_Type
(T1
) = Base_Type
(T
)
2865 and then Is_Numeric_Type
(T
)
2866 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2868 elsif Op_Name
= Name_Op_Concat
then
2869 return Is_Array_Type
(T
)
2870 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2871 and then (Base_Type
(T1
) = Base_Type
(T
)
2873 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2874 and then (Base_Type
(T2
) = Base_Type
(T
)
2876 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2882 end Operator_Matches_Spec
;
2888 procedure Remove_Interp
(I
: in out Interp_Index
) is
2892 -- Find end of Interp list and copy downward to erase the discarded one
2895 while Present
(All_Interp
.Table
(II
).Typ
) loop
2899 for J
in I
+ 1 .. II
loop
2900 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2903 -- Back up interp. index to insure that iterator will pick up next
2904 -- available interpretation.
2913 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2915 O_N
: Node_Id
:= Old_N
;
2918 if Is_Overloaded
(Old_N
) then
2919 if Nkind
(Old_N
) = N_Selected_Component
2920 and then Is_Overloaded
(Selector_Name
(Old_N
))
2922 O_N
:= Selector_Name
(Old_N
);
2925 Map_Ptr
:= Headers
(Hash
(O_N
));
2927 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2928 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2929 pragma Assert
(Map_Ptr
/= No_Entry
);
2932 New_Interps
(New_N
);
2933 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2934 Interp_Map
.Table
(Map_Ptr
).Index
;
2942 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
2943 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
2944 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
2945 B1
: constant Entity_Id
:= Base_Type
(T1
);
2946 B2
: constant Entity_Id
:= Base_Type
(T2
);
2948 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2949 -- Check whether T is the equivalent type of a remote access type.
2950 -- If distribution is enabled, T is a legal context for Null.
2952 ----------------------
2953 -- Is_Remote_Access --
2954 ----------------------
2956 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2958 return Is_Record_Type
(T
)
2959 and then (Is_Remote_Call_Interface
(T
)
2960 or else Is_Remote_Types
(T
))
2961 and then Present
(Corresponding_Remote_Type
(T
))
2962 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2963 end Is_Remote_Access
;
2965 -- Start of processing for Specific_Type
2968 if T1
= Any_Type
or else T2
= Any_Type
then
2975 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2976 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2977 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2978 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2982 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2983 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2984 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2985 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2989 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2992 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2995 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2998 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3001 elsif T1
= Any_Access
3002 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3006 elsif T2
= Any_Access
3007 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3011 elsif T2
= Any_Composite
3012 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
3016 elsif T1
= Any_Composite
3017 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
3021 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3024 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3027 -- ----------------------------------------------------------
3028 -- Special cases for equality operators (all other predefined
3029 -- operators can never apply to tagged types)
3030 -- ----------------------------------------------------------
3032 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3035 elsif Is_Class_Wide_Type
(T1
)
3036 and then Is_Class_Wide_Type
(T2
)
3037 and then Is_Interface
(Etype
(T2
))
3041 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3042 -- class-wide interface T2
3044 elsif Is_Class_Wide_Type
(T2
)
3045 and then Is_Interface
(Etype
(T2
))
3046 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3047 Iface
=> Etype
(T2
))
3051 elsif Is_Class_Wide_Type
(T1
)
3052 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3056 elsif Is_Class_Wide_Type
(T2
)
3057 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3061 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
3063 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
3064 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3065 and then Is_Access_Type
(T2
)
3069 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
3071 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
3072 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3073 and then Is_Access_Type
(T1
)
3077 elsif (Ekind
(T1
) = E_Allocator_Type
3078 or else Ekind
(T1
) = E_Access_Attribute_Type
3079 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
3080 and then Is_Access_Type
(T2
)
3084 elsif (Ekind
(T2
) = E_Allocator_Type
3085 or else Ekind
(T2
) = E_Access_Attribute_Type
3086 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
3087 and then Is_Access_Type
(T1
)
3091 -- If none of the above cases applies, types are not compatible
3098 ---------------------
3099 -- Set_Abstract_Op --
3100 ---------------------
3102 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3104 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3105 end Set_Abstract_Op
;
3107 -----------------------
3108 -- Valid_Boolean_Arg --
3109 -----------------------
3111 -- In addition to booleans and arrays of booleans, we must include
3112 -- aggregates as valid boolean arguments, because in the first pass of
3113 -- resolution their components are not examined. If it turns out not to be
3114 -- an aggregate of booleans, this will be diagnosed in Resolve.
3115 -- Any_Composite must be checked for prior to the array type checks because
3116 -- Any_Composite does not have any associated indexes.
3118 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3120 return Is_Boolean_Type
(T
)
3121 or else T
= Any_Composite
3122 or else (Is_Array_Type
(T
)
3123 and then T
/= Any_String
3124 and then Number_Dimensions
(T
) = 1
3125 and then Is_Boolean_Type
(Component_Type
(T
))
3126 and then (not Is_Private_Composite
(T
)
3127 or else In_Instance
)
3128 and then (not Is_Limited_Composite
(T
)
3129 or else In_Instance
))
3130 or else Is_Modular_Integer_Type
(T
)
3131 or else T
= Universal_Integer
;
3132 end Valid_Boolean_Arg
;
3134 --------------------------
3135 -- Valid_Comparison_Arg --
3136 --------------------------
3138 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3141 if T
= Any_Composite
then
3143 elsif Is_Discrete_Type
(T
)
3144 or else Is_Real_Type
(T
)
3147 elsif Is_Array_Type
(T
)
3148 and then Number_Dimensions
(T
) = 1
3149 and then Is_Discrete_Type
(Component_Type
(T
))
3150 and then (not Is_Private_Composite
(T
)
3151 or else In_Instance
)
3152 and then (not Is_Limited_Composite
(T
)
3153 or else In_Instance
)
3156 elsif Is_String_Type
(T
) then
3161 end Valid_Comparison_Arg
;
3163 ----------------------
3164 -- Write_Interp_Ref --
3165 ----------------------
3167 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3169 Write_Str
(" Node: ");
3170 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3171 Write_Str
(" Index: ");
3172 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3173 Write_Str
(" Next: ");
3174 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
3176 end Write_Interp_Ref
;
3178 ---------------------
3179 -- Write_Overloads --
3180 ---------------------
3182 procedure Write_Overloads
(N
: Node_Id
) is
3188 if not Is_Overloaded
(N
) then
3189 Write_Str
("Non-overloaded entity ");
3191 Write_Entity_Info
(Entity
(N
), " ");
3194 Get_First_Interp
(N
, I
, It
);
3195 Write_Str
("Overloaded entity ");
3197 Write_Str
(" Name Type Abstract Op");
3199 Write_Str
("===============================================");
3203 while Present
(Nam
) loop
3204 Write_Int
(Int
(Nam
));
3206 Write_Name
(Chars
(Nam
));
3208 Write_Int
(Int
(It
.Typ
));
3210 Write_Name
(Chars
(It
.Typ
));
3212 if Present
(It
.Abstract_Op
) then
3214 Write_Int
(Int
(It
.Abstract_Op
));
3216 Write_Name
(Chars
(It
.Abstract_Op
));
3220 Get_Next_Interp
(I
, It
);
3224 end Write_Overloads
;