1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Nlists
; use Nlists
;
32 with Errout
; use Errout
;
34 with Namet
; use Namet
;
36 with Output
; use Output
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch6
; use Sem_Ch6
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Ch12
; use Sem_Ch12
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Util
; use Sem_Util
;
45 with Stand
; use Stand
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
49 with Uintp
; use Uintp
;
51 package body Sem_Type
is
57 -- The following data structures establish a mapping between nodes and
58 -- their interpretations. An overloaded node has an entry in Interp_Map,
59 -- which in turn contains a pointer into the All_Interp array. The
60 -- interpretations of a given node are contiguous in All_Interp. Each set
61 -- of interpretations is terminated with the marker No_Interp. In order to
62 -- speed up the retrieval of the interpretations of an overloaded node, the
63 -- Interp_Map table is accessed by means of a simple hashing scheme, and
64 -- the entries in Interp_Map are chained. The heads of clash lists are
65 -- stored in array Headers.
67 -- Headers Interp_Map All_Interp
69 -- _ +-----+ +--------+
70 -- |_| |_____| --->|interp1 |
71 -- |_|---------->|node | | |interp2 |
72 -- |_| |index|---------| |nointerp|
77 -- This scheme does not currently reclaim interpretations. In principle,
78 -- after a unit is compiled, all overloadings have been resolved, and the
79 -- candidate interpretations should be deleted. This should be easier
80 -- now than with the previous scheme???
82 package All_Interp
is new Table
.Table
(
83 Table_Component_Type
=> Interp
,
84 Table_Index_Type
=> Int
,
86 Table_Initial
=> Alloc
.All_Interp_Initial
,
87 Table_Increment
=> Alloc
.All_Interp_Increment
,
88 Table_Name
=> "All_Interp");
90 type Interp_Ref
is record
96 Header_Size
: constant Int
:= 2 ** 12;
97 No_Entry
: constant Int
:= -1;
98 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
100 package Interp_Map
is new Table
.Table
(
101 Table_Component_Type
=> Interp_Ref
,
102 Table_Index_Type
=> Int
,
103 Table_Low_Bound
=> 0,
104 Table_Initial
=> Alloc
.Interp_Map_Initial
,
105 Table_Increment
=> Alloc
.Interp_Map_Increment
,
106 Table_Name
=> "Interp_Map");
108 function Hash
(N
: Node_Id
) return Int
;
109 -- A trivial hashing function for nodes, used to insert an overloaded
110 -- node into the Interp_Map table.
112 -------------------------------------
113 -- Handling of Overload Resolution --
114 -------------------------------------
116 -- Overload resolution uses two passes over the syntax tree of a complete
117 -- context. In the first, bottom-up pass, the types of actuals in calls
118 -- are used to resolve possibly overloaded subprogram and operator names.
119 -- In the second top-down pass, the type of the context (for example the
120 -- condition in a while statement) is used to resolve a possibly ambiguous
121 -- call, and the unique subprogram name in turn imposes a specific context
122 -- on each of its actuals.
124 -- Most expressions are in fact unambiguous, and the bottom-up pass is
125 -- sufficient to resolve most everything. To simplify the common case,
126 -- names and expressions carry a flag Is_Overloaded to indicate whether
127 -- they have more than one interpretation. If the flag is off, then each
128 -- name has already a unique meaning and type, and the bottom-up pass is
129 -- sufficient (and much simpler).
131 --------------------------
132 -- Operator Overloading --
133 --------------------------
135 -- The visibility of operators is handled differently from that of other
136 -- entities. We do not introduce explicit versions of primitive operators
137 -- for each type definition. As a result, there is only one entity
138 -- corresponding to predefined addition on all numeric types, etc. The
139 -- back-end resolves predefined operators according to their type. The
140 -- visibility of primitive operations then reduces to the visibility of the
141 -- resulting type: (a + b) is a legal interpretation of some primitive
142 -- operator + if the type of the result (which must also be the type of a
143 -- and b) is directly visible (either immediately visible or use-visible).
145 -- User-defined operators are treated like other functions, but the
146 -- visibility of these user-defined operations must be special-cased
147 -- to determine whether they hide or are hidden by predefined operators.
148 -- The form P."+" (x, y) requires additional handling.
150 -- Concatenation is treated more conventionally: for every one-dimensional
151 -- array type we introduce a explicit concatenation operator. This is
152 -- necessary to handle the case of (element & element => array) which
153 -- cannot be handled conveniently if there is no explicit instance of
154 -- resulting type of the operation.
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure All_Overloads
;
161 pragma Warnings
(Off
, All_Overloads
);
162 -- Debugging procedure: list full contents of Overloads table
164 function Binary_Op_Interp_Has_Abstract_Op
166 E
: Entity_Id
) return Entity_Id
;
167 -- Given the node and entity of a binary operator, determine whether the
168 -- actuals of E contain an abstract interpretation with regards to the
169 -- types of their corresponding formals. Return the abstract operation or
172 function Function_Interp_Has_Abstract_Op
174 E
: Entity_Id
) return Entity_Id
;
175 -- Given the node and entity of a function call, determine whether the
176 -- actuals of E contain an abstract interpretation with regards to the
177 -- types of their corresponding formals. Return the abstract operation or
180 function Has_Abstract_Op
182 Typ
: Entity_Id
) return Entity_Id
;
183 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
184 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
185 -- abstract interpretation which yields type Typ.
187 procedure New_Interps
(N
: Node_Id
);
188 -- Initialize collection of interpretations for the given node, which is
189 -- either an overloaded entity, or an operation whose arguments have
190 -- multiple interpretations. Interpretations can be added to only one
193 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
;
194 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
195 -- or is not a "class" type (any_character, etc).
201 procedure Add_One_Interp
205 Opnd_Type
: Entity_Id
:= Empty
)
207 Vis_Type
: Entity_Id
;
209 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
210 -- Add one interpretation to an overloaded node. Add a new entry if
211 -- not hidden by previous one, and remove previous one if hidden by
214 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
215 -- True if the entity is a predefined operator and the operands have
216 -- a universal Interpretation.
222 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
223 Abstr_Op
: Entity_Id
:= Empty
;
227 -- Start of processing for Add_Entry
230 -- Find out whether the new entry references interpretations that
231 -- are abstract or disabled by abstract operators.
233 if Ada_Version
>= Ada_05
then
234 if Nkind
(N
) in N_Binary_Op
then
235 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
236 elsif Nkind
(N
) = N_Function_Call
then
237 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
241 Get_First_Interp
(N
, I
, It
);
242 while Present
(It
.Nam
) loop
244 -- A user-defined subprogram hides another declared at an outer
245 -- level, or one that is use-visible. So return if previous
246 -- definition hides new one (which is either in an outer
247 -- scope, or use-visible). Note that for functions use-visible
248 -- is the same as potentially use-visible. If new one hides
249 -- previous one, replace entry in table of interpretations.
250 -- If this is a universal operation, retain the operator in case
251 -- preference rule applies.
253 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
254 and then Ekind
(Name
) = Ekind
(It
.Nam
))
255 or else (Ekind
(Name
) = E_Operator
256 and then Ekind
(It
.Nam
) = E_Function
))
258 and then Is_Immediately_Visible
(It
.Nam
)
259 and then Type_Conformant
(Name
, It
.Nam
)
260 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
262 if Is_Universal_Operation
(Name
) then
265 -- If node is an operator symbol, we have no actuals with
266 -- which to check hiding, and this is done in full in the
267 -- caller (Analyze_Subprogram_Renaming) so we include the
268 -- predefined operator in any case.
270 elsif Nkind
(N
) = N_Operator_Symbol
271 or else (Nkind
(N
) = N_Expanded_Name
273 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
277 elsif not In_Open_Scopes
(Scope
(Name
))
278 or else Scope_Depth
(Scope
(Name
)) <=
279 Scope_Depth
(Scope
(It
.Nam
))
281 -- If ambiguity within instance, and entity is not an
282 -- implicit operation, save for later disambiguation.
284 if Scope
(Name
) = Scope
(It
.Nam
)
285 and then not Is_Inherited_Operation
(Name
)
294 All_Interp
.Table
(I
).Nam
:= Name
;
298 -- Avoid making duplicate entries in overloads
301 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
305 -- Otherwise keep going
308 Get_Next_Interp
(I
, It
);
313 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
314 All_Interp
.Append
(No_Interp
);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
325 if Ekind
(Op
) /= E_Operator
then
328 elsif Nkind
(N
) in N_Binary_Op
then
329 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
330 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
332 elsif Nkind
(N
) in N_Unary_Op
then
333 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
335 elsif Nkind
(N
) = N_Function_Call
then
336 Arg
:= First_Actual
(N
);
337 while Present
(Arg
) loop
338 if No
(Universal_Interpretation
(Arg
)) then
350 end Is_Universal_Operation
;
352 -- Start of processing for Add_One_Interp
355 -- If the interpretation is a predefined operator, verify that the
356 -- result type is visible, or that the entity has already been
357 -- resolved (case of an instantiation node that refers to a predefined
358 -- operation, or an internally generated operator node, or an operator
359 -- given as an expanded name). If the operator is a comparison or
360 -- equality, it is the type of the operand that matters to determine
361 -- whether the operator is visible. In an instance, the check is not
362 -- performed, given that the operator was visible in the generic.
364 if Ekind
(E
) = E_Operator
then
365 if Present
(Opnd_Type
) then
366 Vis_Type
:= Opnd_Type
;
368 Vis_Type
:= Base_Type
(T
);
371 if In_Open_Scopes
(Scope
(Vis_Type
))
372 or else Is_Potentially_Use_Visible
(Vis_Type
)
373 or else In_Use
(Vis_Type
)
374 or else (In_Use
(Scope
(Vis_Type
))
375 and then not Is_Hidden
(Vis_Type
))
376 or else Nkind
(N
) = N_Expanded_Name
377 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
379 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
383 -- If the node is given in functional notation and the prefix
384 -- is an expanded name, then the operator is visible if the
385 -- prefix is the scope of the result type as well. If the
386 -- operator is (implicitly) defined in an extension of system,
387 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
389 elsif Nkind
(N
) = N_Function_Call
390 and then Nkind
(Name
(N
)) = N_Expanded_Name
391 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
392 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
393 or else Scope
(Vis_Type
) = System_Aux_Id
)
397 -- Save type for subsequent error message, in case no other
398 -- interpretation is found.
401 Candidate_Type
:= Vis_Type
;
405 -- In an instance, an abstract non-dispatching operation cannot be a
406 -- candidate interpretation, because it could not have been one in the
407 -- generic (it may be a spurious overloading in the instance).
410 and then Is_Overloadable
(E
)
411 and then Is_Abstract_Subprogram
(E
)
412 and then not Is_Dispatching_Operation
(E
)
416 -- An inherited interface operation that is implemented by some derived
417 -- type does not participate in overload resolution, only the
418 -- implementation operation does.
421 and then Is_Subprogram
(E
)
422 and then Present
(Interface_Alias
(E
))
424 -- Ada 2005 (AI-251): If this primitive operation corresponds with
425 -- an immediate ancestor interface there is no need to add it to the
426 -- list of interpretations. The corresponding aliased primitive is
427 -- also in this list of primitive operations and will be used instead
428 -- because otherwise we have a dummy ambiguity between the two
429 -- subprograms which are in fact the same.
432 (Find_Dispatching_Type
(Interface_Alias
(E
)),
433 Find_Dispatching_Type
(E
))
435 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
440 -- Calling stubs for an RACW operation never participate in resolution,
441 -- they are executed only through dispatching calls.
443 elsif Is_RACW_Stub_Type_Operation
(E
) then
447 -- If this is the first interpretation of N, N has type Any_Type.
448 -- In that case place the new type on the node. If one interpretation
449 -- already exists, indicate that the node is overloaded, and store
450 -- both the previous and the new interpretation in All_Interp. If
451 -- this is a later interpretation, just add it to the set.
453 if Etype
(N
) = Any_Type
then
458 -- Record both the operator or subprogram name, and its type
460 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
467 -- Either there is no current interpretation in the table for any
468 -- node or the interpretation that is present is for a different
469 -- node. In both cases add a new interpretation to the table.
471 elsif Interp_Map
.Last
< 0
473 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
474 and then not Is_Overloaded
(N
))
478 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
479 and then Present
(Entity
(N
))
481 Add_Entry
(Entity
(N
), Etype
(N
));
483 elsif (Nkind
(N
) = N_Function_Call
484 or else Nkind
(N
) = N_Procedure_Call_Statement
)
485 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
486 or else Is_Entity_Name
(Name
(N
)))
488 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
490 -- If this is an indirect call there will be no name associated
491 -- with the previous entry. To make diagnostics clearer, save
492 -- Subprogram_Type of first interpretation, so that the error will
493 -- point to the anonymous access to subprogram, not to the result
494 -- type of the call itself.
496 elsif (Nkind
(N
)) = N_Function_Call
497 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
498 and then Is_Overloaded
(Name
(N
))
504 pragma Warnings
(Off
, Itn
);
507 Get_First_Interp
(Name
(N
), Itn
, It
);
508 Add_Entry
(It
.Nam
, Etype
(N
));
512 -- Overloaded prefix in indexed or selected component, or call
513 -- whose name is an expression or another call.
515 Add_Entry
(Etype
(N
), Etype
(N
));
529 procedure All_Overloads
is
531 for J
in All_Interp
.First
.. All_Interp
.Last
loop
533 if Present
(All_Interp
.Table
(J
).Nam
) then
534 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
536 Write_Str
("No Interp");
540 Write_Str
("=================");
545 --------------------------------------
546 -- Binary_Op_Interp_Has_Abstract_Op --
547 --------------------------------------
549 function Binary_Op_Interp_Has_Abstract_Op
551 E
: Entity_Id
) return Entity_Id
553 Abstr_Op
: Entity_Id
;
554 E_Left
: constant Node_Id
:= First_Formal
(E
);
555 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
558 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
559 if Present
(Abstr_Op
) then
563 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
564 end Binary_Op_Interp_Has_Abstract_Op
;
566 ---------------------
567 -- Collect_Interps --
568 ---------------------
570 procedure Collect_Interps
(N
: Node_Id
) is
571 Ent
: constant Entity_Id
:= Entity
(N
);
573 First_Interp
: Interp_Index
;
578 -- Unconditionally add the entity that was initially matched
580 First_Interp
:= All_Interp
.Last
;
581 Add_One_Interp
(N
, Ent
, Etype
(N
));
583 -- For expanded name, pick up all additional entities from the
584 -- same scope, since these are obviously also visible. Note that
585 -- these are not necessarily contiguous on the homonym chain.
587 if Nkind
(N
) = N_Expanded_Name
then
589 while Present
(H
) loop
590 if Scope
(H
) = Scope
(Entity
(N
)) then
591 Add_One_Interp
(N
, H
, Etype
(H
));
597 -- Case of direct name
600 -- First, search the homonym chain for directly visible entities
602 H
:= Current_Entity
(Ent
);
603 while Present
(H
) loop
604 exit when (not Is_Overloadable
(H
))
605 and then Is_Immediately_Visible
(H
);
607 if Is_Immediately_Visible
(H
)
610 -- Only add interpretation if not hidden by an inner
611 -- immediately visible one.
613 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
615 -- Current homograph is not hidden. Add to overloads
617 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
620 -- Homograph is hidden, unless it is a predefined operator
622 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
624 -- A homograph in the same scope can occur within an
625 -- instantiation, the resulting ambiguity has to be
628 if Scope
(H
) = Scope
(Ent
)
630 and then not Is_Inherited_Operation
(H
)
632 All_Interp
.Table
(All_Interp
.Last
) :=
633 (H
, Etype
(H
), Empty
);
634 All_Interp
.Append
(No_Interp
);
637 elsif Scope
(H
) /= Standard_Standard
then
643 -- On exit, we know that current homograph is not hidden
645 Add_One_Interp
(N
, H
, Etype
(H
));
648 Write_Str
("Add overloaded interpretation ");
658 -- Scan list of homographs for use-visible entities only
660 H
:= Current_Entity
(Ent
);
662 while Present
(H
) loop
663 if Is_Potentially_Use_Visible
(H
)
665 and then Is_Overloadable
(H
)
667 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
669 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
672 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
673 goto Next_Use_Homograph
;
677 Add_One_Interp
(N
, H
, Etype
(H
));
680 <<Next_Use_Homograph
>>
685 if All_Interp
.Last
= First_Interp
+ 1 then
687 -- The final interpretation is in fact not overloaded. Note that the
688 -- unique legal interpretation may or may not be the original one,
689 -- so we need to update N's entity and etype now, because once N
690 -- is marked as not overloaded it is also expected to carry the
691 -- proper interpretation.
693 Set_Is_Overloaded
(N
, False);
694 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
695 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
703 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
708 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
709 -- In an instance the proper view may not always be correct for
710 -- private types, but private and full view are compatible. This
711 -- removes spurious errors from nested instantiations that involve,
712 -- among other things, types derived from private types.
714 ----------------------
715 -- Full_View_Covers --
716 ----------------------
718 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
721 Is_Private_Type
(Typ1
)
723 ((Present
(Full_View
(Typ1
))
724 and then Covers
(Full_View
(Typ1
), Typ2
))
725 or else Base_Type
(Typ1
) = Typ2
726 or else Base_Type
(Typ2
) = Typ1
);
727 end Full_View_Covers
;
729 -- Start of processing for Covers
732 -- If either operand missing, then this is an error, but ignore it (and
733 -- pretend we have a cover) if errors already detected, since this may
734 -- simply mean we have malformed trees or a semantic error upstream.
736 if No
(T1
) or else No
(T2
) then
737 if Total_Errors_Detected
/= 0 then
744 BT1
:= Base_Type
(T1
);
745 BT2
:= Base_Type
(T2
);
747 -- Handle underlying view of records with unknown discriminants
748 -- using the original entity that motivated the construction of
749 -- this underlying record view (see Build_Derived_Private_Type).
751 if Is_Underlying_Record_View
(BT1
) then
752 BT1
:= Underlying_Record_View
(BT1
);
755 if Is_Underlying_Record_View
(BT2
) then
756 BT2
:= Underlying_Record_View
(BT2
);
760 -- Simplest case: same types are compatible, and types that have the
761 -- same base type and are not generic actuals are compatible. Generic
762 -- actuals belong to their class but are not compatible with other
763 -- types of their class, and in particular with other generic actuals.
764 -- They are however compatible with their own subtypes, and itypes
765 -- with the same base are compatible as well. Similarly, constrained
766 -- subtypes obtained from expressions of an unconstrained nominal type
767 -- are compatible with the base type (may lead to spurious ambiguities
768 -- in obscure cases ???)
770 -- Generic actuals require special treatment to avoid spurious ambi-
771 -- guities in an instance, when two formal types are instantiated with
772 -- the same actual, so that different subprograms end up with the same
773 -- signature in the instance.
782 if not Is_Generic_Actual_Type
(T1
) then
785 return (not Is_Generic_Actual_Type
(T2
)
786 or else Is_Itype
(T1
)
787 or else Is_Itype
(T2
)
788 or else Is_Constr_Subt_For_U_Nominal
(T1
)
789 or else Is_Constr_Subt_For_U_Nominal
(T2
)
790 or else Scope
(T1
) /= Scope
(T2
));
793 -- Literals are compatible with types in a given "class"
795 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
796 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
797 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
798 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
799 or else (T2
= Any_String
and then Is_String_Type
(T1
))
800 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
801 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
805 -- The context may be class wide, and a class-wide type is compatible
806 -- with any member of the class.
808 elsif Is_Class_Wide_Type
(T1
)
809 and then Is_Ancestor
(Root_Type
(T1
), T2
)
813 elsif Is_Class_Wide_Type
(T1
)
814 and then Is_Class_Wide_Type
(T2
)
815 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
819 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
820 -- task_type or protected_type that implements the interface.
822 elsif Ada_Version
>= Ada_05
823 and then Is_Class_Wide_Type
(T1
)
824 and then Is_Interface
(Etype
(T1
))
825 and then Is_Concurrent_Type
(T2
)
826 and then Interface_Present_In_Ancestor
827 (Typ
=> Base_Type
(T2
),
832 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
833 -- object T2 implementing T1
835 elsif Ada_Version
>= Ada_05
836 and then Is_Class_Wide_Type
(T1
)
837 and then Is_Interface
(Etype
(T1
))
838 and then Is_Tagged_Type
(T2
)
840 if Interface_Present_In_Ancestor
(Typ
=> T2
,
851 if Is_Concurrent_Type
(BT2
) then
852 E
:= Corresponding_Record_Type
(BT2
);
857 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
858 -- covers an object T2 that implements a direct derivation of T1.
859 -- Note: test for presence of E is defense against previous error.
862 and then Present
(Interfaces
(E
))
864 Elmt
:= First_Elmt
(Interfaces
(E
));
865 while Present
(Elmt
) loop
866 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
874 -- We should also check the case in which T1 is an ancestor of
875 -- some implemented interface???
880 -- In a dispatching call the actual may be class-wide
882 elsif Is_Class_Wide_Type
(T2
)
883 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
887 -- Some contexts require a class of types rather than a specific type.
888 -- For example, conditions require any boolean type, fixed point
889 -- attributes require some real type, etc. The built-in types Any_XXX
890 -- represent these classes.
892 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
893 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
894 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
895 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
896 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
900 -- An aggregate is compatible with an array or record type
902 elsif T2
= Any_Composite
903 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
907 -- If the expected type is an anonymous access, the designated type must
908 -- cover that of the expression. Use the base type for this check: even
909 -- though access subtypes are rare in sources, they are generated for
910 -- actuals in instantiations.
912 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
913 and then Is_Access_Type
(T2
)
914 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
918 -- An Access_To_Subprogram is compatible with itself, or with an
919 -- anonymous type created for an attribute reference Access.
921 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
923 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
924 and then Is_Access_Type
(T2
)
925 and then (not Comes_From_Source
(T1
)
926 or else not Comes_From_Source
(T2
))
927 and then (Is_Overloadable
(Designated_Type
(T2
))
929 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
931 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
933 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
937 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
938 -- with itself, or with an anonymous type created for an attribute
941 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
944 = E_Anonymous_Access_Protected_Subprogram_Type
)
945 and then Is_Access_Type
(T2
)
946 and then (not Comes_From_Source
(T1
)
947 or else not Comes_From_Source
(T2
))
948 and then (Is_Overloadable
(Designated_Type
(T2
))
950 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
952 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
954 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
958 -- The context can be a remote access type, and the expression the
959 -- corresponding source type declared in a categorized package, or
962 elsif Is_Record_Type
(T1
)
963 and then (Is_Remote_Call_Interface
(T1
)
964 or else Is_Remote_Types
(T1
))
965 and then Present
(Corresponding_Remote_Type
(T1
))
967 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
971 elsif Is_Record_Type
(T2
)
972 and then (Is_Remote_Call_Interface
(T2
)
973 or else Is_Remote_Types
(T2
))
974 and then Present
(Corresponding_Remote_Type
(T2
))
976 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
978 -- Synchronized types are represented at run time by their corresponding
979 -- record type. During expansion one is replaced with the other, but
980 -- they are compatible views of the same type.
982 elsif Is_Record_Type
(T1
)
983 and then Is_Concurrent_Type
(T2
)
984 and then Present
(Corresponding_Record_Type
(T2
))
986 return Covers
(T1
, Corresponding_Record_Type
(T2
));
988 elsif Is_Concurrent_Type
(T1
)
989 and then Present
(Corresponding_Record_Type
(T1
))
990 and then Is_Record_Type
(T2
)
992 return Covers
(Corresponding_Record_Type
(T1
), T2
);
994 -- During analysis, an attribute reference 'Access has a special type
995 -- kind: Access_Attribute_Type, to be replaced eventually with the type
996 -- imposed by context.
998 elsif Ekind
(T2
) = E_Access_Attribute_Type
999 and then Ekind_In
(BT1
, E_General_Access_Type
, E_Access_Type
)
1000 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1002 -- If the target type is a RACW type while the source is an access
1003 -- attribute type, we are building a RACW that may be exported.
1005 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1006 Set_Has_RACW
(Current_Sem_Unit
);
1011 -- Ditto for allocators, which eventually resolve to the context type
1013 elsif Ekind
(T2
) = E_Allocator_Type
1014 and then Is_Access_Type
(T1
)
1016 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1018 (From_With_Type
(Designated_Type
(T1
))
1019 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1021 -- A boolean operation on integer literals is compatible with modular
1024 elsif T2
= Any_Modular
1025 and then Is_Modular_Integer_Type
(T1
)
1029 -- The actual type may be the result of a previous error
1031 elsif Base_Type
(T2
) = Any_Type
then
1034 -- A packed array type covers its corresponding non-packed type. This is
1035 -- not legitimate Ada, but allows the omission of a number of otherwise
1036 -- useless unchecked conversions, and since this can only arise in
1037 -- (known correct) expanded code, no harm is done.
1039 elsif Is_Array_Type
(T2
)
1040 and then Is_Packed
(T2
)
1041 and then T1
= Packed_Array_Type
(T2
)
1045 -- Similarly an array type covers its corresponding packed array type
1047 elsif Is_Array_Type
(T1
)
1048 and then Is_Packed
(T1
)
1049 and then T2
= Packed_Array_Type
(T1
)
1053 -- In instances, or with types exported from instantiations, check
1054 -- whether a partial and a full view match. Verify that types are
1055 -- legal, to prevent cascaded errors.
1059 (Full_View_Covers
(T1
, T2
)
1060 or else Full_View_Covers
(T2
, T1
))
1065 and then Is_Generic_Actual_Type
(T2
)
1066 and then Full_View_Covers
(T1
, T2
)
1071 and then Is_Generic_Actual_Type
(T1
)
1072 and then Full_View_Covers
(T2
, T1
)
1076 -- In the expansion of inlined bodies, types are compatible if they
1077 -- are structurally equivalent.
1079 elsif In_Inlined_Body
1080 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1081 or else (Is_Access_Type
(T1
)
1082 and then Is_Access_Type
(T2
)
1084 Designated_Type
(T1
) = Designated_Type
(T2
))
1085 or else (T1
= Any_Access
1086 and then Is_Access_Type
(Underlying_Type
(T2
)))
1087 or else (T2
= Any_Composite
1089 Is_Composite_Type
(Underlying_Type
(T1
))))
1093 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1094 -- obtained through a limited_with compatible with its real entity.
1096 elsif From_With_Type
(T1
) then
1098 -- If the expected type is the non-limited view of a type, the
1099 -- expression may have the limited view. If that one in turn is
1100 -- incomplete, get full view if available.
1102 if Is_Incomplete_Type
(T1
) then
1103 return Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1105 elsif Ekind
(T1
) = E_Class_Wide_Type
then
1107 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1112 elsif From_With_Type
(T2
) then
1114 -- If units in the context have Limited_With clauses on each other,
1115 -- either type might have a limited view. Checks performed elsewhere
1116 -- verify that the context type is the nonlimited view.
1118 if Is_Incomplete_Type
(T2
) then
1119 return Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1121 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1123 Present
(Non_Limited_View
(Etype
(T2
)))
1125 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1130 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1132 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1133 return Covers
(Full_View
(Etype
(T1
)), T2
);
1135 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1136 return Covers
(T1
, Full_View
(Etype
(T2
)));
1138 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1139 -- and actual anonymous access types in the context of generic
1140 -- instantiations. We have the following situation:
1143 -- type Formal is private;
1144 -- Formal_Obj : access Formal; -- T1
1148 -- type Actual is ...
1149 -- Actual_Obj : access Actual; -- T2
1150 -- package Instance is new G (Formal => Actual,
1151 -- Formal_Obj => Actual_Obj);
1153 elsif Ada_Version
>= Ada_05
1154 and then Ekind
(T1
) = E_Anonymous_Access_Type
1155 and then Ekind
(T2
) = E_Anonymous_Access_Type
1156 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1157 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1158 Directly_Designated_Type
(T2
)
1162 -- Otherwise, types are not compatible!
1173 function Disambiguate
1175 I1
, I2
: Interp_Index
;
1176 Typ
: Entity_Id
) return Interp
1181 Nam1
, Nam2
: Entity_Id
;
1182 Predef_Subp
: Entity_Id
;
1183 User_Subp
: Entity_Id
;
1185 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1186 -- Determine whether one of the candidates is an operation inherited by
1187 -- a type that is derived from an actual in an instantiation.
1189 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1190 -- Determine whether a subprogram is an actual in an enclosing instance.
1191 -- An overloading between such a subprogram and one declared outside the
1192 -- instance is resolved in favor of the first, because it resolved in
1195 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1196 -- Look for exact type match in an instance, to remove spurious
1197 -- ambiguities when two formal types have the same actual.
1199 function Standard_Operator
return Boolean;
1200 -- Check whether subprogram is predefined operator declared in Standard.
1201 -- It may given by an operator name, or by an expanded name whose prefix
1204 function Remove_Conversions
return Interp
;
1205 -- Last chance for pathological cases involving comparisons on literals,
1206 -- and user overloadings of the same operator. Such pathologies have
1207 -- been removed from the ACVC, but still appear in two DEC tests, with
1208 -- the following notable quote from Ben Brosgol:
1210 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1211 -- this example; Robert Dewar brought it to our attention, since it is
1212 -- apparently found in the ACVC 1.5. I did not attempt to find the
1213 -- reason in the Reference Manual that makes the example legal, since I
1214 -- was too nauseated by it to want to pursue it further.]
1216 -- Accordingly, this is not a fully recursive solution, but it handles
1217 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1218 -- pathology in the other direction with calls whose multiple overloaded
1219 -- actuals make them truly unresolvable.
1221 -- The new rules concerning abstract operations create additional need
1222 -- for special handling of expressions with universal operands, see
1223 -- comments to Has_Abstract_Interpretation below.
1225 ---------------------------
1226 -- Inherited_From_Actual --
1227 ---------------------------
1229 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1230 Par
: constant Node_Id
:= Parent
(S
);
1232 if Nkind
(Par
) /= N_Full_Type_Declaration
1233 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1237 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1239 Is_Generic_Actual_Type
(
1240 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1242 end Inherited_From_Actual
;
1244 --------------------------
1245 -- Is_Actual_Subprogram --
1246 --------------------------
1248 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1250 return In_Open_Scopes
(Scope
(S
))
1252 (Is_Generic_Instance
(Scope
(S
))
1253 or else Is_Wrapper_Package
(Scope
(S
)));
1254 end Is_Actual_Subprogram
;
1260 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1261 T1
: constant Entity_Id
:= Etype
(Actual
);
1262 T2
: constant Entity_Id
:= Etype
(Formal
);
1266 (Is_Numeric_Type
(T2
)
1267 and then (T1
= Universal_Real
or else T1
= Universal_Integer
));
1270 ------------------------
1271 -- Remove_Conversions --
1272 ------------------------
1274 function Remove_Conversions
return Interp
is
1282 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1283 -- If an operation has universal operands the universal operation
1284 -- is present among its interpretations. If there is an abstract
1285 -- interpretation for the operator, with a numeric result, this
1286 -- interpretation was already removed in sem_ch4, but the universal
1287 -- one is still visible. We must rescan the list of operators and
1288 -- remove the universal interpretation to resolve the ambiguity.
1290 ---------------------------------
1291 -- Has_Abstract_Interpretation --
1292 ---------------------------------
1294 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1298 if Nkind
(N
) not in N_Op
1299 or else Ada_Version
< Ada_05
1300 or else not Is_Overloaded
(N
)
1301 or else No
(Universal_Interpretation
(N
))
1306 E
:= Get_Name_Entity_Id
(Chars
(N
));
1307 while Present
(E
) loop
1308 if Is_Overloadable
(E
)
1309 and then Is_Abstract_Subprogram
(E
)
1310 and then Is_Numeric_Type
(Etype
(E
))
1318 -- Finally, if an operand of the binary operator is itself
1319 -- an operator, recurse to see whether its own abstract
1320 -- interpretation is responsible for the spurious ambiguity.
1322 if Nkind
(N
) in N_Binary_Op
then
1323 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1324 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1326 elsif Nkind
(N
) in N_Unary_Op
then
1327 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1333 end Has_Abstract_Interpretation
;
1335 -- Start of processing for Remove_Conversions
1340 Get_First_Interp
(N
, I
, It
);
1341 while Present
(It
.Typ
) loop
1342 if not Is_Overloadable
(It
.Nam
) then
1346 F1
:= First_Formal
(It
.Nam
);
1352 if Nkind
(N
) = N_Function_Call
1353 or else Nkind
(N
) = N_Procedure_Call_Statement
1355 Act1
:= First_Actual
(N
);
1357 if Present
(Act1
) then
1358 Act2
:= Next_Actual
(Act1
);
1363 elsif Nkind
(N
) in N_Unary_Op
then
1364 Act1
:= Right_Opnd
(N
);
1367 elsif Nkind
(N
) in N_Binary_Op
then
1368 Act1
:= Left_Opnd
(N
);
1369 Act2
:= Right_Opnd
(N
);
1371 -- Use type of second formal, so as to include
1372 -- exponentiation, where the exponent may be
1373 -- ambiguous and the result non-universal.
1381 if Nkind
(Act1
) in N_Op
1382 and then Is_Overloaded
(Act1
)
1383 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1384 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1385 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1386 and then Etype
(F1
) = Standard_Boolean
1388 -- If the two candidates are the original ones, the
1389 -- ambiguity is real. Otherwise keep the original, further
1390 -- calls to Disambiguate will take care of others in the
1391 -- list of candidates.
1393 if It1
/= No_Interp
then
1394 if It
= Disambiguate
.It1
1395 or else It
= Disambiguate
.It2
1397 if It1
= Disambiguate
.It1
1398 or else It1
= Disambiguate
.It2
1406 elsif Present
(Act2
)
1407 and then Nkind
(Act2
) in N_Op
1408 and then Is_Overloaded
(Act2
)
1409 and then Nkind_In
(Right_Opnd
(Act2
), N_Integer_Literal
,
1411 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1413 -- The preference rule on the first actual is not
1414 -- sufficient to disambiguate.
1422 elsif Is_Numeric_Type
(Etype
(F1
))
1423 and then Has_Abstract_Interpretation
(Act1
)
1425 -- Current interpretation is not the right one because it
1426 -- expects a numeric operand. Examine all the other ones.
1433 Get_First_Interp
(N
, I
, It
);
1434 while Present
(It
.Typ
) loop
1436 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1439 or else not Has_Abstract_Interpretation
(Act2
)
1442 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1448 Get_Next_Interp
(I
, It
);
1457 Get_Next_Interp
(I
, It
);
1460 -- After some error, a formal may have Any_Type and yield a spurious
1461 -- match. To avoid cascaded errors if possible, check for such a
1462 -- formal in either candidate.
1464 if Serious_Errors_Detected
> 0 then
1469 Formal
:= First_Formal
(Nam1
);
1470 while Present
(Formal
) loop
1471 if Etype
(Formal
) = Any_Type
then
1472 return Disambiguate
.It2
;
1475 Next_Formal
(Formal
);
1478 Formal
:= First_Formal
(Nam2
);
1479 while Present
(Formal
) loop
1480 if Etype
(Formal
) = Any_Type
then
1481 return Disambiguate
.It1
;
1484 Next_Formal
(Formal
);
1490 end Remove_Conversions
;
1492 -----------------------
1493 -- Standard_Operator --
1494 -----------------------
1496 function Standard_Operator
return Boolean is
1500 if Nkind
(N
) in N_Op
then
1503 elsif Nkind
(N
) = N_Function_Call
then
1506 if Nkind
(Nam
) /= N_Expanded_Name
then
1509 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1514 end Standard_Operator
;
1516 -- Start of processing for Disambiguate
1519 -- Recover the two legal interpretations
1521 Get_First_Interp
(N
, I
, It
);
1523 Get_Next_Interp
(I
, It
);
1529 Get_Next_Interp
(I
, It
);
1535 if Ada_Version
< Ada_05
then
1537 -- Check whether one of the entities is an Ada 2005 entity and we are
1538 -- operating in an earlier mode, in which case we discard the Ada
1539 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1541 if Is_Ada_2005_Only
(Nam1
) then
1543 elsif Is_Ada_2005_Only
(Nam2
) then
1548 -- Check for overloaded CIL convention stuff because the CIL libraries
1549 -- do sick things like Console.Write_Line where it matches two different
1550 -- overloads, so just pick the first ???
1552 if Convention
(Nam1
) = Convention_CIL
1553 and then Convention
(Nam2
) = Convention_CIL
1554 and then Ekind
(Nam1
) = Ekind
(Nam2
)
1555 and then (Ekind
(Nam1
) = E_Procedure
1556 or else Ekind
(Nam1
) = E_Function
)
1561 -- If the context is universal, the predefined operator is preferred.
1562 -- This includes bounds in numeric type declarations, and expressions
1563 -- in type conversions. If no interpretation yields a universal type,
1564 -- then we must check whether the user-defined entity hides the prede-
1567 if Chars
(Nam1
) in Any_Operator_Name
1568 and then Standard_Operator
1570 if Typ
= Universal_Integer
1571 or else Typ
= Universal_Real
1572 or else Typ
= Any_Integer
1573 or else Typ
= Any_Discrete
1574 or else Typ
= Any_Real
1575 or else Typ
= Any_Type
1577 -- Find an interpretation that yields the universal type, or else
1578 -- a predefined operator that yields a predefined numeric type.
1581 Candidate
: Interp
:= No_Interp
;
1584 Get_First_Interp
(N
, I
, It
);
1585 while Present
(It
.Typ
) loop
1586 if (Covers
(Typ
, It
.Typ
)
1587 or else Typ
= Any_Type
)
1589 (It
.Typ
= Universal_Integer
1590 or else It
.Typ
= Universal_Real
)
1594 elsif Covers
(Typ
, It
.Typ
)
1595 and then Scope
(It
.Typ
) = Standard_Standard
1596 and then Scope
(It
.Nam
) = Standard_Standard
1597 and then Is_Numeric_Type
(It
.Typ
)
1602 Get_Next_Interp
(I
, It
);
1605 if Candidate
/= No_Interp
then
1610 elsif Chars
(Nam1
) /= Name_Op_Not
1611 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1613 -- Equality or comparison operation. Choose predefined operator if
1614 -- arguments are universal. The node may be an operator, name, or
1615 -- a function call, so unpack arguments accordingly.
1618 Arg1
, Arg2
: Node_Id
;
1621 if Nkind
(N
) in N_Op
then
1622 Arg1
:= Left_Opnd
(N
);
1623 Arg2
:= Right_Opnd
(N
);
1625 elsif Is_Entity_Name
(N
)
1626 or else Nkind
(N
) = N_Operator_Symbol
1628 Arg1
:= First_Entity
(Entity
(N
));
1629 Arg2
:= Next_Entity
(Arg1
);
1632 Arg1
:= First_Actual
(N
);
1633 Arg2
:= Next_Actual
(Arg1
);
1637 and then Present
(Universal_Interpretation
(Arg1
))
1638 and then Universal_Interpretation
(Arg2
) =
1639 Universal_Interpretation
(Arg1
)
1641 Get_First_Interp
(N
, I
, It
);
1642 while Scope
(It
.Nam
) /= Standard_Standard
loop
1643 Get_Next_Interp
(I
, It
);
1652 -- If no universal interpretation, check whether user-defined operator
1653 -- hides predefined one, as well as other special cases. If the node
1654 -- is a range, then one or both bounds are ambiguous. Each will have
1655 -- to be disambiguated w.r.t. the context type. The type of the range
1656 -- itself is imposed by the context, so we can return either legal
1659 if Ekind
(Nam1
) = E_Operator
then
1660 Predef_Subp
:= Nam1
;
1663 elsif Ekind
(Nam2
) = E_Operator
then
1664 Predef_Subp
:= Nam2
;
1667 elsif Nkind
(N
) = N_Range
then
1670 -- Implement AI05-105: A renaming declaration with an access
1671 -- definition must resolve to an anonymous access type. This
1672 -- is a resolution rule and can be used to disambiguate.
1674 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1675 and then Present
(Access_Definition
(Parent
(N
)))
1677 if Ekind_In
(It1
.Typ
, E_Anonymous_Access_Type
,
1678 E_Anonymous_Access_Subprogram_Type
)
1680 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1690 elsif Ekind_In
(It2
.Typ
, E_Anonymous_Access_Type
,
1691 E_Anonymous_Access_Subprogram_Type
)
1695 -- No legal interpretation
1701 -- If two user defined-subprograms are visible, it is a true ambiguity,
1702 -- unless one of them is an entry and the context is a conditional or
1703 -- timed entry call, or unless we are within an instance and this is
1704 -- results from two formals types with the same actual.
1707 if Nkind
(N
) = N_Procedure_Call_Statement
1708 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1709 and then N
= Entry_Call_Statement
(Parent
(N
))
1711 if Ekind
(Nam2
) = E_Entry
then
1713 elsif Ekind
(Nam1
) = E_Entry
then
1719 -- If the ambiguity occurs within an instance, it is due to several
1720 -- formal types with the same actual. Look for an exact match between
1721 -- the types of the formals of the overloadable entities, and the
1722 -- actuals in the call, to recover the unambiguous match in the
1723 -- original generic.
1725 -- The ambiguity can also be due to an overloading between a formal
1726 -- subprogram and a subprogram declared outside the generic. If the
1727 -- node is overloaded, it did not resolve to the global entity in
1728 -- the generic, and we choose the formal subprogram.
1730 -- Finally, the ambiguity can be between an explicit subprogram and
1731 -- one inherited (with different defaults) from an actual. In this
1732 -- case the resolution was to the explicit declaration in the
1733 -- generic, and remains so in the instance.
1736 and then not In_Generic_Actual
(N
)
1738 if Nkind
(N
) = N_Function_Call
1739 or else Nkind
(N
) = N_Procedure_Call_Statement
1744 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1745 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1748 if Is_Act1
and then not Is_Act2
then
1751 elsif Is_Act2
and then not Is_Act1
then
1754 elsif Inherited_From_Actual
(Nam1
)
1755 and then Comes_From_Source
(Nam2
)
1759 elsif Inherited_From_Actual
(Nam2
)
1760 and then Comes_From_Source
(Nam1
)
1765 Actual
:= First_Actual
(N
);
1766 Formal
:= First_Formal
(Nam1
);
1767 while Present
(Actual
) loop
1768 if Etype
(Actual
) /= Etype
(Formal
) then
1772 Next_Actual
(Actual
);
1773 Next_Formal
(Formal
);
1779 elsif Nkind
(N
) in N_Binary_Op
then
1780 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1782 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1789 elsif Nkind
(N
) in N_Unary_Op
then
1790 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1797 return Remove_Conversions
;
1800 return Remove_Conversions
;
1804 -- An implicit concatenation operator on a string type cannot be
1805 -- disambiguated from the predefined concatenation. This can only
1806 -- happen with concatenation of string literals.
1808 if Chars
(User_Subp
) = Name_Op_Concat
1809 and then Ekind
(User_Subp
) = E_Operator
1810 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1814 -- If the user-defined operator is in an open scope, or in the scope
1815 -- of the resulting type, or given by an expanded name that names its
1816 -- scope, it hides the predefined operator for the type. Exponentiation
1817 -- has to be special-cased because the implicit operator does not have
1818 -- a symmetric signature, and may not be hidden by the explicit one.
1820 elsif (Nkind
(N
) = N_Function_Call
1821 and then Nkind
(Name
(N
)) = N_Expanded_Name
1822 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1823 or else Hides_Op
(User_Subp
, Predef_Subp
))
1824 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1825 or else Hides_Op
(User_Subp
, Predef_Subp
)
1827 if It1
.Nam
= User_Subp
then
1833 -- Otherwise, the predefined operator has precedence, or if the user-
1834 -- defined operation is directly visible we have a true ambiguity. If
1835 -- this is a fixed-point multiplication and division in Ada83 mode,
1836 -- exclude the universal_fixed operator, which often causes ambiguities
1840 if (In_Open_Scopes
(Scope
(User_Subp
))
1841 or else Is_Potentially_Use_Visible
(User_Subp
))
1842 and then not In_Instance
1844 if Is_Fixed_Point_Type
(Typ
)
1845 and then (Chars
(Nam1
) = Name_Op_Multiply
1846 or else Chars
(Nam1
) = Name_Op_Divide
)
1847 and then Ada_Version
= Ada_83
1849 if It2
.Nam
= Predef_Subp
then
1855 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1856 -- states that the operator defined in Standard is not available
1857 -- if there is a user-defined equality with the proper signature,
1858 -- declared in the same declarative list as the type. The node
1859 -- may be an operator or a function call.
1861 elsif (Chars
(Nam1
) = Name_Op_Eq
1863 Chars
(Nam1
) = Name_Op_Ne
)
1864 and then Ada_Version
>= Ada_05
1865 and then Etype
(User_Subp
) = Standard_Boolean
1870 if Nkind
(N
) = N_Function_Call
then
1871 Opnd
:= First_Actual
(N
);
1873 Opnd
:= Left_Opnd
(N
);
1876 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1878 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1879 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1881 if It2
.Nam
= Predef_Subp
then
1887 return Remove_Conversions
;
1895 elsif It1
.Nam
= Predef_Subp
then
1904 ---------------------
1905 -- End_Interp_List --
1906 ---------------------
1908 procedure End_Interp_List
is
1910 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1911 All_Interp
.Increment_Last
;
1912 end End_Interp_List
;
1914 -------------------------
1915 -- Entity_Matches_Spec --
1916 -------------------------
1918 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1920 -- Simple case: same entity kinds, type conformance is required. A
1921 -- parameterless function can also rename a literal.
1923 if Ekind
(Old_S
) = Ekind
(New_S
)
1924 or else (Ekind
(New_S
) = E_Function
1925 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1927 return Type_Conformant
(New_S
, Old_S
);
1929 elsif Ekind
(New_S
) = E_Function
1930 and then Ekind
(Old_S
) = E_Operator
1932 return Operator_Matches_Spec
(Old_S
, New_S
);
1934 elsif Ekind
(New_S
) = E_Procedure
1935 and then Is_Entry
(Old_S
)
1937 return Type_Conformant
(New_S
, Old_S
);
1942 end Entity_Matches_Spec
;
1944 ----------------------
1945 -- Find_Unique_Type --
1946 ----------------------
1948 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1949 T
: constant Entity_Id
:= Etype
(L
);
1952 TR
: Entity_Id
:= Any_Type
;
1955 if Is_Overloaded
(R
) then
1956 Get_First_Interp
(R
, I
, It
);
1957 while Present
(It
.Typ
) loop
1958 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1960 -- If several interpretations are possible and L is universal,
1961 -- apply preference rule.
1963 if TR
/= Any_Type
then
1965 if (T
= Universal_Integer
or else T
= Universal_Real
)
1976 Get_Next_Interp
(I
, It
);
1981 -- In the non-overloaded case, the Etype of R is already set correctly
1987 -- If one of the operands is Universal_Fixed, the type of the other
1988 -- operand provides the context.
1990 if Etype
(R
) = Universal_Fixed
then
1993 elsif T
= Universal_Fixed
then
1996 -- Ada 2005 (AI-230): Support the following operators:
1998 -- function "=" (L, R : universal_access) return Boolean;
1999 -- function "/=" (L, R : universal_access) return Boolean;
2001 -- Pool specific access types (E_Access_Type) are not covered by these
2002 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2003 -- of the equality operators for universal_access shall be convertible
2004 -- to one another (see 4.6)". For example, considering the type decla-
2005 -- ration "type P is access Integer" and an anonymous access to Integer,
2006 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2007 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2009 elsif Ada_Version
>= Ada_05
2011 (Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
2013 Ekind
(Etype
(L
)) = E_Anonymous_Access_Subprogram_Type
)
2014 and then Is_Access_Type
(Etype
(R
))
2015 and then Ekind
(Etype
(R
)) /= E_Access_Type
2019 elsif Ada_Version
>= Ada_05
2021 (Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
2022 or else Ekind
(Etype
(R
)) = E_Anonymous_Access_Subprogram_Type
)
2023 and then Is_Access_Type
(Etype
(L
))
2024 and then Ekind
(Etype
(L
)) /= E_Access_Type
2029 return Specific_Type
(T
, Etype
(R
));
2031 end Find_Unique_Type
;
2033 -------------------------------------
2034 -- Function_Interp_Has_Abstract_Op --
2035 -------------------------------------
2037 function Function_Interp_Has_Abstract_Op
2039 E
: Entity_Id
) return Entity_Id
2041 Abstr_Op
: Entity_Id
;
2044 Form_Parm
: Node_Id
;
2047 -- Why is check on E needed below ???
2048 -- In any case this para needs comments ???
2050 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2051 Act_Parm
:= First_Actual
(N
);
2052 Form_Parm
:= First_Formal
(E
);
2053 while Present
(Act_Parm
)
2054 and then Present
(Form_Parm
)
2058 if Nkind
(Act
) = N_Parameter_Association
then
2059 Act
:= Explicit_Actual_Parameter
(Act
);
2062 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2064 if Present
(Abstr_Op
) then
2068 Next_Actual
(Act_Parm
);
2069 Next_Formal
(Form_Parm
);
2074 end Function_Interp_Has_Abstract_Op
;
2076 ----------------------
2077 -- Get_First_Interp --
2078 ----------------------
2080 procedure Get_First_Interp
2082 I
: out Interp_Index
;
2085 Int_Ind
: Interp_Index
;
2090 -- If a selected component is overloaded because the selector has
2091 -- multiple interpretations, the node is a call to a protected
2092 -- operation or an indirect call. Retrieve the interpretation from
2093 -- the selector name. The selected component may be overloaded as well
2094 -- if the prefix is overloaded. That case is unchanged.
2096 if Nkind
(N
) = N_Selected_Component
2097 and then Is_Overloaded
(Selector_Name
(N
))
2099 O_N
:= Selector_Name
(N
);
2104 Map_Ptr
:= Headers
(Hash
(O_N
));
2105 while Map_Ptr
/= No_Entry
loop
2106 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2107 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2108 It
:= All_Interp
.Table
(Int_Ind
);
2112 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2116 -- Procedure should never be called if the node has no interpretations
2118 raise Program_Error
;
2119 end Get_First_Interp
;
2121 ---------------------
2122 -- Get_Next_Interp --
2123 ---------------------
2125 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2128 It
:= All_Interp
.Table
(I
);
2129 end Get_Next_Interp
;
2131 -------------------------
2132 -- Has_Compatible_Type --
2133 -------------------------
2135 function Has_Compatible_Type
2137 Typ
: Entity_Id
) return Boolean
2147 if Nkind
(N
) = N_Subtype_Indication
2148 or else not Is_Overloaded
(N
)
2151 Covers
(Typ
, Etype
(N
))
2153 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2154 -- If the type is already frozen use the corresponding_record
2155 -- to check whether it is a proper descendant.
2158 (Is_Record_Type
(Typ
)
2159 and then Is_Concurrent_Type
(Etype
(N
))
2160 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2161 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2164 (Is_Concurrent_Type
(Typ
)
2165 and then Is_Record_Type
(Etype
(N
))
2166 and then Present
(Corresponding_Record_Type
(Typ
))
2167 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2170 (not Is_Tagged_Type
(Typ
)
2171 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2172 and then Covers
(Etype
(N
), Typ
));
2175 Get_First_Interp
(N
, I
, It
);
2176 while Present
(It
.Typ
) loop
2177 if (Covers
(Typ
, It
.Typ
)
2179 (Scope
(It
.Nam
) /= Standard_Standard
2180 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2182 -- Ada 2005 (AI-345)
2185 (Is_Concurrent_Type
(It
.Typ
)
2186 and then Present
(Corresponding_Record_Type
2188 and then Covers
(Typ
, Corresponding_Record_Type
2191 or else (not Is_Tagged_Type
(Typ
)
2192 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2193 and then Covers
(It
.Typ
, Typ
))
2198 Get_Next_Interp
(I
, It
);
2203 end Has_Compatible_Type
;
2205 ---------------------
2206 -- Has_Abstract_Op --
2207 ---------------------
2209 function Has_Abstract_Op
2211 Typ
: Entity_Id
) return Entity_Id
2217 if Is_Overloaded
(N
) then
2218 Get_First_Interp
(N
, I
, It
);
2219 while Present
(It
.Nam
) loop
2220 if Present
(It
.Abstract_Op
)
2221 and then Etype
(It
.Abstract_Op
) = Typ
2223 return It
.Abstract_Op
;
2226 Get_Next_Interp
(I
, It
);
2231 end Has_Abstract_Op
;
2237 function Hash
(N
: Node_Id
) return Int
is
2239 -- Nodes have a size that is power of two, so to select significant
2240 -- bits only we remove the low-order bits.
2242 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2249 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2250 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2252 return Operator_Matches_Spec
(Op
, F
)
2253 and then (In_Open_Scopes
(Scope
(F
))
2254 or else Scope
(F
) = Scope
(Btyp
)
2255 or else (not In_Open_Scopes
(Scope
(Btyp
))
2256 and then not In_Use
(Btyp
)
2257 and then not In_Use
(Scope
(Btyp
))));
2260 ------------------------
2261 -- Init_Interp_Tables --
2262 ------------------------
2264 procedure Init_Interp_Tables
is
2268 Headers
:= (others => No_Entry
);
2269 end Init_Interp_Tables
;
2271 -----------------------------------
2272 -- Interface_Present_In_Ancestor --
2273 -----------------------------------
2275 function Interface_Present_In_Ancestor
2277 Iface
: Entity_Id
) return Boolean
2279 Target_Typ
: Entity_Id
;
2280 Iface_Typ
: Entity_Id
;
2282 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2283 -- Returns True if Typ or some ancestor of Typ implements Iface
2285 -------------------------------
2286 -- Iface_Present_In_Ancestor --
2287 -------------------------------
2289 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2295 if Typ
= Iface_Typ
then
2299 -- Handle private types
2301 if Present
(Full_View
(Typ
))
2302 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2304 E
:= Full_View
(Typ
);
2310 if Present
(Interfaces
(E
))
2311 and then Present
(Interfaces
(E
))
2312 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2314 Elmt
:= First_Elmt
(Interfaces
(E
));
2315 while Present
(Elmt
) loop
2318 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2326 exit when Etype
(E
) = E
2328 -- Handle private types
2330 or else (Present
(Full_View
(Etype
(E
)))
2331 and then Full_View
(Etype
(E
)) = E
);
2333 -- Check if the current type is a direct derivation of the
2336 if Etype
(E
) = Iface_Typ
then
2340 -- Climb to the immediate ancestor handling private types
2342 if Present
(Full_View
(Etype
(E
))) then
2343 E
:= Full_View
(Etype
(E
));
2350 end Iface_Present_In_Ancestor
;
2352 -- Start of processing for Interface_Present_In_Ancestor
2355 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2357 if Is_Class_Wide_Type
(Iface
) then
2358 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2365 Iface_Typ
:= Base_Type
(Iface_Typ
);
2367 if Is_Access_Type
(Typ
) then
2368 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2373 if Is_Concurrent_Record_Type
(Target_Typ
) then
2374 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2377 Target_Typ
:= Base_Type
(Target_Typ
);
2379 -- In case of concurrent types we can't use the Corresponding Record_Typ
2380 -- to look for the interface because it is built by the expander (and
2381 -- hence it is not always available). For this reason we traverse the
2382 -- list of interfaces (available in the parent of the concurrent type)
2384 if Is_Concurrent_Type
(Target_Typ
) then
2385 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2390 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2391 while Present
(AI
) loop
2392 if Etype
(AI
) = Iface_Typ
then
2395 elsif Present
(Interfaces
(Etype
(AI
)))
2396 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2409 if Is_Class_Wide_Type
(Target_Typ
) then
2410 Target_Typ
:= Etype
(Target_Typ
);
2413 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2414 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2415 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2417 -- Protect the frontend against previously detected errors
2419 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2424 return Iface_Present_In_Ancestor
(Target_Typ
);
2425 end Interface_Present_In_Ancestor
;
2427 ---------------------
2428 -- Intersect_Types --
2429 ---------------------
2431 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2432 Index
: Interp_Index
;
2436 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2437 -- Find interpretation of right arg that has type compatible with T
2439 --------------------------
2440 -- Check_Right_Argument --
2441 --------------------------
2443 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2444 Index
: Interp_Index
;
2449 if not Is_Overloaded
(R
) then
2450 return Specific_Type
(T
, Etype
(R
));
2453 Get_First_Interp
(R
, Index
, It
);
2455 T2
:= Specific_Type
(T
, It
.Typ
);
2457 if T2
/= Any_Type
then
2461 Get_Next_Interp
(Index
, It
);
2462 exit when No
(It
.Typ
);
2467 end Check_Right_Argument
;
2469 -- Start of processing for Intersect_Types
2472 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2476 if not Is_Overloaded
(L
) then
2477 Typ
:= Check_Right_Argument
(Etype
(L
));
2481 Get_First_Interp
(L
, Index
, It
);
2482 while Present
(It
.Typ
) loop
2483 Typ
:= Check_Right_Argument
(It
.Typ
);
2484 exit when Typ
/= Any_Type
;
2485 Get_Next_Interp
(Index
, It
);
2490 -- If Typ is Any_Type, it means no compatible pair of types was found
2492 if Typ
= Any_Type
then
2493 if Nkind
(Parent
(L
)) in N_Op
then
2494 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2496 elsif Nkind
(Parent
(L
)) = N_Range
then
2497 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2499 -- Ada 2005 (AI-251): Complete the error notification
2501 elsif Is_Class_Wide_Type
(Etype
(R
))
2502 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2504 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2505 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2508 Error_Msg_N
("incompatible types", Parent
(L
));
2513 end Intersect_Types
;
2515 -----------------------
2516 -- In_Generic_Actual --
2517 -----------------------
2519 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2520 Par
: constant Node_Id
:= Parent
(Exp
);
2526 elsif Nkind
(Par
) in N_Declaration
then
2527 if Nkind
(Par
) = N_Object_Declaration
then
2528 return Present
(Corresponding_Generic_Association
(Par
));
2533 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2534 return Present
(Corresponding_Generic_Association
(Par
));
2536 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2540 return In_Generic_Actual
(Parent
(Par
));
2542 end In_Generic_Actual
;
2548 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2554 BT1
:= Base_Type
(T1
);
2555 BT2
:= Base_Type
(T2
);
2557 -- Handle underlying view of records with unknown discriminants using
2558 -- the original entity that motivated the construction of this
2559 -- underlying record view (see Build_Derived_Private_Type).
2561 if Is_Underlying_Record_View
(BT1
) then
2562 BT1
:= Underlying_Record_View
(BT1
);
2565 if Is_Underlying_Record_View
(BT2
) then
2566 BT2
:= Underlying_Record_View
(BT2
);
2572 -- The predicate must look past privacy
2574 elsif Is_Private_Type
(T1
)
2575 and then Present
(Full_View
(T1
))
2576 and then BT2
= Base_Type
(Full_View
(T1
))
2580 elsif Is_Private_Type
(T2
)
2581 and then Present
(Full_View
(T2
))
2582 and then BT1
= Base_Type
(Full_View
(T2
))
2590 -- If there was a error on the type declaration, do not recurse
2592 if Error_Posted
(Par
) then
2595 elsif BT1
= Base_Type
(Par
)
2596 or else (Is_Private_Type
(T1
)
2597 and then Present
(Full_View
(T1
))
2598 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2602 elsif Is_Private_Type
(Par
)
2603 and then Present
(Full_View
(Par
))
2604 and then Full_View
(Par
) = BT1
2608 elsif Etype
(Par
) /= Par
then
2617 ---------------------------
2618 -- Is_Invisible_Operator --
2619 ---------------------------
2621 function Is_Invisible_Operator
2623 T
: Entity_Id
) return Boolean
2625 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2628 if Nkind
(N
) not in N_Op
then
2631 elsif not Comes_From_Source
(N
) then
2634 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2637 elsif Nkind
(N
) in N_Binary_Op
2638 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2643 return Is_Numeric_Type
(T
)
2644 and then not In_Open_Scopes
(Scope
(T
))
2645 and then not Is_Potentially_Use_Visible
(T
)
2646 and then not In_Use
(T
)
2647 and then not In_Use
(Scope
(T
))
2649 (Nkind
(Orig_Node
) /= N_Function_Call
2650 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2651 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2652 and then not In_Instance
;
2654 end Is_Invisible_Operator
;
2660 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2664 S
:= Ancestor_Subtype
(T1
);
2665 while Present
(S
) loop
2669 S
:= Ancestor_Subtype
(S
);
2680 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2681 Index
: Interp_Index
;
2685 Get_First_Interp
(Nam
, Index
, It
);
2686 while Present
(It
.Nam
) loop
2687 if Scope
(It
.Nam
) = Standard_Standard
2688 and then Scope
(It
.Typ
) /= Standard_Standard
2690 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2691 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2694 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2695 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2698 Get_Next_Interp
(Index
, It
);
2706 procedure New_Interps
(N
: Node_Id
) is
2710 All_Interp
.Append
(No_Interp
);
2712 Map_Ptr
:= Headers
(Hash
(N
));
2714 if Map_Ptr
= No_Entry
then
2716 -- Place new node at end of table
2718 Interp_Map
.Increment_Last
;
2719 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2722 -- Place node at end of chain, or locate its previous entry
2725 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2727 -- Node is already in the table, and is being rewritten.
2728 -- Start a new interp section, retain hash link.
2730 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2731 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2732 Set_Is_Overloaded
(N
, True);
2736 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2737 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2741 -- Chain the new node
2743 Interp_Map
.Increment_Last
;
2744 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2747 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2748 Set_Is_Overloaded
(N
, True);
2751 ---------------------------
2752 -- Operator_Matches_Spec --
2753 ---------------------------
2755 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2756 Op_Name
: constant Name_Id
:= Chars
(Op
);
2757 T
: constant Entity_Id
:= Etype
(New_S
);
2765 -- To verify that a predefined operator matches a given signature,
2766 -- do a case analysis of the operator classes. Function can have one
2767 -- or two formals and must have the proper result type.
2769 New_F
:= First_Formal
(New_S
);
2770 Old_F
:= First_Formal
(Op
);
2772 while Present
(New_F
) and then Present
(Old_F
) loop
2774 Next_Formal
(New_F
);
2775 Next_Formal
(Old_F
);
2778 -- Definite mismatch if different number of parameters
2780 if Present
(Old_F
) or else Present
(New_F
) then
2786 T1
:= Etype
(First_Formal
(New_S
));
2788 if Op_Name
= Name_Op_Subtract
2789 or else Op_Name
= Name_Op_Add
2790 or else Op_Name
= Name_Op_Abs
2792 return Base_Type
(T1
) = Base_Type
(T
)
2793 and then Is_Numeric_Type
(T
);
2795 elsif Op_Name
= Name_Op_Not
then
2796 return Base_Type
(T1
) = Base_Type
(T
)
2797 and then Valid_Boolean_Arg
(Base_Type
(T
));
2806 T1
:= Etype
(First_Formal
(New_S
));
2807 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2809 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2810 or else Op_Name
= Name_Op_Xor
2812 return Base_Type
(T1
) = Base_Type
(T2
)
2813 and then Base_Type
(T1
) = Base_Type
(T
)
2814 and then Valid_Boolean_Arg
(Base_Type
(T
));
2816 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2817 return Base_Type
(T1
) = Base_Type
(T2
)
2818 and then not Is_Limited_Type
(T1
)
2819 and then Is_Boolean_Type
(T
);
2821 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2822 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2824 return Base_Type
(T1
) = Base_Type
(T2
)
2825 and then Valid_Comparison_Arg
(T1
)
2826 and then Is_Boolean_Type
(T
);
2828 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2829 return Base_Type
(T1
) = Base_Type
(T2
)
2830 and then Base_Type
(T1
) = Base_Type
(T
)
2831 and then Is_Numeric_Type
(T
);
2833 -- For division and multiplication, a user-defined function does not
2834 -- match the predefined universal_fixed operation, except in Ada 83.
2836 elsif Op_Name
= Name_Op_Divide
then
2837 return (Base_Type
(T1
) = Base_Type
(T2
)
2838 and then Base_Type
(T1
) = Base_Type
(T
)
2839 and then Is_Numeric_Type
(T
)
2840 and then (not Is_Fixed_Point_Type
(T
)
2841 or else Ada_Version
= Ada_83
))
2843 -- Mixed_Mode operations on fixed-point types
2845 or else (Base_Type
(T1
) = Base_Type
(T
)
2846 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2847 and then Is_Fixed_Point_Type
(T
))
2849 -- A user defined operator can also match (and hide) a mixed
2850 -- operation on universal literals.
2852 or else (Is_Integer_Type
(T2
)
2853 and then Is_Floating_Point_Type
(T1
)
2854 and then Base_Type
(T1
) = Base_Type
(T
));
2856 elsif Op_Name
= Name_Op_Multiply
then
2857 return (Base_Type
(T1
) = Base_Type
(T2
)
2858 and then Base_Type
(T1
) = Base_Type
(T
)
2859 and then Is_Numeric_Type
(T
)
2860 and then (not Is_Fixed_Point_Type
(T
)
2861 or else Ada_Version
= Ada_83
))
2863 -- Mixed_Mode operations on fixed-point types
2865 or else (Base_Type
(T1
) = Base_Type
(T
)
2866 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2867 and then Is_Fixed_Point_Type
(T
))
2869 or else (Base_Type
(T2
) = Base_Type
(T
)
2870 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2871 and then Is_Fixed_Point_Type
(T
))
2873 or else (Is_Integer_Type
(T2
)
2874 and then Is_Floating_Point_Type
(T1
)
2875 and then Base_Type
(T1
) = Base_Type
(T
))
2877 or else (Is_Integer_Type
(T1
)
2878 and then Is_Floating_Point_Type
(T2
)
2879 and then Base_Type
(T2
) = Base_Type
(T
));
2881 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2882 return Base_Type
(T1
) = Base_Type
(T2
)
2883 and then Base_Type
(T1
) = Base_Type
(T
)
2884 and then Is_Integer_Type
(T
);
2886 elsif Op_Name
= Name_Op_Expon
then
2887 return Base_Type
(T1
) = Base_Type
(T
)
2888 and then Is_Numeric_Type
(T
)
2889 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2891 elsif Op_Name
= Name_Op_Concat
then
2892 return Is_Array_Type
(T
)
2893 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2894 and then (Base_Type
(T1
) = Base_Type
(T
)
2896 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2897 and then (Base_Type
(T2
) = Base_Type
(T
)
2899 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2905 end Operator_Matches_Spec
;
2911 procedure Remove_Interp
(I
: in out Interp_Index
) is
2915 -- Find end of interp list and copy downward to erase the discarded one
2918 while Present
(All_Interp
.Table
(II
).Typ
) loop
2922 for J
in I
+ 1 .. II
loop
2923 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2926 -- Back up interp index to insure that iterator will pick up next
2927 -- available interpretation.
2936 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2938 O_N
: Node_Id
:= Old_N
;
2941 if Is_Overloaded
(Old_N
) then
2942 if Nkind
(Old_N
) = N_Selected_Component
2943 and then Is_Overloaded
(Selector_Name
(Old_N
))
2945 O_N
:= Selector_Name
(Old_N
);
2948 Map_Ptr
:= Headers
(Hash
(O_N
));
2950 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2951 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2952 pragma Assert
(Map_Ptr
/= No_Entry
);
2955 New_Interps
(New_N
);
2956 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2957 Interp_Map
.Table
(Map_Ptr
).Index
;
2965 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
2966 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
2967 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
2968 B1
: constant Entity_Id
:= Base_Type
(T1
);
2969 B2
: constant Entity_Id
:= Base_Type
(T2
);
2971 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2972 -- Check whether T is the equivalent type of a remote access type.
2973 -- If distribution is enabled, T is a legal context for Null.
2975 ----------------------
2976 -- Is_Remote_Access --
2977 ----------------------
2979 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2981 return Is_Record_Type
(T
)
2982 and then (Is_Remote_Call_Interface
(T
)
2983 or else Is_Remote_Types
(T
))
2984 and then Present
(Corresponding_Remote_Type
(T
))
2985 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2986 end Is_Remote_Access
;
2988 -- Start of processing for Specific_Type
2991 if T1
= Any_Type
or else T2
= Any_Type
then
2998 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2999 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
3000 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
3001 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3005 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3006 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3007 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3008 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3012 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
3015 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
3018 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
3021 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3024 elsif T1
= Any_Access
3025 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3029 elsif T2
= Any_Access
3030 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3034 elsif T2
= Any_Composite
3035 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
3039 elsif T1
= Any_Composite
3040 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
3044 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3047 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3050 -- ----------------------------------------------------------
3051 -- Special cases for equality operators (all other predefined
3052 -- operators can never apply to tagged types)
3053 -- ----------------------------------------------------------
3055 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3058 elsif Is_Class_Wide_Type
(T1
)
3059 and then Is_Class_Wide_Type
(T2
)
3060 and then Is_Interface
(Etype
(T2
))
3064 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3065 -- class-wide interface T2
3067 elsif Is_Class_Wide_Type
(T2
)
3068 and then Is_Interface
(Etype
(T2
))
3069 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3070 Iface
=> Etype
(T2
))
3074 elsif Is_Class_Wide_Type
(T1
)
3075 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3079 elsif Is_Class_Wide_Type
(T2
)
3080 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3084 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
3086 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
3087 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3088 and then Is_Access_Type
(T2
)
3092 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
3094 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
3095 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3096 and then Is_Access_Type
(T1
)
3100 elsif (Ekind
(T1
) = E_Allocator_Type
3101 or else Ekind
(T1
) = E_Access_Attribute_Type
3102 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
3103 and then Is_Access_Type
(T2
)
3107 elsif (Ekind
(T2
) = E_Allocator_Type
3108 or else Ekind
(T2
) = E_Access_Attribute_Type
3109 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
3110 and then Is_Access_Type
(T1
)
3114 -- If none of the above cases applies, types are not compatible
3121 ---------------------
3122 -- Set_Abstract_Op --
3123 ---------------------
3125 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3127 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3128 end Set_Abstract_Op
;
3130 -----------------------
3131 -- Valid_Boolean_Arg --
3132 -----------------------
3134 -- In addition to booleans and arrays of booleans, we must include
3135 -- aggregates as valid boolean arguments, because in the first pass of
3136 -- resolution their components are not examined. If it turns out not to be
3137 -- an aggregate of booleans, this will be diagnosed in Resolve.
3138 -- Any_Composite must be checked for prior to the array type checks because
3139 -- Any_Composite does not have any associated indexes.
3141 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3143 return Is_Boolean_Type
(T
)
3144 or else T
= Any_Composite
3145 or else (Is_Array_Type
(T
)
3146 and then T
/= Any_String
3147 and then Number_Dimensions
(T
) = 1
3148 and then Is_Boolean_Type
(Component_Type
(T
))
3149 and then (not Is_Private_Composite
(T
)
3150 or else In_Instance
)
3151 and then (not Is_Limited_Composite
(T
)
3152 or else In_Instance
))
3153 or else Is_Modular_Integer_Type
(T
)
3154 or else T
= Universal_Integer
;
3155 end Valid_Boolean_Arg
;
3157 --------------------------
3158 -- Valid_Comparison_Arg --
3159 --------------------------
3161 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3164 if T
= Any_Composite
then
3166 elsif Is_Discrete_Type
(T
)
3167 or else Is_Real_Type
(T
)
3170 elsif Is_Array_Type
(T
)
3171 and then Number_Dimensions
(T
) = 1
3172 and then Is_Discrete_Type
(Component_Type
(T
))
3173 and then (not Is_Private_Composite
(T
)
3174 or else In_Instance
)
3175 and then (not Is_Limited_Composite
(T
)
3176 or else In_Instance
)
3179 elsif Is_String_Type
(T
) then
3184 end Valid_Comparison_Arg
;
3186 ----------------------
3187 -- Write_Interp_Ref --
3188 ----------------------
3190 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3192 Write_Str
(" Node: ");
3193 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3194 Write_Str
(" Index: ");
3195 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3196 Write_Str
(" Next: ");
3197 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
3199 end Write_Interp_Ref
;
3201 ---------------------
3202 -- Write_Overloads --
3203 ---------------------
3205 procedure Write_Overloads
(N
: Node_Id
) is
3211 if not Is_Overloaded
(N
) then
3212 Write_Str
("Non-overloaded entity ");
3214 Write_Entity_Info
(Entity
(N
), " ");
3217 Get_First_Interp
(N
, I
, It
);
3218 Write_Str
("Overloaded entity ");
3220 Write_Str
(" Name Type Abstract Op");
3222 Write_Str
("===============================================");
3226 while Present
(Nam
) loop
3227 Write_Int
(Int
(Nam
));
3229 Write_Name
(Chars
(Nam
));
3231 Write_Int
(Int
(It
.Typ
));
3233 Write_Name
(Chars
(It
.Typ
));
3235 if Present
(It
.Abstract_Op
) then
3237 Write_Int
(Int
(It
.Abstract_Op
));
3239 Write_Name
(Chars
(It
.Abstract_Op
));
3243 Get_Next_Interp
(I
, It
);
3247 end Write_Overloads
;