1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Nlists
; use Nlists
;
32 with Errout
; use Errout
;
34 with Namet
; use Namet
;
36 with Output
; use Output
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch6
; use Sem_Ch6
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Ch12
; use Sem_Ch12
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Util
; use Sem_Util
;
45 with Stand
; use Stand
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
49 with Uintp
; use Uintp
;
51 package body Sem_Type
is
57 -- The following data structures establish a mapping between nodes and
58 -- their interpretations. An overloaded node has an entry in Interp_Map,
59 -- which in turn contains a pointer into the All_Interp array. The
60 -- interpretations of a given node are contiguous in All_Interp. Each set
61 -- of interpretations is terminated with the marker No_Interp. In order to
62 -- speed up the retrieval of the interpretations of an overloaded node, the
63 -- Interp_Map table is accessed by means of a simple hashing scheme, and
64 -- the entries in Interp_Map are chained. The heads of clash lists are
65 -- stored in array Headers.
67 -- Headers Interp_Map All_Interp
69 -- _ +-----+ +--------+
70 -- |_| |_____| --->|interp1 |
71 -- |_|---------->|node | | |interp2 |
72 -- |_| |index|---------| |nointerp|
77 -- This scheme does not currently reclaim interpretations. In principle,
78 -- after a unit is compiled, all overloadings have been resolved, and the
79 -- candidate interpretations should be deleted. This should be easier
80 -- now than with the previous scheme???
82 package All_Interp
is new Table
.Table
(
83 Table_Component_Type
=> Interp
,
84 Table_Index_Type
=> Int
,
86 Table_Initial
=> Alloc
.All_Interp_Initial
,
87 Table_Increment
=> Alloc
.All_Interp_Increment
,
88 Table_Name
=> "All_Interp");
90 type Interp_Ref
is record
96 Header_Size
: constant Int
:= 2 ** 12;
97 No_Entry
: constant Int
:= -1;
98 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
100 package Interp_Map
is new Table
.Table
(
101 Table_Component_Type
=> Interp_Ref
,
102 Table_Index_Type
=> Int
,
103 Table_Low_Bound
=> 0,
104 Table_Initial
=> Alloc
.Interp_Map_Initial
,
105 Table_Increment
=> Alloc
.Interp_Map_Increment
,
106 Table_Name
=> "Interp_Map");
108 function Hash
(N
: Node_Id
) return Int
;
109 -- A trivial hashing function for nodes, used to insert an overloaded
110 -- node into the Interp_Map table.
112 -------------------------------------
113 -- Handling of Overload Resolution --
114 -------------------------------------
116 -- Overload resolution uses two passes over the syntax tree of a complete
117 -- context. In the first, bottom-up pass, the types of actuals in calls
118 -- are used to resolve possibly overloaded subprogram and operator names.
119 -- In the second top-down pass, the type of the context (for example the
120 -- condition in a while statement) is used to resolve a possibly ambiguous
121 -- call, and the unique subprogram name in turn imposes a specific context
122 -- on each of its actuals.
124 -- Most expressions are in fact unambiguous, and the bottom-up pass is
125 -- sufficient to resolve most everything. To simplify the common case,
126 -- names and expressions carry a flag Is_Overloaded to indicate whether
127 -- they have more than one interpretation. If the flag is off, then each
128 -- name has already a unique meaning and type, and the bottom-up pass is
129 -- sufficient (and much simpler).
131 --------------------------
132 -- Operator Overloading --
133 --------------------------
135 -- The visibility of operators is handled differently from that of other
136 -- entities. We do not introduce explicit versions of primitive operators
137 -- for each type definition. As a result, there is only one entity
138 -- corresponding to predefined addition on all numeric types, etc. The
139 -- back-end resolves predefined operators according to their type. The
140 -- visibility of primitive operations then reduces to the visibility of the
141 -- resulting type: (a + b) is a legal interpretation of some primitive
142 -- operator + if the type of the result (which must also be the type of a
143 -- and b) is directly visible (either immediately visible or use-visible).
145 -- User-defined operators are treated like other functions, but the
146 -- visibility of these user-defined operations must be special-cased
147 -- to determine whether they hide or are hidden by predefined operators.
148 -- The form P."+" (x, y) requires additional handling.
150 -- Concatenation is treated more conventionally: for every one-dimensional
151 -- array type we introduce a explicit concatenation operator. This is
152 -- necessary to handle the case of (element & element => array) which
153 -- cannot be handled conveniently if there is no explicit instance of
154 -- resulting type of the operation.
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure All_Overloads
;
161 pragma Warnings
(Off
, All_Overloads
);
162 -- Debugging procedure: list full contents of Overloads table
164 function Binary_Op_Interp_Has_Abstract_Op
166 E
: Entity_Id
) return Entity_Id
;
167 -- Given the node and entity of a binary operator, determine whether the
168 -- actuals of E contain an abstract interpretation with regards to the
169 -- types of their corresponding formals. Return the abstract operation or
172 function Function_Interp_Has_Abstract_Op
174 E
: Entity_Id
) return Entity_Id
;
175 -- Given the node and entity of a function call, determine whether the
176 -- actuals of E contain an abstract interpretation with regards to the
177 -- types of their corresponding formals. Return the abstract operation or
180 function Has_Abstract_Op
182 Typ
: Entity_Id
) return Entity_Id
;
183 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
184 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
185 -- abstract interpretation which yields type Typ.
187 procedure New_Interps
(N
: Node_Id
);
188 -- Initialize collection of interpretations for the given node, which is
189 -- either an overloaded entity, or an operation whose arguments have
190 -- multiple interpretations. Interpretations can be added to only one
193 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
;
194 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
195 -- or is not a "class" type (any_character, etc).
201 procedure Add_One_Interp
205 Opnd_Type
: Entity_Id
:= Empty
)
207 Vis_Type
: Entity_Id
;
209 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
210 -- Add one interpretation to an overloaded node. Add a new entry if
211 -- not hidden by previous one, and remove previous one if hidden by
214 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
215 -- True if the entity is a predefined operator and the operands have
216 -- a universal Interpretation.
222 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
223 Abstr_Op
: Entity_Id
:= Empty
;
227 -- Start of processing for Add_Entry
230 -- Find out whether the new entry references interpretations that
231 -- are abstract or disabled by abstract operators.
233 if Ada_Version
>= Ada_2005
then
234 if Nkind
(N
) in N_Binary_Op
then
235 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
236 elsif Nkind
(N
) = N_Function_Call
then
237 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
241 Get_First_Interp
(N
, I
, It
);
242 while Present
(It
.Nam
) loop
244 -- A user-defined subprogram hides another declared at an outer
245 -- level, or one that is use-visible. So return if previous
246 -- definition hides new one (which is either in an outer
247 -- scope, or use-visible). Note that for functions use-visible
248 -- is the same as potentially use-visible. If new one hides
249 -- previous one, replace entry in table of interpretations.
250 -- If this is a universal operation, retain the operator in case
251 -- preference rule applies.
253 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
254 and then Ekind
(Name
) = Ekind
(It
.Nam
))
255 or else (Ekind
(Name
) = E_Operator
256 and then Ekind
(It
.Nam
) = E_Function
))
258 and then Is_Immediately_Visible
(It
.Nam
)
259 and then Type_Conformant
(Name
, It
.Nam
)
260 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
262 if Is_Universal_Operation
(Name
) then
265 -- If node is an operator symbol, we have no actuals with
266 -- which to check hiding, and this is done in full in the
267 -- caller (Analyze_Subprogram_Renaming) so we include the
268 -- predefined operator in any case.
270 elsif Nkind
(N
) = N_Operator_Symbol
271 or else (Nkind
(N
) = N_Expanded_Name
273 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
277 elsif not In_Open_Scopes
(Scope
(Name
))
278 or else Scope_Depth
(Scope
(Name
)) <=
279 Scope_Depth
(Scope
(It
.Nam
))
281 -- If ambiguity within instance, and entity is not an
282 -- implicit operation, save for later disambiguation.
284 if Scope
(Name
) = Scope
(It
.Nam
)
285 and then not Is_Inherited_Operation
(Name
)
294 All_Interp
.Table
(I
).Nam
:= Name
;
298 -- Avoid making duplicate entries in overloads
301 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
305 -- Otherwise keep going
308 Get_Next_Interp
(I
, It
);
313 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
314 All_Interp
.Append
(No_Interp
);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
325 if Ekind
(Op
) /= E_Operator
then
328 elsif Nkind
(N
) in N_Binary_Op
then
329 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
330 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
332 elsif Nkind
(N
) in N_Unary_Op
then
333 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
335 elsif Nkind
(N
) = N_Function_Call
then
336 Arg
:= First_Actual
(N
);
337 while Present
(Arg
) loop
338 if No
(Universal_Interpretation
(Arg
)) then
350 end Is_Universal_Operation
;
352 -- Start of processing for Add_One_Interp
355 -- If the interpretation is a predefined operator, verify that the
356 -- result type is visible, or that the entity has already been
357 -- resolved (case of an instantiation node that refers to a predefined
358 -- operation, or an internally generated operator node, or an operator
359 -- given as an expanded name). If the operator is a comparison or
360 -- equality, it is the type of the operand that matters to determine
361 -- whether the operator is visible. In an instance, the check is not
362 -- performed, given that the operator was visible in the generic.
364 if Ekind
(E
) = E_Operator
then
365 if Present
(Opnd_Type
) then
366 Vis_Type
:= Opnd_Type
;
368 Vis_Type
:= Base_Type
(T
);
371 if In_Open_Scopes
(Scope
(Vis_Type
))
372 or else Is_Potentially_Use_Visible
(Vis_Type
)
373 or else In_Use
(Vis_Type
)
374 or else (In_Use
(Scope
(Vis_Type
))
375 and then not Is_Hidden
(Vis_Type
))
376 or else Nkind
(N
) = N_Expanded_Name
377 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
379 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
383 -- If the node is given in functional notation and the prefix
384 -- is an expanded name, then the operator is visible if the
385 -- prefix is the scope of the result type as well. If the
386 -- operator is (implicitly) defined in an extension of system,
387 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
389 elsif Nkind
(N
) = N_Function_Call
390 and then Nkind
(Name
(N
)) = N_Expanded_Name
391 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
392 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
393 or else Scope
(Vis_Type
) = System_Aux_Id
)
397 -- Save type for subsequent error message, in case no other
398 -- interpretation is found.
401 Candidate_Type
:= Vis_Type
;
405 -- In an instance, an abstract non-dispatching operation cannot be a
406 -- candidate interpretation, because it could not have been one in the
407 -- generic (it may be a spurious overloading in the instance).
410 and then Is_Overloadable
(E
)
411 and then Is_Abstract_Subprogram
(E
)
412 and then not Is_Dispatching_Operation
(E
)
416 -- An inherited interface operation that is implemented by some derived
417 -- type does not participate in overload resolution, only the
418 -- implementation operation does.
421 and then Is_Subprogram
(E
)
422 and then Present
(Interface_Alias
(E
))
424 -- Ada 2005 (AI-251): If this primitive operation corresponds with
425 -- an immediate ancestor interface there is no need to add it to the
426 -- list of interpretations. The corresponding aliased primitive is
427 -- also in this list of primitive operations and will be used instead
428 -- because otherwise we have a dummy ambiguity between the two
429 -- subprograms which are in fact the same.
432 (Find_Dispatching_Type
(Interface_Alias
(E
)),
433 Find_Dispatching_Type
(E
))
435 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
440 -- Calling stubs for an RACW operation never participate in resolution,
441 -- they are executed only through dispatching calls.
443 elsif Is_RACW_Stub_Type_Operation
(E
) then
447 -- If this is the first interpretation of N, N has type Any_Type.
448 -- In that case place the new type on the node. If one interpretation
449 -- already exists, indicate that the node is overloaded, and store
450 -- both the previous and the new interpretation in All_Interp. If
451 -- this is a later interpretation, just add it to the set.
453 if Etype
(N
) = Any_Type
then
458 -- Record both the operator or subprogram name, and its type
460 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
467 -- Either there is no current interpretation in the table for any
468 -- node or the interpretation that is present is for a different
469 -- node. In both cases add a new interpretation to the table.
471 elsif Interp_Map
.Last
< 0
473 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
474 and then not Is_Overloaded
(N
))
478 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
479 and then Present
(Entity
(N
))
481 Add_Entry
(Entity
(N
), Etype
(N
));
483 elsif Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
484 and then Is_Entity_Name
(Name
(N
))
486 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
488 -- If this is an indirect call there will be no name associated
489 -- with the previous entry. To make diagnostics clearer, save
490 -- Subprogram_Type of first interpretation, so that the error will
491 -- point to the anonymous access to subprogram, not to the result
492 -- type of the call itself.
494 elsif (Nkind
(N
)) = N_Function_Call
495 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
496 and then Is_Overloaded
(Name
(N
))
502 pragma Warnings
(Off
, Itn
);
505 Get_First_Interp
(Name
(N
), Itn
, It
);
506 Add_Entry
(It
.Nam
, Etype
(N
));
510 -- Overloaded prefix in indexed or selected component, or call
511 -- whose name is an expression or another call.
513 Add_Entry
(Etype
(N
), Etype
(N
));
527 procedure All_Overloads
is
529 for J
in All_Interp
.First
.. All_Interp
.Last
loop
531 if Present
(All_Interp
.Table
(J
).Nam
) then
532 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
534 Write_Str
("No Interp");
538 Write_Str
("=================");
543 --------------------------------------
544 -- Binary_Op_Interp_Has_Abstract_Op --
545 --------------------------------------
547 function Binary_Op_Interp_Has_Abstract_Op
549 E
: Entity_Id
) return Entity_Id
551 Abstr_Op
: Entity_Id
;
552 E_Left
: constant Node_Id
:= First_Formal
(E
);
553 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
556 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
557 if Present
(Abstr_Op
) then
561 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
562 end Binary_Op_Interp_Has_Abstract_Op
;
564 ---------------------
565 -- Collect_Interps --
566 ---------------------
568 procedure Collect_Interps
(N
: Node_Id
) is
569 Ent
: constant Entity_Id
:= Entity
(N
);
571 First_Interp
: Interp_Index
;
576 -- Unconditionally add the entity that was initially matched
578 First_Interp
:= All_Interp
.Last
;
579 Add_One_Interp
(N
, Ent
, Etype
(N
));
581 -- For expanded name, pick up all additional entities from the
582 -- same scope, since these are obviously also visible. Note that
583 -- these are not necessarily contiguous on the homonym chain.
585 if Nkind
(N
) = N_Expanded_Name
then
587 while Present
(H
) loop
588 if Scope
(H
) = Scope
(Entity
(N
)) then
589 Add_One_Interp
(N
, H
, Etype
(H
));
595 -- Case of direct name
598 -- First, search the homonym chain for directly visible entities
600 H
:= Current_Entity
(Ent
);
601 while Present
(H
) loop
602 exit when (not Is_Overloadable
(H
))
603 and then Is_Immediately_Visible
(H
);
605 if Is_Immediately_Visible
(H
)
608 -- Only add interpretation if not hidden by an inner
609 -- immediately visible one.
611 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
613 -- Current homograph is not hidden. Add to overloads
615 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
618 -- Homograph is hidden, unless it is a predefined operator
620 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
622 -- A homograph in the same scope can occur within an
623 -- instantiation, the resulting ambiguity has to be
626 if Scope
(H
) = Scope
(Ent
)
628 and then not Is_Inherited_Operation
(H
)
630 All_Interp
.Table
(All_Interp
.Last
) :=
631 (H
, Etype
(H
), Empty
);
632 All_Interp
.Append
(No_Interp
);
635 elsif Scope
(H
) /= Standard_Standard
then
641 -- On exit, we know that current homograph is not hidden
643 Add_One_Interp
(N
, H
, Etype
(H
));
646 Write_Str
("Add overloaded interpretation ");
656 -- Scan list of homographs for use-visible entities only
658 H
:= Current_Entity
(Ent
);
660 while Present
(H
) loop
661 if Is_Potentially_Use_Visible
(H
)
663 and then Is_Overloadable
(H
)
665 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
667 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
670 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
671 goto Next_Use_Homograph
;
675 Add_One_Interp
(N
, H
, Etype
(H
));
678 <<Next_Use_Homograph
>>
683 if All_Interp
.Last
= First_Interp
+ 1 then
685 -- The final interpretation is in fact not overloaded. Note that the
686 -- unique legal interpretation may or may not be the original one,
687 -- so we need to update N's entity and etype now, because once N
688 -- is marked as not overloaded it is also expected to carry the
689 -- proper interpretation.
691 Set_Is_Overloaded
(N
, False);
692 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
693 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
701 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
706 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
707 -- In an instance the proper view may not always be correct for
708 -- private types, but private and full view are compatible. This
709 -- removes spurious errors from nested instantiations that involve,
710 -- among other things, types derived from private types.
712 ----------------------
713 -- Full_View_Covers --
714 ----------------------
716 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
719 Is_Private_Type
(Typ1
)
721 ((Present
(Full_View
(Typ1
))
722 and then Covers
(Full_View
(Typ1
), Typ2
))
723 or else Base_Type
(Typ1
) = Typ2
724 or else Base_Type
(Typ2
) = Typ1
);
725 end Full_View_Covers
;
727 -- Start of processing for Covers
730 -- If either operand missing, then this is an error, but ignore it (and
731 -- pretend we have a cover) if errors already detected, since this may
732 -- simply mean we have malformed trees or a semantic error upstream.
734 if No
(T1
) or else No
(T2
) then
735 if Total_Errors_Detected
/= 0 then
742 BT1
:= Base_Type
(T1
);
743 BT2
:= Base_Type
(T2
);
745 -- Handle underlying view of records with unknown discriminants
746 -- using the original entity that motivated the construction of
747 -- this underlying record view (see Build_Derived_Private_Type).
749 if Is_Underlying_Record_View
(BT1
) then
750 BT1
:= Underlying_Record_View
(BT1
);
753 if Is_Underlying_Record_View
(BT2
) then
754 BT2
:= Underlying_Record_View
(BT2
);
758 -- First check for Standard_Void_Type, which is special. Subsequent
759 -- processing in this routine assumes T1 and T2 are bona fide types;
760 -- Standard_Void_Type is a special entity that has some, but not all,
761 -- properties of types.
763 if (T1
= Standard_Void_Type
) /= (T2
= Standard_Void_Type
) then
766 -- Simplest case: same types are compatible, and types that have the
767 -- same base type and are not generic actuals are compatible. Generic
768 -- actuals belong to their class but are not compatible with other
769 -- types of their class, and in particular with other generic actuals.
770 -- They are however compatible with their own subtypes, and itypes
771 -- with the same base are compatible as well. Similarly, constrained
772 -- subtypes obtained from expressions of an unconstrained nominal type
773 -- are compatible with the base type (may lead to spurious ambiguities
774 -- in obscure cases ???)
776 -- Generic actuals require special treatment to avoid spurious ambi-
777 -- guities in an instance, when two formal types are instantiated with
778 -- the same actual, so that different subprograms end up with the same
779 -- signature in the instance.
788 if not Is_Generic_Actual_Type
(T1
) then
791 return (not Is_Generic_Actual_Type
(T2
)
792 or else Is_Itype
(T1
)
793 or else Is_Itype
(T2
)
794 or else Is_Constr_Subt_For_U_Nominal
(T1
)
795 or else Is_Constr_Subt_For_U_Nominal
(T2
)
796 or else Scope
(T1
) /= Scope
(T2
));
799 -- Literals are compatible with types in a given "class"
801 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
802 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
803 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
804 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
805 or else (T2
= Any_String
and then Is_String_Type
(T1
))
806 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
807 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
811 -- The context may be class wide, and a class-wide type is compatible
812 -- with any member of the class.
814 elsif Is_Class_Wide_Type
(T1
)
815 and then Is_Ancestor
(Root_Type
(T1
), T2
)
819 elsif Is_Class_Wide_Type
(T1
)
820 and then Is_Class_Wide_Type
(T2
)
821 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
825 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
826 -- task_type or protected_type that implements the interface.
828 elsif Ada_Version
>= Ada_2005
829 and then Is_Class_Wide_Type
(T1
)
830 and then Is_Interface
(Etype
(T1
))
831 and then Is_Concurrent_Type
(T2
)
832 and then Interface_Present_In_Ancestor
833 (Typ
=> Base_Type
(T2
),
838 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
839 -- object T2 implementing T1
841 elsif Ada_Version
>= Ada_2005
842 and then Is_Class_Wide_Type
(T1
)
843 and then Is_Interface
(Etype
(T1
))
844 and then Is_Tagged_Type
(T2
)
846 if Interface_Present_In_Ancestor
(Typ
=> T2
,
857 if Is_Concurrent_Type
(BT2
) then
858 E
:= Corresponding_Record_Type
(BT2
);
863 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
864 -- covers an object T2 that implements a direct derivation of T1.
865 -- Note: test for presence of E is defense against previous error.
868 and then Present
(Interfaces
(E
))
870 Elmt
:= First_Elmt
(Interfaces
(E
));
871 while Present
(Elmt
) loop
872 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
880 -- We should also check the case in which T1 is an ancestor of
881 -- some implemented interface???
886 -- In a dispatching call the actual may be class-wide, the formal
887 -- may be its specific type, or that of a descendent of it.
889 elsif Is_Class_Wide_Type
(T2
)
891 (Class_Wide_Type
(T1
) = T2
892 or else Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
))
896 -- Some contexts require a class of types rather than a specific type.
897 -- For example, conditions require any boolean type, fixed point
898 -- attributes require some real type, etc. The built-in types Any_XXX
899 -- represent these classes.
901 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
902 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
903 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
904 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
905 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
909 -- An aggregate is compatible with an array or record type
911 elsif T2
= Any_Composite
912 and then Is_Aggregate_Type
(T1
)
916 -- If the expected type is an anonymous access, the designated type must
917 -- cover that of the expression. Use the base type for this check: even
918 -- though access subtypes are rare in sources, they are generated for
919 -- actuals in instantiations.
921 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
922 and then Is_Access_Type
(T2
)
923 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
927 -- An Access_To_Subprogram is compatible with itself, or with an
928 -- anonymous type created for an attribute reference Access.
930 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
932 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
933 and then Is_Access_Type
(T2
)
934 and then (not Comes_From_Source
(T1
)
935 or else not Comes_From_Source
(T2
))
936 and then (Is_Overloadable
(Designated_Type
(T2
))
938 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
940 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
942 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
946 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
947 -- with itself, or with an anonymous type created for an attribute
950 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
953 = E_Anonymous_Access_Protected_Subprogram_Type
)
954 and then Is_Access_Type
(T2
)
955 and then (not Comes_From_Source
(T1
)
956 or else not Comes_From_Source
(T2
))
957 and then (Is_Overloadable
(Designated_Type
(T2
))
959 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
961 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
963 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
967 -- The context can be a remote access type, and the expression the
968 -- corresponding source type declared in a categorized package, or
971 elsif Is_Record_Type
(T1
)
972 and then (Is_Remote_Call_Interface
(T1
)
973 or else Is_Remote_Types
(T1
))
974 and then Present
(Corresponding_Remote_Type
(T1
))
976 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
980 elsif Is_Record_Type
(T2
)
981 and then (Is_Remote_Call_Interface
(T2
)
982 or else Is_Remote_Types
(T2
))
983 and then Present
(Corresponding_Remote_Type
(T2
))
985 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
987 -- Synchronized types are represented at run time by their corresponding
988 -- record type. During expansion one is replaced with the other, but
989 -- they are compatible views of the same type.
991 elsif Is_Record_Type
(T1
)
992 and then Is_Concurrent_Type
(T2
)
993 and then Present
(Corresponding_Record_Type
(T2
))
995 return Covers
(T1
, Corresponding_Record_Type
(T2
));
997 elsif Is_Concurrent_Type
(T1
)
998 and then Present
(Corresponding_Record_Type
(T1
))
999 and then Is_Record_Type
(T2
)
1001 return Covers
(Corresponding_Record_Type
(T1
), T2
);
1003 -- During analysis, an attribute reference 'Access has a special type
1004 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1005 -- imposed by context.
1007 elsif Ekind
(T2
) = E_Access_Attribute_Type
1008 and then Ekind_In
(BT1
, E_General_Access_Type
, E_Access_Type
)
1009 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1011 -- If the target type is a RACW type while the source is an access
1012 -- attribute type, we are building a RACW that may be exported.
1014 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1015 Set_Has_RACW
(Current_Sem_Unit
);
1020 -- Ditto for allocators, which eventually resolve to the context type
1022 elsif Ekind
(T2
) = E_Allocator_Type
1023 and then Is_Access_Type
(T1
)
1025 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1027 (From_With_Type
(Designated_Type
(T1
))
1028 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1030 -- A boolean operation on integer literals is compatible with modular
1033 elsif T2
= Any_Modular
1034 and then Is_Modular_Integer_Type
(T1
)
1038 -- The actual type may be the result of a previous error
1040 elsif Base_Type
(T2
) = Any_Type
then
1043 -- A packed array type covers its corresponding non-packed type. This is
1044 -- not legitimate Ada, but allows the omission of a number of otherwise
1045 -- useless unchecked conversions, and since this can only arise in
1046 -- (known correct) expanded code, no harm is done.
1048 elsif Is_Array_Type
(T2
)
1049 and then Is_Packed
(T2
)
1050 and then T1
= Packed_Array_Type
(T2
)
1054 -- Similarly an array type covers its corresponding packed array type
1056 elsif Is_Array_Type
(T1
)
1057 and then Is_Packed
(T1
)
1058 and then T2
= Packed_Array_Type
(T1
)
1062 -- In instances, or with types exported from instantiations, check
1063 -- whether a partial and a full view match. Verify that types are
1064 -- legal, to prevent cascaded errors.
1068 (Full_View_Covers
(T1
, T2
)
1069 or else Full_View_Covers
(T2
, T1
))
1074 and then Is_Generic_Actual_Type
(T2
)
1075 and then Full_View_Covers
(T1
, T2
)
1080 and then Is_Generic_Actual_Type
(T1
)
1081 and then Full_View_Covers
(T2
, T1
)
1085 -- In the expansion of inlined bodies, types are compatible if they
1086 -- are structurally equivalent.
1088 elsif In_Inlined_Body
1089 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1090 or else (Is_Access_Type
(T1
)
1091 and then Is_Access_Type
(T2
)
1093 Designated_Type
(T1
) = Designated_Type
(T2
))
1094 or else (T1
= Any_Access
1095 and then Is_Access_Type
(Underlying_Type
(T2
)))
1096 or else (T2
= Any_Composite
1098 Is_Composite_Type
(Underlying_Type
(T1
))))
1102 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1103 -- obtained through a limited_with compatible with its real entity.
1105 elsif From_With_Type
(T1
) then
1107 -- If the expected type is the non-limited view of a type, the
1108 -- expression may have the limited view. If that one in turn is
1109 -- incomplete, get full view if available.
1111 if Is_Incomplete_Type
(T1
) then
1112 return Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1114 elsif Ekind
(T1
) = E_Class_Wide_Type
then
1116 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1121 elsif From_With_Type
(T2
) then
1123 -- If units in the context have Limited_With clauses on each other,
1124 -- either type might have a limited view. Checks performed elsewhere
1125 -- verify that the context type is the nonlimited view.
1127 if Is_Incomplete_Type
(T2
) then
1128 return Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1130 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1132 Present
(Non_Limited_View
(Etype
(T2
)))
1134 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1139 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1141 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1142 return Covers
(Full_View
(Etype
(T1
)), T2
);
1144 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1145 return Covers
(T1
, Full_View
(Etype
(T2
)));
1147 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1148 -- and actual anonymous access types in the context of generic
1149 -- instantiations. We have the following situation:
1152 -- type Formal is private;
1153 -- Formal_Obj : access Formal; -- T1
1157 -- type Actual is ...
1158 -- Actual_Obj : access Actual; -- T2
1159 -- package Instance is new G (Formal => Actual,
1160 -- Formal_Obj => Actual_Obj);
1162 elsif Ada_Version
>= Ada_2005
1163 and then Ekind
(T1
) = E_Anonymous_Access_Type
1164 and then Ekind
(T2
) = E_Anonymous_Access_Type
1165 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1166 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1167 Directly_Designated_Type
(T2
)
1171 -- Otherwise, types are not compatible!
1182 function Disambiguate
1184 I1
, I2
: Interp_Index
;
1185 Typ
: Entity_Id
) return Interp
1190 Nam1
, Nam2
: Entity_Id
;
1191 Predef_Subp
: Entity_Id
;
1192 User_Subp
: Entity_Id
;
1194 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1195 -- Determine whether one of the candidates is an operation inherited by
1196 -- a type that is derived from an actual in an instantiation.
1198 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1199 -- Determine whether a subprogram is an actual in an enclosing instance.
1200 -- An overloading between such a subprogram and one declared outside the
1201 -- instance is resolved in favor of the first, because it resolved in
1204 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1205 -- Look for exact type match in an instance, to remove spurious
1206 -- ambiguities when two formal types have the same actual.
1208 function Standard_Operator
return Boolean;
1209 -- Check whether subprogram is predefined operator declared in Standard.
1210 -- It may given by an operator name, or by an expanded name whose prefix
1213 function Remove_Conversions
return Interp
;
1214 -- Last chance for pathological cases involving comparisons on literals,
1215 -- and user overloadings of the same operator. Such pathologies have
1216 -- been removed from the ACVC, but still appear in two DEC tests, with
1217 -- the following notable quote from Ben Brosgol:
1219 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1220 -- this example; Robert Dewar brought it to our attention, since it is
1221 -- apparently found in the ACVC 1.5. I did not attempt to find the
1222 -- reason in the Reference Manual that makes the example legal, since I
1223 -- was too nauseated by it to want to pursue it further.]
1225 -- Accordingly, this is not a fully recursive solution, but it handles
1226 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1227 -- pathology in the other direction with calls whose multiple overloaded
1228 -- actuals make them truly unresolvable.
1230 -- The new rules concerning abstract operations create additional need
1231 -- for special handling of expressions with universal operands, see
1232 -- comments to Has_Abstract_Interpretation below.
1234 ---------------------------
1235 -- Inherited_From_Actual --
1236 ---------------------------
1238 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1239 Par
: constant Node_Id
:= Parent
(S
);
1241 if Nkind
(Par
) /= N_Full_Type_Declaration
1242 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1246 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1248 Is_Generic_Actual_Type
(
1249 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1251 end Inherited_From_Actual
;
1253 --------------------------
1254 -- Is_Actual_Subprogram --
1255 --------------------------
1257 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1259 return In_Open_Scopes
(Scope
(S
))
1261 (Is_Generic_Instance
(Scope
(S
))
1262 or else Is_Wrapper_Package
(Scope
(S
)));
1263 end Is_Actual_Subprogram
;
1269 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1270 T1
: constant Entity_Id
:= Etype
(Actual
);
1271 T2
: constant Entity_Id
:= Etype
(Formal
);
1275 (Is_Numeric_Type
(T2
)
1276 and then (T1
= Universal_Real
or else T1
= Universal_Integer
));
1279 ------------------------
1280 -- Remove_Conversions --
1281 ------------------------
1283 function Remove_Conversions
return Interp
is
1291 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1292 -- If an operation has universal operands the universal operation
1293 -- is present among its interpretations. If there is an abstract
1294 -- interpretation for the operator, with a numeric result, this
1295 -- interpretation was already removed in sem_ch4, but the universal
1296 -- one is still visible. We must rescan the list of operators and
1297 -- remove the universal interpretation to resolve the ambiguity.
1299 ---------------------------------
1300 -- Has_Abstract_Interpretation --
1301 ---------------------------------
1303 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1307 if Nkind
(N
) not in N_Op
1308 or else Ada_Version
< Ada_2005
1309 or else not Is_Overloaded
(N
)
1310 or else No
(Universal_Interpretation
(N
))
1315 E
:= Get_Name_Entity_Id
(Chars
(N
));
1316 while Present
(E
) loop
1317 if Is_Overloadable
(E
)
1318 and then Is_Abstract_Subprogram
(E
)
1319 and then Is_Numeric_Type
(Etype
(E
))
1327 -- Finally, if an operand of the binary operator is itself
1328 -- an operator, recurse to see whether its own abstract
1329 -- interpretation is responsible for the spurious ambiguity.
1331 if Nkind
(N
) in N_Binary_Op
then
1332 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1333 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1335 elsif Nkind
(N
) in N_Unary_Op
then
1336 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1342 end Has_Abstract_Interpretation
;
1344 -- Start of processing for Remove_Conversions
1349 Get_First_Interp
(N
, I
, It
);
1350 while Present
(It
.Typ
) loop
1351 if not Is_Overloadable
(It
.Nam
) then
1355 F1
:= First_Formal
(It
.Nam
);
1361 if Nkind
(N
) = N_Function_Call
1362 or else Nkind
(N
) = N_Procedure_Call_Statement
1364 Act1
:= First_Actual
(N
);
1366 if Present
(Act1
) then
1367 Act2
:= Next_Actual
(Act1
);
1372 elsif Nkind
(N
) in N_Unary_Op
then
1373 Act1
:= Right_Opnd
(N
);
1376 elsif Nkind
(N
) in N_Binary_Op
then
1377 Act1
:= Left_Opnd
(N
);
1378 Act2
:= Right_Opnd
(N
);
1380 -- Use type of second formal, so as to include
1381 -- exponentiation, where the exponent may be
1382 -- ambiguous and the result non-universal.
1390 if Nkind
(Act1
) in N_Op
1391 and then Is_Overloaded
(Act1
)
1392 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1393 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1394 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1395 and then Etype
(F1
) = Standard_Boolean
1397 -- If the two candidates are the original ones, the
1398 -- ambiguity is real. Otherwise keep the original, further
1399 -- calls to Disambiguate will take care of others in the
1400 -- list of candidates.
1402 if It1
/= No_Interp
then
1403 if It
= Disambiguate
.It1
1404 or else It
= Disambiguate
.It2
1406 if It1
= Disambiguate
.It1
1407 or else It1
= Disambiguate
.It2
1415 elsif Present
(Act2
)
1416 and then Nkind
(Act2
) in N_Op
1417 and then Is_Overloaded
(Act2
)
1418 and then Nkind_In
(Right_Opnd
(Act2
), N_Integer_Literal
,
1420 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1422 -- The preference rule on the first actual is not
1423 -- sufficient to disambiguate.
1431 elsif Is_Numeric_Type
(Etype
(F1
))
1432 and then Has_Abstract_Interpretation
(Act1
)
1434 -- Current interpretation is not the right one because it
1435 -- expects a numeric operand. Examine all the other ones.
1442 Get_First_Interp
(N
, I
, It
);
1443 while Present
(It
.Typ
) loop
1445 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1448 or else not Has_Abstract_Interpretation
(Act2
)
1451 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1457 Get_Next_Interp
(I
, It
);
1466 Get_Next_Interp
(I
, It
);
1469 -- After some error, a formal may have Any_Type and yield a spurious
1470 -- match. To avoid cascaded errors if possible, check for such a
1471 -- formal in either candidate.
1473 if Serious_Errors_Detected
> 0 then
1478 Formal
:= First_Formal
(Nam1
);
1479 while Present
(Formal
) loop
1480 if Etype
(Formal
) = Any_Type
then
1481 return Disambiguate
.It2
;
1484 Next_Formal
(Formal
);
1487 Formal
:= First_Formal
(Nam2
);
1488 while Present
(Formal
) loop
1489 if Etype
(Formal
) = Any_Type
then
1490 return Disambiguate
.It1
;
1493 Next_Formal
(Formal
);
1499 end Remove_Conversions
;
1501 -----------------------
1502 -- Standard_Operator --
1503 -----------------------
1505 function Standard_Operator
return Boolean is
1509 if Nkind
(N
) in N_Op
then
1512 elsif Nkind
(N
) = N_Function_Call
then
1515 if Nkind
(Nam
) /= N_Expanded_Name
then
1518 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1523 end Standard_Operator
;
1525 -- Start of processing for Disambiguate
1528 -- Recover the two legal interpretations
1530 Get_First_Interp
(N
, I
, It
);
1532 Get_Next_Interp
(I
, It
);
1538 Get_Next_Interp
(I
, It
);
1544 -- Check whether one of the entities is an Ada 2005/2012 and we are
1545 -- operating in an earlier mode, in which case we discard the Ada
1546 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
1548 if Ada_Version
< Ada_2005
then
1549 if Is_Ada_2005_Only
(Nam1
) or else Is_Ada_2012_Only
(Nam1
) then
1551 elsif Is_Ada_2005_Only
(Nam2
) or else Is_Ada_2012_Only
(Nam1
) then
1556 -- Check whether one of the entities is an Ada 2012 entity and we are
1557 -- operating in Ada 2005 mode, in which case we discard the Ada 2012
1558 -- entity, so that we get proper Ada 2005 overload resolution.
1560 if Ada_Version
= Ada_2005
then
1561 if Is_Ada_2012_Only
(Nam1
) then
1563 elsif Is_Ada_2012_Only
(Nam2
) then
1568 -- Check for overloaded CIL convention stuff because the CIL libraries
1569 -- do sick things like Console.Write_Line where it matches two different
1570 -- overloads, so just pick the first ???
1572 if Convention
(Nam1
) = Convention_CIL
1573 and then Convention
(Nam2
) = Convention_CIL
1574 and then Ekind
(Nam1
) = Ekind
(Nam2
)
1575 and then (Ekind
(Nam1
) = E_Procedure
1576 or else Ekind
(Nam1
) = E_Function
)
1581 -- If the context is universal, the predefined operator is preferred.
1582 -- This includes bounds in numeric type declarations, and expressions
1583 -- in type conversions. If no interpretation yields a universal type,
1584 -- then we must check whether the user-defined entity hides the prede-
1587 if Chars
(Nam1
) in Any_Operator_Name
1588 and then Standard_Operator
1590 if Typ
= Universal_Integer
1591 or else Typ
= Universal_Real
1592 or else Typ
= Any_Integer
1593 or else Typ
= Any_Discrete
1594 or else Typ
= Any_Real
1595 or else Typ
= Any_Type
1597 -- Find an interpretation that yields the universal type, or else
1598 -- a predefined operator that yields a predefined numeric type.
1601 Candidate
: Interp
:= No_Interp
;
1604 Get_First_Interp
(N
, I
, It
);
1605 while Present
(It
.Typ
) loop
1606 if (Covers
(Typ
, It
.Typ
)
1607 or else Typ
= Any_Type
)
1609 (It
.Typ
= Universal_Integer
1610 or else It
.Typ
= Universal_Real
)
1614 elsif Covers
(Typ
, It
.Typ
)
1615 and then Scope
(It
.Typ
) = Standard_Standard
1616 and then Scope
(It
.Nam
) = Standard_Standard
1617 and then Is_Numeric_Type
(It
.Typ
)
1622 Get_Next_Interp
(I
, It
);
1625 if Candidate
/= No_Interp
then
1630 elsif Chars
(Nam1
) /= Name_Op_Not
1631 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1633 -- Equality or comparison operation. Choose predefined operator if
1634 -- arguments are universal. The node may be an operator, name, or
1635 -- a function call, so unpack arguments accordingly.
1638 Arg1
, Arg2
: Node_Id
;
1641 if Nkind
(N
) in N_Op
then
1642 Arg1
:= Left_Opnd
(N
);
1643 Arg2
:= Right_Opnd
(N
);
1645 elsif Is_Entity_Name
(N
) then
1646 Arg1
:= First_Entity
(Entity
(N
));
1647 Arg2
:= Next_Entity
(Arg1
);
1650 Arg1
:= First_Actual
(N
);
1651 Arg2
:= Next_Actual
(Arg1
);
1655 and then Present
(Universal_Interpretation
(Arg1
))
1656 and then Universal_Interpretation
(Arg2
) =
1657 Universal_Interpretation
(Arg1
)
1659 Get_First_Interp
(N
, I
, It
);
1660 while Scope
(It
.Nam
) /= Standard_Standard
loop
1661 Get_Next_Interp
(I
, It
);
1670 -- If no universal interpretation, check whether user-defined operator
1671 -- hides predefined one, as well as other special cases. If the node
1672 -- is a range, then one or both bounds are ambiguous. Each will have
1673 -- to be disambiguated w.r.t. the context type. The type of the range
1674 -- itself is imposed by the context, so we can return either legal
1677 if Ekind
(Nam1
) = E_Operator
then
1678 Predef_Subp
:= Nam1
;
1681 elsif Ekind
(Nam2
) = E_Operator
then
1682 Predef_Subp
:= Nam2
;
1685 elsif Nkind
(N
) = N_Range
then
1688 -- Implement AI05-105: A renaming declaration with an access
1689 -- definition must resolve to an anonymous access type. This
1690 -- is a resolution rule and can be used to disambiguate.
1692 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1693 and then Present
(Access_Definition
(Parent
(N
)))
1695 if Ekind_In
(It1
.Typ
, E_Anonymous_Access_Type
,
1696 E_Anonymous_Access_Subprogram_Type
)
1698 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1708 elsif Ekind_In
(It2
.Typ
, E_Anonymous_Access_Type
,
1709 E_Anonymous_Access_Subprogram_Type
)
1713 -- No legal interpretation
1719 -- If two user defined-subprograms are visible, it is a true ambiguity,
1720 -- unless one of them is an entry and the context is a conditional or
1721 -- timed entry call, or unless we are within an instance and this is
1722 -- results from two formals types with the same actual.
1725 if Nkind
(N
) = N_Procedure_Call_Statement
1726 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1727 and then N
= Entry_Call_Statement
(Parent
(N
))
1729 if Ekind
(Nam2
) = E_Entry
then
1731 elsif Ekind
(Nam1
) = E_Entry
then
1737 -- If the ambiguity occurs within an instance, it is due to several
1738 -- formal types with the same actual. Look for an exact match between
1739 -- the types of the formals of the overloadable entities, and the
1740 -- actuals in the call, to recover the unambiguous match in the
1741 -- original generic.
1743 -- The ambiguity can also be due to an overloading between a formal
1744 -- subprogram and a subprogram declared outside the generic. If the
1745 -- node is overloaded, it did not resolve to the global entity in
1746 -- the generic, and we choose the formal subprogram.
1748 -- Finally, the ambiguity can be between an explicit subprogram and
1749 -- one inherited (with different defaults) from an actual. In this
1750 -- case the resolution was to the explicit declaration in the
1751 -- generic, and remains so in the instance.
1754 and then not In_Generic_Actual
(N
)
1756 if Nkind
(N
) = N_Function_Call
1757 or else Nkind
(N
) = N_Procedure_Call_Statement
1762 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1763 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1766 if Is_Act1
and then not Is_Act2
then
1769 elsif Is_Act2
and then not Is_Act1
then
1772 elsif Inherited_From_Actual
(Nam1
)
1773 and then Comes_From_Source
(Nam2
)
1777 elsif Inherited_From_Actual
(Nam2
)
1778 and then Comes_From_Source
(Nam1
)
1783 Actual
:= First_Actual
(N
);
1784 Formal
:= First_Formal
(Nam1
);
1785 while Present
(Actual
) loop
1786 if Etype
(Actual
) /= Etype
(Formal
) then
1790 Next_Actual
(Actual
);
1791 Next_Formal
(Formal
);
1797 elsif Nkind
(N
) in N_Binary_Op
then
1798 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1800 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1807 elsif Nkind
(N
) in N_Unary_Op
then
1808 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1815 return Remove_Conversions
;
1818 return Remove_Conversions
;
1822 -- An implicit concatenation operator on a string type cannot be
1823 -- disambiguated from the predefined concatenation. This can only
1824 -- happen with concatenation of string literals.
1826 if Chars
(User_Subp
) = Name_Op_Concat
1827 and then Ekind
(User_Subp
) = E_Operator
1828 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1832 -- If the user-defined operator is in an open scope, or in the scope
1833 -- of the resulting type, or given by an expanded name that names its
1834 -- scope, it hides the predefined operator for the type. Exponentiation
1835 -- has to be special-cased because the implicit operator does not have
1836 -- a symmetric signature, and may not be hidden by the explicit one.
1838 elsif (Nkind
(N
) = N_Function_Call
1839 and then Nkind
(Name
(N
)) = N_Expanded_Name
1840 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1841 or else Hides_Op
(User_Subp
, Predef_Subp
))
1842 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1843 or else Hides_Op
(User_Subp
, Predef_Subp
)
1845 if It1
.Nam
= User_Subp
then
1851 -- Otherwise, the predefined operator has precedence, or if the user-
1852 -- defined operation is directly visible we have a true ambiguity. If
1853 -- this is a fixed-point multiplication and division in Ada83 mode,
1854 -- exclude the universal_fixed operator, which often causes ambiguities
1858 if (In_Open_Scopes
(Scope
(User_Subp
))
1859 or else Is_Potentially_Use_Visible
(User_Subp
))
1860 and then not In_Instance
1862 if Is_Fixed_Point_Type
(Typ
)
1863 and then (Chars
(Nam1
) = Name_Op_Multiply
1864 or else Chars
(Nam1
) = Name_Op_Divide
)
1865 and then Ada_Version
= Ada_83
1867 if It2
.Nam
= Predef_Subp
then
1873 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1874 -- states that the operator defined in Standard is not available
1875 -- if there is a user-defined equality with the proper signature,
1876 -- declared in the same declarative list as the type. The node
1877 -- may be an operator or a function call.
1879 elsif (Chars
(Nam1
) = Name_Op_Eq
1881 Chars
(Nam1
) = Name_Op_Ne
)
1882 and then Ada_Version
>= Ada_2005
1883 and then Etype
(User_Subp
) = Standard_Boolean
1889 if Nkind
(N
) = N_Function_Call
then
1890 Opnd
:= First_Actual
(N
);
1892 Opnd
:= Left_Opnd
(N
);
1895 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1897 In_Same_List
(Parent
(Designated_Type
(Etype
(Opnd
))),
1898 Unit_Declaration_Node
(User_Subp
))
1900 if It2
.Nam
= Predef_Subp
then
1906 return Remove_Conversions
;
1914 elsif It1
.Nam
= Predef_Subp
then
1923 ---------------------
1924 -- End_Interp_List --
1925 ---------------------
1927 procedure End_Interp_List
is
1929 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1930 All_Interp
.Increment_Last
;
1931 end End_Interp_List
;
1933 -------------------------
1934 -- Entity_Matches_Spec --
1935 -------------------------
1937 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1939 -- Simple case: same entity kinds, type conformance is required. A
1940 -- parameterless function can also rename a literal.
1942 if Ekind
(Old_S
) = Ekind
(New_S
)
1943 or else (Ekind
(New_S
) = E_Function
1944 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1946 return Type_Conformant
(New_S
, Old_S
);
1948 elsif Ekind
(New_S
) = E_Function
1949 and then Ekind
(Old_S
) = E_Operator
1951 return Operator_Matches_Spec
(Old_S
, New_S
);
1953 elsif Ekind
(New_S
) = E_Procedure
1954 and then Is_Entry
(Old_S
)
1956 return Type_Conformant
(New_S
, Old_S
);
1961 end Entity_Matches_Spec
;
1963 ----------------------
1964 -- Find_Unique_Type --
1965 ----------------------
1967 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1968 T
: constant Entity_Id
:= Etype
(L
);
1971 TR
: Entity_Id
:= Any_Type
;
1974 if Is_Overloaded
(R
) then
1975 Get_First_Interp
(R
, I
, It
);
1976 while Present
(It
.Typ
) loop
1977 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1979 -- If several interpretations are possible and L is universal,
1980 -- apply preference rule.
1982 if TR
/= Any_Type
then
1984 if (T
= Universal_Integer
or else T
= Universal_Real
)
1995 Get_Next_Interp
(I
, It
);
2000 -- In the non-overloaded case, the Etype of R is already set correctly
2006 -- If one of the operands is Universal_Fixed, the type of the other
2007 -- operand provides the context.
2009 if Etype
(R
) = Universal_Fixed
then
2012 elsif T
= Universal_Fixed
then
2015 -- Ada 2005 (AI-230): Support the following operators:
2017 -- function "=" (L, R : universal_access) return Boolean;
2018 -- function "/=" (L, R : universal_access) return Boolean;
2020 -- Pool specific access types (E_Access_Type) are not covered by these
2021 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2022 -- of the equality operators for universal_access shall be convertible
2023 -- to one another (see 4.6)". For example, considering the type decla-
2024 -- ration "type P is access Integer" and an anonymous access to Integer,
2025 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2026 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2028 elsif Ada_Version
>= Ada_2005
2030 (Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
2032 Ekind
(Etype
(L
)) = E_Anonymous_Access_Subprogram_Type
)
2033 and then Is_Access_Type
(Etype
(R
))
2034 and then Ekind
(Etype
(R
)) /= E_Access_Type
2038 elsif Ada_Version
>= Ada_2005
2040 (Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
2041 or else Ekind
(Etype
(R
)) = E_Anonymous_Access_Subprogram_Type
)
2042 and then Is_Access_Type
(Etype
(L
))
2043 and then Ekind
(Etype
(L
)) /= E_Access_Type
2048 return Specific_Type
(T
, Etype
(R
));
2050 end Find_Unique_Type
;
2052 -------------------------------------
2053 -- Function_Interp_Has_Abstract_Op --
2054 -------------------------------------
2056 function Function_Interp_Has_Abstract_Op
2058 E
: Entity_Id
) return Entity_Id
2060 Abstr_Op
: Entity_Id
;
2063 Form_Parm
: Node_Id
;
2066 -- Why is check on E needed below ???
2067 -- In any case this para needs comments ???
2069 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2070 Act_Parm
:= First_Actual
(N
);
2071 Form_Parm
:= First_Formal
(E
);
2072 while Present
(Act_Parm
)
2073 and then Present
(Form_Parm
)
2077 if Nkind
(Act
) = N_Parameter_Association
then
2078 Act
:= Explicit_Actual_Parameter
(Act
);
2081 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2083 if Present
(Abstr_Op
) then
2087 Next_Actual
(Act_Parm
);
2088 Next_Formal
(Form_Parm
);
2093 end Function_Interp_Has_Abstract_Op
;
2095 ----------------------
2096 -- Get_First_Interp --
2097 ----------------------
2099 procedure Get_First_Interp
2101 I
: out Interp_Index
;
2104 Int_Ind
: Interp_Index
;
2109 -- If a selected component is overloaded because the selector has
2110 -- multiple interpretations, the node is a call to a protected
2111 -- operation or an indirect call. Retrieve the interpretation from
2112 -- the selector name. The selected component may be overloaded as well
2113 -- if the prefix is overloaded. That case is unchanged.
2115 if Nkind
(N
) = N_Selected_Component
2116 and then Is_Overloaded
(Selector_Name
(N
))
2118 O_N
:= Selector_Name
(N
);
2123 Map_Ptr
:= Headers
(Hash
(O_N
));
2124 while Map_Ptr
/= No_Entry
loop
2125 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2126 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2127 It
:= All_Interp
.Table
(Int_Ind
);
2131 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2135 -- Procedure should never be called if the node has no interpretations
2137 raise Program_Error
;
2138 end Get_First_Interp
;
2140 ---------------------
2141 -- Get_Next_Interp --
2142 ---------------------
2144 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2147 It
:= All_Interp
.Table
(I
);
2148 end Get_Next_Interp
;
2150 -------------------------
2151 -- Has_Compatible_Type --
2152 -------------------------
2154 function Has_Compatible_Type
2156 Typ
: Entity_Id
) return Boolean
2166 if Nkind
(N
) = N_Subtype_Indication
2167 or else not Is_Overloaded
(N
)
2170 Covers
(Typ
, Etype
(N
))
2172 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2173 -- If the type is already frozen use the corresponding_record
2174 -- to check whether it is a proper descendant.
2177 (Is_Record_Type
(Typ
)
2178 and then Is_Concurrent_Type
(Etype
(N
))
2179 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2180 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2183 (Is_Concurrent_Type
(Typ
)
2184 and then Is_Record_Type
(Etype
(N
))
2185 and then Present
(Corresponding_Record_Type
(Typ
))
2186 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2189 (not Is_Tagged_Type
(Typ
)
2190 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2191 and then Covers
(Etype
(N
), Typ
));
2194 Get_First_Interp
(N
, I
, It
);
2195 while Present
(It
.Typ
) loop
2196 if (Covers
(Typ
, It
.Typ
)
2198 (Scope
(It
.Nam
) /= Standard_Standard
2199 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2201 -- Ada 2005 (AI-345)
2204 (Is_Concurrent_Type
(It
.Typ
)
2205 and then Present
(Corresponding_Record_Type
2207 and then Covers
(Typ
, Corresponding_Record_Type
2210 or else (not Is_Tagged_Type
(Typ
)
2211 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2212 and then Covers
(It
.Typ
, Typ
))
2217 Get_Next_Interp
(I
, It
);
2222 end Has_Compatible_Type
;
2224 ---------------------
2225 -- Has_Abstract_Op --
2226 ---------------------
2228 function Has_Abstract_Op
2230 Typ
: Entity_Id
) return Entity_Id
2236 if Is_Overloaded
(N
) then
2237 Get_First_Interp
(N
, I
, It
);
2238 while Present
(It
.Nam
) loop
2239 if Present
(It
.Abstract_Op
)
2240 and then Etype
(It
.Abstract_Op
) = Typ
2242 return It
.Abstract_Op
;
2245 Get_Next_Interp
(I
, It
);
2250 end Has_Abstract_Op
;
2256 function Hash
(N
: Node_Id
) return Int
is
2258 -- Nodes have a size that is power of two, so to select significant
2259 -- bits only we remove the low-order bits.
2261 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2268 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2269 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2271 return Operator_Matches_Spec
(Op
, F
)
2272 and then (In_Open_Scopes
(Scope
(F
))
2273 or else Scope
(F
) = Scope
(Btyp
)
2274 or else (not In_Open_Scopes
(Scope
(Btyp
))
2275 and then not In_Use
(Btyp
)
2276 and then not In_Use
(Scope
(Btyp
))));
2279 ------------------------
2280 -- Init_Interp_Tables --
2281 ------------------------
2283 procedure Init_Interp_Tables
is
2287 Headers
:= (others => No_Entry
);
2288 end Init_Interp_Tables
;
2290 -----------------------------------
2291 -- Interface_Present_In_Ancestor --
2292 -----------------------------------
2294 function Interface_Present_In_Ancestor
2296 Iface
: Entity_Id
) return Boolean
2298 Target_Typ
: Entity_Id
;
2299 Iface_Typ
: Entity_Id
;
2301 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2302 -- Returns True if Typ or some ancestor of Typ implements Iface
2304 -------------------------------
2305 -- Iface_Present_In_Ancestor --
2306 -------------------------------
2308 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2314 if Typ
= Iface_Typ
then
2318 -- Handle private types
2320 if Present
(Full_View
(Typ
))
2321 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2323 E
:= Full_View
(Typ
);
2329 if Present
(Interfaces
(E
))
2330 and then Present
(Interfaces
(E
))
2331 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2333 Elmt
:= First_Elmt
(Interfaces
(E
));
2334 while Present
(Elmt
) loop
2337 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2345 exit when Etype
(E
) = E
2347 -- Handle private types
2349 or else (Present
(Full_View
(Etype
(E
)))
2350 and then Full_View
(Etype
(E
)) = E
);
2352 -- Check if the current type is a direct derivation of the
2355 if Etype
(E
) = Iface_Typ
then
2359 -- Climb to the immediate ancestor handling private types
2361 if Present
(Full_View
(Etype
(E
))) then
2362 E
:= Full_View
(Etype
(E
));
2369 end Iface_Present_In_Ancestor
;
2371 -- Start of processing for Interface_Present_In_Ancestor
2374 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2376 if Is_Class_Wide_Type
(Iface
) then
2377 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2384 Iface_Typ
:= Base_Type
(Iface_Typ
);
2386 if Is_Access_Type
(Typ
) then
2387 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2392 if Is_Concurrent_Record_Type
(Target_Typ
) then
2393 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2396 Target_Typ
:= Base_Type
(Target_Typ
);
2398 -- In case of concurrent types we can't use the Corresponding Record_Typ
2399 -- to look for the interface because it is built by the expander (and
2400 -- hence it is not always available). For this reason we traverse the
2401 -- list of interfaces (available in the parent of the concurrent type)
2403 if Is_Concurrent_Type
(Target_Typ
) then
2404 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2409 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2410 while Present
(AI
) loop
2411 if Etype
(AI
) = Iface_Typ
then
2414 elsif Present
(Interfaces
(Etype
(AI
)))
2415 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2428 if Is_Class_Wide_Type
(Target_Typ
) then
2429 Target_Typ
:= Etype
(Target_Typ
);
2432 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2433 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2434 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2436 -- Protect the frontend against previously detected errors
2438 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2443 return Iface_Present_In_Ancestor
(Target_Typ
);
2444 end Interface_Present_In_Ancestor
;
2446 ---------------------
2447 -- Intersect_Types --
2448 ---------------------
2450 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2451 Index
: Interp_Index
;
2455 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2456 -- Find interpretation of right arg that has type compatible with T
2458 --------------------------
2459 -- Check_Right_Argument --
2460 --------------------------
2462 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2463 Index
: Interp_Index
;
2468 if not Is_Overloaded
(R
) then
2469 return Specific_Type
(T
, Etype
(R
));
2472 Get_First_Interp
(R
, Index
, It
);
2474 T2
:= Specific_Type
(T
, It
.Typ
);
2476 if T2
/= Any_Type
then
2480 Get_Next_Interp
(Index
, It
);
2481 exit when No
(It
.Typ
);
2486 end Check_Right_Argument
;
2488 -- Start of processing for Intersect_Types
2491 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2495 if not Is_Overloaded
(L
) then
2496 Typ
:= Check_Right_Argument
(Etype
(L
));
2500 Get_First_Interp
(L
, Index
, It
);
2501 while Present
(It
.Typ
) loop
2502 Typ
:= Check_Right_Argument
(It
.Typ
);
2503 exit when Typ
/= Any_Type
;
2504 Get_Next_Interp
(Index
, It
);
2509 -- If Typ is Any_Type, it means no compatible pair of types was found
2511 if Typ
= Any_Type
then
2512 if Nkind
(Parent
(L
)) in N_Op
then
2513 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2515 elsif Nkind
(Parent
(L
)) = N_Range
then
2516 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2518 -- Ada 2005 (AI-251): Complete the error notification
2520 elsif Is_Class_Wide_Type
(Etype
(R
))
2521 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2523 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2524 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2527 Error_Msg_N
("incompatible types", Parent
(L
));
2532 end Intersect_Types
;
2534 -----------------------
2535 -- In_Generic_Actual --
2536 -----------------------
2538 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2539 Par
: constant Node_Id
:= Parent
(Exp
);
2545 elsif Nkind
(Par
) in N_Declaration
then
2546 if Nkind
(Par
) = N_Object_Declaration
then
2547 return Present
(Corresponding_Generic_Association
(Par
));
2552 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2553 return Present
(Corresponding_Generic_Association
(Par
));
2555 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2559 return In_Generic_Actual
(Parent
(Par
));
2561 end In_Generic_Actual
;
2567 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2573 BT1
:= Base_Type
(T1
);
2574 BT2
:= Base_Type
(T2
);
2576 -- Handle underlying view of records with unknown discriminants using
2577 -- the original entity that motivated the construction of this
2578 -- underlying record view (see Build_Derived_Private_Type).
2580 if Is_Underlying_Record_View
(BT1
) then
2581 BT1
:= Underlying_Record_View
(BT1
);
2584 if Is_Underlying_Record_View
(BT2
) then
2585 BT2
:= Underlying_Record_View
(BT2
);
2591 -- The predicate must look past privacy
2593 elsif Is_Private_Type
(T1
)
2594 and then Present
(Full_View
(T1
))
2595 and then BT2
= Base_Type
(Full_View
(T1
))
2599 elsif Is_Private_Type
(T2
)
2600 and then Present
(Full_View
(T2
))
2601 and then BT1
= Base_Type
(Full_View
(T2
))
2609 -- If there was a error on the type declaration, do not recurse
2611 if Error_Posted
(Par
) then
2614 elsif BT1
= Base_Type
(Par
)
2615 or else (Is_Private_Type
(T1
)
2616 and then Present
(Full_View
(T1
))
2617 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2621 elsif Is_Private_Type
(Par
)
2622 and then Present
(Full_View
(Par
))
2623 and then Full_View
(Par
) = BT1
2627 elsif Etype
(Par
) /= Par
then
2629 -- If this is a private type and its parent is an interface
2630 -- then use the parent of the full view (which is a type that
2631 -- implements such interface)
2633 if Is_Private_Type
(Par
)
2634 and then Is_Interface
(Etype
(Par
))
2635 and then Present
(Full_View
(Par
))
2637 Par
:= Etype
(Full_View
(Par
));
2642 -- For all other cases return False, not an Ancestor
2651 ---------------------------
2652 -- Is_Invisible_Operator --
2653 ---------------------------
2655 function Is_Invisible_Operator
2657 T
: Entity_Id
) return Boolean
2659 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2662 if Nkind
(N
) not in N_Op
then
2665 elsif not Comes_From_Source
(N
) then
2668 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2671 elsif Nkind
(N
) in N_Binary_Op
2672 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2677 return Is_Numeric_Type
(T
)
2678 and then not In_Open_Scopes
(Scope
(T
))
2679 and then not Is_Potentially_Use_Visible
(T
)
2680 and then not In_Use
(T
)
2681 and then not In_Use
(Scope
(T
))
2683 (Nkind
(Orig_Node
) /= N_Function_Call
2684 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2685 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2686 and then not In_Instance
;
2688 end Is_Invisible_Operator
;
2690 --------------------
2692 --------------------
2694 function Is_Progenitor
2696 Typ
: Entity_Id
) return Boolean
2699 return Implements_Interface
(Typ
, Iface
, Exclude_Parents
=> True);
2706 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2710 S
:= Ancestor_Subtype
(T1
);
2711 while Present
(S
) loop
2715 S
:= Ancestor_Subtype
(S
);
2726 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2727 Index
: Interp_Index
;
2731 Get_First_Interp
(Nam
, Index
, It
);
2732 while Present
(It
.Nam
) loop
2733 if Scope
(It
.Nam
) = Standard_Standard
2734 and then Scope
(It
.Typ
) /= Standard_Standard
2736 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2737 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2740 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2741 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2744 Get_Next_Interp
(Index
, It
);
2752 procedure New_Interps
(N
: Node_Id
) is
2756 All_Interp
.Append
(No_Interp
);
2758 Map_Ptr
:= Headers
(Hash
(N
));
2760 if Map_Ptr
= No_Entry
then
2762 -- Place new node at end of table
2764 Interp_Map
.Increment_Last
;
2765 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2768 -- Place node at end of chain, or locate its previous entry
2771 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2773 -- Node is already in the table, and is being rewritten.
2774 -- Start a new interp section, retain hash link.
2776 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2777 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2778 Set_Is_Overloaded
(N
, True);
2782 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2783 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2787 -- Chain the new node
2789 Interp_Map
.Increment_Last
;
2790 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2793 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2794 Set_Is_Overloaded
(N
, True);
2797 ---------------------------
2798 -- Operator_Matches_Spec --
2799 ---------------------------
2801 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2802 Op_Name
: constant Name_Id
:= Chars
(Op
);
2803 T
: constant Entity_Id
:= Etype
(New_S
);
2811 -- To verify that a predefined operator matches a given signature,
2812 -- do a case analysis of the operator classes. Function can have one
2813 -- or two formals and must have the proper result type.
2815 New_F
:= First_Formal
(New_S
);
2816 Old_F
:= First_Formal
(Op
);
2818 while Present
(New_F
) and then Present
(Old_F
) loop
2820 Next_Formal
(New_F
);
2821 Next_Formal
(Old_F
);
2824 -- Definite mismatch if different number of parameters
2826 if Present
(Old_F
) or else Present
(New_F
) then
2832 T1
:= Etype
(First_Formal
(New_S
));
2834 if Op_Name
= Name_Op_Subtract
2835 or else Op_Name
= Name_Op_Add
2836 or else Op_Name
= Name_Op_Abs
2838 return Base_Type
(T1
) = Base_Type
(T
)
2839 and then Is_Numeric_Type
(T
);
2841 elsif Op_Name
= Name_Op_Not
then
2842 return Base_Type
(T1
) = Base_Type
(T
)
2843 and then Valid_Boolean_Arg
(Base_Type
(T
));
2852 T1
:= Etype
(First_Formal
(New_S
));
2853 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2855 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2856 or else Op_Name
= Name_Op_Xor
2858 return Base_Type
(T1
) = Base_Type
(T2
)
2859 and then Base_Type
(T1
) = Base_Type
(T
)
2860 and then Valid_Boolean_Arg
(Base_Type
(T
));
2862 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2863 return Base_Type
(T1
) = Base_Type
(T2
)
2864 and then not Is_Limited_Type
(T1
)
2865 and then Is_Boolean_Type
(T
);
2867 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2868 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2870 return Base_Type
(T1
) = Base_Type
(T2
)
2871 and then Valid_Comparison_Arg
(T1
)
2872 and then Is_Boolean_Type
(T
);
2874 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2875 return Base_Type
(T1
) = Base_Type
(T2
)
2876 and then Base_Type
(T1
) = Base_Type
(T
)
2877 and then Is_Numeric_Type
(T
);
2879 -- For division and multiplication, a user-defined function does not
2880 -- match the predefined universal_fixed operation, except in Ada 83.
2882 elsif Op_Name
= Name_Op_Divide
then
2883 return (Base_Type
(T1
) = Base_Type
(T2
)
2884 and then Base_Type
(T1
) = Base_Type
(T
)
2885 and then Is_Numeric_Type
(T
)
2886 and then (not Is_Fixed_Point_Type
(T
)
2887 or else Ada_Version
= Ada_83
))
2889 -- Mixed_Mode operations on fixed-point types
2891 or else (Base_Type
(T1
) = Base_Type
(T
)
2892 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2893 and then Is_Fixed_Point_Type
(T
))
2895 -- A user defined operator can also match (and hide) a mixed
2896 -- operation on universal literals.
2898 or else (Is_Integer_Type
(T2
)
2899 and then Is_Floating_Point_Type
(T1
)
2900 and then Base_Type
(T1
) = Base_Type
(T
));
2902 elsif Op_Name
= Name_Op_Multiply
then
2903 return (Base_Type
(T1
) = Base_Type
(T2
)
2904 and then Base_Type
(T1
) = Base_Type
(T
)
2905 and then Is_Numeric_Type
(T
)
2906 and then (not Is_Fixed_Point_Type
(T
)
2907 or else Ada_Version
= Ada_83
))
2909 -- Mixed_Mode operations on fixed-point types
2911 or else (Base_Type
(T1
) = Base_Type
(T
)
2912 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2913 and then Is_Fixed_Point_Type
(T
))
2915 or else (Base_Type
(T2
) = Base_Type
(T
)
2916 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2917 and then Is_Fixed_Point_Type
(T
))
2919 or else (Is_Integer_Type
(T2
)
2920 and then Is_Floating_Point_Type
(T1
)
2921 and then Base_Type
(T1
) = Base_Type
(T
))
2923 or else (Is_Integer_Type
(T1
)
2924 and then Is_Floating_Point_Type
(T2
)
2925 and then Base_Type
(T2
) = Base_Type
(T
));
2927 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2928 return Base_Type
(T1
) = Base_Type
(T2
)
2929 and then Base_Type
(T1
) = Base_Type
(T
)
2930 and then Is_Integer_Type
(T
);
2932 elsif Op_Name
= Name_Op_Expon
then
2933 return Base_Type
(T1
) = Base_Type
(T
)
2934 and then Is_Numeric_Type
(T
)
2935 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2937 elsif Op_Name
= Name_Op_Concat
then
2938 return Is_Array_Type
(T
)
2939 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2940 and then (Base_Type
(T1
) = Base_Type
(T
)
2942 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2943 and then (Base_Type
(T2
) = Base_Type
(T
)
2945 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2951 end Operator_Matches_Spec
;
2957 procedure Remove_Interp
(I
: in out Interp_Index
) is
2961 -- Find end of interp list and copy downward to erase the discarded one
2964 while Present
(All_Interp
.Table
(II
).Typ
) loop
2968 for J
in I
+ 1 .. II
loop
2969 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2972 -- Back up interp index to insure that iterator will pick up next
2973 -- available interpretation.
2982 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2984 O_N
: Node_Id
:= Old_N
;
2987 if Is_Overloaded
(Old_N
) then
2988 if Nkind
(Old_N
) = N_Selected_Component
2989 and then Is_Overloaded
(Selector_Name
(Old_N
))
2991 O_N
:= Selector_Name
(Old_N
);
2994 Map_Ptr
:= Headers
(Hash
(O_N
));
2996 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2997 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2998 pragma Assert
(Map_Ptr
/= No_Entry
);
3001 New_Interps
(New_N
);
3002 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
3003 Interp_Map
.Table
(Map_Ptr
).Index
;
3011 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
3012 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
3013 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
3014 B1
: constant Entity_Id
:= Base_Type
(T1
);
3015 B2
: constant Entity_Id
:= Base_Type
(T2
);
3017 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
3018 -- Check whether T is the equivalent type of a remote access type.
3019 -- If distribution is enabled, T is a legal context for Null.
3021 ----------------------
3022 -- Is_Remote_Access --
3023 ----------------------
3025 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
3027 return Is_Record_Type
(T
)
3028 and then (Is_Remote_Call_Interface
(T
)
3029 or else Is_Remote_Types
(T
))
3030 and then Present
(Corresponding_Remote_Type
(T
))
3031 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
3032 end Is_Remote_Access
;
3034 -- Start of processing for Specific_Type
3037 if T1
= Any_Type
or else T2
= Any_Type
then
3044 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
3045 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
3046 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
3047 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3051 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3052 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3053 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3054 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3058 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
3061 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
3064 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
3067 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3070 elsif T1
= Any_Access
3071 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3075 elsif T2
= Any_Access
3076 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3080 elsif T2
= Any_Composite
3081 and then Is_Aggregate_Type
(T1
)
3085 elsif T1
= Any_Composite
3086 and then Is_Aggregate_Type
(T2
)
3090 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3093 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3096 -- ----------------------------------------------------------
3097 -- Special cases for equality operators (all other predefined
3098 -- operators can never apply to tagged types)
3099 -- ----------------------------------------------------------
3101 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3104 elsif Is_Class_Wide_Type
(T1
)
3105 and then Is_Class_Wide_Type
(T2
)
3106 and then Is_Interface
(Etype
(T2
))
3110 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3111 -- class-wide interface T2
3113 elsif Is_Class_Wide_Type
(T2
)
3114 and then Is_Interface
(Etype
(T2
))
3115 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3116 Iface
=> Etype
(T2
))
3120 elsif Is_Class_Wide_Type
(T1
)
3121 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3125 elsif Is_Class_Wide_Type
(T2
)
3126 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3130 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
3132 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
3133 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3134 and then Is_Access_Type
(T2
)
3138 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
3140 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
3141 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3142 and then Is_Access_Type
(T1
)
3146 elsif (Ekind
(T1
) = E_Allocator_Type
3147 or else Ekind
(T1
) = E_Access_Attribute_Type
3148 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
3149 and then Is_Access_Type
(T2
)
3153 elsif (Ekind
(T2
) = E_Allocator_Type
3154 or else Ekind
(T2
) = E_Access_Attribute_Type
3155 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
3156 and then Is_Access_Type
(T1
)
3160 -- If none of the above cases applies, types are not compatible
3167 ---------------------
3168 -- Set_Abstract_Op --
3169 ---------------------
3171 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3173 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3174 end Set_Abstract_Op
;
3176 -----------------------
3177 -- Valid_Boolean_Arg --
3178 -----------------------
3180 -- In addition to booleans and arrays of booleans, we must include
3181 -- aggregates as valid boolean arguments, because in the first pass of
3182 -- resolution their components are not examined. If it turns out not to be
3183 -- an aggregate of booleans, this will be diagnosed in Resolve.
3184 -- Any_Composite must be checked for prior to the array type checks because
3185 -- Any_Composite does not have any associated indexes.
3187 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3189 return Is_Boolean_Type
(T
)
3190 or else T
= Any_Composite
3191 or else (Is_Array_Type
(T
)
3192 and then T
/= Any_String
3193 and then Number_Dimensions
(T
) = 1
3194 and then Is_Boolean_Type
(Component_Type
(T
))
3195 and then (not Is_Private_Composite
(T
)
3196 or else In_Instance
)
3197 and then (not Is_Limited_Composite
(T
)
3198 or else In_Instance
))
3199 or else Is_Modular_Integer_Type
(T
)
3200 or else T
= Universal_Integer
;
3201 end Valid_Boolean_Arg
;
3203 --------------------------
3204 -- Valid_Comparison_Arg --
3205 --------------------------
3207 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3210 if T
= Any_Composite
then
3212 elsif Is_Discrete_Type
(T
)
3213 or else Is_Real_Type
(T
)
3216 elsif Is_Array_Type
(T
)
3217 and then Number_Dimensions
(T
) = 1
3218 and then Is_Discrete_Type
(Component_Type
(T
))
3219 and then (not Is_Private_Composite
(T
)
3220 or else In_Instance
)
3221 and then (not Is_Limited_Composite
(T
)
3222 or else In_Instance
)
3225 elsif Is_String_Type
(T
) then
3230 end Valid_Comparison_Arg
;
3232 ----------------------
3233 -- Write_Interp_Ref --
3234 ----------------------
3236 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3238 Write_Str
(" Node: ");
3239 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3240 Write_Str
(" Index: ");
3241 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3242 Write_Str
(" Next: ");
3243 Write_Int
(Interp_Map
.Table
(Map_Ptr
).Next
);
3245 end Write_Interp_Ref
;
3247 ---------------------
3248 -- Write_Overloads --
3249 ---------------------
3251 procedure Write_Overloads
(N
: Node_Id
) is
3257 if not Is_Overloaded
(N
) then
3258 Write_Str
("Non-overloaded entity ");
3260 Write_Entity_Info
(Entity
(N
), " ");
3263 Get_First_Interp
(N
, I
, It
);
3264 Write_Str
("Overloaded entity ");
3266 Write_Str
(" Name Type Abstract Op");
3268 Write_Str
("===============================================");
3272 while Present
(Nam
) loop
3273 Write_Int
(Int
(Nam
));
3275 Write_Name
(Chars
(Nam
));
3277 Write_Int
(Int
(It
.Typ
));
3279 Write_Name
(Chars
(It
.Typ
));
3281 if Present
(It
.Abstract_Op
) then
3283 Write_Int
(Int
(It
.Abstract_Op
));
3285 Write_Name
(Chars
(It
.Abstract_Op
));
3289 Get_Next_Interp
(I
, It
);
3293 end Write_Overloads
;