1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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
366 if Present
(Opnd_Type
) then
367 Vis_Type
:= Opnd_Type
;
369 Vis_Type
:= Base_Type
(T
);
372 if In_Open_Scopes
(Scope
(Vis_Type
))
373 or else Is_Potentially_Use_Visible
(Vis_Type
)
374 or else In_Use
(Vis_Type
)
375 or else (In_Use
(Scope
(Vis_Type
))
376 and then not Is_Hidden
(Vis_Type
))
377 or else Nkind
(N
) = N_Expanded_Name
378 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
380 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
384 -- If the node is given in functional notation and the prefix
385 -- is an expanded name, then the operator is visible if the
386 -- prefix is the scope of the result type as well. If the
387 -- operator is (implicitly) defined in an extension of system,
388 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
390 elsif Nkind
(N
) = N_Function_Call
391 and then Nkind
(Name
(N
)) = N_Expanded_Name
392 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
393 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
394 or else Scope
(Vis_Type
) = System_Aux_Id
)
398 -- Save type for subsequent error message, in case no other
399 -- interpretation is found.
402 Candidate_Type
:= Vis_Type
;
406 -- In an instance, an abstract non-dispatching operation cannot be a
407 -- candidate interpretation, because it could not have been one in the
408 -- generic (it may be a spurious overloading in the instance).
411 and then Is_Overloadable
(E
)
412 and then Is_Abstract_Subprogram
(E
)
413 and then not Is_Dispatching_Operation
(E
)
417 -- An inherited interface operation that is implemented by some derived
418 -- type does not participate in overload resolution, only the
419 -- implementation operation does.
422 and then Is_Subprogram
(E
)
423 and then Present
(Interface_Alias
(E
))
425 -- Ada 2005 (AI-251): If this primitive operation corresponds with
426 -- an immediate ancestor interface there is no need to add it to the
427 -- list of interpretations. The corresponding aliased primitive is
428 -- also in this list of primitive operations and will be used instead
429 -- because otherwise we have a dummy ambiguity between the two
430 -- subprograms which are in fact the same.
433 (Find_Dispatching_Type
(Interface_Alias
(E
)),
434 Find_Dispatching_Type
(E
))
436 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
441 -- Calling stubs for an RACW operation never participate in resolution,
442 -- they are executed only through dispatching calls.
444 elsif Is_RACW_Stub_Type_Operation
(E
) then
448 -- If this is the first interpretation of N, N has type Any_Type.
449 -- In that case place the new type on the node. If one interpretation
450 -- already exists, indicate that the node is overloaded, and store
451 -- both the previous and the new interpretation in All_Interp. If
452 -- this is a later interpretation, just add it to the set.
454 if Etype
(N
) = Any_Type
then
459 -- Record both the operator or subprogram name, and its type
461 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
468 -- Either there is no current interpretation in the table for any
469 -- node or the interpretation that is present is for a different
470 -- node. In both cases add a new interpretation to the table.
472 elsif Interp_Map
.Last
< 0
474 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
475 and then not Is_Overloaded
(N
))
479 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
480 and then Present
(Entity
(N
))
482 Add_Entry
(Entity
(N
), Etype
(N
));
484 elsif (Nkind
(N
) = N_Function_Call
485 or else Nkind
(N
) = N_Procedure_Call_Statement
)
486 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
487 or else Is_Entity_Name
(Name
(N
)))
489 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
491 -- If this is an indirect call there will be no name associated
492 -- with the previous entry. To make diagnostics clearer, save
493 -- Subprogram_Type of first interpretation, so that the error will
494 -- point to the anonymous access to subprogram, not to the result
495 -- type of the call itself.
497 elsif (Nkind
(N
)) = N_Function_Call
498 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
499 and then Is_Overloaded
(Name
(N
))
505 pragma Warnings
(Off
, Itn
);
508 Get_First_Interp
(Name
(N
), Itn
, It
);
509 Add_Entry
(It
.Nam
, Etype
(N
));
513 -- Overloaded prefix in indexed or selected component, or call
514 -- whose name is an expression or another call.
516 Add_Entry
(Etype
(N
), Etype
(N
));
530 procedure All_Overloads
is
532 for J
in All_Interp
.First
.. All_Interp
.Last
loop
534 if Present
(All_Interp
.Table
(J
).Nam
) then
535 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
537 Write_Str
("No Interp");
541 Write_Str
("=================");
546 --------------------------------------
547 -- Binary_Op_Interp_Has_Abstract_Op --
548 --------------------------------------
550 function Binary_Op_Interp_Has_Abstract_Op
552 E
: Entity_Id
) return Entity_Id
554 Abstr_Op
: Entity_Id
;
555 E_Left
: constant Node_Id
:= First_Formal
(E
);
556 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
559 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
560 if Present
(Abstr_Op
) then
564 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
565 end Binary_Op_Interp_Has_Abstract_Op
;
567 ---------------------
568 -- Collect_Interps --
569 ---------------------
571 procedure Collect_Interps
(N
: Node_Id
) is
572 Ent
: constant Entity_Id
:= Entity
(N
);
574 First_Interp
: Interp_Index
;
579 -- Unconditionally add the entity that was initially matched
581 First_Interp
:= All_Interp
.Last
;
582 Add_One_Interp
(N
, Ent
, Etype
(N
));
584 -- For expanded name, pick up all additional entities from the
585 -- same scope, since these are obviously also visible. Note that
586 -- these are not necessarily contiguous on the homonym chain.
588 if Nkind
(N
) = N_Expanded_Name
then
590 while Present
(H
) loop
591 if Scope
(H
) = Scope
(Entity
(N
)) then
592 Add_One_Interp
(N
, H
, Etype
(H
));
598 -- Case of direct name
601 -- First, search the homonym chain for directly visible entities
603 H
:= Current_Entity
(Ent
);
604 while Present
(H
) loop
605 exit when (not Is_Overloadable
(H
))
606 and then Is_Immediately_Visible
(H
);
608 if Is_Immediately_Visible
(H
)
611 -- Only add interpretation if not hidden by an inner
612 -- immediately visible one.
614 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
616 -- Current homograph is not hidden. Add to overloads
618 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
621 -- Homograph is hidden, unless it is a predefined operator
623 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
625 -- A homograph in the same scope can occur within an
626 -- instantiation, the resulting ambiguity has to be
629 if Scope
(H
) = Scope
(Ent
)
631 and then not Is_Inherited_Operation
(H
)
633 All_Interp
.Table
(All_Interp
.Last
) :=
634 (H
, Etype
(H
), Empty
);
635 All_Interp
.Append
(No_Interp
);
638 elsif Scope
(H
) /= Standard_Standard
then
644 -- On exit, we know that current homograph is not hidden
646 Add_One_Interp
(N
, H
, Etype
(H
));
649 Write_Str
("Add overloaded interpretation ");
659 -- Scan list of homographs for use-visible entities only
661 H
:= Current_Entity
(Ent
);
663 while Present
(H
) loop
664 if Is_Potentially_Use_Visible
(H
)
666 and then Is_Overloadable
(H
)
668 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
670 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
673 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
674 goto Next_Use_Homograph
;
678 Add_One_Interp
(N
, H
, Etype
(H
));
681 <<Next_Use_Homograph
>>
686 if All_Interp
.Last
= First_Interp
+ 1 then
688 -- The final interpretation is in fact not overloaded. Note that the
689 -- unique legal interpretation may or may not be the original one,
690 -- so we need to update N's entity and etype now, because once N
691 -- is marked as not overloaded it is also expected to carry the
692 -- proper interpretation.
694 Set_Is_Overloaded
(N
, False);
695 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
696 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
704 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
709 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
710 -- In an instance the proper view may not always be correct for
711 -- private types, but private and full view are compatible. This
712 -- removes spurious errors from nested instantiations that involve,
713 -- among other things, types derived from private types.
715 ----------------------
716 -- Full_View_Covers --
717 ----------------------
719 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
722 Is_Private_Type
(Typ1
)
724 ((Present
(Full_View
(Typ1
))
725 and then Covers
(Full_View
(Typ1
), Typ2
))
726 or else Base_Type
(Typ1
) = Typ2
727 or else Base_Type
(Typ2
) = Typ1
);
728 end Full_View_Covers
;
730 -- Start of processing for Covers
733 -- If either operand missing, then this is an error, but ignore it (and
734 -- pretend we have a cover) if errors already detected, since this may
735 -- simply mean we have malformed trees or a semantic error upstream.
737 if No
(T1
) or else No
(T2
) then
738 if Total_Errors_Detected
/= 0 then
745 BT1
:= Base_Type
(T1
);
746 BT2
:= Base_Type
(T2
);
748 -- Handle underlying view of records with unknown discriminants
749 -- using the original entity that motivated the construction of
750 -- this underlying record view (see Build_Derived_Private_Type).
752 if Is_Underlying_Record_View
(BT1
) then
753 BT1
:= Underlying_Record_View
(BT1
);
756 if Is_Underlying_Record_View
(BT2
) then
757 BT2
:= Underlying_Record_View
(BT2
);
761 -- Simplest case: same types are compatible, and types that have the
762 -- same base type and are not generic actuals are compatible. Generic
763 -- actuals belong to their class but are not compatible with other
764 -- types of their class, and in particular with other generic actuals.
765 -- They are however compatible with their own subtypes, and itypes
766 -- with the same base are compatible as well. Similarly, constrained
767 -- subtypes obtained from expressions of an unconstrained nominal type
768 -- are compatible with the base type (may lead to spurious ambiguities
769 -- in obscure cases ???)
771 -- Generic actuals require special treatment to avoid spurious ambi-
772 -- guities in an instance, when two formal types are instantiated with
773 -- the same actual, so that different subprograms end up with the same
774 -- signature in the instance.
783 if not Is_Generic_Actual_Type
(T1
) then
786 return (not Is_Generic_Actual_Type
(T2
)
787 or else Is_Itype
(T1
)
788 or else Is_Itype
(T2
)
789 or else Is_Constr_Subt_For_U_Nominal
(T1
)
790 or else Is_Constr_Subt_For_U_Nominal
(T2
)
791 or else Scope
(T1
) /= Scope
(T2
));
794 -- Literals are compatible with types in a given "class"
796 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
797 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
798 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
799 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
800 or else (T2
= Any_String
and then Is_String_Type
(T1
))
801 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
802 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
806 -- The context may be class wide, and a class-wide type is
807 -- compatible with any member of the class.
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 covers a
821 -- task_type or protected_type that implements the interface.
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.
889 -- For example, conditions require any boolean type, fixed point
890 -- attributes require some real type, etc. The built-in types Any_XXX
891 -- represent these classes.
893 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
894 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
895 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
896 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
897 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
901 -- An aggregate is compatible with an array or record type
903 elsif T2
= Any_Composite
904 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
908 -- If the expected type is an anonymous access, the designated type must
909 -- cover that of the expression. Use the base type for this check: even
910 -- though access subtypes are rare in sources, they are generated for
911 -- actuals in instantiations.
913 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
914 and then Is_Access_Type
(T2
)
915 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
919 -- An Access_To_Subprogram is compatible with itself, or with an
920 -- anonymous type created for an attribute reference Access.
922 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
924 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
925 and then Is_Access_Type
(T2
)
926 and then (not Comes_From_Source
(T1
)
927 or else not Comes_From_Source
(T2
))
928 and then (Is_Overloadable
(Designated_Type
(T2
))
930 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
932 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
934 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
938 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
939 -- with itself, or with an anonymous type created for an attribute
942 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
945 = E_Anonymous_Access_Protected_Subprogram_Type
)
946 and then Is_Access_Type
(T2
)
947 and then (not Comes_From_Source
(T1
)
948 or else not Comes_From_Source
(T2
))
949 and then (Is_Overloadable
(Designated_Type
(T2
))
951 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
953 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
955 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
959 -- The context can be a remote access type, and the expression the
960 -- corresponding source type declared in a categorized package, or
963 elsif Is_Record_Type
(T1
)
964 and then (Is_Remote_Call_Interface
(T1
)
965 or else Is_Remote_Types
(T1
))
966 and then Present
(Corresponding_Remote_Type
(T1
))
968 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
972 elsif Is_Record_Type
(T2
)
973 and then (Is_Remote_Call_Interface
(T2
)
974 or else Is_Remote_Types
(T2
))
975 and then Present
(Corresponding_Remote_Type
(T2
))
977 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
979 -- Synchronized types are represented at run time by their corresponding
980 -- record type. During expansion one is replaced with the other, but
981 -- they are compatible views of the same type.
983 elsif Is_Record_Type
(T1
)
984 and then Is_Concurrent_Type
(T2
)
985 and then Present
(Corresponding_Record_Type
(T2
))
987 return Covers
(T1
, Corresponding_Record_Type
(T2
));
989 elsif Is_Concurrent_Type
(T1
)
990 and then Present
(Corresponding_Record_Type
(T1
))
991 and then Is_Record_Type
(T2
)
993 return Covers
(Corresponding_Record_Type
(T1
), T2
);
995 -- During analysis, an attribute reference 'Access has a special type
996 -- kind: Access_Attribute_Type, to be replaced eventually with the type
997 -- imposed by context.
999 elsif Ekind
(T2
) = E_Access_Attribute_Type
1000 and then (Ekind
(BT1
) = E_General_Access_Type
1002 Ekind
(BT1
) = E_Access_Type
)
1003 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1005 -- If the target type is a RACW type while the source is an access
1006 -- attribute type, we are building a RACW that may be exported.
1008 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1009 Set_Has_RACW
(Current_Sem_Unit
);
1014 -- Ditto for allocators, which eventually resolve to the context type
1016 elsif Ekind
(T2
) = E_Allocator_Type
1017 and then Is_Access_Type
(T1
)
1019 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1021 (From_With_Type
(Designated_Type
(T1
))
1022 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1024 -- A boolean operation on integer literals is compatible with modular
1027 elsif T2
= Any_Modular
1028 and then Is_Modular_Integer_Type
(T1
)
1032 -- The actual type may be the result of a previous error
1034 elsif Base_Type
(T2
) = Any_Type
then
1037 -- A packed array type covers its corresponding non-packed type. This is
1038 -- not legitimate Ada, but allows the omission of a number of otherwise
1039 -- useless unchecked conversions, and since this can only arise in
1040 -- (known correct) expanded code, no harm is done.
1042 elsif Is_Array_Type
(T2
)
1043 and then Is_Packed
(T2
)
1044 and then T1
= Packed_Array_Type
(T2
)
1048 -- Similarly an array type covers its corresponding packed array type
1050 elsif Is_Array_Type
(T1
)
1051 and then Is_Packed
(T1
)
1052 and then T2
= Packed_Array_Type
(T1
)
1056 -- In instances, or with types exported from instantiations, check
1057 -- whether a partial and a full view match. Verify that types are
1058 -- legal, to prevent cascaded errors.
1062 (Full_View_Covers
(T1
, T2
)
1063 or else Full_View_Covers
(T2
, T1
))
1068 and then Is_Generic_Actual_Type
(T2
)
1069 and then Full_View_Covers
(T1
, T2
)
1074 and then Is_Generic_Actual_Type
(T1
)
1075 and then Full_View_Covers
(T2
, T1
)
1079 -- In the expansion of inlined bodies, types are compatible if they
1080 -- are structurally equivalent.
1082 elsif In_Inlined_Body
1083 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1084 or else (Is_Access_Type
(T1
)
1085 and then Is_Access_Type
(T2
)
1087 Designated_Type
(T1
) = Designated_Type
(T2
))
1088 or else (T1
= Any_Access
1089 and then Is_Access_Type
(Underlying_Type
(T2
)))
1090 or else (T2
= Any_Composite
1092 Is_Composite_Type
(Underlying_Type
(T1
))))
1096 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1097 -- obtained through a limited_with compatible with its real entity.
1099 elsif From_With_Type
(T1
) then
1101 -- If the expected type is the non-limited view of a type, the
1102 -- expression may have the limited view. If that one in turn is
1103 -- incomplete, get full view if available.
1105 if Is_Incomplete_Type
(T1
) then
1106 return Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1108 elsif Ekind
(T1
) = E_Class_Wide_Type
then
1110 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1115 elsif From_With_Type
(T2
) then
1117 -- If units in the context have Limited_With clauses on each other,
1118 -- either type might have a limited view. Checks performed elsewhere
1119 -- verify that the context type is the nonlimited view.
1121 if Is_Incomplete_Type
(T2
) then
1122 return Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1124 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1126 Present
(Non_Limited_View
(Etype
(T2
)))
1128 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1133 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1135 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1136 return Covers
(Full_View
(Etype
(T1
)), T2
);
1138 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1139 return Covers
(T1
, Full_View
(Etype
(T2
)));
1141 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1142 -- and actual anonymous access types in the context of generic
1143 -- instantiations. We have the following situation:
1146 -- type Formal is private;
1147 -- Formal_Obj : access Formal; -- T1
1151 -- type Actual is ...
1152 -- Actual_Obj : access Actual; -- T2
1153 -- package Instance is new G (Formal => Actual,
1154 -- Formal_Obj => Actual_Obj);
1156 elsif Ada_Version
>= Ada_05
1157 and then Ekind
(T1
) = E_Anonymous_Access_Type
1158 and then Ekind
(T2
) = E_Anonymous_Access_Type
1159 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1160 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1161 Directly_Designated_Type
(T2
)
1165 -- Otherwise, types are not compatible!
1176 function Disambiguate
1178 I1
, I2
: Interp_Index
;
1179 Typ
: Entity_Id
) return Interp
1184 Nam1
, Nam2
: Entity_Id
;
1185 Predef_Subp
: Entity_Id
;
1186 User_Subp
: Entity_Id
;
1188 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1189 -- Determine whether one of the candidates is an operation inherited by
1190 -- a type that is derived from an actual in an instantiation.
1192 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1193 -- Determine whether a subprogram is an actual in an enclosing instance.
1194 -- An overloading between such a subprogram and one declared outside the
1195 -- instance is resolved in favor of the first, because it resolved in
1198 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1199 -- Look for exact type match in an instance, to remove spurious
1200 -- ambiguities when two formal types have the same actual.
1202 function Standard_Operator
return Boolean;
1203 -- Check whether subprogram is predefined operator declared in Standard.
1204 -- It may given by an operator name, or by an expanded name whose prefix
1207 function Remove_Conversions
return Interp
;
1208 -- Last chance for pathological cases involving comparisons on literals,
1209 -- and user overloadings of the same operator. Such pathologies have
1210 -- been removed from the ACVC, but still appear in two DEC tests, with
1211 -- the following notable quote from Ben Brosgol:
1213 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1214 -- this example; Robert Dewar brought it to our attention, since it is
1215 -- apparently found in the ACVC 1.5. I did not attempt to find the
1216 -- reason in the Reference Manual that makes the example legal, since I
1217 -- was too nauseated by it to want to pursue it further.]
1219 -- Accordingly, this is not a fully recursive solution, but it handles
1220 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1221 -- pathology in the other direction with calls whose multiple overloaded
1222 -- actuals make them truly unresolvable.
1224 -- The new rules concerning abstract operations create additional need
1225 -- for special handling of expressions with universal operands, see
1226 -- comments to Has_Abstract_Interpretation below.
1228 ---------------------------
1229 -- Inherited_From_Actual --
1230 ---------------------------
1232 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1233 Par
: constant Node_Id
:= Parent
(S
);
1235 if Nkind
(Par
) /= N_Full_Type_Declaration
1236 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1240 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1242 Is_Generic_Actual_Type
(
1243 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1245 end Inherited_From_Actual
;
1247 --------------------------
1248 -- Is_Actual_Subprogram --
1249 --------------------------
1251 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1253 return In_Open_Scopes
(Scope
(S
))
1255 (Is_Generic_Instance
(Scope
(S
))
1256 or else Is_Wrapper_Package
(Scope
(S
)));
1257 end Is_Actual_Subprogram
;
1263 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1264 T1
: constant Entity_Id
:= Etype
(Actual
);
1265 T2
: constant Entity_Id
:= Etype
(Formal
);
1269 (Is_Numeric_Type
(T2
)
1270 and then (T1
= Universal_Real
or else T1
= Universal_Integer
));
1273 ------------------------
1274 -- Remove_Conversions --
1275 ------------------------
1277 function Remove_Conversions
return Interp
is
1285 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1286 -- If an operation has universal operands the universal operation
1287 -- is present among its interpretations. If there is an abstract
1288 -- interpretation for the operator, with a numeric result, this
1289 -- interpretation was already removed in sem_ch4, but the universal
1290 -- one is still visible. We must rescan the list of operators and
1291 -- remove the universal interpretation to resolve the ambiguity.
1293 ---------------------------------
1294 -- Has_Abstract_Interpretation --
1295 ---------------------------------
1297 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1301 if Nkind
(N
) not in N_Op
1302 or else Ada_Version
< Ada_05
1303 or else not Is_Overloaded
(N
)
1304 or else No
(Universal_Interpretation
(N
))
1309 E
:= Get_Name_Entity_Id
(Chars
(N
));
1310 while Present
(E
) loop
1311 if Is_Overloadable
(E
)
1312 and then Is_Abstract_Subprogram
(E
)
1313 and then Is_Numeric_Type
(Etype
(E
))
1321 -- Finally, if an operand of the binary operator is itself
1322 -- an operator, recurse to see whether its own abstract
1323 -- interpretation is responsible for the spurious ambiguity.
1325 if Nkind
(N
) in N_Binary_Op
then
1326 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1327 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1329 elsif Nkind
(N
) in N_Unary_Op
then
1330 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1336 end Has_Abstract_Interpretation
;
1338 -- Start of processing for Remove_Conversions
1343 Get_First_Interp
(N
, I
, It
);
1344 while Present
(It
.Typ
) loop
1345 if not Is_Overloadable
(It
.Nam
) then
1349 F1
:= First_Formal
(It
.Nam
);
1355 if Nkind
(N
) = N_Function_Call
1356 or else Nkind
(N
) = N_Procedure_Call_Statement
1358 Act1
:= First_Actual
(N
);
1360 if Present
(Act1
) then
1361 Act2
:= Next_Actual
(Act1
);
1366 elsif Nkind
(N
) in N_Unary_Op
then
1367 Act1
:= Right_Opnd
(N
);
1370 elsif Nkind
(N
) in N_Binary_Op
then
1371 Act1
:= Left_Opnd
(N
);
1372 Act2
:= Right_Opnd
(N
);
1374 -- Use type of second formal, so as to include
1375 -- exponentiation, where the exponent may be
1376 -- ambiguous and the result non-universal.
1384 if Nkind
(Act1
) in N_Op
1385 and then Is_Overloaded
(Act1
)
1386 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1387 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1388 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1389 and then Etype
(F1
) = Standard_Boolean
1391 -- If the two candidates are the original ones, the
1392 -- ambiguity is real. Otherwise keep the original, further
1393 -- calls to Disambiguate will take care of others in the
1394 -- list of candidates.
1396 if It1
/= No_Interp
then
1397 if It
= Disambiguate
.It1
1398 or else It
= Disambiguate
.It2
1400 if It1
= Disambiguate
.It1
1401 or else It1
= Disambiguate
.It2
1409 elsif Present
(Act2
)
1410 and then Nkind
(Act2
) in N_Op
1411 and then Is_Overloaded
(Act2
)
1412 and then Nkind_In
(Right_Opnd
(Act2
), N_Integer_Literal
,
1414 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1416 -- The preference rule on the first actual is not
1417 -- sufficient to disambiguate.
1425 elsif Is_Numeric_Type
(Etype
(F1
))
1426 and then Has_Abstract_Interpretation
(Act1
)
1428 -- Current interpretation is not the right one because it
1429 -- expects a numeric operand. Examine all the other ones.
1436 Get_First_Interp
(N
, I
, It
);
1437 while Present
(It
.Typ
) loop
1439 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1442 or else not Has_Abstract_Interpretation
(Act2
)
1445 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1451 Get_Next_Interp
(I
, It
);
1460 Get_Next_Interp
(I
, It
);
1463 -- After some error, a formal may have Any_Type and yield a spurious
1464 -- match. To avoid cascaded errors if possible, check for such a
1465 -- formal in either candidate.
1467 if Serious_Errors_Detected
> 0 then
1472 Formal
:= First_Formal
(Nam1
);
1473 while Present
(Formal
) loop
1474 if Etype
(Formal
) = Any_Type
then
1475 return Disambiguate
.It2
;
1478 Next_Formal
(Formal
);
1481 Formal
:= First_Formal
(Nam2
);
1482 while Present
(Formal
) loop
1483 if Etype
(Formal
) = Any_Type
then
1484 return Disambiguate
.It1
;
1487 Next_Formal
(Formal
);
1493 end Remove_Conversions
;
1495 -----------------------
1496 -- Standard_Operator --
1497 -----------------------
1499 function Standard_Operator
return Boolean is
1503 if Nkind
(N
) in N_Op
then
1506 elsif Nkind
(N
) = N_Function_Call
then
1509 if Nkind
(Nam
) /= N_Expanded_Name
then
1512 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1517 end Standard_Operator
;
1519 -- Start of processing for Disambiguate
1522 -- Recover the two legal interpretations
1524 Get_First_Interp
(N
, I
, It
);
1526 Get_Next_Interp
(I
, It
);
1532 Get_Next_Interp
(I
, It
);
1538 if Ada_Version
< Ada_05
then
1540 -- Check whether one of the entities is an Ada 2005 entity and we are
1541 -- operating in an earlier mode, in which case we discard the Ada
1542 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1544 if Is_Ada_2005_Only
(Nam1
) then
1546 elsif Is_Ada_2005_Only
(Nam2
) then
1551 -- Check for overloaded CIL convention stuff because the CIL libraries
1552 -- do sick things like Console.Write_Line where it matches two different
1553 -- overloads, so just pick the first ???
1555 if Convention
(Nam1
) = Convention_CIL
1556 and then Convention
(Nam2
) = Convention_CIL
1557 and then Ekind
(Nam1
) = Ekind
(Nam2
)
1558 and then (Ekind
(Nam1
) = E_Procedure
1559 or else Ekind
(Nam1
) = E_Function
)
1564 -- If the context is universal, the predefined operator is preferred.
1565 -- This includes bounds in numeric type declarations, and expressions
1566 -- in type conversions. If no interpretation yields a universal type,
1567 -- then we must check whether the user-defined entity hides the prede-
1570 if Chars
(Nam1
) in Any_Operator_Name
1571 and then Standard_Operator
1573 if Typ
= Universal_Integer
1574 or else Typ
= Universal_Real
1575 or else Typ
= Any_Integer
1576 or else Typ
= Any_Discrete
1577 or else Typ
= Any_Real
1578 or else Typ
= Any_Type
1580 -- Find an interpretation that yields the universal type, or else
1581 -- a predefined operator that yields a predefined numeric type.
1584 Candidate
: Interp
:= No_Interp
;
1587 Get_First_Interp
(N
, I
, It
);
1588 while Present
(It
.Typ
) loop
1589 if (Covers
(Typ
, It
.Typ
)
1590 or else Typ
= Any_Type
)
1592 (It
.Typ
= Universal_Integer
1593 or else It
.Typ
= Universal_Real
)
1597 elsif Covers
(Typ
, It
.Typ
)
1598 and then Scope
(It
.Typ
) = Standard_Standard
1599 and then Scope
(It
.Nam
) = Standard_Standard
1600 and then Is_Numeric_Type
(It
.Typ
)
1605 Get_Next_Interp
(I
, It
);
1608 if Candidate
/= No_Interp
then
1613 elsif Chars
(Nam1
) /= Name_Op_Not
1614 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1616 -- Equality or comparison operation. Choose predefined operator if
1617 -- arguments are universal. The node may be an operator, name, or
1618 -- a function call, so unpack arguments accordingly.
1621 Arg1
, Arg2
: Node_Id
;
1624 if Nkind
(N
) in N_Op
then
1625 Arg1
:= Left_Opnd
(N
);
1626 Arg2
:= Right_Opnd
(N
);
1628 elsif Is_Entity_Name
(N
)
1629 or else Nkind
(N
) = N_Operator_Symbol
1631 Arg1
:= First_Entity
(Entity
(N
));
1632 Arg2
:= Next_Entity
(Arg1
);
1635 Arg1
:= First_Actual
(N
);
1636 Arg2
:= Next_Actual
(Arg1
);
1640 and then Present
(Universal_Interpretation
(Arg1
))
1641 and then Universal_Interpretation
(Arg2
) =
1642 Universal_Interpretation
(Arg1
)
1644 Get_First_Interp
(N
, I
, It
);
1645 while Scope
(It
.Nam
) /= Standard_Standard
loop
1646 Get_Next_Interp
(I
, It
);
1655 -- If no universal interpretation, check whether user-defined operator
1656 -- hides predefined one, as well as other special cases. If the node
1657 -- is a range, then one or both bounds are ambiguous. Each will have
1658 -- to be disambiguated w.r.t. the context type. The type of the range
1659 -- itself is imposed by the context, so we can return either legal
1662 if Ekind
(Nam1
) = E_Operator
then
1663 Predef_Subp
:= Nam1
;
1666 elsif Ekind
(Nam2
) = E_Operator
then
1667 Predef_Subp
:= Nam2
;
1670 elsif Nkind
(N
) = N_Range
then
1673 -- Implement AI05-105: A renaming declaration with an access
1674 -- definition must resolve to an anonymous access type. This
1675 -- is a resolution rule and can be used to disambiguate.
1677 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1678 and then Present
(Access_Definition
(Parent
(N
)))
1680 if Ekind
(It1
.Typ
) = E_Anonymous_Access_Type
1682 Ekind
(It1
.Typ
) = E_Anonymous_Access_Subprogram_Type
1684 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1694 elsif Ekind
(It2
.Typ
) = E_Anonymous_Access_Type
1696 Ekind
(It2
.Typ
) = E_Anonymous_Access_Subprogram_Type
1700 -- No legal interpretation
1706 -- If two user defined-subprograms are visible, it is a true ambiguity,
1707 -- unless one of them is an entry and the context is a conditional or
1708 -- timed entry call, or unless we are within an instance and this is
1709 -- results from two formals types with the same actual.
1712 if Nkind
(N
) = N_Procedure_Call_Statement
1713 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1714 and then N
= Entry_Call_Statement
(Parent
(N
))
1716 if Ekind
(Nam2
) = E_Entry
then
1718 elsif Ekind
(Nam1
) = E_Entry
then
1724 -- If the ambiguity occurs within an instance, it is due to several
1725 -- formal types with the same actual. Look for an exact match between
1726 -- the types of the formals of the overloadable entities, and the
1727 -- actuals in the call, to recover the unambiguous match in the
1728 -- original generic.
1730 -- The ambiguity can also be due to an overloading between a formal
1731 -- subprogram and a subprogram declared outside the generic. If the
1732 -- node is overloaded, it did not resolve to the global entity in
1733 -- the generic, and we choose the formal subprogram.
1735 -- Finally, the ambiguity can be between an explicit subprogram and
1736 -- one inherited (with different defaults) from an actual. In this
1737 -- case the resolution was to the explicit declaration in the
1738 -- generic, and remains so in the instance.
1741 and then not In_Generic_Actual
(N
)
1743 if Nkind
(N
) = N_Function_Call
1744 or else Nkind
(N
) = N_Procedure_Call_Statement
1749 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1750 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1753 if Is_Act1
and then not Is_Act2
then
1756 elsif Is_Act2
and then not Is_Act1
then
1759 elsif Inherited_From_Actual
(Nam1
)
1760 and then Comes_From_Source
(Nam2
)
1764 elsif Inherited_From_Actual
(Nam2
)
1765 and then Comes_From_Source
(Nam1
)
1770 Actual
:= First_Actual
(N
);
1771 Formal
:= First_Formal
(Nam1
);
1772 while Present
(Actual
) loop
1773 if Etype
(Actual
) /= Etype
(Formal
) then
1777 Next_Actual
(Actual
);
1778 Next_Formal
(Formal
);
1784 elsif Nkind
(N
) in N_Binary_Op
then
1785 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1787 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1794 elsif Nkind
(N
) in N_Unary_Op
then
1795 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1802 return Remove_Conversions
;
1805 return Remove_Conversions
;
1809 -- An implicit concatenation operator on a string type cannot be
1810 -- disambiguated from the predefined concatenation. This can only
1811 -- happen with concatenation of string literals.
1813 if Chars
(User_Subp
) = Name_Op_Concat
1814 and then Ekind
(User_Subp
) = E_Operator
1815 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1819 -- If the user-defined operator is in an open scope, or in the scope
1820 -- of the resulting type, or given by an expanded name that names its
1821 -- scope, it hides the predefined operator for the type. Exponentiation
1822 -- has to be special-cased because the implicit operator does not have
1823 -- a symmetric signature, and may not be hidden by the explicit one.
1825 elsif (Nkind
(N
) = N_Function_Call
1826 and then Nkind
(Name
(N
)) = N_Expanded_Name
1827 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1828 or else Hides_Op
(User_Subp
, Predef_Subp
))
1829 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1830 or else Hides_Op
(User_Subp
, Predef_Subp
)
1832 if It1
.Nam
= User_Subp
then
1838 -- Otherwise, the predefined operator has precedence, or if the user-
1839 -- defined operation is directly visible we have a true ambiguity. If
1840 -- this is a fixed-point multiplication and division in Ada83 mode,
1841 -- exclude the universal_fixed operator, which often causes ambiguities
1845 if (In_Open_Scopes
(Scope
(User_Subp
))
1846 or else Is_Potentially_Use_Visible
(User_Subp
))
1847 and then not In_Instance
1849 if Is_Fixed_Point_Type
(Typ
)
1850 and then (Chars
(Nam1
) = Name_Op_Multiply
1851 or else Chars
(Nam1
) = Name_Op_Divide
)
1852 and then Ada_Version
= Ada_83
1854 if It2
.Nam
= Predef_Subp
then
1860 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1861 -- states that the operator defined in Standard is not available
1862 -- if there is a user-defined equality with the proper signature,
1863 -- declared in the same declarative list as the type. The node
1864 -- may be an operator or a function call.
1866 elsif (Chars
(Nam1
) = Name_Op_Eq
1868 Chars
(Nam1
) = Name_Op_Ne
)
1869 and then Ada_Version
>= Ada_05
1870 and then Etype
(User_Subp
) = Standard_Boolean
1875 if Nkind
(N
) = N_Function_Call
then
1876 Opnd
:= First_Actual
(N
);
1878 Opnd
:= Left_Opnd
(N
);
1881 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1883 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1884 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1886 if It2
.Nam
= Predef_Subp
then
1892 return Remove_Conversions
;
1900 elsif It1
.Nam
= Predef_Subp
then
1909 ---------------------
1910 -- End_Interp_List --
1911 ---------------------
1913 procedure End_Interp_List
is
1915 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1916 All_Interp
.Increment_Last
;
1917 end End_Interp_List
;
1919 -------------------------
1920 -- Entity_Matches_Spec --
1921 -------------------------
1923 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1925 -- Simple case: same entity kinds, type conformance is required. A
1926 -- parameterless function can also rename a literal.
1928 if Ekind
(Old_S
) = Ekind
(New_S
)
1929 or else (Ekind
(New_S
) = E_Function
1930 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1932 return Type_Conformant
(New_S
, Old_S
);
1934 elsif Ekind
(New_S
) = E_Function
1935 and then Ekind
(Old_S
) = E_Operator
1937 return Operator_Matches_Spec
(Old_S
, New_S
);
1939 elsif Ekind
(New_S
) = E_Procedure
1940 and then Is_Entry
(Old_S
)
1942 return Type_Conformant
(New_S
, Old_S
);
1947 end Entity_Matches_Spec
;
1949 ----------------------
1950 -- Find_Unique_Type --
1951 ----------------------
1953 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1954 T
: constant Entity_Id
:= Etype
(L
);
1957 TR
: Entity_Id
:= Any_Type
;
1960 if Is_Overloaded
(R
) then
1961 Get_First_Interp
(R
, I
, It
);
1962 while Present
(It
.Typ
) loop
1963 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1965 -- If several interpretations are possible and L is universal,
1966 -- apply preference rule.
1968 if TR
/= Any_Type
then
1970 if (T
= Universal_Integer
or else T
= Universal_Real
)
1981 Get_Next_Interp
(I
, It
);
1986 -- In the non-overloaded case, the Etype of R is already set correctly
1992 -- If one of the operands is Universal_Fixed, the type of the other
1993 -- operand provides the context.
1995 if Etype
(R
) = Universal_Fixed
then
1998 elsif T
= Universal_Fixed
then
2001 -- Ada 2005 (AI-230): Support the following operators:
2003 -- function "=" (L, R : universal_access) return Boolean;
2004 -- function "/=" (L, R : universal_access) return Boolean;
2006 -- Pool specific access types (E_Access_Type) are not covered by these
2007 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2008 -- of the equality operators for universal_access shall be convertible
2009 -- to one another (see 4.6)". For example, considering the type decla-
2010 -- ration "type P is access Integer" and an anonymous access to Integer,
2011 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2012 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2014 elsif Ada_Version
>= Ada_05
2016 (Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
2018 Ekind
(Etype
(L
)) = E_Anonymous_Access_Subprogram_Type
)
2019 and then Is_Access_Type
(Etype
(R
))
2020 and then Ekind
(Etype
(R
)) /= E_Access_Type
2024 elsif Ada_Version
>= Ada_05
2026 (Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
2027 or else Ekind
(Etype
(R
)) = E_Anonymous_Access_Subprogram_Type
)
2028 and then Is_Access_Type
(Etype
(L
))
2029 and then Ekind
(Etype
(L
)) /= E_Access_Type
2034 return Specific_Type
(T
, Etype
(R
));
2036 end Find_Unique_Type
;
2038 -------------------------------------
2039 -- Function_Interp_Has_Abstract_Op --
2040 -------------------------------------
2042 function Function_Interp_Has_Abstract_Op
2044 E
: Entity_Id
) return Entity_Id
2046 Abstr_Op
: Entity_Id
;
2049 Form_Parm
: Node_Id
;
2052 -- Why is check on E needed below ???
2053 -- In any case this para needs comments ???
2055 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2056 Act_Parm
:= First_Actual
(N
);
2057 Form_Parm
:= First_Formal
(E
);
2058 while Present
(Act_Parm
)
2059 and then Present
(Form_Parm
)
2063 if Nkind
(Act
) = N_Parameter_Association
then
2064 Act
:= Explicit_Actual_Parameter
(Act
);
2067 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2069 if Present
(Abstr_Op
) then
2073 Next_Actual
(Act_Parm
);
2074 Next_Formal
(Form_Parm
);
2079 end Function_Interp_Has_Abstract_Op
;
2081 ----------------------
2082 -- Get_First_Interp --
2083 ----------------------
2085 procedure Get_First_Interp
2087 I
: out Interp_Index
;
2090 Int_Ind
: Interp_Index
;
2095 -- If a selected component is overloaded because the selector has
2096 -- multiple interpretations, the node is a call to a protected
2097 -- operation or an indirect call. Retrieve the interpretation from
2098 -- the selector name. The selected component may be overloaded as well
2099 -- if the prefix is overloaded. That case is unchanged.
2101 if Nkind
(N
) = N_Selected_Component
2102 and then Is_Overloaded
(Selector_Name
(N
))
2104 O_N
:= Selector_Name
(N
);
2109 Map_Ptr
:= Headers
(Hash
(O_N
));
2110 while Map_Ptr
/= No_Entry
loop
2111 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2112 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2113 It
:= All_Interp
.Table
(Int_Ind
);
2117 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2121 -- Procedure should never be called if the node has no interpretations
2123 raise Program_Error
;
2124 end Get_First_Interp
;
2126 ---------------------
2127 -- Get_Next_Interp --
2128 ---------------------
2130 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2133 It
:= All_Interp
.Table
(I
);
2134 end Get_Next_Interp
;
2136 -------------------------
2137 -- Has_Compatible_Type --
2138 -------------------------
2140 function Has_Compatible_Type
2142 Typ
: Entity_Id
) return Boolean
2152 if Nkind
(N
) = N_Subtype_Indication
2153 or else not Is_Overloaded
(N
)
2156 Covers
(Typ
, Etype
(N
))
2158 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2159 -- If the type is already frozen use the corresponding_record
2160 -- to check whether it is a proper descendant.
2163 (Is_Record_Type
(Typ
)
2164 and then Is_Concurrent_Type
(Etype
(N
))
2165 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2166 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2169 (Is_Concurrent_Type
(Typ
)
2170 and then Is_Record_Type
(Etype
(N
))
2171 and then Present
(Corresponding_Record_Type
(Typ
))
2172 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2175 (not Is_Tagged_Type
(Typ
)
2176 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2177 and then Covers
(Etype
(N
), Typ
));
2180 Get_First_Interp
(N
, I
, It
);
2181 while Present
(It
.Typ
) loop
2182 if (Covers
(Typ
, It
.Typ
)
2184 (Scope
(It
.Nam
) /= Standard_Standard
2185 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2187 -- Ada 2005 (AI-345)
2190 (Is_Concurrent_Type
(It
.Typ
)
2191 and then Present
(Corresponding_Record_Type
2193 and then Covers
(Typ
, Corresponding_Record_Type
2196 or else (not Is_Tagged_Type
(Typ
)
2197 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2198 and then Covers
(It
.Typ
, Typ
))
2203 Get_Next_Interp
(I
, It
);
2208 end Has_Compatible_Type
;
2210 ---------------------
2211 -- Has_Abstract_Op --
2212 ---------------------
2214 function Has_Abstract_Op
2216 Typ
: Entity_Id
) return Entity_Id
2222 if Is_Overloaded
(N
) then
2223 Get_First_Interp
(N
, I
, It
);
2224 while Present
(It
.Nam
) loop
2225 if Present
(It
.Abstract_Op
)
2226 and then Etype
(It
.Abstract_Op
) = Typ
2228 return It
.Abstract_Op
;
2231 Get_Next_Interp
(I
, It
);
2236 end Has_Abstract_Op
;
2242 function Hash
(N
: Node_Id
) return Int
is
2244 -- Nodes have a size that is power of two, so to select significant
2245 -- bits only we remove the low-order bits.
2247 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2254 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2255 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2257 return Operator_Matches_Spec
(Op
, F
)
2258 and then (In_Open_Scopes
(Scope
(F
))
2259 or else Scope
(F
) = Scope
(Btyp
)
2260 or else (not In_Open_Scopes
(Scope
(Btyp
))
2261 and then not In_Use
(Btyp
)
2262 and then not In_Use
(Scope
(Btyp
))));
2265 ------------------------
2266 -- Init_Interp_Tables --
2267 ------------------------
2269 procedure Init_Interp_Tables
is
2273 Headers
:= (others => No_Entry
);
2274 end Init_Interp_Tables
;
2276 -----------------------------------
2277 -- Interface_Present_In_Ancestor --
2278 -----------------------------------
2280 function Interface_Present_In_Ancestor
2282 Iface
: Entity_Id
) return Boolean
2284 Target_Typ
: Entity_Id
;
2285 Iface_Typ
: Entity_Id
;
2287 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2288 -- Returns True if Typ or some ancestor of Typ implements Iface
2290 -------------------------------
2291 -- Iface_Present_In_Ancestor --
2292 -------------------------------
2294 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2300 if Typ
= Iface_Typ
then
2304 -- Handle private types
2306 if Present
(Full_View
(Typ
))
2307 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2309 E
:= Full_View
(Typ
);
2315 if Present
(Interfaces
(E
))
2316 and then Present
(Interfaces
(E
))
2317 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2319 Elmt
:= First_Elmt
(Interfaces
(E
));
2320 while Present
(Elmt
) loop
2323 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2331 exit when Etype
(E
) = E
2333 -- Handle private types
2335 or else (Present
(Full_View
(Etype
(E
)))
2336 and then Full_View
(Etype
(E
)) = E
);
2338 -- Check if the current type is a direct derivation of the
2341 if Etype
(E
) = Iface_Typ
then
2345 -- Climb to the immediate ancestor handling private types
2347 if Present
(Full_View
(Etype
(E
))) then
2348 E
:= Full_View
(Etype
(E
));
2355 end Iface_Present_In_Ancestor
;
2357 -- Start of processing for Interface_Present_In_Ancestor
2360 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2362 if Is_Class_Wide_Type
(Iface
) then
2363 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2370 Iface_Typ
:= Base_Type
(Iface_Typ
);
2372 if Is_Access_Type
(Typ
) then
2373 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2378 if Is_Concurrent_Record_Type
(Target_Typ
) then
2379 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2382 Target_Typ
:= Base_Type
(Target_Typ
);
2384 -- In case of concurrent types we can't use the Corresponding Record_Typ
2385 -- to look for the interface because it is built by the expander (and
2386 -- hence it is not always available). For this reason we traverse the
2387 -- list of interfaces (available in the parent of the concurrent type)
2389 if Is_Concurrent_Type
(Target_Typ
) then
2390 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2395 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2396 while Present
(AI
) loop
2397 if Etype
(AI
) = Iface_Typ
then
2400 elsif Present
(Interfaces
(Etype
(AI
)))
2401 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2414 if Is_Class_Wide_Type
(Target_Typ
) then
2415 Target_Typ
:= Etype
(Target_Typ
);
2418 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2419 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2420 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2422 -- Protect the frontend against previously detected errors
2424 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2429 return Iface_Present_In_Ancestor
(Target_Typ
);
2430 end Interface_Present_In_Ancestor
;
2432 ---------------------
2433 -- Intersect_Types --
2434 ---------------------
2436 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2437 Index
: Interp_Index
;
2441 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2442 -- Find interpretation of right arg that has type compatible with T
2444 --------------------------
2445 -- Check_Right_Argument --
2446 --------------------------
2448 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2449 Index
: Interp_Index
;
2454 if not Is_Overloaded
(R
) then
2455 return Specific_Type
(T
, Etype
(R
));
2458 Get_First_Interp
(R
, Index
, It
);
2460 T2
:= Specific_Type
(T
, It
.Typ
);
2462 if T2
/= Any_Type
then
2466 Get_Next_Interp
(Index
, It
);
2467 exit when No
(It
.Typ
);
2472 end Check_Right_Argument
;
2474 -- Start of processing for Intersect_Types
2477 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2481 if not Is_Overloaded
(L
) then
2482 Typ
:= Check_Right_Argument
(Etype
(L
));
2486 Get_First_Interp
(L
, Index
, It
);
2487 while Present
(It
.Typ
) loop
2488 Typ
:= Check_Right_Argument
(It
.Typ
);
2489 exit when Typ
/= Any_Type
;
2490 Get_Next_Interp
(Index
, It
);
2495 -- If Typ is Any_Type, it means no compatible pair of types was found
2497 if Typ
= Any_Type
then
2498 if Nkind
(Parent
(L
)) in N_Op
then
2499 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2501 elsif Nkind
(Parent
(L
)) = N_Range
then
2502 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2504 -- Ada 2005 (AI-251): Complete the error notification
2506 elsif Is_Class_Wide_Type
(Etype
(R
))
2507 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2509 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2510 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2513 Error_Msg_N
("incompatible types", Parent
(L
));
2518 end Intersect_Types
;
2520 -----------------------
2521 -- In_Generic_Actual --
2522 -----------------------
2524 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2525 Par
: constant Node_Id
:= Parent
(Exp
);
2531 elsif Nkind
(Par
) in N_Declaration
then
2532 if Nkind
(Par
) = N_Object_Declaration
then
2533 return Present
(Corresponding_Generic_Association
(Par
));
2538 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2539 return Present
(Corresponding_Generic_Association
(Par
));
2541 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2545 return In_Generic_Actual
(Parent
(Par
));
2547 end In_Generic_Actual
;
2553 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2559 BT1
:= Base_Type
(T1
);
2560 BT2
:= Base_Type
(T2
);
2562 -- Handle underlying view of records with unknown discriminants
2563 -- using the original entity that motivated the construction of
2564 -- this underlying record view (see Build_Derived_Private_Type).
2566 if Is_Underlying_Record_View
(BT1
) then
2567 BT1
:= Underlying_Record_View
(BT1
);
2570 if Is_Underlying_Record_View
(BT2
) then
2571 BT2
:= Underlying_Record_View
(BT2
);
2577 elsif Is_Private_Type
(T1
)
2578 and then Present
(Full_View
(T1
))
2579 and then BT2
= Base_Type
(Full_View
(T1
))
2587 -- If there was a error on the type declaration, do not recurse
2589 if Error_Posted
(Par
) then
2592 elsif BT1
= Base_Type
(Par
)
2593 or else (Is_Private_Type
(T1
)
2594 and then Present
(Full_View
(T1
))
2595 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2599 elsif Is_Private_Type
(Par
)
2600 and then Present
(Full_View
(Par
))
2601 and then Full_View
(Par
) = BT1
2605 elsif Etype
(Par
) /= Par
then
2614 ---------------------------
2615 -- Is_Invisible_Operator --
2616 ---------------------------
2618 function Is_Invisible_Operator
2620 T
: Entity_Id
) return Boolean
2622 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2625 if Nkind
(N
) not in N_Op
then
2628 elsif not Comes_From_Source
(N
) then
2631 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2634 elsif Nkind
(N
) in N_Binary_Op
2635 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2640 return Is_Numeric_Type
(T
)
2641 and then not In_Open_Scopes
(Scope
(T
))
2642 and then not Is_Potentially_Use_Visible
(T
)
2643 and then not In_Use
(T
)
2644 and then not In_Use
(Scope
(T
))
2646 (Nkind
(Orig_Node
) /= N_Function_Call
2647 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2648 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2649 and then not In_Instance
;
2651 end Is_Invisible_Operator
;
2657 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2661 S
:= Ancestor_Subtype
(T1
);
2662 while Present
(S
) loop
2666 S
:= Ancestor_Subtype
(S
);
2677 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2678 Index
: Interp_Index
;
2682 Get_First_Interp
(Nam
, Index
, It
);
2683 while Present
(It
.Nam
) loop
2684 if Scope
(It
.Nam
) = Standard_Standard
2685 and then Scope
(It
.Typ
) /= Standard_Standard
2687 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2688 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2691 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2692 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2695 Get_Next_Interp
(Index
, It
);
2703 procedure New_Interps
(N
: Node_Id
) is
2707 All_Interp
.Append
(No_Interp
);
2709 Map_Ptr
:= Headers
(Hash
(N
));
2711 if Map_Ptr
= No_Entry
then
2713 -- Place new node at end of table
2715 Interp_Map
.Increment_Last
;
2716 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2719 -- Place node at end of chain, or locate its previous entry
2722 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2724 -- Node is already in the table, and is being rewritten.
2725 -- Start a new interp section, retain hash link.
2727 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2728 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2729 Set_Is_Overloaded
(N
, True);
2733 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2734 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2738 -- Chain the new node
2740 Interp_Map
.Increment_Last
;
2741 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2744 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2745 Set_Is_Overloaded
(N
, True);
2748 ---------------------------
2749 -- Operator_Matches_Spec --
2750 ---------------------------
2752 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2753 Op_Name
: constant Name_Id
:= Chars
(Op
);
2754 T
: constant Entity_Id
:= Etype
(New_S
);
2762 -- To verify that a predefined operator matches a given signature,
2763 -- do a case analysis of the operator classes. Function can have one
2764 -- or two formals and must have the proper result type.
2766 New_F
:= First_Formal
(New_S
);
2767 Old_F
:= First_Formal
(Op
);
2769 while Present
(New_F
) and then Present
(Old_F
) loop
2771 Next_Formal
(New_F
);
2772 Next_Formal
(Old_F
);
2775 -- Definite mismatch if different number of parameters
2777 if Present
(Old_F
) or else Present
(New_F
) then
2783 T1
:= Etype
(First_Formal
(New_S
));
2785 if Op_Name
= Name_Op_Subtract
2786 or else Op_Name
= Name_Op_Add
2787 or else Op_Name
= Name_Op_Abs
2789 return Base_Type
(T1
) = Base_Type
(T
)
2790 and then Is_Numeric_Type
(T
);
2792 elsif Op_Name
= Name_Op_Not
then
2793 return Base_Type
(T1
) = Base_Type
(T
)
2794 and then Valid_Boolean_Arg
(Base_Type
(T
));
2803 T1
:= Etype
(First_Formal
(New_S
));
2804 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2806 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2807 or else Op_Name
= Name_Op_Xor
2809 return Base_Type
(T1
) = Base_Type
(T2
)
2810 and then Base_Type
(T1
) = Base_Type
(T
)
2811 and then Valid_Boolean_Arg
(Base_Type
(T
));
2813 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2814 return Base_Type
(T1
) = Base_Type
(T2
)
2815 and then not Is_Limited_Type
(T1
)
2816 and then Is_Boolean_Type
(T
);
2818 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2819 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2821 return Base_Type
(T1
) = Base_Type
(T2
)
2822 and then Valid_Comparison_Arg
(T1
)
2823 and then Is_Boolean_Type
(T
);
2825 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2826 return Base_Type
(T1
) = Base_Type
(T2
)
2827 and then Base_Type
(T1
) = Base_Type
(T
)
2828 and then Is_Numeric_Type
(T
);
2830 -- For division and multiplication, a user-defined function does not
2831 -- match the predefined universal_fixed operation, except in Ada 83.
2833 elsif Op_Name
= Name_Op_Divide
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 -- A user defined operator can also match (and hide) a mixed
2847 -- operation on universal literals.
2849 or else (Is_Integer_Type
(T2
)
2850 and then Is_Floating_Point_Type
(T1
)
2851 and then Base_Type
(T1
) = Base_Type
(T
));
2853 elsif Op_Name
= Name_Op_Multiply
then
2854 return (Base_Type
(T1
) = Base_Type
(T2
)
2855 and then Base_Type
(T1
) = Base_Type
(T
)
2856 and then Is_Numeric_Type
(T
)
2857 and then (not Is_Fixed_Point_Type
(T
)
2858 or else Ada_Version
= Ada_83
))
2860 -- Mixed_Mode operations on fixed-point types
2862 or else (Base_Type
(T1
) = Base_Type
(T
)
2863 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2864 and then Is_Fixed_Point_Type
(T
))
2866 or else (Base_Type
(T2
) = Base_Type
(T
)
2867 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2868 and then Is_Fixed_Point_Type
(T
))
2870 or else (Is_Integer_Type
(T2
)
2871 and then Is_Floating_Point_Type
(T1
)
2872 and then Base_Type
(T1
) = Base_Type
(T
))
2874 or else (Is_Integer_Type
(T1
)
2875 and then Is_Floating_Point_Type
(T2
)
2876 and then Base_Type
(T2
) = Base_Type
(T
));
2878 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2879 return Base_Type
(T1
) = Base_Type
(T2
)
2880 and then Base_Type
(T1
) = Base_Type
(T
)
2881 and then Is_Integer_Type
(T
);
2883 elsif Op_Name
= Name_Op_Expon
then
2884 return Base_Type
(T1
) = Base_Type
(T
)
2885 and then Is_Numeric_Type
(T
)
2886 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2888 elsif Op_Name
= Name_Op_Concat
then
2889 return Is_Array_Type
(T
)
2890 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2891 and then (Base_Type
(T1
) = Base_Type
(T
)
2893 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2894 and then (Base_Type
(T2
) = Base_Type
(T
)
2896 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2902 end Operator_Matches_Spec
;
2908 procedure Remove_Interp
(I
: in out Interp_Index
) is
2912 -- Find end of interp list and copy downward to erase the discarded one
2915 while Present
(All_Interp
.Table
(II
).Typ
) loop
2919 for J
in I
+ 1 .. II
loop
2920 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2923 -- Back up interp index to insure that iterator will pick up next
2924 -- available interpretation.
2933 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2935 O_N
: Node_Id
:= Old_N
;
2938 if Is_Overloaded
(Old_N
) then
2939 if Nkind
(Old_N
) = N_Selected_Component
2940 and then Is_Overloaded
(Selector_Name
(Old_N
))
2942 O_N
:= Selector_Name
(Old_N
);
2945 Map_Ptr
:= Headers
(Hash
(O_N
));
2947 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2948 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2949 pragma Assert
(Map_Ptr
/= No_Entry
);
2952 New_Interps
(New_N
);
2953 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2954 Interp_Map
.Table
(Map_Ptr
).Index
;
2962 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
2963 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
2964 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
2965 B1
: constant Entity_Id
:= Base_Type
(T1
);
2966 B2
: constant Entity_Id
:= Base_Type
(T2
);
2968 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2969 -- Check whether T is the equivalent type of a remote access type.
2970 -- If distribution is enabled, T is a legal context for Null.
2972 ----------------------
2973 -- Is_Remote_Access --
2974 ----------------------
2976 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2978 return Is_Record_Type
(T
)
2979 and then (Is_Remote_Call_Interface
(T
)
2980 or else Is_Remote_Types
(T
))
2981 and then Present
(Corresponding_Remote_Type
(T
))
2982 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2983 end Is_Remote_Access
;
2985 -- Start of processing for Specific_Type
2988 if T1
= Any_Type
or else T2
= Any_Type
then
2995 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2996 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2997 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2998 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3002 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3003 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3004 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3005 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3009 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
3012 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
3015 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
3018 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3021 elsif T1
= Any_Access
3022 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3026 elsif T2
= Any_Access
3027 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3031 elsif T2
= Any_Composite
3032 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
3036 elsif T1
= Any_Composite
3037 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
3041 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3044 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3047 -- ----------------------------------------------------------
3048 -- Special cases for equality operators (all other predefined
3049 -- operators can never apply to tagged types)
3050 -- ----------------------------------------------------------
3052 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3055 elsif Is_Class_Wide_Type
(T1
)
3056 and then Is_Class_Wide_Type
(T2
)
3057 and then Is_Interface
(Etype
(T2
))
3061 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3062 -- class-wide interface T2
3064 elsif Is_Class_Wide_Type
(T2
)
3065 and then Is_Interface
(Etype
(T2
))
3066 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3067 Iface
=> Etype
(T2
))
3071 elsif Is_Class_Wide_Type
(T1
)
3072 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3076 elsif Is_Class_Wide_Type
(T2
)
3077 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3081 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
3083 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
3084 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3085 and then Is_Access_Type
(T2
)
3089 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
3091 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
3092 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3093 and then Is_Access_Type
(T1
)
3097 elsif (Ekind
(T1
) = E_Allocator_Type
3098 or else Ekind
(T1
) = E_Access_Attribute_Type
3099 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
3100 and then Is_Access_Type
(T2
)
3104 elsif (Ekind
(T2
) = E_Allocator_Type
3105 or else Ekind
(T2
) = E_Access_Attribute_Type
3106 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
3107 and then Is_Access_Type
(T1
)
3111 -- If none of the above cases applies, types are not compatible
3118 ---------------------
3119 -- Set_Abstract_Op --
3120 ---------------------
3122 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3124 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3125 end Set_Abstract_Op
;
3127 -----------------------
3128 -- Valid_Boolean_Arg --
3129 -----------------------
3131 -- In addition to booleans and arrays of booleans, we must include
3132 -- aggregates as valid boolean arguments, because in the first pass of
3133 -- resolution their components are not examined. If it turns out not to be
3134 -- an aggregate of booleans, this will be diagnosed in Resolve.
3135 -- Any_Composite must be checked for prior to the array type checks because
3136 -- Any_Composite does not have any associated indexes.
3138 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3140 return Is_Boolean_Type
(T
)
3141 or else T
= Any_Composite
3142 or else (Is_Array_Type
(T
)
3143 and then T
/= Any_String
3144 and then Number_Dimensions
(T
) = 1
3145 and then Is_Boolean_Type
(Component_Type
(T
))
3146 and then (not Is_Private_Composite
(T
)
3147 or else In_Instance
)
3148 and then (not Is_Limited_Composite
(T
)
3149 or else In_Instance
))
3150 or else Is_Modular_Integer_Type
(T
)
3151 or else T
= Universal_Integer
;
3152 end Valid_Boolean_Arg
;
3154 --------------------------
3155 -- Valid_Comparison_Arg --
3156 --------------------------
3158 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3161 if T
= Any_Composite
then
3163 elsif Is_Discrete_Type
(T
)
3164 or else Is_Real_Type
(T
)
3167 elsif Is_Array_Type
(T
)
3168 and then Number_Dimensions
(T
) = 1
3169 and then Is_Discrete_Type
(Component_Type
(T
))
3170 and then (not Is_Private_Composite
(T
)
3171 or else In_Instance
)
3172 and then (not Is_Limited_Composite
(T
)
3173 or else In_Instance
)
3176 elsif Is_String_Type
(T
) then
3181 end Valid_Comparison_Arg
;
3183 ----------------------
3184 -- Write_Interp_Ref --
3185 ----------------------
3187 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3189 Write_Str
(" Node: ");
3190 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3191 Write_Str
(" Index: ");
3192 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3193 Write_Str
(" Next: ");
3194 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
3196 end Write_Interp_Ref
;
3198 ---------------------
3199 -- Write_Overloads --
3200 ---------------------
3202 procedure Write_Overloads
(N
: Node_Id
) is
3208 if not Is_Overloaded
(N
) then
3209 Write_Str
("Non-overloaded entity ");
3211 Write_Entity_Info
(Entity
(N
), " ");
3214 Get_First_Interp
(N
, I
, It
);
3215 Write_Str
("Overloaded entity ");
3217 Write_Str
(" Name Type Abstract Op");
3219 Write_Str
("===============================================");
3223 while Present
(Nam
) loop
3224 Write_Int
(Int
(Nam
));
3226 Write_Name
(Chars
(Nam
));
3228 Write_Int
(Int
(It
.Typ
));
3230 Write_Name
(Chars
(It
.Typ
));
3232 if Present
(It
.Abstract_Op
) then
3234 Write_Int
(Int
(It
.Abstract_Op
));
3236 Write_Name
(Chars
(It
.Abstract_Op
));
3240 Get_Next_Interp
(I
, It
);
3244 end Write_Overloads
;