1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Nlists
; use Nlists
;
35 with Errout
; use Errout
;
37 with Namet
; use Namet
;
39 with Output
; use Output
;
41 with Sem_Aux
; use Sem_Aux
;
42 with Sem_Ch6
; use Sem_Ch6
;
43 with Sem_Ch8
; use Sem_Ch8
;
44 with Sem_Ch12
; use Sem_Ch12
;
45 with Sem_Disp
; use Sem_Disp
;
46 with Sem_Dist
; use Sem_Dist
;
47 with Sem_Util
; use Sem_Util
;
48 with Stand
; use Stand
;
49 with Sinfo
; use Sinfo
;
50 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
51 with Sinfo
.Utils
; use Sinfo
.Utils
;
52 with Snames
; use Snames
;
54 with Treepr
; use Treepr
;
55 with Uintp
; use Uintp
;
57 with GNAT
.HTable
; use GNAT
.HTable
;
59 package body Sem_Type
is
65 -- The following data structures establish a mapping between nodes and
66 -- their interpretations. An overloaded node has an entry in Interp_Map,
67 -- which in turn contains a pointer into the All_Interp array. The
68 -- interpretations of a given node are contiguous in All_Interp. Each set
69 -- of interpretations is terminated with the marker No_Interp.
71 -- Interp_Map All_Interp
75 -- |_____| | |interp2 |
76 -- |index|---------| |nointerp|
81 -- This scheme does not currently reclaim interpretations. In principle,
82 -- after a unit is compiled, all overloadings have been resolved, and the
83 -- candidate interpretations should be deleted. This should be easier
84 -- now than with the previous scheme???
86 package All_Interp
is new Table
.Table
(
87 Table_Component_Type
=> Interp
,
88 Table_Index_Type
=> Interp_Index
,
90 Table_Initial
=> Alloc
.All_Interp_Initial
,
91 Table_Increment
=> Alloc
.All_Interp_Increment
,
92 Table_Name
=> "All_Interp");
94 Header_Max
: constant := 3079;
95 -- The number of hash buckets; an arbitrary prime number
97 subtype Header_Num
is Integer range 0 .. Header_Max
- 1;
99 function Hash
(N
: Node_Id
) return Header_Num
;
100 -- A trivial hashing function for nodes, used to insert an overloaded
101 -- node into the Interp_Map table.
103 package Interp_Map
is new Simple_HTable
104 (Header_Num
=> Header_Num
,
105 Element
=> Interp_Index
,
111 Last_Overloaded
: Node_Id
:= Empty
;
112 -- Overloaded node after initializing a new collection of intepretation
114 -------------------------------------
115 -- Handling of Overload Resolution --
116 -------------------------------------
118 -- Overload resolution uses two passes over the syntax tree of a complete
119 -- context. In the first, bottom-up pass, the types of actuals in calls
120 -- are used to resolve possibly overloaded subprogram and operator names.
121 -- In the second top-down pass, the type of the context (for example the
122 -- condition in a while statement) is used to resolve a possibly ambiguous
123 -- call, and the unique subprogram name in turn imposes a specific context
124 -- on each of its actuals.
126 -- Most expressions are in fact unambiguous, and the bottom-up pass is
127 -- sufficient to resolve most everything. To simplify the common case,
128 -- names and expressions carry a flag Is_Overloaded to indicate whether
129 -- they have more than one interpretation. If the flag is off, then each
130 -- name has already a unique meaning and type, and the bottom-up pass is
131 -- sufficient (and much simpler).
133 --------------------------
134 -- Operator Overloading --
135 --------------------------
137 -- The visibility of operators is handled differently from that of other
138 -- entities. We do not introduce explicit versions of primitive operators
139 -- for each type definition. As a result, there is only one entity
140 -- corresponding to predefined addition on all numeric types, etc. The
141 -- back end resolves predefined operators according to their type. The
142 -- visibility of primitive operations then reduces to the visibility of the
143 -- resulting type: (a + b) is a legal interpretation of some primitive
144 -- operator + if the type of the result (which must also be the type of a
145 -- and b) is directly visible (either immediately visible or use-visible).
147 -- User-defined operators are treated like other functions, but the
148 -- visibility of these user-defined operations must be special-cased
149 -- to determine whether they hide or are hidden by predefined operators.
150 -- The form P."+" (x, y) requires additional handling.
152 -- Concatenation is treated more conventionally: for every one-dimensional
153 -- array type we introduce a explicit concatenation operator. This is
154 -- necessary to handle the case of (element & element => array) which
155 -- cannot be handled conveniently if there is no explicit instance of
156 -- resulting type of the operation.
158 -----------------------
159 -- Local Subprograms --
160 -----------------------
162 procedure All_Overloads
;
163 pragma Warnings
(Off
, All_Overloads
);
164 -- Debugging procedure: list full contents of Overloads table
166 function Binary_Op_Interp_Has_Abstract_Op
168 E
: Entity_Id
) return Entity_Id
;
169 -- Given the node and entity of a binary operator, determine whether the
170 -- actuals of E contain an abstract interpretation with regards to the
171 -- types of their corresponding formals. Return the abstract operation or
174 function Function_Interp_Has_Abstract_Op
176 E
: Entity_Id
) return Entity_Id
;
177 -- Given the node and entity of a function call, determine whether the
178 -- actuals of E contain an abstract interpretation with regards to the
179 -- types of their corresponding formals. Return the abstract operation or
182 function Has_Abstract_Op
184 Typ
: Entity_Id
) return Entity_Id
;
185 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
186 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
187 -- abstract interpretation which yields type Typ.
189 procedure New_Interps
(N
: Node_Id
);
190 -- Initialize collection of interpretations for the given node, which is
191 -- either an overloaded entity, or an operation whose arguments have
192 -- multiple interpretations. Interpretations can be added to only one
199 procedure Add_One_Interp
203 Opnd_Type
: Entity_Id
:= Empty
)
205 Vis_Type
: Entity_Id
;
207 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
208 -- Add one interpretation to an overloaded node. Add a new entry if
209 -- not hidden by previous one, and remove previous one if hidden by
212 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
213 -- True if the entity is a predefined operator and the operands have
214 -- a universal Interpretation.
220 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
221 Abstr_Op
: Entity_Id
:= Empty
;
225 -- Start of processing for Add_Entry
228 -- Find out whether the new entry references interpretations that
229 -- are abstract or disabled by abstract operators.
231 if Ada_Version
>= Ada_2005
then
232 if Nkind
(N
) in N_Binary_Op
then
233 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
234 elsif Nkind
(N
) = N_Function_Call
235 and then Ekind
(Name
) = E_Function
237 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
241 Get_First_Interp
(N
, I
, It
);
242 while Present
(It
.Nam
) loop
244 -- Avoid making duplicate entries in overloads
247 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
251 -- A user-defined subprogram hides another declared at an outer
252 -- level, or one that is use-visible. So return if previous
253 -- definition hides new one (which is either in an outer
254 -- scope, or use-visible). Note that for functions use-visible
255 -- is the same as potentially use-visible. If new one hides
256 -- previous one, replace entry in table of interpretations.
257 -- If this is a universal operation, retain the operator in case
258 -- preference rule applies.
260 elsif ((Ekind
(Name
) in E_Function | E_Procedure
261 and then Ekind
(Name
) = Ekind
(It
.Nam
))
262 or else (Ekind
(Name
) = E_Operator
263 and then Ekind
(It
.Nam
) = E_Function
))
264 and then Is_Immediately_Visible
(It
.Nam
)
265 and then Type_Conformant
(Name
, It
.Nam
)
266 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
268 if Is_Universal_Operation
(Name
) then
271 -- If node is an operator symbol, we have no actuals with
272 -- which to check hiding, and this is done in full in the
273 -- caller (Analyze_Subprogram_Renaming) so we include the
274 -- predefined operator in any case.
276 elsif Nkind
(N
) = N_Operator_Symbol
278 (Nkind
(N
) = N_Expanded_Name
279 and then Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
283 elsif not In_Open_Scopes
(Scope
(Name
))
284 or else Scope_Depth
(Scope
(Name
)) <=
285 Scope_Depth
(Scope
(It
.Nam
))
287 -- If ambiguity within instance, and entity is not an
288 -- implicit operation, save for later disambiguation.
290 if Scope
(Name
) = Scope
(It
.Nam
)
291 and then not Is_Inherited_Operation
(Name
)
300 All_Interp
.Table
(I
).Nam
:= Name
;
304 -- Otherwise keep going
307 Get_Next_Interp
(I
, It
);
311 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
312 All_Interp
.Append
(No_Interp
);
315 ----------------------------
316 -- Is_Universal_Operation --
317 ----------------------------
319 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
323 if Ekind
(Op
) /= E_Operator
then
326 elsif Nkind
(N
) in N_Binary_Op
then
327 if Present
(Universal_Interpretation
(Left_Opnd
(N
)))
328 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)))
331 elsif Nkind
(N
) in N_Op_Eq | N_Op_Ne
333 (Is_Anonymous_Access_Type
(Etype
(Left_Opnd
(N
)))
334 or else Is_Anonymous_Access_Type
(Etype
(Right_Opnd
(N
))))
341 elsif Nkind
(N
) in N_Unary_Op
then
342 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
344 elsif Nkind
(N
) = N_Function_Call
then
345 Arg
:= First_Actual
(N
);
346 while Present
(Arg
) loop
347 if No
(Universal_Interpretation
(Arg
)) then
359 end Is_Universal_Operation
;
361 -- Start of processing for Add_One_Interp
364 -- If the interpretation is a predefined operator, verify that it is
365 -- visible, or that the entity has already been resolved (case of an
366 -- instantiation node that refers to a predefined operation, or an
367 -- internally generated operator node, or an operator given as an
368 -- expanded name). If the operator is a comparison or equality, then
369 -- it is the type of the operand that is relevant here.
371 if Ekind
(E
) = E_Operator
then
372 if Present
(Opnd_Type
) then
373 Vis_Type
:= Opnd_Type
;
375 Vis_Type
:= Base_Type
(T
);
378 if Nkind
(N
) = N_Expanded_Name
379 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
380 or else Is_Visible_Operator
(N
, Vis_Type
)
384 -- Save type for subsequent error message, in case no other
385 -- interpretation is found.
388 Candidate_Type
:= Vis_Type
;
392 -- In an instance, an abstract non-dispatching operation cannot be a
393 -- candidate interpretation, because it could not have been one in the
394 -- generic (it may be a spurious overloading in the instance).
397 and then Is_Overloadable
(E
)
398 and then Is_Abstract_Subprogram
(E
)
399 and then not Is_Dispatching_Operation
(E
)
403 -- An inherited interface operation that is implemented by some derived
404 -- type does not participate in overload resolution, only the
405 -- implementation operation does.
408 and then Is_Subprogram
(E
)
409 and then Present
(Interface_Alias
(E
))
411 -- Ada 2005 (AI-251): If this primitive operation corresponds with
412 -- an immediate ancestor interface there is no need to add it to the
413 -- list of interpretations. The corresponding aliased primitive is
414 -- also in this list of primitive operations and will be used instead
415 -- because otherwise we have a dummy ambiguity between the two
416 -- subprograms which are in fact the same.
419 (Find_Dispatching_Type
(Interface_Alias
(E
)),
420 Find_Dispatching_Type
(E
))
422 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
424 -- Otherwise this is the first interpretation, N has type Any_Type
425 -- and we must place the new type on the node.
433 -- Calling stubs for an RACW operation never participate in resolution,
434 -- they are executed only through dispatching calls.
436 elsif Is_RACW_Stub_Type_Operation
(E
) then
440 -- If this is the first interpretation of N, N has type Any_Type.
441 -- In that case place the new type on the node. If one interpretation
442 -- already exists, indicate that the node is overloaded, and store
443 -- both the previous and the new interpretation in All_Interp. If
444 -- this is a later interpretation, just add it to the set.
446 if Etype
(N
) = Any_Type
then
451 -- Record both the operator or subprogram name, and its type
453 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
460 -- Either there is no current interpretation in the table for any
461 -- node or the interpretation that is present is for a different
462 -- node. In both cases add a new interpretation to the table.
464 elsif No
(Last_Overloaded
)
466 (Last_Overloaded
/= N
467 and then not Is_Overloaded
(N
))
471 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
472 and then Present
(Entity
(N
))
474 Add_Entry
(Entity
(N
), Etype
(N
));
476 elsif Nkind
(N
) in N_Subprogram_Call
477 and then Is_Entity_Name
(Name
(N
))
479 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
481 -- If this is an indirect call there will be no name associated
482 -- with the previous entry. To make diagnostics clearer, save
483 -- Subprogram_Type of first interpretation, so that the error will
484 -- point to the anonymous access to subprogram, not to the result
485 -- type of the call itself.
487 elsif (Nkind
(N
)) = N_Function_Call
488 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
489 and then Is_Overloaded
(Name
(N
))
495 pragma Warnings
(Off
, Itn
);
498 Get_First_Interp
(Name
(N
), Itn
, It
);
499 Add_Entry
(It
.Nam
, Etype
(N
));
503 -- Overloaded prefix in indexed or selected component, or call
504 -- whose name is an expression or another call.
506 Add_Entry
(Etype
(N
), Etype
(N
));
520 procedure All_Overloads
is
522 for J
in All_Interp
.First
.. All_Interp
.Last
loop
524 if Present
(All_Interp
.Table
(J
).Nam
) then
525 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
527 Write_Str
("No Interp");
531 Write_Str
("=================");
536 --------------------------------------
537 -- Binary_Op_Interp_Has_Abstract_Op --
538 --------------------------------------
540 function Binary_Op_Interp_Has_Abstract_Op
542 E
: Entity_Id
) return Entity_Id
544 Abstr_Op
: Entity_Id
;
545 E_Left
: constant Node_Id
:= First_Formal
(E
);
546 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
549 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
550 if Present
(Abstr_Op
) then
554 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
555 end Binary_Op_Interp_Has_Abstract_Op
;
557 ---------------------
558 -- Collect_Interps --
559 ---------------------
561 procedure Collect_Interps
(N
: Node_Id
) is
562 Ent
: constant Entity_Id
:= Entity
(N
);
564 First_Interp
: Interp_Index
;
566 function Within_Instance
(E
: Entity_Id
) return Boolean;
567 -- Within an instance there can be spurious ambiguities between a local
568 -- entity and one declared outside of the instance. This can only happen
569 -- for subprograms, because otherwise the local entity hides the outer
570 -- one. For an overloadable entity, this predicate determines whether it
571 -- is a candidate within the instance, or must be ignored.
573 ---------------------
574 -- Within_Instance --
575 ---------------------
577 function Within_Instance
(E
: Entity_Id
) return Boolean is
582 if not In_Instance
then
586 Inst
:= Current_Scope
;
587 while Present
(Inst
) and then not Is_Generic_Instance
(Inst
) loop
588 Inst
:= Scope
(Inst
);
592 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
597 Scop
:= Scope
(Scop
);
603 -- Start of processing for Collect_Interps
608 -- Unconditionally add the entity that was initially matched
610 First_Interp
:= All_Interp
.Last
;
611 Add_One_Interp
(N
, Ent
, Etype
(N
));
613 -- For expanded name, pick up all additional entities from the
614 -- same scope, since these are obviously also visible. Note that
615 -- these are not necessarily contiguous on the homonym chain.
617 if Nkind
(N
) = N_Expanded_Name
then
619 while Present
(H
) loop
620 if Scope
(H
) = Scope
(Entity
(N
)) then
621 Add_One_Interp
(N
, H
, Etype
(H
));
627 -- Case of direct name
630 -- First, search the homonym chain for directly visible entities
632 H
:= Current_Entity
(Ent
);
633 while Present
(H
) loop
635 not Is_Overloadable
(H
)
636 and then Is_Immediately_Visible
(H
);
638 if Is_Immediately_Visible
(H
) and then H
/= Ent
then
640 -- Only add interpretation if not hidden by an inner
641 -- immediately visible one.
643 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
645 -- Current homograph is not hidden. Add to overloads
647 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
650 -- Homograph is hidden, unless it is a predefined operator
652 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
654 -- A homograph in the same scope can occur within an
655 -- instantiation, the resulting ambiguity has to be
656 -- resolved later. The homographs may both be local
657 -- functions or actuals, or may be declared at different
658 -- levels within the instance. The renaming of an actual
659 -- within the instance must not be included.
661 if Within_Instance
(H
)
662 and then H
/= Renamed_Entity
(Ent
)
663 and then not Is_Inherited_Operation
(H
)
665 All_Interp
.Table
(All_Interp
.Last
) :=
666 (H
, Etype
(H
), Empty
);
667 All_Interp
.Append
(No_Interp
);
670 elsif Scope
(H
) /= Standard_Standard
then
676 -- On exit, we know that current homograph is not hidden
678 Add_One_Interp
(N
, H
, Etype
(H
));
681 Write_Str
("Add overloaded interpretation ");
691 -- Scan list of homographs for use-visible entities only
693 H
:= Current_Entity
(Ent
);
695 while Present
(H
) loop
696 if Is_Potentially_Use_Visible
(H
)
698 and then Is_Overloadable
(H
)
700 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
702 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
705 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
706 goto Next_Use_Homograph
;
710 Add_One_Interp
(N
, H
, Etype
(H
));
713 <<Next_Use_Homograph
>>
718 if All_Interp
.Last
= First_Interp
+ 1 then
720 -- The final interpretation is in fact not overloaded. Note that the
721 -- unique legal interpretation may or may not be the original one,
722 -- so we need to update N's entity and etype now, because once N
723 -- is marked as not overloaded it is also expected to carry the
724 -- proper interpretation.
726 Set_Is_Overloaded
(N
, False);
727 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
728 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
736 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
740 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
741 -- In an instance the proper view may not always be correct for
742 -- private types, but private and full view are compatible. This
743 -- removes spurious errors from nested instantiations that involve,
744 -- among other things, types derived from private types.
746 function Real_Actual
(T
: Entity_Id
) return Entity_Id
;
747 -- If an actual in an inner instance is the formal of an enclosing
748 -- generic, the actual in the enclosing instance is the one that can
749 -- create an accidental ambiguity, and the check on compatibility of
750 -- generic actual types must use this enclosing actual.
752 ----------------------
753 -- Full_View_Covers --
754 ----------------------
756 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
758 if Present
(Full_View
(Typ1
))
759 and then Covers
(Full_View
(Typ1
), Typ2
)
763 elsif Present
(Underlying_Full_View
(Typ1
))
764 and then Covers
(Underlying_Full_View
(Typ1
), Typ2
)
771 end Full_View_Covers
;
777 function Real_Actual
(T
: Entity_Id
) return Entity_Id
is
778 Par
: constant Node_Id
:= Parent
(T
);
782 -- Retrieve parent subtype from subtype declaration for actual
784 if Nkind
(Par
) = N_Subtype_Declaration
785 and then not Comes_From_Source
(Par
)
786 and then Is_Entity_Name
(Subtype_Indication
(Par
))
788 RA
:= Entity
(Subtype_Indication
(Par
));
790 if Is_Generic_Actual_Type
(RA
) then
795 -- Otherwise actual is not the actual of an enclosing instance
800 -- Start of processing for Covers
803 -- If either operand is missing, then this is an error, but ignore it
804 -- and pretend we have a cover if errors already detected since this may
805 -- simply mean we have malformed trees or a semantic error upstream.
807 if No
(T1
) or else No
(T2
) then
808 if Total_Errors_Detected
/= 0 then
815 -- Trivial case: same types are always compatible
821 -- First check for Standard_Void_Type, which is special. Subsequent
822 -- processing in this routine assumes T1 and T2 are bona fide types;
823 -- Standard_Void_Type is a special entity that has some, but not all,
824 -- properties of types.
826 if T1
= Standard_Void_Type
or else T2
= Standard_Void_Type
then
830 BT1
:= Base_Type
(T1
);
831 BT2
:= Base_Type
(T2
);
833 -- Handle underlying view of records with unknown discriminants
834 -- using the original entity that motivated the construction of
835 -- this underlying record view (see Build_Derived_Private_Type).
837 if Is_Underlying_Record_View
(BT1
) then
838 BT1
:= Underlying_Record_View
(BT1
);
841 if Is_Underlying_Record_View
(BT2
) then
842 BT2
:= Underlying_Record_View
(BT2
);
845 -- Simplest case: types that have the same base type and are not generic
846 -- actuals are compatible. Generic actuals belong to their class but are
847 -- not compatible with other types of their class, and in particular
848 -- with other generic actuals. They are however compatible with their
849 -- own subtypes, and itypes with the same base are compatible as well.
850 -- Similarly, constrained subtypes obtained from expressions of an
851 -- unconstrained nominal type are compatible with the base type (may
852 -- lead to spurious ambiguities in obscure cases ???)
854 -- Generic actuals require special treatment to avoid spurious ambi-
855 -- guities in an instance, when two formal types are instantiated with
856 -- the same actual, so that different subprograms end up with the same
857 -- signature in the instance. If a generic actual is the actual of an
858 -- enclosing instance, it is that actual that we must compare: generic
859 -- actuals are only incompatible if they appear in the same instance.
865 if not Is_Generic_Actual_Type
(T1
)
867 not Is_Generic_Actual_Type
(T2
)
871 -- Both T1 and T2 are generic actual types
875 RT1
: constant Entity_Id
:= Real_Actual
(T1
);
876 RT2
: constant Entity_Id
:= Real_Actual
(T2
);
879 or else Is_Itype
(T1
)
880 or else Is_Itype
(T2
)
881 or else Is_Constr_Subt_For_U_Nominal
(T1
)
882 or else Is_Constr_Subt_For_U_Nominal
(T2
)
883 or else Scope
(RT1
) /= Scope
(RT2
);
887 -- Literals are compatible with types in a given "class"
889 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
890 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
891 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
892 or else (T2
= Universal_Access
and then Is_Access_Type
(T1
))
893 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
894 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
895 or else (T2
= Any_String
and then Is_String_Type
(T1
))
899 -- The context may be class wide, and a class-wide type is compatible
900 -- with any member of the class.
902 elsif Is_Class_Wide_Type
(T1
)
903 and then Is_Ancestor
(Root_Type
(T1
), T2
)
907 elsif Is_Class_Wide_Type
(T1
)
908 and then Is_Class_Wide_Type
(T2
)
909 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
913 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
914 -- task_type or protected_type that implements the interface.
916 elsif Ada_Version
>= Ada_2005
917 and then Is_Concurrent_Type
(T2
)
918 and then Is_Class_Wide_Type
(T1
)
919 and then Is_Interface
(Etype
(T1
))
920 and then Interface_Present_In_Ancestor
921 (Typ
=> BT2
, Iface
=> Etype
(T1
))
925 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
926 -- object T2 implementing T1.
928 elsif Ada_Version
>= Ada_2005
929 and then Is_Tagged_Type
(T2
)
930 and then Is_Class_Wide_Type
(T1
)
931 and then Is_Interface
(Etype
(T1
))
933 if Interface_Present_In_Ancestor
(Typ
=> T2
,
944 if Is_Concurrent_Type
(BT2
) then
945 E
:= Corresponding_Record_Type
(BT2
);
950 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
951 -- covers an object T2 that implements a direct derivation of T1.
952 -- Note: test for presence of E is defense against previous error.
955 Check_Error_Detected
;
957 -- Here we have a corresponding record type
959 elsif Present
(Interfaces
(E
)) then
960 Elmt
:= First_Elmt
(Interfaces
(E
));
961 while Present
(Elmt
) loop
962 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
970 -- We should also check the case in which T1 is an ancestor of
971 -- some implemented interface???
976 -- In a dispatching call, the formal is of some specific type, and the
977 -- actual is of the corresponding class-wide type, including a subtype
978 -- of the class-wide type.
980 elsif Is_Class_Wide_Type
(T2
)
982 (Class_Wide_Type
(T1
) = Class_Wide_Type
(T2
)
983 or else Base_Type
(Root_Type
(T2
)) = BT1
)
987 -- Some contexts require a class of types rather than a specific type.
988 -- For example, conditions require any boolean type, fixed point
989 -- attributes require some real type, etc. The built-in types Any_XXX
990 -- represent these classes.
992 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
993 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
994 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
995 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
996 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
1000 -- An aggregate is compatible with an array or record type
1002 elsif T2
= Any_Composite
and then Is_Aggregate_Type
(T1
) then
1005 -- In Ada_2022, an aggregate is compatible with the type that
1006 -- as the corresponding aspect.
1008 elsif Ada_Version
>= Ada_2022
1009 and then T2
= Any_Composite
1010 and then Has_Aspect
(T1
, Aspect_Aggregate
)
1014 -- If the expected type is an anonymous access, the designated type must
1015 -- cover that of the expression. Use the base type for this check: even
1016 -- though access subtypes are rare in sources, they are generated for
1017 -- actuals in instantiations.
1019 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
1020 and then Is_Access_Type
(T2
)
1021 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1025 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1026 -- of a named general access type. An implicit conversion will be
1027 -- applied. For the resolution, the designated types must match if
1028 -- untagged; further, if the designated type is tagged, the designated
1029 -- type of the anonymous access type shall be covered by the designated
1030 -- type of the named access type.
1032 elsif Ada_Version
>= Ada_2012
1033 and then Ekind
(BT1
) = E_General_Access_Type
1034 and then Ekind
(BT2
) = E_Anonymous_Access_Type
1035 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1036 and then (Is_Class_Wide_Type
(Designated_Type
(T1
)) >=
1037 Is_Class_Wide_Type
(Designated_Type
(T2
)))
1041 -- An Access_To_Subprogram is compatible with itself, or with an
1042 -- anonymous type created for an attribute reference Access.
1044 elsif Ekind
(BT1
) in E_Access_Subprogram_Type
1045 | E_Access_Protected_Subprogram_Type
1046 and then Is_Access_Type
(T2
)
1047 and then (not Comes_From_Source
(T1
)
1048 or else not Comes_From_Source
(T2
))
1049 and then (Is_Overloadable
(Designated_Type
(T2
))
1050 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1051 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1052 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1056 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1057 -- with itself, or with an anonymous type created for an attribute
1058 -- reference Access.
1060 elsif Ekind
(BT1
) in E_Anonymous_Access_Subprogram_Type
1061 | E_Anonymous_Access_Protected_Subprogram_Type
1062 and then Is_Access_Type
(T2
)
1063 and then (not Comes_From_Source
(T1
)
1064 or else not Comes_From_Source
(T2
))
1065 and then (Is_Overloadable
(Designated_Type
(T2
))
1066 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1067 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1068 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1072 -- The context can be a remote access type, and the expression the
1073 -- corresponding source type declared in a categorized package, or
1076 elsif Is_Record_Type
(T1
)
1077 and then (Is_Remote_Call_Interface
(T1
) or else Is_Remote_Types
(T1
))
1078 and then Present
(Corresponding_Remote_Type
(T1
))
1080 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
1084 elsif Is_Record_Type
(T2
)
1085 and then (Is_Remote_Call_Interface
(T2
) or else Is_Remote_Types
(T2
))
1086 and then Present
(Corresponding_Remote_Type
(T2
))
1088 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
1090 -- Synchronized types are represented at run time by their corresponding
1091 -- record type. During expansion one is replaced with the other, but
1092 -- they are compatible views of the same type.
1094 elsif Is_Record_Type
(T1
)
1095 and then Is_Concurrent_Type
(T2
)
1096 and then Present
(Corresponding_Record_Type
(T2
))
1098 return Covers
(T1
, Corresponding_Record_Type
(T2
));
1100 elsif Is_Concurrent_Type
(T1
)
1101 and then Present
(Corresponding_Record_Type
(T1
))
1102 and then Is_Record_Type
(T2
)
1104 return Covers
(Corresponding_Record_Type
(T1
), T2
);
1106 -- During analysis, an attribute reference 'Access has a special type
1107 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1108 -- imposed by context.
1110 elsif Ekind
(T2
) = E_Access_Attribute_Type
1111 and then Ekind
(BT1
) in E_General_Access_Type | E_Access_Type
1112 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1114 -- If the target type is a RACW type while the source is an access
1115 -- attribute type, we are building a RACW that may be exported.
1117 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1118 Set_Has_RACW
(Current_Sem_Unit
);
1123 -- Ditto for allocators, which eventually resolve to the context type
1125 elsif Ekind
(T2
) = E_Allocator_Type
and then Is_Access_Type
(T1
) then
1126 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1128 (From_Limited_With
(Designated_Type
(T1
))
1129 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1131 -- A boolean operation on integer literals is compatible with modular
1134 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
1137 -- The actual type may be the result of a previous error
1139 elsif BT2
= Any_Type
then
1142 -- A Raise_Expressions is legal in any expression context
1144 elsif BT2
= Raise_Type
then
1147 -- A packed array type covers its corresponding non-packed type. This is
1148 -- not legitimate Ada, but allows the omission of a number of otherwise
1149 -- useless unchecked conversions, and since this can only arise in
1150 -- (known correct) expanded code, no harm is done.
1152 elsif Is_Packed_Array
(T2
)
1153 and then T1
= Packed_Array_Impl_Type
(T2
)
1157 -- Similarly an array type covers its corresponding packed array type
1159 elsif Is_Packed_Array
(T1
)
1160 and then T2
= Packed_Array_Impl_Type
(T1
)
1164 -- In instances, or with types exported from instantiations, check
1165 -- whether a partial and a full view match. Verify that types are
1166 -- legal, to prevent cascaded errors.
1168 elsif Is_Private_Type
(T1
)
1169 and then (In_Instance
1170 or else (Is_Type
(T2
) and then Is_Generic_Actual_Type
(T2
)))
1171 and then Full_View_Covers
(T1
, T2
)
1175 elsif Is_Private_Type
(T2
)
1176 and then (In_Instance
1177 or else (Is_Type
(T1
) and then Is_Generic_Actual_Type
(T1
)))
1178 and then Full_View_Covers
(T2
, T1
)
1182 -- In the expansion of inlined bodies, types are compatible if they
1183 -- are structurally equivalent.
1185 elsif In_Inlined_Body
1186 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1188 (Is_Access_Type
(T1
)
1189 and then Is_Access_Type
(T2
)
1190 and then Designated_Type
(T1
) = Designated_Type
(T2
))
1192 (T1
= Universal_Access
1193 and then Is_Access_Type
(Underlying_Type
(T2
)))
1196 and then Is_Composite_Type
(Underlying_Type
(T1
))))
1200 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1201 -- obtained through a limited_with compatible with its real entity.
1203 elsif From_Limited_With
(T1
) then
1205 -- If the expected type is the nonlimited view of a type, the
1206 -- expression may have the limited view. If that one in turn is
1207 -- incomplete, get full view if available.
1209 return Has_Non_Limited_View
(T1
)
1210 and then Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1212 elsif From_Limited_With
(T2
) then
1214 -- If units in the context have Limited_With clauses on each other,
1215 -- either type might have a limited view. Checks performed elsewhere
1216 -- verify that the context type is the nonlimited view.
1218 return Has_Non_Limited_View
(T2
)
1219 and then Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1221 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1223 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1224 return Covers
(Full_View
(Etype
(T1
)), T2
);
1226 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1227 return Covers
(T1
, Full_View
(Etype
(T2
)));
1229 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1230 -- and actual anonymous access types in the context of generic
1231 -- instantiations. We have the following situation:
1234 -- type Formal is private;
1235 -- Formal_Obj : access Formal; -- T1
1239 -- type Actual is ...
1240 -- Actual_Obj : access Actual; -- T2
1241 -- package Instance is new G (Formal => Actual,
1242 -- Formal_Obj => Actual_Obj);
1244 elsif Ada_Version
>= Ada_2005
1245 and then Is_Anonymous_Access_Type
(T1
)
1246 and then Is_Anonymous_Access_Type
(T2
)
1247 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1248 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1249 Directly_Designated_Type
(T2
)
1253 -- Otherwise, types are not compatible
1264 function Disambiguate
1266 I1
, I2
: Interp_Index
;
1267 Typ
: Entity_Id
) return Interp
1272 Nam1
, Nam2
: Entity_Id
;
1273 Predef_Subp
: Entity_Id
;
1274 User_Subp
: Entity_Id
;
1276 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1277 -- Determine whether one of the candidates is an operation inherited by
1278 -- a type that is derived from an actual in an instantiation.
1280 function In_Same_Declaration_List
1282 Op_Decl
: Entity_Id
) return Boolean;
1283 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1284 -- access types is declared on the partial view of a designated type, so
1285 -- that the type declaration and equality are not in the same list of
1286 -- declarations. This AI gives a preference rule for the user-defined
1287 -- operation. Same rule applies for arithmetic operations on private
1288 -- types completed with fixed-point types: the predefined operation is
1289 -- hidden; this is already handled properly in GNAT.
1291 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1292 -- Determine whether a subprogram is an actual in an enclosing instance.
1293 -- An overloading between such a subprogram and one declared outside the
1294 -- instance is resolved in favor of the first, because it resolved in
1295 -- the generic. Within the instance the actual is represented by a
1296 -- constructed subprogram renaming.
1298 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean;
1299 -- Determine whether function Func_Id is an exact match for binary or
1300 -- unary operator Op.
1302 function Operand_Type
return Entity_Id
;
1303 -- Determine type of operand for an equality operation, to apply Ada
1304 -- 2005 rules to equality on anonymous access types.
1306 function Standard_Operator
return Boolean;
1307 -- Check whether subprogram is predefined operator declared in Standard.
1308 -- It may given by an operator name, or by an expanded name whose prefix
1311 function Remove_Conversions_And_Abstract_Operations
return Interp
;
1312 -- Last chance for pathological cases involving comparisons on literals,
1313 -- and user overloadings of the same operator. Such pathologies have
1314 -- been removed from the ACVC, but still appear in two DEC tests, with
1315 -- the following notable quote from Ben Brosgol:
1317 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1318 -- this example; Robert Dewar brought it to our attention, since it is
1319 -- apparently found in the ACVC 1.5. I did not attempt to find the
1320 -- reason in the Reference Manual that makes the example legal, since I
1321 -- was too nauseated by it to want to pursue it further.]
1323 -- Accordingly, this is not a fully recursive solution, but it handles
1324 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1325 -- pathology in the other direction with calls whose multiple overloaded
1326 -- actuals make them truly unresolvable.
1328 -- The new rules concerning abstract operations create additional need
1329 -- for special handling of expressions with universal operands, see
1330 -- comments to Has_Abstract_Interpretation below.
1332 function Is_User_Defined_Anonymous_Access_Equality
1333 (User_Subp
, Predef_Subp
: Entity_Id
) return Boolean;
1334 -- Check for Ada 2005, AI-020: If the context involves an anonymous
1335 -- access operand, recognize a user-defined equality (User_Subp) with
1336 -- the proper signature, declared in the same declarative list as the
1337 -- type and not hiding a predefined equality Predef_Subp.
1339 ---------------------------
1340 -- Inherited_From_Actual --
1341 ---------------------------
1343 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1344 Par
: constant Node_Id
:= Parent
(S
);
1346 if Nkind
(Par
) /= N_Full_Type_Declaration
1347 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1351 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1353 Is_Generic_Actual_Type
(
1354 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1356 end Inherited_From_Actual
;
1358 ------------------------------
1359 -- In_Same_Declaration_List --
1360 ------------------------------
1362 function In_Same_Declaration_List
1364 Op_Decl
: Entity_Id
) return Boolean
1366 Scop
: constant Entity_Id
:= Scope
(Typ
);
1369 return In_Same_List
(Parent
(Typ
), Op_Decl
)
1371 (Is_Package_Or_Generic_Package
(Scop
)
1372 and then List_Containing
(Op_Decl
) =
1373 Visible_Declarations
(Parent
(Scop
))
1374 and then List_Containing
(Parent
(Typ
)) =
1375 Private_Declarations
(Parent
(Scop
)));
1376 end In_Same_Declaration_List
;
1378 --------------------------
1379 -- Is_Actual_Subprogram --
1380 --------------------------
1382 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1384 return In_Open_Scopes
(Scope
(S
))
1385 and then Nkind
(Unit_Declaration_Node
(S
)) =
1386 N_Subprogram_Renaming_Declaration
1388 -- Determine if the renaming came from source or was generated as a
1389 -- a result of generic expansion since the actual is represented by
1390 -- a constructed subprogram renaming.
1392 and then not Comes_From_Source
(Unit_Declaration_Node
(S
))
1395 (Is_Generic_Instance
(Scope
(S
))
1396 or else Is_Wrapper_Package
(Scope
(S
)));
1397 end Is_Actual_Subprogram
;
1403 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean is
1404 function Matching_Types
1405 (Opnd_Typ
: Entity_Id
;
1406 Formal_Typ
: Entity_Id
) return Boolean;
1407 -- Determine whether operand type Opnd_Typ and formal parameter type
1408 -- Formal_Typ are either the same or compatible.
1410 --------------------
1411 -- Matching_Types --
1412 --------------------
1414 function Matching_Types
1415 (Opnd_Typ
: Entity_Id
;
1416 Formal_Typ
: Entity_Id
) return Boolean
1421 if Opnd_Typ
= Formal_Typ
then
1424 -- Any integer type matches universal integer
1426 elsif Opnd_Typ
= Universal_Integer
1427 and then Is_Integer_Type
(Formal_Typ
)
1431 -- Any floating point type matches universal real
1433 elsif Opnd_Typ
= Universal_Real
1434 and then Is_Floating_Point_Type
(Formal_Typ
)
1438 -- The type of the formal parameter maps a generic actual type to
1439 -- a generic formal type. If the operand type is the type being
1440 -- mapped in an instance, then this is a match.
1442 elsif Is_Generic_Actual_Type
(Formal_Typ
)
1443 and then Etype
(Formal_Typ
) = Opnd_Typ
1447 -- Formal_Typ is a private view, or Opnd_Typ and Formal_Typ are
1448 -- compatible only on a base-type basis.
1457 F1
: constant Entity_Id
:= First_Formal
(Func_Id
);
1458 F1_Typ
: constant Entity_Id
:= Etype
(F1
);
1459 F2
: constant Entity_Id
:= Next_Formal
(F1
);
1460 F2_Typ
: constant Entity_Id
:= Etype
(F2
);
1461 Lop_Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(Op
));
1462 Rop_Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(Op
));
1464 -- Start of processing for Matches
1467 if Lop_Typ
= F1_Typ
then
1468 return Matching_Types
(Rop_Typ
, F2_Typ
);
1470 elsif Rop_Typ
= F2_Typ
then
1471 return Matching_Types
(Lop_Typ
, F1_Typ
);
1473 -- Otherwise this is not a good match because each operand-formal
1474 -- pair is compatible only on base-type basis, which is not specific
1486 function Operand_Type
return Entity_Id
is
1490 if Nkind
(N
) = N_Function_Call
then
1491 Opnd
:= First_Actual
(N
);
1493 Opnd
:= Left_Opnd
(N
);
1496 return Etype
(Opnd
);
1499 ------------------------------------------------
1500 -- Remove_Conversions_And_Abstract_Operations --
1501 ------------------------------------------------
1503 function Remove_Conversions_And_Abstract_Operations
return Interp
is
1511 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1512 -- If an operation has universal operands, the universal operation
1513 -- is present among its interpretations. If there is an abstract
1514 -- interpretation for the operator, with a numeric result, this
1515 -- interpretation was already removed in sem_ch4, but the universal
1516 -- one is still visible. We must rescan the list of operators and
1517 -- remove the universal interpretation to resolve the ambiguity.
1519 function Is_Numeric_Only_Type
(T
: Entity_Id
) return Boolean;
1520 -- Return True if T is a numeric type and not Any_Type
1522 ---------------------------------
1523 -- Has_Abstract_Interpretation --
1524 ---------------------------------
1526 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1530 if Nkind
(N
) not in N_Op
1531 or else Ada_Version
< Ada_2005
1532 or else not Is_Overloaded
(N
)
1533 or else No
(Universal_Interpretation
(N
))
1538 E
:= Get_Name_Entity_Id
(Chars
(N
));
1539 while Present
(E
) loop
1540 if Is_Overloadable
(E
)
1541 and then Is_Abstract_Subprogram
(E
)
1542 and then Is_Numeric_Only_Type
(Etype
(E
))
1550 -- Finally, if an operand of the binary operator is itself
1551 -- an operator, recurse to see whether its own abstract
1552 -- interpretation is responsible for the spurious ambiguity.
1554 if Nkind
(N
) in N_Binary_Op
then
1555 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1556 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1558 elsif Nkind
(N
) in N_Unary_Op
then
1559 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1565 end Has_Abstract_Interpretation
;
1567 --------------------------
1568 -- Is_Numeric_Only_Type --
1569 --------------------------
1571 function Is_Numeric_Only_Type
(T
: Entity_Id
) return Boolean is
1573 return Is_Numeric_Type
(T
) and then T
/= Any_Type
;
1574 end Is_Numeric_Only_Type
;
1576 -- Start of processing for Remove_Conversions_And_Abstract_Operations
1581 Get_First_Interp
(N
, I
, It
);
1582 while Present
(It
.Typ
) loop
1583 if not Is_Overloadable
(It
.Nam
) then
1587 F1
:= First_Formal
(It
.Nam
);
1593 if Nkind
(N
) in N_Subprogram_Call
then
1594 Act1
:= First_Actual
(N
);
1596 if Present
(Act1
) then
1597 Act2
:= Next_Actual
(Act1
);
1602 elsif Nkind
(N
) in N_Unary_Op
then
1603 Act1
:= Right_Opnd
(N
);
1606 elsif Nkind
(N
) in N_Binary_Op
then
1607 Act1
:= Left_Opnd
(N
);
1608 Act2
:= Right_Opnd
(N
);
1610 -- Use the type of the second formal, so as to include
1611 -- exponentiation, where the exponent may be ambiguous and
1612 -- the result non-universal.
1620 if Nkind
(Act1
) in N_Op
1621 and then Is_Overloaded
(Act1
)
1623 (Nkind
(Act1
) in N_Unary_Op
1624 or else Nkind
(Left_Opnd
(Act1
)) in
1625 N_Integer_Literal | N_Real_Literal
)
1626 and then Nkind
(Right_Opnd
(Act1
)) in
1627 N_Integer_Literal | N_Real_Literal
1628 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1629 and then Etype
(F1
) = Standard_Boolean
1631 -- If the two candidates are the original ones, the
1632 -- ambiguity is real. Otherwise keep the original, further
1633 -- calls to Disambiguate will take care of others in the
1634 -- list of candidates.
1636 if It1
/= No_Interp
then
1637 if It
= Disambiguate
.It1
1638 or else It
= Disambiguate
.It2
1640 if It1
= Disambiguate
.It1
1641 or else It1
= Disambiguate
.It2
1649 elsif Present
(Act2
)
1650 and then Nkind
(Act2
) in N_Op
1651 and then Is_Overloaded
(Act2
)
1652 and then Nkind
(Right_Opnd
(Act2
)) in
1653 N_Integer_Literal | N_Real_Literal
1654 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1656 -- The preference rule on the first actual is not
1657 -- sufficient to disambiguate.
1665 elsif Is_Numeric_Only_Type
(Etype
(F1
))
1666 and then Has_Abstract_Interpretation
(Act1
)
1668 -- Current interpretation is not the right one because it
1669 -- expects a numeric operand. Examine all the others.
1676 Get_First_Interp
(N
, I
, It
);
1677 while Present
(It
.Typ
) loop
1678 if not Is_Numeric_Only_Type
1679 (Etype
(First_Formal
(It
.Nam
)))
1683 Is_Numeric_Only_Type
1684 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1685 or else not Has_Abstract_Interpretation
(Act2
)
1691 Get_Next_Interp
(I
, It
);
1697 elsif Is_Numeric_Only_Type
(Etype
(F1
))
1698 and then Present
(Act2
)
1699 and then Has_Abstract_Interpretation
(Act2
)
1701 -- Current interpretation is not the right one because it
1702 -- expects a numeric operand. Examine all the others.
1709 Get_First_Interp
(N
, I
, It
);
1710 while Present
(It
.Typ
) loop
1711 if not Is_Numeric_Only_Type
1712 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1714 if not Is_Numeric_Only_Type
1715 (Etype
(First_Formal
(It
.Nam
)))
1716 or else not Has_Abstract_Interpretation
(Act1
)
1722 Get_Next_Interp
(I
, It
);
1731 Get_Next_Interp
(I
, It
);
1735 end Remove_Conversions_And_Abstract_Operations
;
1737 -----------------------
1738 -- Standard_Operator --
1739 -----------------------
1741 function Standard_Operator
return Boolean is
1745 if Nkind
(N
) in N_Op
then
1748 elsif Nkind
(N
) = N_Function_Call
then
1751 if Nkind
(Nam
) /= N_Expanded_Name
then
1754 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1759 end Standard_Operator
;
1761 -----------------------------------------------
1762 -- Is_User_Defined_Anonymous_Access_Equality --
1763 -----------------------------------------------
1765 function Is_User_Defined_Anonymous_Access_Equality
1766 (User_Subp
, Predef_Subp
: Entity_Id
) return Boolean is
1768 return Present
(User_Subp
)
1770 -- Check for Ada 2005 and use of anonymous access
1772 and then Ada_Version
>= Ada_2005
1773 and then Etype
(User_Subp
) = Standard_Boolean
1774 and then Is_Anonymous_Access_Type
(Operand_Type
)
1776 -- This check is only relevant if User_Subp is visible and not in
1779 and then (In_Open_Scopes
(Scope
(User_Subp
))
1780 or else Is_Potentially_Use_Visible
(User_Subp
))
1781 and then not In_Instance
1782 and then not Hides_Op
(User_Subp
, Predef_Subp
)
1784 -- Is User_Subp declared in the same declarative list as the type?
1787 In_Same_Declaration_List
1788 (Designated_Type
(Operand_Type
),
1789 Unit_Declaration_Node
(User_Subp
));
1790 end Is_User_Defined_Anonymous_Access_Equality
;
1792 -- Start of processing for Disambiguate
1795 -- Recover the two legal interpretations
1797 Get_First_Interp
(N
, I
, It
);
1799 Get_Next_Interp
(I
, It
);
1806 Get_Next_Interp
(I
, It
);
1812 -- Check whether one of the entities is an Ada 2005/2012/2022 and we
1813 -- are operating in an earlier mode, in which case we discard the Ada
1814 -- 2005/2012/2022 entity, so that we get proper Ada 95 overload
1817 if Ada_Version
< Ada_2005
then
1818 if Is_Ada_2005_Only
(Nam1
)
1819 or else Is_Ada_2012_Only
(Nam1
)
1820 or else Is_Ada_2022_Only
(Nam1
)
1824 elsif Is_Ada_2005_Only
(Nam2
)
1825 or else Is_Ada_2012_Only
(Nam2
)
1826 or else Is_Ada_2022_Only
(Nam2
)
1831 -- Check whether one of the entities is an Ada 2012/2022 entity and we
1832 -- are operating in Ada 2005 mode, in which case we discard the Ada 2012
1833 -- Ada 2022 entity, so that we get proper Ada 2005 overload resolution.
1835 elsif Ada_Version
= Ada_2005
then
1836 if Is_Ada_2012_Only
(Nam1
) or else Is_Ada_2022_Only
(Nam1
) then
1838 elsif Is_Ada_2012_Only
(Nam2
) or else Is_Ada_2022_Only
(Nam2
) then
1842 -- Ditto for Ada 2012 vs Ada 2022.
1844 elsif Ada_Version
= Ada_2012
then
1845 if Is_Ada_2022_Only
(Nam1
) then
1847 elsif Is_Ada_2022_Only
(Nam2
) then
1852 -- If the context is universal, the predefined operator is preferred.
1853 -- This includes bounds in numeric type declarations, and expressions
1854 -- in type conversions. If no interpretation yields a universal type,
1855 -- then we must check whether the user-defined entity hides the prede-
1858 if Chars
(Nam1
) in Any_Operator_Name
and then Standard_Operator
then
1859 if Typ
= Universal_Integer
1860 or else Typ
= Universal_Real
1861 or else Typ
= Any_Integer
1862 or else Typ
= Any_Discrete
1863 or else Typ
= Any_Real
1864 or else Typ
= Any_Type
1866 -- Find an interpretation that yields the universal type, or else
1867 -- a predefined operator that yields a predefined numeric type.
1870 Candidate
: Interp
:= No_Interp
;
1873 Get_First_Interp
(N
, I
, It
);
1874 while Present
(It
.Typ
) loop
1875 if Is_Universal_Numeric_Type
(It
.Typ
)
1876 and then (Typ
= Any_Type
or else Covers
(Typ
, It
.Typ
))
1880 elsif Is_Numeric_Type
(It
.Typ
)
1881 and then Scope
(It
.Typ
) = Standard_Standard
1882 and then Scope
(It
.Nam
) = Standard_Standard
1883 and then Covers
(Typ
, It
.Typ
)
1888 Get_Next_Interp
(I
, It
);
1891 if Candidate
/= No_Interp
then
1896 elsif Chars
(Nam1
) /= Name_Op_Not
1897 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1899 -- Equality or comparison operation. Choose predefined operator if
1900 -- arguments are universal. The node may be an operator, name, or
1901 -- a function call, so unpack arguments accordingly.
1904 Arg1
, Arg2
: Node_Id
;
1907 if Nkind
(N
) in N_Op
then
1908 Arg1
:= Left_Opnd
(N
);
1909 Arg2
:= Right_Opnd
(N
);
1911 elsif Is_Entity_Name
(N
) then
1912 Arg1
:= First_Entity
(Entity
(N
));
1913 Arg2
:= Next_Entity
(Arg1
);
1916 Arg1
:= First_Actual
(N
);
1917 Arg2
:= Next_Actual
(Arg1
);
1920 if Present
(Arg2
) then
1921 if Ekind
(Nam1
) = E_Operator
then
1922 Predef_Subp
:= Nam1
;
1924 elsif Ekind
(Nam2
) = E_Operator
then
1925 Predef_Subp
:= Nam2
;
1928 Predef_Subp
:= Empty
;
1932 -- Take into account universal interpretation as well as
1933 -- universal_access equality, as long as AI05-0020 does not
1936 if (Present
(Universal_Interpretation
(Arg1
))
1937 and then Universal_Interpretation
(Arg2
) =
1938 Universal_Interpretation
(Arg1
))
1940 (Nkind
(N
) in N_Op_Eq | N_Op_Ne
1941 and then (Is_Anonymous_Access_Type
(Etype
(Arg1
))
1943 Is_Anonymous_Access_Type
(Etype
(Arg2
)))
1945 Is_User_Defined_Anonymous_Access_Equality
1946 (User_Subp
, Predef_Subp
))
1948 Get_First_Interp
(N
, I
, It
);
1949 while Scope
(It
.Nam
) /= Standard_Standard
loop
1950 Get_Next_Interp
(I
, It
);
1960 -- If no universal interpretation, check whether user-defined operator
1961 -- hides predefined one, as well as other special cases. If the node
1962 -- is a range, then one or both bounds are ambiguous. Each will have
1963 -- to be disambiguated w.r.t. the context type. The type of the range
1964 -- itself is imposed by the context, so we can return either legal
1967 if Ekind
(Nam1
) = E_Operator
then
1968 Predef_Subp
:= Nam1
;
1971 elsif Ekind
(Nam2
) = E_Operator
then
1972 Predef_Subp
:= Nam2
;
1975 elsif Nkind
(N
) = N_Range
then
1978 -- Implement AI05-105: A renaming declaration with an access
1979 -- definition must resolve to an anonymous access type. This
1980 -- is a resolution rule and can be used to disambiguate.
1982 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1983 and then Present
(Access_Definition
(Parent
(N
)))
1985 if Is_Anonymous_Access_Type
(It1
.Typ
) then
1986 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1996 elsif Is_Anonymous_Access_Type
(It2
.Typ
) then
1999 -- No legal interpretation
2005 -- Two access attribute types may have been created for an expression
2006 -- with an implicit dereference, which is automatically overloaded.
2007 -- If both access attribute types designate the same object type,
2008 -- disambiguation if any will take place elsewhere, so keep any one of
2009 -- the interpretations.
2011 elsif Ekind
(It1
.Typ
) = E_Access_Attribute_Type
2012 and then Ekind
(It2
.Typ
) = E_Access_Attribute_Type
2013 and then Designated_Type
(It1
.Typ
) = Designated_Type
(It2
.Typ
)
2017 -- If two user defined-subprograms are visible, it is a true ambiguity,
2018 -- unless one of them is an entry and the context is a conditional or
2019 -- timed entry call, or unless we are within an instance and this is
2020 -- results from two formals types with the same actual.
2023 if Nkind
(N
) = N_Procedure_Call_Statement
2024 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
2025 and then N
= Entry_Call_Statement
(Parent
(N
))
2027 if Ekind
(Nam2
) = E_Entry
then
2029 elsif Ekind
(Nam1
) = E_Entry
then
2035 -- If the ambiguity occurs within an instance, it is due to several
2036 -- formal types with the same actual. Look for an exact match between
2037 -- the types of the formals of the overloadable entities, and the
2038 -- actuals in the call, to recover the unambiguous match in the
2039 -- original generic.
2041 -- The ambiguity can also be due to an overloading between a formal
2042 -- subprogram and a subprogram declared outside the generic. If the
2043 -- node is overloaded, it did not resolve to the global entity in
2044 -- the generic, and we choose the formal subprogram.
2046 -- Finally, the ambiguity can be between an explicit subprogram and
2047 -- one inherited (with different defaults) from an actual. In this
2048 -- case the resolution was to the explicit declaration in the
2049 -- generic, and remains so in the instance.
2051 -- The same sort of disambiguation needed for calls is also required
2052 -- for the name given in a subprogram renaming, and that case is
2053 -- handled here as well. We test Comes_From_Source to exclude this
2054 -- treatment for implicit renamings created for formal subprograms.
2056 elsif In_Instance
and then not In_Generic_Actual
(N
) then
2057 if Nkind
(N
) in N_Subprogram_Call
2059 (Nkind
(N
) in N_Has_Entity
2061 Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
2062 and then Comes_From_Source
(Parent
(N
)))
2067 Renam
: Entity_Id
:= Empty
;
2068 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
2069 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
2072 if Is_Act1
and then not Is_Act2
then
2075 elsif Is_Act2
and then not Is_Act1
then
2078 elsif Inherited_From_Actual
(Nam1
)
2079 and then Comes_From_Source
(Nam2
)
2083 elsif Inherited_From_Actual
(Nam2
)
2084 and then Comes_From_Source
(Nam1
)
2089 -- In the case of a renamed subprogram, pick up the entity
2090 -- of the renaming declaration so we can traverse its
2091 -- formal parameters.
2093 if Nkind
(N
) in N_Has_Entity
then
2094 Renam
:= Defining_Unit_Name
(Specification
(Parent
(N
)));
2097 if Present
(Renam
) then
2098 Actual
:= First_Formal
(Renam
);
2100 Actual
:= First_Actual
(N
);
2103 Formal
:= First_Formal
(Nam1
);
2104 while Present
(Actual
) loop
2105 if Etype
(Actual
) /= Etype
(Formal
) then
2109 if Present
(Renam
) then
2110 Next_Formal
(Actual
);
2112 Next_Actual
(Actual
);
2115 Next_Formal
(Formal
);
2121 elsif Nkind
(N
) in N_Binary_Op
then
2122 if Matches
(N
, Nam1
) then
2128 elsif Nkind
(N
) in N_Unary_Op
then
2129 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
2136 return Remove_Conversions_And_Abstract_Operations
;
2139 return Remove_Conversions_And_Abstract_Operations
;
2143 -- An implicit concatenation operator on a string type cannot be
2144 -- disambiguated from the predefined concatenation. This can only
2145 -- happen with concatenation of string literals.
2147 if Chars
(User_Subp
) = Name_Op_Concat
2148 and then Ekind
(User_Subp
) = E_Operator
2149 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
2153 -- If the user-defined operator matches the signature of the operator,
2154 -- and is declared in an open scope, or in the scope of the resulting
2155 -- type, or given by an expanded name that names its scope, it hides
2156 -- the predefined operator for the type. But exponentiation has to be
2157 -- special-cased because the latter operator does not have a symmetric
2158 -- signature, and may not be hidden by the explicit one.
2160 elsif Hides_Op
(User_Subp
, Predef_Subp
)
2161 or else (Nkind
(N
) = N_Function_Call
2162 and then Nkind
(Name
(N
)) = N_Expanded_Name
2163 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
2164 or else Hides_Op
(User_Subp
, Predef_Subp
))
2165 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
2167 if It1
.Nam
= User_Subp
then
2173 -- Otherwise, the predefined operator has precedence, or if the user-
2174 -- defined operation is directly visible we have a true ambiguity.
2176 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2177 -- exclude the universal_fixed operator, which often causes ambiguities
2180 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2181 -- on a partial view that is completed with a fixed point type. See
2182 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2183 -- user-defined type and subprogram, so that a client of the package
2184 -- has the same resolution as the body of the package.
2187 if (In_Open_Scopes
(Scope
(User_Subp
))
2188 or else Is_Potentially_Use_Visible
(User_Subp
))
2189 and then not In_Instance
2191 if Is_Fixed_Point_Type
(Typ
)
2192 and then Chars
(Nam1
) in Name_Op_Multiply | Name_Op_Divide
2194 (Ada_Version
= Ada_83
2195 or else (Ada_Version
>= Ada_2012
2196 and then In_Same_Declaration_List
2197 (First_Subtype
(Typ
),
2198 Unit_Declaration_Node
(User_Subp
))))
2200 if It2
.Nam
= Predef_Subp
then
2206 -- Check for AI05-020
2208 elsif Chars
(Nam1
) in Name_Op_Eq | Name_Op_Ne
2209 and then Is_User_Defined_Anonymous_Access_Equality
2210 (User_Subp
, Predef_Subp
)
2212 if It2
.Nam
= Predef_Subp
then
2218 -- RM 8.4(10): an immediately visible operator hides a use-visible
2219 -- user-defined operation that is a homograph. This disambiguation
2220 -- cannot take place earlier because visibility of the predefined
2221 -- operator can only be established when operand types are known.
2223 elsif Ekind
(User_Subp
) = E_Function
2224 and then Ekind
(Predef_Subp
) = E_Operator
2225 and then Operator_Matches_Spec
(Predef_Subp
, User_Subp
)
2226 and then Nkind
(N
) in N_Op
2227 and then not Is_Overloaded
(Right_Opnd
(N
))
2229 Is_Immediately_Visible
(Base_Type
(Etype
(Right_Opnd
(N
))))
2230 and then Is_Potentially_Use_Visible
(User_Subp
)
2232 if It2
.Nam
= Predef_Subp
then
2239 return Remove_Conversions_And_Abstract_Operations
;
2242 elsif It1
.Nam
= Predef_Subp
then
2251 -------------------------
2252 -- Entity_Matches_Spec --
2253 -------------------------
2255 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
2257 -- For the simple case of same kinds, type conformance is required, but
2258 -- a parameterless function can also rename a literal.
2260 if Ekind
(Old_S
) = Ekind
(New_S
)
2261 or else (Ekind
(New_S
) = E_Function
2262 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
2264 return Type_Conformant
(New_S
, Old_S
);
2266 -- Likewise for a procedure and an entry
2268 elsif Ekind
(New_S
) = E_Procedure
and then Is_Entry
(Old_S
) then
2269 return Type_Conformant
(New_S
, Old_S
);
2271 -- For a user-defined operator, use the dedicated predicate
2273 elsif Ekind
(New_S
) = E_Function
and then Ekind
(Old_S
) = E_Operator
then
2274 return Operator_Matches_Spec
(Old_S
, New_S
);
2279 end Entity_Matches_Spec
;
2281 ----------------------
2282 -- Find_Unique_Type --
2283 ----------------------
2285 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
2286 T
: constant Entity_Id
:= Specific_Type
(Etype
(L
), Etype
(R
));
2289 if T
= Any_Type
then
2290 if Is_User_Defined_Literal
(L
, Etype
(R
)) then
2292 elsif Is_User_Defined_Literal
(R
, Etype
(L
)) then
2298 end Find_Unique_Type
;
2300 -------------------------------------
2301 -- Function_Interp_Has_Abstract_Op --
2302 -------------------------------------
2304 function Function_Interp_Has_Abstract_Op
2306 E
: Entity_Id
) return Entity_Id
2308 Abstr_Op
: Entity_Id
;
2311 Form_Parm
: Node_Id
;
2314 if Is_Overloaded
(N
) then
2315 -- Move through the formals and actuals of the call to
2316 -- determine if an abstract interpretation exists.
2318 Act_Parm
:= First_Actual
(N
);
2319 Form_Parm
:= First_Formal
(E
);
2320 while Present
(Act_Parm
) and then Present
(Form_Parm
) loop
2323 -- Extract the actual from a parameter association
2325 if Nkind
(Act
) = N_Parameter_Association
then
2326 Act
:= Explicit_Actual_Parameter
(Act
);
2329 -- Use the actual and the type of its correponding formal to test
2330 -- for an abstract interpretation and return it when found.
2332 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2334 if Present
(Abstr_Op
) then
2338 Next_Actual
(Act_Parm
);
2339 Next_Formal
(Form_Parm
);
2343 -- Otherwise, return empty
2346 end Function_Interp_Has_Abstract_Op
;
2348 ----------------------
2349 -- Get_First_Interp --
2350 ----------------------
2352 procedure Get_First_Interp
2354 I
: out Interp_Index
;
2357 Int_Ind
: Interp_Index
;
2361 -- If a selected component is overloaded because the selector has
2362 -- multiple interpretations, the node is a call to a protected
2363 -- operation or an indirect call. Retrieve the interpretation from
2364 -- the selector name. The selected component may be overloaded as well
2365 -- if the prefix is overloaded. That case is unchanged.
2367 if Nkind
(N
) = N_Selected_Component
2368 and then Is_Overloaded
(Selector_Name
(N
))
2370 O_N
:= Selector_Name
(N
);
2375 Int_Ind
:= Interp_Map
.Get
(O_N
);
2377 -- Procedure should never be called if the node has no interpretations
2380 raise Program_Error
;
2384 It
:= All_Interp
.Table
(Int_Ind
);
2385 end Get_First_Interp
;
2387 ---------------------
2388 -- Get_Next_Interp --
2389 ---------------------
2391 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2394 It
:= All_Interp
.Table
(I
);
2395 end Get_Next_Interp
;
2397 -------------------------
2398 -- Has_Compatible_Type --
2399 -------------------------
2401 function Has_Compatible_Type
(N
: Node_Id
; Typ
: Entity_Id
) return Boolean
2411 if Nkind
(N
) = N_Subtype_Indication
or else not Is_Overloaded
(N
) then
2412 if Covers
(Typ
, Etype
(N
))
2414 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2415 -- If the type is already frozen, use the corresponding_record to
2416 -- check whether it is a proper descendant.
2419 (Is_Record_Type
(Typ
)
2420 and then Is_Concurrent_Type
(Etype
(N
))
2421 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2422 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2425 (Is_Concurrent_Type
(Typ
)
2426 and then Is_Record_Type
(Etype
(N
))
2427 and then Present
(Corresponding_Record_Type
(Typ
))
2428 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2430 or else Is_User_Defined_Literal
(N
, Typ
)
2439 Get_First_Interp
(N
, I
, It
);
2440 while Present
(It
.Typ
) loop
2441 if Covers
(Typ
, It
.Typ
)
2443 -- Ada 2005 (AI-345)
2446 (Is_Record_Type
(Typ
)
2447 and then Is_Concurrent_Type
(It
.Typ
)
2448 and then Present
(Corresponding_Record_Type
(Etype
(It
.Typ
)))
2450 Covers
(Typ
, Corresponding_Record_Type
(Etype
(It
.Typ
))))
2453 (Is_Concurrent_Type
(Typ
)
2454 and then Is_Record_Type
(It
.Typ
)
2455 and then Present
(Corresponding_Record_Type
(Typ
))
2457 Covers
(Corresponding_Record_Type
(Typ
), Etype
(It
.Typ
)))
2463 Get_Next_Interp
(I
, It
);
2468 end Has_Compatible_Type
;
2470 ---------------------
2471 -- Has_Abstract_Op --
2472 ---------------------
2474 function Has_Abstract_Op
2476 Typ
: Entity_Id
) return Entity_Id
2482 if Is_Overloaded
(N
) then
2483 Get_First_Interp
(N
, I
, It
);
2484 while Present
(It
.Nam
) loop
2485 if Present
(It
.Abstract_Op
)
2486 and then Etype
(It
.Abstract_Op
) = Typ
2488 return It
.Abstract_Op
;
2491 Get_Next_Interp
(I
, It
);
2496 end Has_Abstract_Op
;
2502 function Hash
(N
: Node_Id
) return Header_Num
is
2504 return Header_Num
(N
mod Header_Max
);
2511 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2512 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2514 return Operator_Matches_Spec
(Op
, F
)
2515 and then (In_Open_Scopes
(Scope
(F
))
2516 or else Scope
(F
) = Scope
(Btyp
)
2517 or else (not In_Open_Scopes
(Scope
(Btyp
))
2518 and then not In_Use
(Btyp
)
2519 and then not In_Use
(Scope
(Btyp
))));
2522 ------------------------
2523 -- Init_Interp_Tables --
2524 ------------------------
2526 procedure Init_Interp_Tables
is
2530 end Init_Interp_Tables
;
2532 -----------------------------------
2533 -- Interface_Present_In_Ancestor --
2534 -----------------------------------
2536 function Interface_Present_In_Ancestor
2538 Iface
: Entity_Id
) return Boolean
2540 Target_Typ
: Entity_Id
;
2541 Iface_Typ
: Entity_Id
;
2543 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2544 -- Returns True if Typ or some ancestor of Typ implements Iface
2546 -------------------------------
2547 -- Iface_Present_In_Ancestor --
2548 -------------------------------
2550 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2556 if Typ
= Iface_Typ
then
2560 -- Handle private types
2562 if Present
(Full_View
(Typ
))
2563 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2565 E
:= Full_View
(Typ
);
2571 if Present
(Interfaces
(E
))
2572 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2574 Elmt
:= First_Elmt
(Interfaces
(E
));
2575 while Present
(Elmt
) loop
2578 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2586 exit when Etype
(E
) = E
2588 -- Handle private types
2590 or else (Present
(Full_View
(Etype
(E
)))
2591 and then Full_View
(Etype
(E
)) = E
);
2593 -- Check if the current type is a direct derivation of the
2596 if Etype
(E
) = Iface_Typ
then
2600 -- Climb to the immediate ancestor handling private types
2602 if Present
(Full_View
(Etype
(E
))) then
2603 E
:= Full_View
(Etype
(E
));
2610 end Iface_Present_In_Ancestor
;
2612 -- Start of processing for Interface_Present_In_Ancestor
2615 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2617 if Is_Class_Wide_Type
(Iface
) then
2618 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2625 Iface_Typ
:= Base_Type
(Iface_Typ
);
2627 if Is_Access_Type
(Typ
) then
2628 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2633 if Is_Concurrent_Record_Type
(Target_Typ
) then
2634 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2637 Target_Typ
:= Base_Type
(Target_Typ
);
2639 -- In case of concurrent types we can't use the Corresponding Record_Typ
2640 -- to look for the interface because it is built by the expander (and
2641 -- hence it is not always available). For this reason we traverse the
2642 -- list of interfaces (available in the parent of the concurrent type)
2644 if Is_Concurrent_Type
(Target_Typ
) then
2645 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2650 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2652 -- The progenitor itself may be a subtype of an interface type.
2654 while Present
(AI
) loop
2655 if Etype
(AI
) = Iface_Typ
2656 or else Base_Type
(Etype
(AI
)) = Iface_Typ
2660 elsif Present
(Interfaces
(Etype
(AI
)))
2661 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2674 if Is_Class_Wide_Type
(Target_Typ
) then
2675 Target_Typ
:= Etype
(Target_Typ
);
2678 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2680 -- We must have either a full view or a nonlimited view of the type
2681 -- to locate the list of ancestors.
2683 if Present
(Full_View
(Target_Typ
)) then
2684 Target_Typ
:= Full_View
(Target_Typ
);
2686 -- In a spec expression or in an expression function, the use of
2687 -- an incomplete type is legal; legality of the conversion will be
2688 -- checked at freeze point of related entity.
2690 if In_Spec_Expression
then
2694 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2695 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2699 -- Protect the front end against previously detected errors
2701 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2706 return Iface_Present_In_Ancestor
(Target_Typ
);
2707 end Interface_Present_In_Ancestor
;
2709 ---------------------
2710 -- Intersect_Types --
2711 ---------------------
2713 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2714 Index
: Interp_Index
;
2718 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2719 -- Find interpretation of right arg that has type compatible with T
2721 --------------------------
2722 -- Check_Right_Argument --
2723 --------------------------
2725 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2726 Index
: Interp_Index
;
2731 if not Is_Overloaded
(R
) then
2732 return Specific_Type
(T
, Etype
(R
));
2735 Get_First_Interp
(R
, Index
, It
);
2737 T2
:= Specific_Type
(T
, It
.Typ
);
2739 if T2
/= Any_Type
then
2743 Get_Next_Interp
(Index
, It
);
2744 exit when No
(It
.Typ
);
2749 end Check_Right_Argument
;
2751 -- Start of processing for Intersect_Types
2754 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2758 if not Is_Overloaded
(L
) then
2759 Typ
:= Check_Right_Argument
(Etype
(L
));
2763 Get_First_Interp
(L
, Index
, It
);
2764 while Present
(It
.Typ
) loop
2765 Typ
:= Check_Right_Argument
(It
.Typ
);
2766 exit when Typ
/= Any_Type
;
2767 Get_Next_Interp
(Index
, It
);
2772 -- If Typ is Any_Type, it means no compatible pair of types was found
2774 if Typ
= Any_Type
then
2775 if Nkind
(Parent
(L
)) in N_Op
then
2776 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2778 elsif Nkind
(Parent
(L
)) = N_Range
then
2779 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2781 -- Ada 2005 (AI-251): Complete the error notification
2783 elsif Is_Class_Wide_Type
(Etype
(R
))
2784 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2786 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2787 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2789 -- Specialize message if one operand is a limited view, a priori
2790 -- unrelated to all other types.
2792 elsif From_Limited_With
(Etype
(R
)) then
2793 Error_Msg_NE
("limited view of& not compatible with context",
2796 elsif From_Limited_With
(Etype
(L
)) then
2797 Error_Msg_NE
("limited view of& not compatible with context",
2800 Error_Msg_N
("incompatible types", Parent
(L
));
2805 end Intersect_Types
;
2807 -----------------------
2808 -- In_Generic_Actual --
2809 -----------------------
2811 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2812 Par
: constant Node_Id
:= Parent
(Exp
);
2818 elsif Nkind
(Par
) in N_Declaration
then
2820 Nkind
(Par
) = N_Object_Declaration
2821 and then Present
(Corresponding_Generic_Association
(Par
));
2823 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2824 return Present
(Corresponding_Generic_Association
(Par
));
2826 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2830 return In_Generic_Actual
(Par
);
2832 end In_Generic_Actual
;
2838 function Is_Ancestor
2841 Use_Full_View
: Boolean := False) return Boolean
2848 BT1
:= Base_Type
(T1
);
2849 BT2
:= Base_Type
(T2
);
2851 -- Handle underlying view of records with unknown discriminants using
2852 -- the original entity that motivated the construction of this
2853 -- underlying record view (see Build_Derived_Private_Type).
2855 if Is_Underlying_Record_View
(BT1
) then
2856 BT1
:= Underlying_Record_View
(BT1
);
2859 if Is_Underlying_Record_View
(BT2
) then
2860 BT2
:= Underlying_Record_View
(BT2
);
2866 -- The predicate must look past privacy
2868 elsif Is_Private_Type
(T1
)
2869 and then Present
(Full_View
(T1
))
2870 and then BT2
= Base_Type
(Full_View
(T1
))
2874 elsif Is_Private_Type
(T2
)
2875 and then Present
(Full_View
(T2
))
2876 and then BT1
= Base_Type
(Full_View
(T2
))
2881 -- Obtain the parent of the base type of T2 (use the full view if
2885 and then Is_Private_Type
(BT2
)
2886 and then Present
(Full_View
(BT2
))
2888 -- No climbing needed if its full view is the root type
2890 if Full_View
(BT2
) = Root_Type
(Full_View
(BT2
)) then
2894 Par
:= Etype
(Full_View
(BT2
));
2901 -- If there was a error on the type declaration, do not recurse
2903 if Error_Posted
(Par
) then
2906 elsif BT1
= Base_Type
(Par
)
2907 or else (Is_Private_Type
(T1
)
2908 and then Present
(Full_View
(T1
))
2909 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2913 elsif Is_Private_Type
(Par
)
2914 and then Present
(Full_View
(Par
))
2915 and then Full_View
(Par
) = BT1
2921 elsif Par
= Root_Type
(Par
) then
2924 -- Continue climbing
2927 -- Use the full-view of private types (if allowed). Guard
2928 -- against infinite loops when full view has same type as
2929 -- parent, as can happen with interface extensions.
2932 and then Is_Private_Type
(Par
)
2933 and then Present
(Full_View
(Par
))
2934 and then Par
/= Etype
(Full_View
(Par
))
2936 Par
:= Etype
(Full_View
(Par
));
2945 --------------------
2947 --------------------
2949 function Is_Progenitor
2951 Typ
: Entity_Id
) return Boolean
2954 return Implements_Interface
(Typ
, Iface
, Exclude_Parents
=> True);
2961 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2965 S
:= Ancestor_Subtype
(T1
);
2966 while Present
(S
) loop
2970 S
:= Ancestor_Subtype
(S
);
2977 -------------------------
2978 -- Is_Visible_Operator --
2979 -------------------------
2981 function Is_Visible_Operator
(N
: Node_Id
; Typ
: Entity_Id
) return Boolean
2984 -- The predefined operators of the universal types are always visible
2986 if Typ
in Universal_Integer | Universal_Real | Universal_Access
then
2989 -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
2990 -- anonymous access types in universal_access equality operators.
2992 elsif Is_Anonymous_Access_Type
(Typ
) then
2993 return Ada_Version
>= Ada_2005
;
2995 -- Similar reasoning for special types used for composite types before
2996 -- type resolution is done.
2998 elsif Typ
= Any_Composite
or else Typ
= Any_String
then
3001 -- Within an instance, the predefined operators of the formal types are
3002 -- visible and, for the other types, the generic package declaration has
3003 -- already been successfully analyzed. Likewise for an inlined body.
3005 elsif In_Instance
or else In_Inlined_Body
then
3008 -- If the operation is given in functional notation and the prefix is an
3009 -- expanded name, then the operator is visible if the prefix is the scope
3010 -- of the type, or System if the type is declared in an extension of it.
3012 elsif Nkind
(N
) = N_Function_Call
3013 and then Nkind
(Name
(N
)) = N_Expanded_Name
3016 Pref
: constant Entity_Id
:= Entity
(Prefix
(Name
(N
)));
3017 Scop
: constant Entity_Id
:= Scope
(Typ
);
3021 or else (Present
(System_Aux_Id
)
3022 and then Scop
= System_Aux_Id
3023 and then Pref
= Scope
(Scop
));
3026 -- Otherwise the operator is visible when the type is visible
3029 return Is_Potentially_Use_Visible
(Typ
)
3030 or else In_Use
(Typ
)
3031 or else (In_Use
(Scope
(Typ
)) and then not Is_Hidden
(Typ
))
3032 or else In_Open_Scopes
(Scope
(Typ
));
3034 end Is_Visible_Operator
;
3040 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
3041 Index
: Interp_Index
;
3045 Get_First_Interp
(Nam
, Index
, It
);
3046 while Present
(It
.Nam
) loop
3047 if Scope
(It
.Nam
) = Standard_Standard
3048 and then Scope
(It
.Typ
) /= Standard_Standard
3050 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
3051 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
3054 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
3055 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
3058 Get_Next_Interp
(Index
, It
);
3066 procedure New_Interps
(N
: Node_Id
) is
3068 All_Interp
.Append
(No_Interp
);
3070 -- Add or rewrite the existing node
3071 Last_Overloaded
:= N
;
3072 Interp_Map
.Set
(N
, All_Interp
.Last
);
3073 Set_Is_Overloaded
(N
, True);
3076 ---------------------------
3077 -- Operator_Matches_Spec --
3078 ---------------------------
3080 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
3081 New_First_F
: constant Entity_Id
:= First_Formal
(New_S
);
3082 Op_Name
: constant Name_Id
:= Chars
(Op
);
3083 T
: constant Entity_Id
:= Etype
(New_S
);
3091 -- To verify that a predefined operator matches a given signature, do a
3092 -- case analysis of the operator classes. Function can have one or two
3093 -- formals and must have the proper result type.
3095 New_F
:= New_First_F
;
3096 Old_F
:= First_Formal
(Op
);
3098 while Present
(New_F
) and then Present
(Old_F
) loop
3100 Next_Formal
(New_F
);
3101 Next_Formal
(Old_F
);
3104 -- Definite mismatch if different number of parameters
3106 if Present
(Old_F
) or else Present
(New_F
) then
3112 T1
:= Etype
(New_First_F
);
3114 if Op_Name
in Name_Op_Subtract | Name_Op_Add | Name_Op_Abs
then
3115 return Base_Type
(T1
) = Base_Type
(T
)
3116 and then Is_Numeric_Type
(T
);
3118 elsif Op_Name
= Name_Op_Not
then
3119 return Base_Type
(T1
) = Base_Type
(T
)
3120 and then Valid_Boolean_Arg
(Base_Type
(T
));
3129 T1
:= Etype
(New_First_F
);
3130 T2
:= Etype
(Next_Formal
(New_First_F
));
3132 if Op_Name
in Name_Op_And | Name_Op_Or | Name_Op_Xor
then
3133 return Base_Type
(T1
) = Base_Type
(T2
)
3134 and then Base_Type
(T1
) = Base_Type
(T
)
3135 and then Valid_Boolean_Arg
(Base_Type
(T
));
3137 elsif Op_Name
in Name_Op_Eq | Name_Op_Ne
then
3138 return Base_Type
(T1
) = Base_Type
(T2
)
3139 and then Valid_Equality_Arg
(T1
)
3140 and then Is_Boolean_Type
(T
);
3142 elsif Op_Name
in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
3144 return Base_Type
(T1
) = Base_Type
(T2
)
3145 and then Valid_Comparison_Arg
(T1
)
3146 and then Is_Boolean_Type
(T
);
3148 elsif Op_Name
in Name_Op_Add | Name_Op_Subtract
then
3149 return Base_Type
(T1
) = Base_Type
(T2
)
3150 and then Base_Type
(T1
) = Base_Type
(T
)
3151 and then Is_Numeric_Type
(T
);
3153 -- For division and multiplication, a user-defined function does not
3154 -- match the predefined universal_fixed operation, except in Ada 83.
3156 elsif Op_Name
= Name_Op_Divide
then
3157 return (Base_Type
(T1
) = Base_Type
(T2
)
3158 and then Base_Type
(T1
) = Base_Type
(T
)
3159 and then Is_Numeric_Type
(T
)
3160 and then (not Is_Fixed_Point_Type
(T
)
3161 or else Ada_Version
= Ada_83
))
3163 -- Mixed_Mode operations on fixed-point types
3165 or else (Base_Type
(T1
) = Base_Type
(T
)
3166 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3167 and then Is_Fixed_Point_Type
(T
))
3169 -- A user defined operator can also match (and hide) a mixed
3170 -- operation on universal literals.
3172 or else (Is_Integer_Type
(T2
)
3173 and then Is_Floating_Point_Type
(T1
)
3174 and then Base_Type
(T1
) = Base_Type
(T
));
3176 elsif Op_Name
= Name_Op_Multiply
then
3177 return (Base_Type
(T1
) = Base_Type
(T2
)
3178 and then Base_Type
(T1
) = Base_Type
(T
)
3179 and then Is_Numeric_Type
(T
)
3180 and then (not Is_Fixed_Point_Type
(T
)
3181 or else Ada_Version
= Ada_83
))
3183 -- Mixed_Mode operations on fixed-point types
3185 or else (Base_Type
(T1
) = Base_Type
(T
)
3186 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3187 and then Is_Fixed_Point_Type
(T
))
3189 or else (Base_Type
(T2
) = Base_Type
(T
)
3190 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
3191 and then Is_Fixed_Point_Type
(T
))
3193 or else (Is_Integer_Type
(T2
)
3194 and then Is_Floating_Point_Type
(T1
)
3195 and then Base_Type
(T1
) = Base_Type
(T
))
3197 or else (Is_Integer_Type
(T1
)
3198 and then Is_Floating_Point_Type
(T2
)
3199 and then Base_Type
(T2
) = Base_Type
(T
));
3201 elsif Op_Name
in Name_Op_Mod | Name_Op_Rem
then
3202 return Base_Type
(T1
) = Base_Type
(T2
)
3203 and then Base_Type
(T1
) = Base_Type
(T
)
3204 and then Is_Integer_Type
(T
);
3206 elsif Op_Name
= Name_Op_Expon
then
3207 return Base_Type
(T1
) = Base_Type
(T
)
3208 and then Is_Numeric_Type
(T
)
3209 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
3211 elsif Op_Name
= Name_Op_Concat
then
3212 return Is_Array_Type
(T
)
3213 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
3214 and then (Base_Type
(T1
) = Base_Type
(T
)
3216 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
3217 and then (Base_Type
(T2
) = Base_Type
(T
)
3219 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
3225 end Operator_Matches_Spec
;
3231 procedure Remove_Interp
(I
: in out Interp_Index
) is
3235 -- Find end of interp list and copy downward to erase the discarded one
3238 while Present
(All_Interp
.Table
(II
).Typ
) loop
3242 for J
in I
+ 1 .. II
loop
3243 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
3246 -- Back up interp index to insure that iterator will pick up next
3247 -- available interpretation.
3256 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
3257 Old_Ind
: Interp_Index
;
3261 if Is_Overloaded
(Old_N
) then
3262 Set_Is_Overloaded
(New_N
);
3264 if Nkind
(Old_N
) = N_Selected_Component
3265 and then Is_Overloaded
(Selector_Name
(Old_N
))
3267 O_N
:= Selector_Name
(Old_N
);
3272 Old_Ind
:= Interp_Map
.Get
(O_N
);
3273 pragma Assert
(Old_Ind
>= 0);
3275 New_Interps
(New_N
);
3276 Interp_Map
.Set
(New_N
, Old_Ind
);
3284 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
3285 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
3286 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
3287 B1
: constant Entity_Id
:= Base_Type
(T1
);
3288 B2
: constant Entity_Id
:= Base_Type
(T2
);
3290 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
3291 -- Check whether T is the equivalent type of a remote access type.
3292 -- If distribution is enabled, T is a legal context for Null.
3294 ----------------------
3295 -- Is_Remote_Access --
3296 ----------------------
3298 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
3300 return Is_Record_Type
(T
)
3301 and then (Is_Remote_Call_Interface
(T
)
3302 or else Is_Remote_Types
(T
))
3303 and then Present
(Corresponding_Remote_Type
(T
))
3304 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
3305 end Is_Remote_Access
;
3307 -- Start of processing for Specific_Type
3310 if T1
= Any_Type
or else T2
= Any_Type
then
3317 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
3318 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
3319 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
3320 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3321 or else (T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
))
3322 or else (T1
= Any_Character
and then Is_Character_Type
(T2
))
3323 or else (T1
= Any_String
and then Is_String_Type
(T2
))
3324 or else (T1
= Any_Composite
and then Is_Aggregate_Type
(T2
))
3328 elsif (T1
= Universal_Access
3329 or else Ekind
(T1
) in E_Allocator_Type | E_Access_Attribute_Type
)
3330 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3334 elsif T1
= Raise_Type
then
3337 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3338 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3339 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3340 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3341 or else (T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
))
3342 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
3343 or else (T2
= Any_String
and then Is_String_Type
(T1
))
3344 or else (T2
= Any_Composite
and then Is_Aggregate_Type
(T1
))
3348 elsif (T2
= Universal_Access
3349 or else Ekind
(T2
) in E_Allocator_Type | E_Access_Attribute_Type
)
3350 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3354 elsif T2
= Raise_Type
then
3357 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3358 -- interface, return T1, and vice versa.
3360 elsif Is_Class_Wide_Type
(T1
)
3361 and then Is_Class_Wide_Type
(T2
)
3362 and then Is_Interface
(Etype
(T2
))
3366 elsif Is_Class_Wide_Type
(T2
)
3367 and then Is_Class_Wide_Type
(T1
)
3368 and then Is_Interface
(Etype
(T1
))
3372 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3373 -- class-wide interface T2, return T1, and vice versa.
3375 elsif Is_Tagged_Type
(T1
)
3376 and then Is_Class_Wide_Type
(T2
)
3377 and then Is_Interface
(Etype
(T2
))
3378 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3379 Iface
=> Etype
(T2
))
3383 elsif Is_Tagged_Type
(T2
)
3384 and then Is_Class_Wide_Type
(T1
)
3385 and then Is_Interface
(Etype
(T1
))
3386 and then Interface_Present_In_Ancestor
(Typ
=> T2
,
3387 Iface
=> Etype
(T1
))
3391 elsif Is_Class_Wide_Type
(T1
)
3392 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3396 elsif Is_Class_Wide_Type
(T2
)
3397 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3401 elsif Is_Access_Type
(T1
)
3402 and then Is_Access_Type
(T2
)
3403 and then Is_Class_Wide_Type
(Designated_Type
(T1
))
3404 and then not Is_Class_Wide_Type
(Designated_Type
(T2
))
3406 Is_Ancestor
(Root_Type
(Designated_Type
(T1
)), Designated_Type
(T2
))
3410 elsif Is_Access_Type
(T1
)
3411 and then Is_Access_Type
(T2
)
3412 and then Is_Class_Wide_Type
(Designated_Type
(T2
))
3413 and then not Is_Class_Wide_Type
(Designated_Type
(T1
))
3415 Is_Ancestor
(Root_Type
(Designated_Type
(T2
)), Designated_Type
(T1
))
3419 elsif Ekind
(B1
) in E_Access_Subprogram_Type
3420 | E_Access_Protected_Subprogram_Type
3421 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3422 and then Is_Access_Type
(T2
)
3426 elsif Ekind
(B2
) in E_Access_Subprogram_Type
3427 | E_Access_Protected_Subprogram_Type
3428 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3429 and then Is_Access_Type
(T1
)
3433 -- Ada 2005 (AI-230): Support the following operators:
3435 -- function "=" (L, R : universal_access) return Boolean;
3436 -- function "/=" (L, R : universal_access) return Boolean;
3438 -- Pool-specific access types (E_Access_Type) are not covered by these
3439 -- operators because of the legality rule of 4.5.2(9.2): "The operands
3440 -- of the equality operators for universal_access shall be convertible
3441 -- to one another (see 4.6)". For example, considering the type decla-
3442 -- ration "type P is access Integer" and an anonymous access to Integer,
3443 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
3444 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
3445 -- Note that this does not preclude one operand to be a pool-specific
3446 -- access type, as a previous version of this code enforced.
3448 elsif Is_Anonymous_Access_Type
(T1
)
3449 and then Is_Access_Type
(T2
)
3450 and then Ada_Version
>= Ada_2005
3454 elsif Is_Anonymous_Access_Type
(T2
)
3455 and then Is_Access_Type
(T1
)
3456 and then Ada_Version
>= Ada_2005
3460 -- In instances, also check private views the same way as Covers
3462 elsif Is_Private_Type
(T1
) and then In_Instance
then
3463 if Present
(Full_View
(T1
)) then
3464 return Specific_Type
(Full_View
(T1
), T2
);
3466 elsif Present
(Underlying_Full_View
(T1
)) then
3467 return Specific_Type
(Underlying_Full_View
(T1
), T2
);
3470 elsif Is_Private_Type
(T2
) and then In_Instance
then
3471 if Present
(Full_View
(T2
)) then
3472 return Specific_Type
(T1
, Full_View
(T2
));
3474 elsif Present
(Underlying_Full_View
(T2
)) then
3475 return Specific_Type
(T1
, Underlying_Full_View
(T2
));
3479 -- If none of the above cases applies, types are not compatible
3484 ---------------------
3485 -- Set_Abstract_Op --
3486 ---------------------
3488 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3490 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3491 end Set_Abstract_Op
;
3493 -----------------------
3494 -- Valid_Boolean_Arg --
3495 -----------------------
3497 -- In addition to booleans and arrays of booleans, we must include
3498 -- aggregates as valid boolean arguments, because in the first pass of
3499 -- resolution their components are not examined. If it turns out not to be
3500 -- an aggregate of booleans, this will be diagnosed in Resolve.
3501 -- Any_Composite must be checked for prior to the array type checks because
3502 -- Any_Composite does not have any associated indexes.
3504 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3506 if Is_Boolean_Type
(T
)
3507 or else Is_Modular_Integer_Type
(T
)
3508 or else T
= Universal_Integer
3509 or else T
= Any_Composite
3510 or else T
= Raise_Type
3514 elsif Is_Array_Type
(T
)
3515 and then Number_Dimensions
(T
) = 1
3516 and then Is_Boolean_Type
(Component_Type
(T
))
3518 ((not Is_Private_Composite
(T
) and then not Is_Limited_Composite
(T
))
3520 or else Available_Full_View_Of_Component
(T
))
3527 end Valid_Boolean_Arg
;
3529 --------------------------
3530 -- Valid_Comparison_Arg --
3531 --------------------------
3533 -- See above for the reason why aggregates and strings are included
3535 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3537 if Is_Discrete_Type
(T
) or else Is_Real_Type
(T
) then
3540 elsif T
= Any_Composite
or else T
= Any_String
then
3543 elsif Is_Array_Type
(T
)
3544 and then Number_Dimensions
(T
) = 1
3545 and then Is_Discrete_Type
(Component_Type
(T
))
3546 and then (not Is_Private_Composite
(T
) or else In_Instance
)
3547 and then (not Is_Limited_Composite
(T
) or else In_Instance
)
3551 elsif Is_Array_Type
(T
)
3552 and then Number_Dimensions
(T
) = 1
3553 and then Is_Discrete_Type
(Component_Type
(T
))
3554 and then Available_Full_View_Of_Component
(T
)
3558 elsif Is_String_Type
(T
) then
3564 end Valid_Comparison_Arg
;
3566 ------------------------
3567 -- Valid_Equality_Arg --
3568 ------------------------
3570 -- Same reasoning as above but implicit because of the nonlimited test
3572 function Valid_Equality_Arg
(T
: Entity_Id
) return Boolean is
3574 -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
3575 -- anonymous access types in universal_access equality operators.
3577 if Is_Anonymous_Access_Type
(T
) then
3578 return Ada_Version
>= Ada_2005
;
3580 elsif not Is_Limited_Type
(T
) then
3583 elsif Is_Array_Type
(T
)
3584 and then not Is_Limited_Type
(Component_Type
(T
))
3585 and then Available_Full_View_Of_Component
(T
)
3592 end Valid_Equality_Arg
;
3598 procedure Write_Interp
(It
: Interp
) is
3600 Write_Str
("Nam: ");
3601 Print_Tree_Node
(It
.Nam
);
3602 Write_Str
("Typ: ");
3603 Print_Tree_Node
(It
.Typ
);
3604 Write_Str
("Abstract_Op: ");
3605 Print_Tree_Node
(It
.Abstract_Op
);
3608 ---------------------
3609 -- Write_Overloads --
3610 ---------------------
3612 procedure Write_Overloads
(N
: Node_Id
) is
3618 Write_Str
("Overloads: ");
3619 Print_Node_Briefly
(N
);
3621 if not Is_Overloaded
(N
) then
3622 if Is_Entity_Name
(N
) then
3623 Write_Line
("Non-overloaded entity ");
3624 Write_Entity_Info
(Entity
(N
), " ");
3627 elsif Nkind
(N
) not in N_Has_Entity
then
3628 Get_First_Interp
(N
, I
, It
);
3629 while Present
(It
.Nam
) loop
3630 Write_Int
(Int
(It
.Typ
));
3632 Write_Name
(Chars
(It
.Typ
));
3634 Get_Next_Interp
(I
, It
);
3638 Get_First_Interp
(N
, I
, It
);
3639 Write_Line
("Overloaded entity ");
3640 Write_Line
(" Name Type Abstract Op");
3641 Write_Line
("===============================================");
3644 while Present
(Nam
) loop
3645 Write_Int
(Int
(Nam
));
3647 Write_Name
(Chars
(Nam
));
3649 Write_Int
(Int
(It
.Typ
));
3651 Write_Name
(Chars
(It
.Typ
));
3653 if Present
(It
.Abstract_Op
) then
3655 Write_Int
(Int
(It
.Abstract_Op
));
3657 Write_Name
(Chars
(It
.Abstract_Op
));
3661 Get_Next_Interp
(I
, It
);
3665 end Write_Overloads
;