1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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
195 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
;
196 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
197 -- or is not a "class" type (any_character, etc).
203 procedure Add_One_Interp
207 Opnd_Type
: Entity_Id
:= Empty
)
209 Vis_Type
: Entity_Id
;
211 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
212 -- Add one interpretation to an overloaded node. Add a new entry if
213 -- not hidden by previous one, and remove previous one if hidden by
216 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
217 -- True if the entity is a predefined operator and the operands have
218 -- a universal Interpretation.
224 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
225 Abstr_Op
: Entity_Id
:= Empty
;
229 -- Start of processing for Add_Entry
232 -- Find out whether the new entry references interpretations that
233 -- are abstract or disabled by abstract operators.
235 if Ada_Version
>= Ada_2005
then
236 if Nkind
(N
) in N_Binary_Op
then
237 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
238 elsif Nkind
(N
) = N_Function_Call
then
239 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
243 Get_First_Interp
(N
, I
, It
);
244 while Present
(It
.Nam
) loop
246 -- Avoid making duplicate entries in overloads
249 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
253 -- A user-defined subprogram hides another declared at an outer
254 -- level, or one that is use-visible. So return if previous
255 -- definition hides new one (which is either in an outer
256 -- scope, or use-visible). Note that for functions use-visible
257 -- is the same as potentially use-visible. If new one hides
258 -- previous one, replace entry in table of interpretations.
259 -- If this is a universal operation, retain the operator in case
260 -- preference rule applies.
262 elsif ((Ekind
(Name
) in E_Function | E_Procedure
263 and then Ekind
(Name
) = Ekind
(It
.Nam
))
264 or else (Ekind
(Name
) = E_Operator
265 and then Ekind
(It
.Nam
) = E_Function
))
266 and then Is_Immediately_Visible
(It
.Nam
)
267 and then Type_Conformant
(Name
, It
.Nam
)
268 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
270 if Is_Universal_Operation
(Name
) then
273 -- If node is an operator symbol, we have no actuals with
274 -- which to check hiding, and this is done in full in the
275 -- caller (Analyze_Subprogram_Renaming) so we include the
276 -- predefined operator in any case.
278 elsif Nkind
(N
) = N_Operator_Symbol
280 (Nkind
(N
) = N_Expanded_Name
281 and then Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
285 elsif not In_Open_Scopes
(Scope
(Name
))
286 or else Scope_Depth
(Scope
(Name
)) <=
287 Scope_Depth
(Scope
(It
.Nam
))
289 -- If ambiguity within instance, and entity is not an
290 -- implicit operation, save for later disambiguation.
292 if Scope
(Name
) = Scope
(It
.Nam
)
293 and then not Is_Inherited_Operation
(Name
)
302 All_Interp
.Table
(I
).Nam
:= Name
;
306 -- Otherwise keep going
309 Get_Next_Interp
(I
, It
);
313 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
314 All_Interp
.Append
(No_Interp
);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
325 if Ekind
(Op
) /= E_Operator
then
328 elsif Nkind
(N
) in N_Binary_Op
then
329 if Present
(Universal_Interpretation
(Left_Opnd
(N
)))
330 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)))
333 elsif Nkind
(N
) in N_Op_Eq | N_Op_Ne
335 (Is_Anonymous_Access_Type
(Etype
(Left_Opnd
(N
)))
336 or else Is_Anonymous_Access_Type
(Etype
(Right_Opnd
(N
))))
343 elsif Nkind
(N
) in N_Unary_Op
then
344 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
346 elsif Nkind
(N
) = N_Function_Call
then
347 Arg
:= First_Actual
(N
);
348 while Present
(Arg
) loop
349 if No
(Universal_Interpretation
(Arg
)) then
361 end Is_Universal_Operation
;
363 -- Start of processing for Add_One_Interp
366 -- If the interpretation is a predefined operator, verify that the
367 -- result type is visible, or that the entity has already been
368 -- resolved (case of an instantiation node that refers to a predefined
369 -- operation, or an internally generated operator node, or an operator
370 -- given as an expanded name). If the operator is a comparison or
371 -- equality, it is the type of the operand that matters to determine
372 -- whether the operator is visible. In an instance, the check is not
373 -- performed, given that the operator was visible in the generic.
375 if Ekind
(E
) = E_Operator
then
376 if Present
(Opnd_Type
) then
377 Vis_Type
:= Opnd_Type
;
379 Vis_Type
:= Base_Type
(T
);
382 if In_Open_Scopes
(Scope
(Vis_Type
))
383 or else Is_Potentially_Use_Visible
(Vis_Type
)
384 or else In_Use
(Vis_Type
)
385 or else (In_Use
(Scope
(Vis_Type
))
386 and then not Is_Hidden
(Vis_Type
))
387 or else Nkind
(N
) = N_Expanded_Name
388 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
389 or else (In_Instance
or else In_Inlined_Body
)
390 or else Is_Anonymous_Access_Type
(Vis_Type
)
394 -- If the node is given in functional notation and the prefix
395 -- is an expanded name, then the operator is visible if the
396 -- prefix is the scope of the result type as well. If the
397 -- operator is (implicitly) defined in an extension of system,
398 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
400 elsif Nkind
(N
) = N_Function_Call
401 and then Nkind
(Name
(N
)) = N_Expanded_Name
402 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
403 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
404 or else Scope
(Vis_Type
) = System_Aux_Id
)
408 -- Save type for subsequent error message, in case no other
409 -- interpretation is found.
412 Candidate_Type
:= Vis_Type
;
416 -- In an instance, an abstract non-dispatching operation cannot be a
417 -- candidate interpretation, because it could not have been one in the
418 -- generic (it may be a spurious overloading in the instance).
421 and then Is_Overloadable
(E
)
422 and then Is_Abstract_Subprogram
(E
)
423 and then not Is_Dispatching_Operation
(E
)
427 -- An inherited interface operation that is implemented by some derived
428 -- type does not participate in overload resolution, only the
429 -- implementation operation does.
432 and then Is_Subprogram
(E
)
433 and then Present
(Interface_Alias
(E
))
435 -- Ada 2005 (AI-251): If this primitive operation corresponds with
436 -- an immediate ancestor interface there is no need to add it to the
437 -- list of interpretations. The corresponding aliased primitive is
438 -- also in this list of primitive operations and will be used instead
439 -- because otherwise we have a dummy ambiguity between the two
440 -- subprograms which are in fact the same.
443 (Find_Dispatching_Type
(Interface_Alias
(E
)),
444 Find_Dispatching_Type
(E
))
446 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
448 -- Otherwise this is the first interpretation, N has type Any_Type
449 -- and we must place the new type on the node.
457 -- Calling stubs for an RACW operation never participate in resolution,
458 -- they are executed only through dispatching calls.
460 elsif Is_RACW_Stub_Type_Operation
(E
) then
464 -- If this is the first interpretation of N, N has type Any_Type.
465 -- In that case place the new type on the node. If one interpretation
466 -- already exists, indicate that the node is overloaded, and store
467 -- both the previous and the new interpretation in All_Interp. If
468 -- this is a later interpretation, just add it to the set.
470 if Etype
(N
) = Any_Type
then
475 -- Record both the operator or subprogram name, and its type
477 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
484 -- Either there is no current interpretation in the table for any
485 -- node or the interpretation that is present is for a different
486 -- node. In both cases add a new interpretation to the table.
488 elsif No
(Last_Overloaded
)
490 (Last_Overloaded
/= N
491 and then not Is_Overloaded
(N
))
495 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
496 and then Present
(Entity
(N
))
498 Add_Entry
(Entity
(N
), Etype
(N
));
500 elsif Nkind
(N
) in N_Subprogram_Call
501 and then Is_Entity_Name
(Name
(N
))
503 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
505 -- If this is an indirect call there will be no name associated
506 -- with the previous entry. To make diagnostics clearer, save
507 -- Subprogram_Type of first interpretation, so that the error will
508 -- point to the anonymous access to subprogram, not to the result
509 -- type of the call itself.
511 elsif (Nkind
(N
)) = N_Function_Call
512 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
513 and then Is_Overloaded
(Name
(N
))
519 pragma Warnings
(Off
, Itn
);
522 Get_First_Interp
(Name
(N
), Itn
, It
);
523 Add_Entry
(It
.Nam
, Etype
(N
));
527 -- Overloaded prefix in indexed or selected component, or call
528 -- whose name is an expression or another call.
530 Add_Entry
(Etype
(N
), Etype
(N
));
544 procedure All_Overloads
is
546 for J
in All_Interp
.First
.. All_Interp
.Last
loop
548 if Present
(All_Interp
.Table
(J
).Nam
) then
549 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
551 Write_Str
("No Interp");
555 Write_Str
("=================");
560 --------------------------------------
561 -- Binary_Op_Interp_Has_Abstract_Op --
562 --------------------------------------
564 function Binary_Op_Interp_Has_Abstract_Op
566 E
: Entity_Id
) return Entity_Id
568 Abstr_Op
: Entity_Id
;
569 E_Left
: constant Node_Id
:= First_Formal
(E
);
570 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
573 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
574 if Present
(Abstr_Op
) then
578 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
579 end Binary_Op_Interp_Has_Abstract_Op
;
581 ---------------------
582 -- Collect_Interps --
583 ---------------------
585 procedure Collect_Interps
(N
: Node_Id
) is
586 Ent
: constant Entity_Id
:= Entity
(N
);
588 First_Interp
: Interp_Index
;
590 function Within_Instance
(E
: Entity_Id
) return Boolean;
591 -- Within an instance there can be spurious ambiguities between a local
592 -- entity and one declared outside of the instance. This can only happen
593 -- for subprograms, because otherwise the local entity hides the outer
594 -- one. For an overloadable entity, this predicate determines whether it
595 -- is a candidate within the instance, or must be ignored.
597 ---------------------
598 -- Within_Instance --
599 ---------------------
601 function Within_Instance
(E
: Entity_Id
) return Boolean is
606 if not In_Instance
then
610 Inst
:= Current_Scope
;
611 while Present
(Inst
) and then not Is_Generic_Instance
(Inst
) loop
612 Inst
:= Scope
(Inst
);
616 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
621 Scop
:= Scope
(Scop
);
627 -- Start of processing for Collect_Interps
632 -- Unconditionally add the entity that was initially matched
634 First_Interp
:= All_Interp
.Last
;
635 Add_One_Interp
(N
, Ent
, Etype
(N
));
637 -- For expanded name, pick up all additional entities from the
638 -- same scope, since these are obviously also visible. Note that
639 -- these are not necessarily contiguous on the homonym chain.
641 if Nkind
(N
) = N_Expanded_Name
then
643 while Present
(H
) loop
644 if Scope
(H
) = Scope
(Entity
(N
)) then
645 Add_One_Interp
(N
, H
, Etype
(H
));
651 -- Case of direct name
654 -- First, search the homonym chain for directly visible entities
656 H
:= Current_Entity
(Ent
);
657 while Present
(H
) loop
659 not Is_Overloadable
(H
)
660 and then Is_Immediately_Visible
(H
);
662 if Is_Immediately_Visible
(H
) and then H
/= Ent
then
664 -- Only add interpretation if not hidden by an inner
665 -- immediately visible one.
667 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
669 -- Current homograph is not hidden. Add to overloads
671 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
674 -- Homograph is hidden, unless it is a predefined operator
676 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
678 -- A homograph in the same scope can occur within an
679 -- instantiation, the resulting ambiguity has to be
680 -- resolved later. The homographs may both be local
681 -- functions or actuals, or may be declared at different
682 -- levels within the instance. The renaming of an actual
683 -- within the instance must not be included.
685 if Within_Instance
(H
)
686 and then H
/= Renamed_Entity
(Ent
)
687 and then not Is_Inherited_Operation
(H
)
689 All_Interp
.Table
(All_Interp
.Last
) :=
690 (H
, Etype
(H
), Empty
);
691 All_Interp
.Append
(No_Interp
);
694 elsif Scope
(H
) /= Standard_Standard
then
700 -- On exit, we know that current homograph is not hidden
702 Add_One_Interp
(N
, H
, Etype
(H
));
705 Write_Str
("Add overloaded interpretation ");
715 -- Scan list of homographs for use-visible entities only
717 H
:= Current_Entity
(Ent
);
719 while Present
(H
) loop
720 if Is_Potentially_Use_Visible
(H
)
722 and then Is_Overloadable
(H
)
724 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
726 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
729 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
730 goto Next_Use_Homograph
;
734 Add_One_Interp
(N
, H
, Etype
(H
));
737 <<Next_Use_Homograph
>>
742 if All_Interp
.Last
= First_Interp
+ 1 then
744 -- The final interpretation is in fact not overloaded. Note that the
745 -- unique legal interpretation may or may not be the original one,
746 -- so we need to update N's entity and etype now, because once N
747 -- is marked as not overloaded it is also expected to carry the
748 -- proper interpretation.
750 Set_Is_Overloaded
(N
, False);
751 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
752 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
760 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
764 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
765 -- In an instance the proper view may not always be correct for
766 -- private types, but private and full view are compatible. This
767 -- removes spurious errors from nested instantiations that involve,
768 -- among other things, types derived from private types.
770 function Real_Actual
(T
: Entity_Id
) return Entity_Id
;
771 -- If an actual in an inner instance is the formal of an enclosing
772 -- generic, the actual in the enclosing instance is the one that can
773 -- create an accidental ambiguity, and the check on compatibily of
774 -- generic actual types must use this enclosing actual.
776 ----------------------
777 -- Full_View_Covers --
778 ----------------------
780 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
782 if Present
(Full_View
(Typ1
))
783 and then Covers
(Full_View
(Typ1
), Typ2
)
787 elsif Present
(Underlying_Full_View
(Typ1
))
788 and then Covers
(Underlying_Full_View
(Typ1
), Typ2
)
795 end Full_View_Covers
;
801 function Real_Actual
(T
: Entity_Id
) return Entity_Id
is
802 Par
: constant Node_Id
:= Parent
(T
);
806 -- Retrieve parent subtype from subtype declaration for actual
808 if Nkind
(Par
) = N_Subtype_Declaration
809 and then not Comes_From_Source
(Par
)
810 and then Is_Entity_Name
(Subtype_Indication
(Par
))
812 RA
:= Entity
(Subtype_Indication
(Par
));
814 if Is_Generic_Actual_Type
(RA
) then
819 -- Otherwise actual is not the actual of an enclosing instance
824 -- Start of processing for Covers
827 -- If either operand is missing, then this is an error, but ignore it
828 -- and pretend we have a cover if errors already detected since this may
829 -- simply mean we have malformed trees or a semantic error upstream.
831 if No
(T1
) or else No
(T2
) then
832 if Total_Errors_Detected
/= 0 then
839 -- Trivial case: same types are always compatible
845 -- First check for Standard_Void_Type, which is special. Subsequent
846 -- processing in this routine assumes T1 and T2 are bona fide types;
847 -- Standard_Void_Type is a special entity that has some, but not all,
848 -- properties of types.
850 if T1
= Standard_Void_Type
or else T2
= Standard_Void_Type
then
854 BT1
:= Base_Type
(T1
);
855 BT2
:= Base_Type
(T2
);
857 -- Handle underlying view of records with unknown discriminants
858 -- using the original entity that motivated the construction of
859 -- this underlying record view (see Build_Derived_Private_Type).
861 if Is_Underlying_Record_View
(BT1
) then
862 BT1
:= Underlying_Record_View
(BT1
);
865 if Is_Underlying_Record_View
(BT2
) then
866 BT2
:= Underlying_Record_View
(BT2
);
869 -- Simplest case: types that have the same base type and are not generic
870 -- actuals are compatible. Generic actuals belong to their class but are
871 -- not compatible with other types of their class, and in particular
872 -- with other generic actuals. They are however compatible with their
873 -- own subtypes, and itypes with the same base are compatible as well.
874 -- Similarly, constrained subtypes obtained from expressions of an
875 -- unconstrained nominal type are compatible with the base type (may
876 -- lead to spurious ambiguities in obscure cases ???)
878 -- Generic actuals require special treatment to avoid spurious ambi-
879 -- guities in an instance, when two formal types are instantiated with
880 -- the same actual, so that different subprograms end up with the same
881 -- signature in the instance. If a generic actual is the actual of an
882 -- enclosing instance, it is that actual that we must compare: generic
883 -- actuals are only incompatible if they appear in the same instance.
889 if not Is_Generic_Actual_Type
(T1
)
891 not Is_Generic_Actual_Type
(T2
)
895 -- Both T1 and T2 are generic actual types
899 RT1
: constant Entity_Id
:= Real_Actual
(T1
);
900 RT2
: constant Entity_Id
:= Real_Actual
(T2
);
903 or else Is_Itype
(T1
)
904 or else Is_Itype
(T2
)
905 or else Is_Constr_Subt_For_U_Nominal
(T1
)
906 or else Is_Constr_Subt_For_U_Nominal
(T2
)
907 or else Scope
(RT1
) /= Scope
(RT2
);
911 -- Literals are compatible with types in a given "class"
913 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
914 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
915 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
916 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
917 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
918 or else (T2
= Any_String
and then Is_String_Type
(T1
))
919 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
923 -- The context may be class wide, and a class-wide type is compatible
924 -- with any member of the class.
926 elsif Is_Class_Wide_Type
(T1
)
927 and then Is_Ancestor
(Root_Type
(T1
), T2
)
931 elsif Is_Class_Wide_Type
(T1
)
932 and then Is_Class_Wide_Type
(T2
)
933 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
937 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
938 -- task_type or protected_type that implements the interface.
940 elsif Ada_Version
>= Ada_2005
941 and then Is_Concurrent_Type
(T2
)
942 and then Is_Class_Wide_Type
(T1
)
943 and then Is_Interface
(Etype
(T1
))
944 and then Interface_Present_In_Ancestor
945 (Typ
=> BT2
, Iface
=> Etype
(T1
))
949 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
950 -- object T2 implementing T1.
952 elsif Ada_Version
>= Ada_2005
953 and then Is_Tagged_Type
(T2
)
954 and then Is_Class_Wide_Type
(T1
)
955 and then Is_Interface
(Etype
(T1
))
957 if Interface_Present_In_Ancestor
(Typ
=> T2
,
968 if Is_Concurrent_Type
(BT2
) then
969 E
:= Corresponding_Record_Type
(BT2
);
974 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
975 -- covers an object T2 that implements a direct derivation of T1.
976 -- Note: test for presence of E is defense against previous error.
979 Check_Error_Detected
;
981 -- Here we have a corresponding record type
983 elsif Present
(Interfaces
(E
)) then
984 Elmt
:= First_Elmt
(Interfaces
(E
));
985 while Present
(Elmt
) loop
986 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
994 -- We should also check the case in which T1 is an ancestor of
995 -- some implemented interface???
1000 -- In a dispatching call, the formal is of some specific type, and the
1001 -- actual is of the corresponding class-wide type, including a subtype
1002 -- of the class-wide type.
1004 elsif Is_Class_Wide_Type
(T2
)
1006 (Class_Wide_Type
(T1
) = Class_Wide_Type
(T2
)
1007 or else Base_Type
(Root_Type
(T2
)) = BT1
)
1011 -- Some contexts require a class of types rather than a specific type.
1012 -- For example, conditions require any boolean type, fixed point
1013 -- attributes require some real type, etc. The built-in types Any_XXX
1014 -- represent these classes.
1016 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
1017 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
1018 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
1019 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
1020 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
1024 -- An aggregate is compatible with an array or record type
1026 elsif T2
= Any_Composite
and then Is_Aggregate_Type
(T1
) then
1029 -- In Ada_2022, an aggregate is compatible with the type that
1030 -- as the corresponding aspect.
1032 elsif Ada_Version
>= Ada_2022
1033 and then T2
= Any_Composite
1034 and then Present
(Find_Aspect
(T1
, Aspect_Aggregate
))
1038 -- If the expected type is an anonymous access, the designated type must
1039 -- cover that of the expression. Use the base type for this check: even
1040 -- though access subtypes are rare in sources, they are generated for
1041 -- actuals in instantiations.
1043 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
1044 and then Is_Access_Type
(T2
)
1045 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1049 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1050 -- of a named general access type. An implicit conversion will be
1051 -- applied. For the resolution, the designated types must match if
1052 -- untagged; further, if the designated type is tagged, the designated
1053 -- type of the anonymous access type shall be covered by the designated
1054 -- type of the named access type.
1056 elsif Ada_Version
>= Ada_2012
1057 and then Ekind
(BT1
) = E_General_Access_Type
1058 and then Ekind
(BT2
) = E_Anonymous_Access_Type
1059 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1060 and then (Is_Class_Wide_Type
(Designated_Type
(T1
)) >=
1061 Is_Class_Wide_Type
(Designated_Type
(T2
)))
1065 -- An Access_To_Subprogram is compatible with itself, or with an
1066 -- anonymous type created for an attribute reference Access.
1068 elsif Ekind
(BT1
) in E_Access_Subprogram_Type
1069 | E_Access_Protected_Subprogram_Type
1070 and then Is_Access_Type
(T2
)
1071 and then (not Comes_From_Source
(T1
)
1072 or else not Comes_From_Source
(T2
))
1073 and then (Is_Overloadable
(Designated_Type
(T2
))
1074 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1075 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1076 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1080 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1081 -- with itself, or with an anonymous type created for an attribute
1082 -- reference Access.
1084 elsif Ekind
(BT1
) in E_Anonymous_Access_Subprogram_Type
1085 | E_Anonymous_Access_Protected_Subprogram_Type
1086 and then Is_Access_Type
(T2
)
1087 and then (not Comes_From_Source
(T1
)
1088 or else not Comes_From_Source
(T2
))
1089 and then (Is_Overloadable
(Designated_Type
(T2
))
1090 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1091 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1092 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1096 -- The context can be a remote access type, and the expression the
1097 -- corresponding source type declared in a categorized package, or
1100 elsif Is_Record_Type
(T1
)
1101 and then (Is_Remote_Call_Interface
(T1
) or else Is_Remote_Types
(T1
))
1102 and then Present
(Corresponding_Remote_Type
(T1
))
1104 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
1108 elsif Is_Record_Type
(T2
)
1109 and then (Is_Remote_Call_Interface
(T2
) or else Is_Remote_Types
(T2
))
1110 and then Present
(Corresponding_Remote_Type
(T2
))
1112 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
1114 -- Synchronized types are represented at run time by their corresponding
1115 -- record type. During expansion one is replaced with the other, but
1116 -- they are compatible views of the same type.
1118 elsif Is_Record_Type
(T1
)
1119 and then Is_Concurrent_Type
(T2
)
1120 and then Present
(Corresponding_Record_Type
(T2
))
1122 return Covers
(T1
, Corresponding_Record_Type
(T2
));
1124 elsif Is_Concurrent_Type
(T1
)
1125 and then Present
(Corresponding_Record_Type
(T1
))
1126 and then Is_Record_Type
(T2
)
1128 return Covers
(Corresponding_Record_Type
(T1
), T2
);
1130 -- During analysis, an attribute reference 'Access has a special type
1131 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1132 -- imposed by context.
1134 elsif Ekind
(T2
) = E_Access_Attribute_Type
1135 and then Ekind
(BT1
) in E_General_Access_Type | E_Access_Type
1136 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1138 -- If the target type is a RACW type while the source is an access
1139 -- attribute type, we are building a RACW that may be exported.
1141 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1142 Set_Has_RACW
(Current_Sem_Unit
);
1147 -- Ditto for allocators, which eventually resolve to the context type
1149 elsif Ekind
(T2
) = E_Allocator_Type
and then Is_Access_Type
(T1
) then
1150 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1152 (From_Limited_With
(Designated_Type
(T1
))
1153 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1155 -- A boolean operation on integer literals is compatible with modular
1158 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
1161 -- The actual type may be the result of a previous error
1163 elsif BT2
= Any_Type
then
1166 -- A Raise_Expressions is legal in any expression context
1168 elsif BT2
= Raise_Type
then
1171 -- A packed array type covers its corresponding non-packed type. This is
1172 -- not legitimate Ada, but allows the omission of a number of otherwise
1173 -- useless unchecked conversions, and since this can only arise in
1174 -- (known correct) expanded code, no harm is done.
1176 elsif Is_Packed_Array
(T2
)
1177 and then T1
= Packed_Array_Impl_Type
(T2
)
1181 -- Similarly an array type covers its corresponding packed array type
1183 elsif Is_Packed_Array
(T1
)
1184 and then T2
= Packed_Array_Impl_Type
(T1
)
1188 -- In instances, or with types exported from instantiations, check
1189 -- whether a partial and a full view match. Verify that types are
1190 -- legal, to prevent cascaded errors.
1192 elsif Is_Private_Type
(T1
)
1193 and then (In_Instance
1194 or else (Is_Type
(T2
) and then Is_Generic_Actual_Type
(T2
)))
1195 and then Full_View_Covers
(T1
, T2
)
1199 elsif Is_Private_Type
(T2
)
1200 and then (In_Instance
1201 or else (Is_Type
(T1
) and then Is_Generic_Actual_Type
(T1
)))
1202 and then Full_View_Covers
(T2
, T1
)
1206 -- In the expansion of inlined bodies, types are compatible if they
1207 -- are structurally equivalent.
1209 elsif In_Inlined_Body
1210 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1212 (Is_Access_Type
(T1
)
1213 and then Is_Access_Type
(T2
)
1214 and then Designated_Type
(T1
) = Designated_Type
(T2
))
1217 and then Is_Access_Type
(Underlying_Type
(T2
)))
1220 and then Is_Composite_Type
(Underlying_Type
(T1
))))
1224 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1225 -- obtained through a limited_with compatible with its real entity.
1227 elsif From_Limited_With
(T1
) then
1229 -- If the expected type is the nonlimited view of a type, the
1230 -- expression may have the limited view. If that one in turn is
1231 -- incomplete, get full view if available.
1233 return Has_Non_Limited_View
(T1
)
1234 and then Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1236 elsif From_Limited_With
(T2
) then
1238 -- If units in the context have Limited_With clauses on each other,
1239 -- either type might have a limited view. Checks performed elsewhere
1240 -- verify that the context type is the nonlimited view.
1242 return Has_Non_Limited_View
(T2
)
1243 and then Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1245 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1247 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1248 return Covers
(Full_View
(Etype
(T1
)), T2
);
1250 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1251 return Covers
(T1
, Full_View
(Etype
(T2
)));
1253 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1254 -- and actual anonymous access types in the context of generic
1255 -- instantiations. We have the following situation:
1258 -- type Formal is private;
1259 -- Formal_Obj : access Formal; -- T1
1263 -- type Actual is ...
1264 -- Actual_Obj : access Actual; -- T2
1265 -- package Instance is new G (Formal => Actual,
1266 -- Formal_Obj => Actual_Obj);
1268 elsif Ada_Version
>= Ada_2005
1269 and then Is_Anonymous_Access_Type
(T1
)
1270 and then Is_Anonymous_Access_Type
(T2
)
1271 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1272 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1273 Directly_Designated_Type
(T2
)
1277 -- Otherwise, types are not compatible
1288 function Disambiguate
1290 I1
, I2
: Interp_Index
;
1291 Typ
: Entity_Id
) return Interp
1296 Nam1
, Nam2
: Entity_Id
;
1297 Predef_Subp
: Entity_Id
;
1298 User_Subp
: Entity_Id
;
1300 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1301 -- Determine whether one of the candidates is an operation inherited by
1302 -- a type that is derived from an actual in an instantiation.
1304 function In_Same_Declaration_List
1306 Op_Decl
: Entity_Id
) return Boolean;
1307 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1308 -- access types is declared on the partial view of a designated type, so
1309 -- that the type declaration and equality are not in the same list of
1310 -- declarations. This AI gives a preference rule for the user-defined
1311 -- operation. Same rule applies for arithmetic operations on private
1312 -- types completed with fixed-point types: the predefined operation is
1313 -- hidden; this is already handled properly in GNAT.
1315 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1316 -- Determine whether a subprogram is an actual in an enclosing instance.
1317 -- An overloading between such a subprogram and one declared outside the
1318 -- instance is resolved in favor of the first, because it resolved in
1319 -- the generic. Within the instance the actual is represented by a
1320 -- constructed subprogram renaming.
1322 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean;
1323 -- Determine whether function Func_Id is an exact match for binary or
1324 -- unary operator Op.
1326 function Operand_Type
return Entity_Id
;
1327 -- Determine type of operand for an equality operation, to apply Ada
1328 -- 2005 rules to equality on anonymous access types.
1330 function Standard_Operator
return Boolean;
1331 -- Check whether subprogram is predefined operator declared in Standard.
1332 -- It may given by an operator name, or by an expanded name whose prefix
1335 function Remove_Conversions
return Interp
;
1336 -- Last chance for pathological cases involving comparisons on literals,
1337 -- and user overloadings of the same operator. Such pathologies have
1338 -- been removed from the ACVC, but still appear in two DEC tests, with
1339 -- the following notable quote from Ben Brosgol:
1341 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1342 -- this example; Robert Dewar brought it to our attention, since it is
1343 -- apparently found in the ACVC 1.5. I did not attempt to find the
1344 -- reason in the Reference Manual that makes the example legal, since I
1345 -- was too nauseated by it to want to pursue it further.]
1347 -- Accordingly, this is not a fully recursive solution, but it handles
1348 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1349 -- pathology in the other direction with calls whose multiple overloaded
1350 -- actuals make them truly unresolvable.
1352 -- The new rules concerning abstract operations create additional need
1353 -- for special handling of expressions with universal operands, see
1354 -- comments to Has_Abstract_Interpretation below.
1356 function Is_User_Defined_Anonymous_Access_Equality
1357 (User_Subp
, Predef_Subp
: Entity_Id
) return Boolean;
1358 -- Check for Ada 2005, AI-020: If the context involves an anonymous
1359 -- access operand, recognize a user-defined equality (User_Subp) with
1360 -- the proper signature, declared in the same declarative list as the
1361 -- type and not hiding a predefined equality Predef_Subp.
1363 ---------------------------
1364 -- Inherited_From_Actual --
1365 ---------------------------
1367 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1368 Par
: constant Node_Id
:= Parent
(S
);
1370 if Nkind
(Par
) /= N_Full_Type_Declaration
1371 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1375 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1377 Is_Generic_Actual_Type
(
1378 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1380 end Inherited_From_Actual
;
1382 ------------------------------
1383 -- In_Same_Declaration_List --
1384 ------------------------------
1386 function In_Same_Declaration_List
1388 Op_Decl
: Entity_Id
) return Boolean
1390 Scop
: constant Entity_Id
:= Scope
(Typ
);
1393 return In_Same_List
(Parent
(Typ
), Op_Decl
)
1395 (Is_Package_Or_Generic_Package
(Scop
)
1396 and then List_Containing
(Op_Decl
) =
1397 Visible_Declarations
(Parent
(Scop
))
1398 and then List_Containing
(Parent
(Typ
)) =
1399 Private_Declarations
(Parent
(Scop
)));
1400 end In_Same_Declaration_List
;
1402 --------------------------
1403 -- Is_Actual_Subprogram --
1404 --------------------------
1406 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1408 return In_Open_Scopes
(Scope
(S
))
1409 and then Nkind
(Unit_Declaration_Node
(S
)) =
1410 N_Subprogram_Renaming_Declaration
1412 -- Determine if the renaming came from source or was generated as a
1413 -- a result of generic expansion since the actual is represented by
1414 -- a constructed subprogram renaming.
1416 and then not Comes_From_Source
(Unit_Declaration_Node
(S
))
1419 (Is_Generic_Instance
(Scope
(S
))
1420 or else Is_Wrapper_Package
(Scope
(S
)));
1421 end Is_Actual_Subprogram
;
1427 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean is
1428 function Matching_Types
1429 (Opnd_Typ
: Entity_Id
;
1430 Formal_Typ
: Entity_Id
) return Boolean;
1431 -- Determine whether operand type Opnd_Typ and formal parameter type
1432 -- Formal_Typ are either the same or compatible.
1434 --------------------
1435 -- Matching_Types --
1436 --------------------
1438 function Matching_Types
1439 (Opnd_Typ
: Entity_Id
;
1440 Formal_Typ
: Entity_Id
) return Boolean
1445 if Opnd_Typ
= Formal_Typ
then
1448 -- Any integer type matches universal integer
1450 elsif Opnd_Typ
= Universal_Integer
1451 and then Is_Integer_Type
(Formal_Typ
)
1455 -- Any floating point type matches universal real
1457 elsif Opnd_Typ
= Universal_Real
1458 and then Is_Floating_Point_Type
(Formal_Typ
)
1462 -- The type of the formal parameter maps a generic actual type to
1463 -- a generic formal type. If the operand type is the type being
1464 -- mapped in an instance, then this is a match.
1466 elsif Is_Generic_Actual_Type
(Formal_Typ
)
1467 and then Etype
(Formal_Typ
) = Opnd_Typ
1471 -- Formal_Typ is a private view, or Opnd_Typ and Formal_Typ are
1472 -- compatible only on a base-type basis.
1481 F1
: constant Entity_Id
:= First_Formal
(Func_Id
);
1482 F1_Typ
: constant Entity_Id
:= Etype
(F1
);
1483 F2
: constant Entity_Id
:= Next_Formal
(F1
);
1484 F2_Typ
: constant Entity_Id
:= Etype
(F2
);
1485 Lop_Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(Op
));
1486 Rop_Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(Op
));
1488 -- Start of processing for Matches
1491 if Lop_Typ
= F1_Typ
then
1492 return Matching_Types
(Rop_Typ
, F2_Typ
);
1494 elsif Rop_Typ
= F2_Typ
then
1495 return Matching_Types
(Lop_Typ
, F1_Typ
);
1497 -- Otherwise this is not a good match because each operand-formal
1498 -- pair is compatible only on base-type basis, which is not specific
1510 function Operand_Type
return Entity_Id
is
1514 if Nkind
(N
) = N_Function_Call
then
1515 Opnd
:= First_Actual
(N
);
1517 Opnd
:= Left_Opnd
(N
);
1520 return Etype
(Opnd
);
1523 ------------------------
1524 -- Remove_Conversions --
1525 ------------------------
1527 function Remove_Conversions
return Interp
is
1535 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1536 -- If an operation has universal operands the universal operation
1537 -- is present among its interpretations. If there is an abstract
1538 -- interpretation for the operator, with a numeric result, this
1539 -- interpretation was already removed in sem_ch4, but the universal
1540 -- one is still visible. We must rescan the list of operators and
1541 -- remove the universal interpretation to resolve the ambiguity.
1543 ---------------------------------
1544 -- Has_Abstract_Interpretation --
1545 ---------------------------------
1547 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1551 if Nkind
(N
) not in N_Op
1552 or else Ada_Version
< Ada_2005
1553 or else not Is_Overloaded
(N
)
1554 or else No
(Universal_Interpretation
(N
))
1559 E
:= Get_Name_Entity_Id
(Chars
(N
));
1560 while Present
(E
) loop
1561 if Is_Overloadable
(E
)
1562 and then Is_Abstract_Subprogram
(E
)
1563 and then Is_Numeric_Type
(Etype
(E
))
1571 -- Finally, if an operand of the binary operator is itself
1572 -- an operator, recurse to see whether its own abstract
1573 -- interpretation is responsible for the spurious ambiguity.
1575 if Nkind
(N
) in N_Binary_Op
then
1576 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1577 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1579 elsif Nkind
(N
) in N_Unary_Op
then
1580 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1586 end Has_Abstract_Interpretation
;
1588 -- Start of processing for Remove_Conversions
1593 Get_First_Interp
(N
, I
, It
);
1594 while Present
(It
.Typ
) loop
1595 if not Is_Overloadable
(It
.Nam
) then
1599 F1
:= First_Formal
(It
.Nam
);
1605 if Nkind
(N
) in N_Subprogram_Call
then
1606 Act1
:= First_Actual
(N
);
1608 if Present
(Act1
) then
1609 Act2
:= Next_Actual
(Act1
);
1614 elsif Nkind
(N
) in N_Unary_Op
then
1615 Act1
:= Right_Opnd
(N
);
1618 elsif Nkind
(N
) in N_Binary_Op
then
1619 Act1
:= Left_Opnd
(N
);
1620 Act2
:= Right_Opnd
(N
);
1622 -- Use the type of the second formal, so as to include
1623 -- exponentiation, where the exponent may be ambiguous and
1624 -- the result non-universal.
1632 if Nkind
(Act1
) in N_Op
1633 and then Is_Overloaded
(Act1
)
1635 (Nkind
(Act1
) in N_Unary_Op
1636 or else Nkind
(Left_Opnd
(Act1
)) in
1637 N_Integer_Literal | N_Real_Literal
)
1638 and then Nkind
(Right_Opnd
(Act1
)) in
1639 N_Integer_Literal | N_Real_Literal
1640 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1641 and then Etype
(F1
) = Standard_Boolean
1643 -- If the two candidates are the original ones, the
1644 -- ambiguity is real. Otherwise keep the original, further
1645 -- calls to Disambiguate will take care of others in the
1646 -- list of candidates.
1648 if It1
/= No_Interp
then
1649 if It
= Disambiguate
.It1
1650 or else It
= Disambiguate
.It2
1652 if It1
= Disambiguate
.It1
1653 or else It1
= Disambiguate
.It2
1661 elsif Present
(Act2
)
1662 and then Nkind
(Act2
) in N_Op
1663 and then Is_Overloaded
(Act2
)
1664 and then Nkind
(Right_Opnd
(Act2
)) in
1665 N_Integer_Literal | N_Real_Literal
1666 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1668 -- The preference rule on the first actual is not
1669 -- sufficient to disambiguate.
1677 elsif Is_Numeric_Type
(Etype
(F1
))
1678 and then Has_Abstract_Interpretation
(Act1
)
1680 -- Current interpretation is not the right one because it
1681 -- expects a numeric operand. Examine all the other ones.
1688 Get_First_Interp
(N
, I
, It
);
1689 while Present
(It
.Typ
) loop
1691 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1694 or else not Has_Abstract_Interpretation
(Act2
)
1697 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1703 Get_Next_Interp
(I
, It
);
1712 Get_Next_Interp
(I
, It
);
1715 -- After some error, a formal may have Any_Type and yield a spurious
1716 -- match. To avoid cascaded errors if possible, check for such a
1717 -- formal in either candidate.
1719 if Serious_Errors_Detected
> 0 then
1724 Formal
:= First_Formal
(Nam1
);
1725 while Present
(Formal
) loop
1726 if Etype
(Formal
) = Any_Type
then
1727 return Disambiguate
.It2
;
1730 Next_Formal
(Formal
);
1733 Formal
:= First_Formal
(Nam2
);
1734 while Present
(Formal
) loop
1735 if Etype
(Formal
) = Any_Type
then
1736 return Disambiguate
.It1
;
1739 Next_Formal
(Formal
);
1745 end Remove_Conversions
;
1747 -----------------------
1748 -- Standard_Operator --
1749 -----------------------
1751 function Standard_Operator
return Boolean is
1755 if Nkind
(N
) in N_Op
then
1758 elsif Nkind
(N
) = N_Function_Call
then
1761 if Nkind
(Nam
) /= N_Expanded_Name
then
1764 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1769 end Standard_Operator
;
1771 -----------------------------------------------
1772 -- Is_User_Defined_Anonymous_Access_Equality --
1773 -----------------------------------------------
1775 function Is_User_Defined_Anonymous_Access_Equality
1776 (User_Subp
, Predef_Subp
: Entity_Id
) return Boolean is
1778 return Present
(User_Subp
)
1780 -- Check for Ada 2005 and use of anonymous access
1782 and then Ada_Version
>= Ada_2005
1783 and then Etype
(User_Subp
) = Standard_Boolean
1784 and then Is_Anonymous_Access_Type
(Operand_Type
)
1786 -- This check is only relevant if User_Subp is visible and not in
1789 and then (In_Open_Scopes
(Scope
(User_Subp
))
1790 or else Is_Potentially_Use_Visible
(User_Subp
))
1791 and then not In_Instance
1792 and then not Hides_Op
(User_Subp
, Predef_Subp
)
1794 -- Is User_Subp declared in the same declarative list as the type?
1797 In_Same_Declaration_List
1798 (Designated_Type
(Operand_Type
),
1799 Unit_Declaration_Node
(User_Subp
));
1800 end Is_User_Defined_Anonymous_Access_Equality
;
1802 -- Start of processing for Disambiguate
1805 -- Recover the two legal interpretations
1807 Get_First_Interp
(N
, I
, It
);
1809 Get_Next_Interp
(I
, It
);
1816 Get_Next_Interp
(I
, It
);
1822 -- Check whether one of the entities is an Ada 2005/2012/2022 and we
1823 -- are operating in an earlier mode, in which case we discard the Ada
1824 -- 2005/2012/2022 entity, so that we get proper Ada 95 overload
1827 if Ada_Version
< Ada_2005
then
1828 if Is_Ada_2005_Only
(Nam1
)
1829 or else Is_Ada_2012_Only
(Nam1
)
1830 or else Is_Ada_2022_Only
(Nam1
)
1834 elsif Is_Ada_2005_Only
(Nam2
)
1835 or else Is_Ada_2012_Only
(Nam2
)
1836 or else Is_Ada_2022_Only
(Nam2
)
1841 -- Check whether one of the entities is an Ada 2012/2022 entity and we
1842 -- are operating in Ada 2005 mode, in which case we discard the Ada 2012
1843 -- Ada 2022 entity, so that we get proper Ada 2005 overload resolution.
1845 elsif Ada_Version
= Ada_2005
then
1846 if Is_Ada_2012_Only
(Nam1
) or else Is_Ada_2022_Only
(Nam1
) then
1848 elsif Is_Ada_2012_Only
(Nam2
) or else Is_Ada_2022_Only
(Nam2
) then
1852 -- Ditto for Ada 2012 vs Ada 2022.
1854 elsif Ada_Version
= Ada_2012
then
1855 if Is_Ada_2022_Only
(Nam1
) then
1857 elsif Is_Ada_2022_Only
(Nam2
) then
1862 -- If the context is universal, the predefined operator is preferred.
1863 -- This includes bounds in numeric type declarations, and expressions
1864 -- in type conversions. If no interpretation yields a universal type,
1865 -- then we must check whether the user-defined entity hides the prede-
1868 if Chars
(Nam1
) in Any_Operator_Name
and then Standard_Operator
then
1869 if Typ
= Universal_Integer
1870 or else Typ
= Universal_Real
1871 or else Typ
= Any_Integer
1872 or else Typ
= Any_Discrete
1873 or else Typ
= Any_Real
1874 or else Typ
= Any_Type
1876 -- Find an interpretation that yields the universal type, or else
1877 -- a predefined operator that yields a predefined numeric type.
1880 Candidate
: Interp
:= No_Interp
;
1883 Get_First_Interp
(N
, I
, It
);
1884 while Present
(It
.Typ
) loop
1885 if Is_Universal_Numeric_Type
(It
.Typ
)
1886 and then (Typ
= Any_Type
or else Covers
(Typ
, It
.Typ
))
1890 elsif Is_Numeric_Type
(It
.Typ
)
1891 and then Scope
(It
.Typ
) = Standard_Standard
1892 and then Scope
(It
.Nam
) = Standard_Standard
1893 and then Covers
(Typ
, It
.Typ
)
1898 Get_Next_Interp
(I
, It
);
1901 if Candidate
/= No_Interp
then
1906 elsif Chars
(Nam1
) /= Name_Op_Not
1907 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1909 -- Equality or comparison operation. Choose predefined operator if
1910 -- arguments are universal. The node may be an operator, name, or
1911 -- a function call, so unpack arguments accordingly.
1914 Arg1
, Arg2
: Node_Id
;
1917 if Nkind
(N
) in N_Op
then
1918 Arg1
:= Left_Opnd
(N
);
1919 Arg2
:= Right_Opnd
(N
);
1921 elsif Is_Entity_Name
(N
) then
1922 Arg1
:= First_Entity
(Entity
(N
));
1923 Arg2
:= Next_Entity
(Arg1
);
1926 Arg1
:= First_Actual
(N
);
1927 Arg2
:= Next_Actual
(Arg1
);
1930 if Present
(Arg2
) then
1931 if Ekind
(Nam1
) = E_Operator
then
1932 Predef_Subp
:= Nam1
;
1934 elsif Ekind
(Nam2
) = E_Operator
then
1935 Predef_Subp
:= Nam2
;
1938 Predef_Subp
:= Empty
;
1942 -- Take into account universal interpretation as well as
1943 -- universal_access equality, as long as AI05-0020 does not
1946 if (Present
(Universal_Interpretation
(Arg1
))
1947 and then Universal_Interpretation
(Arg2
) =
1948 Universal_Interpretation
(Arg1
))
1950 (Nkind
(N
) in N_Op_Eq | N_Op_Ne
1951 and then (Is_Anonymous_Access_Type
(Etype
(Arg1
))
1953 Is_Anonymous_Access_Type
(Etype
(Arg2
)))
1955 Is_User_Defined_Anonymous_Access_Equality
1956 (User_Subp
, Predef_Subp
))
1958 Get_First_Interp
(N
, I
, It
);
1959 while Scope
(It
.Nam
) /= Standard_Standard
loop
1960 Get_Next_Interp
(I
, It
);
1970 -- If no universal interpretation, check whether user-defined operator
1971 -- hides predefined one, as well as other special cases. If the node
1972 -- is a range, then one or both bounds are ambiguous. Each will have
1973 -- to be disambiguated w.r.t. the context type. The type of the range
1974 -- itself is imposed by the context, so we can return either legal
1977 if Ekind
(Nam1
) = E_Operator
then
1978 Predef_Subp
:= Nam1
;
1981 elsif Ekind
(Nam2
) = E_Operator
then
1982 Predef_Subp
:= Nam2
;
1985 elsif Nkind
(N
) = N_Range
then
1988 -- Implement AI05-105: A renaming declaration with an access
1989 -- definition must resolve to an anonymous access type. This
1990 -- is a resolution rule and can be used to disambiguate.
1992 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1993 and then Present
(Access_Definition
(Parent
(N
)))
1995 if Is_Anonymous_Access_Type
(It1
.Typ
) then
1996 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
2006 elsif Is_Anonymous_Access_Type
(It2
.Typ
) then
2009 -- No legal interpretation
2015 -- Two access attribute types may have been created for an expression
2016 -- with an implicit dereference, which is automatically overloaded.
2017 -- If both access attribute types designate the same object type,
2018 -- disambiguation if any will take place elsewhere, so keep any one of
2019 -- the interpretations.
2021 elsif Ekind
(It1
.Typ
) = E_Access_Attribute_Type
2022 and then Ekind
(It2
.Typ
) = E_Access_Attribute_Type
2023 and then Designated_Type
(It1
.Typ
) = Designated_Type
(It2
.Typ
)
2027 -- If two user defined-subprograms are visible, it is a true ambiguity,
2028 -- unless one of them is an entry and the context is a conditional or
2029 -- timed entry call, or unless we are within an instance and this is
2030 -- results from two formals types with the same actual.
2033 if Nkind
(N
) = N_Procedure_Call_Statement
2034 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
2035 and then N
= Entry_Call_Statement
(Parent
(N
))
2037 if Ekind
(Nam2
) = E_Entry
then
2039 elsif Ekind
(Nam1
) = E_Entry
then
2045 -- If the ambiguity occurs within an instance, it is due to several
2046 -- formal types with the same actual. Look for an exact match between
2047 -- the types of the formals of the overloadable entities, and the
2048 -- actuals in the call, to recover the unambiguous match in the
2049 -- original generic.
2051 -- The ambiguity can also be due to an overloading between a formal
2052 -- subprogram and a subprogram declared outside the generic. If the
2053 -- node is overloaded, it did not resolve to the global entity in
2054 -- the generic, and we choose the formal subprogram.
2056 -- Finally, the ambiguity can be between an explicit subprogram and
2057 -- one inherited (with different defaults) from an actual. In this
2058 -- case the resolution was to the explicit declaration in the
2059 -- generic, and remains so in the instance.
2061 -- The same sort of disambiguation needed for calls is also required
2062 -- for the name given in a subprogram renaming, and that case is
2063 -- handled here as well. We test Comes_From_Source to exclude this
2064 -- treatment for implicit renamings created for formal subprograms.
2066 elsif In_Instance
and then not In_Generic_Actual
(N
) then
2067 if Nkind
(N
) in N_Subprogram_Call
2069 (Nkind
(N
) in N_Has_Entity
2071 Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
2072 and then Comes_From_Source
(Parent
(N
)))
2077 Renam
: Entity_Id
:= Empty
;
2078 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
2079 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
2082 if Is_Act1
and then not Is_Act2
then
2085 elsif Is_Act2
and then not Is_Act1
then
2088 elsif Inherited_From_Actual
(Nam1
)
2089 and then Comes_From_Source
(Nam2
)
2093 elsif Inherited_From_Actual
(Nam2
)
2094 and then Comes_From_Source
(Nam1
)
2099 -- In the case of a renamed subprogram, pick up the entity
2100 -- of the renaming declaration so we can traverse its
2101 -- formal parameters.
2103 if Nkind
(N
) in N_Has_Entity
then
2104 Renam
:= Defining_Unit_Name
(Specification
(Parent
(N
)));
2107 if Present
(Renam
) then
2108 Actual
:= First_Formal
(Renam
);
2110 Actual
:= First_Actual
(N
);
2113 Formal
:= First_Formal
(Nam1
);
2114 while Present
(Actual
) loop
2115 if Etype
(Actual
) /= Etype
(Formal
) then
2119 if Present
(Renam
) then
2120 Next_Formal
(Actual
);
2122 Next_Actual
(Actual
);
2125 Next_Formal
(Formal
);
2131 elsif Nkind
(N
) in N_Binary_Op
then
2132 if Matches
(N
, Nam1
) then
2138 elsif Nkind
(N
) in N_Unary_Op
then
2139 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
2146 return Remove_Conversions
;
2149 return Remove_Conversions
;
2153 -- An implicit concatenation operator on a string type cannot be
2154 -- disambiguated from the predefined concatenation. This can only
2155 -- happen with concatenation of string literals.
2157 if Chars
(User_Subp
) = Name_Op_Concat
2158 and then Ekind
(User_Subp
) = E_Operator
2159 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
2163 -- If the user-defined operator is in an open scope, or in the scope
2164 -- of the resulting type, or given by an expanded name that names its
2165 -- scope, it hides the predefined operator for the type. Exponentiation
2166 -- has to be special-cased because the implicit operator does not have
2167 -- a symmetric signature, and may not be hidden by the explicit one.
2169 elsif (Nkind
(N
) = N_Function_Call
2170 and then Nkind
(Name
(N
)) = N_Expanded_Name
2171 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
2172 or else Hides_Op
(User_Subp
, Predef_Subp
))
2173 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
2174 or else Hides_Op
(User_Subp
, Predef_Subp
)
2176 if It1
.Nam
= User_Subp
then
2182 -- Otherwise, the predefined operator has precedence, or if the user-
2183 -- defined operation is directly visible we have a true ambiguity.
2185 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2186 -- exclude the universal_fixed operator, which often causes ambiguities
2189 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2190 -- on a partial view that is completed with a fixed point type. See
2191 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2192 -- user-defined type and subprogram, so that a client of the package
2193 -- has the same resolution as the body of the package.
2196 if (In_Open_Scopes
(Scope
(User_Subp
))
2197 or else Is_Potentially_Use_Visible
(User_Subp
))
2198 and then not In_Instance
2200 if Is_Fixed_Point_Type
(Typ
)
2201 and then Chars
(Nam1
) in Name_Op_Multiply | Name_Op_Divide
2203 (Ada_Version
= Ada_83
2204 or else (Ada_Version
>= Ada_2012
2205 and then In_Same_Declaration_List
2206 (First_Subtype
(Typ
),
2207 Unit_Declaration_Node
(User_Subp
))))
2209 if It2
.Nam
= Predef_Subp
then
2215 -- Check for AI05-020
2217 elsif Chars
(Nam1
) in Name_Op_Eq | Name_Op_Ne
2218 and then Is_User_Defined_Anonymous_Access_Equality
2219 (User_Subp
, Predef_Subp
)
2221 if It2
.Nam
= Predef_Subp
then
2227 -- An immediately visible operator hides a use-visible user-
2228 -- defined operation. This disambiguation cannot take place
2229 -- earlier because the visibility of the predefined operator
2230 -- can only be established when operand types are known.
2232 elsif Ekind
(User_Subp
) = E_Function
2233 and then Ekind
(Predef_Subp
) = E_Operator
2234 and then Nkind
(N
) in N_Op
2235 and then not Is_Overloaded
(Right_Opnd
(N
))
2237 Is_Immediately_Visible
(Base_Type
(Etype
(Right_Opnd
(N
))))
2238 and then Is_Potentially_Use_Visible
(User_Subp
)
2240 if It2
.Nam
= Predef_Subp
then
2250 elsif It1
.Nam
= Predef_Subp
then
2259 -------------------------
2260 -- Entity_Matches_Spec --
2261 -------------------------
2263 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
2265 -- Simple case: same entity kinds, type conformance is required. A
2266 -- parameterless function can also rename a literal.
2268 if Ekind
(Old_S
) = Ekind
(New_S
)
2269 or else (Ekind
(New_S
) = E_Function
2270 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
2272 return Type_Conformant
(New_S
, Old_S
);
2274 elsif Ekind
(New_S
) = E_Function
and then Ekind
(Old_S
) = E_Operator
then
2275 return Operator_Matches_Spec
(Old_S
, New_S
);
2277 elsif Ekind
(New_S
) = E_Procedure
and then Is_Entry
(Old_S
) then
2278 return Type_Conformant
(New_S
, Old_S
);
2283 end Entity_Matches_Spec
;
2285 ----------------------
2286 -- Find_Unique_Type --
2287 ----------------------
2289 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
2290 T
: constant Entity_Id
:= Etype
(L
);
2293 TR
: Entity_Id
:= Any_Type
;
2296 if Is_Overloaded
(R
) then
2297 Get_First_Interp
(R
, I
, It
);
2298 while Present
(It
.Typ
) loop
2299 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
2301 -- If several interpretations are possible and L is universal,
2302 -- apply preference rule.
2304 if TR
/= Any_Type
then
2305 if Is_Universal_Numeric_Type
(T
)
2316 Get_Next_Interp
(I
, It
);
2321 -- In the non-overloaded case, the Etype of R is already set correctly
2327 -- If one of the operands is Universal_Fixed, the type of the other
2328 -- operand provides the context.
2330 if Etype
(R
) = Universal_Fixed
then
2333 elsif T
= Universal_Fixed
then
2336 -- If one operand is a raise_expression, use type of other operand
2338 elsif Nkind
(L
) = N_Raise_Expression
then
2342 return Specific_Type
(T
, Etype
(R
));
2344 end Find_Unique_Type
;
2346 -------------------------------------
2347 -- Function_Interp_Has_Abstract_Op --
2348 -------------------------------------
2350 function Function_Interp_Has_Abstract_Op
2352 E
: Entity_Id
) return Entity_Id
2354 Abstr_Op
: Entity_Id
;
2357 Form_Parm
: Node_Id
;
2360 -- Why is check on E needed below ???
2361 -- In any case this para needs comments ???
2363 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2364 Act_Parm
:= First_Actual
(N
);
2365 Form_Parm
:= First_Formal
(E
);
2366 while Present
(Act_Parm
) and then Present
(Form_Parm
) loop
2369 if Nkind
(Act
) = N_Parameter_Association
then
2370 Act
:= Explicit_Actual_Parameter
(Act
);
2373 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2375 if Present
(Abstr_Op
) then
2379 Next_Actual
(Act_Parm
);
2380 Next_Formal
(Form_Parm
);
2385 end Function_Interp_Has_Abstract_Op
;
2387 ----------------------
2388 -- Get_First_Interp --
2389 ----------------------
2391 procedure Get_First_Interp
2393 I
: out Interp_Index
;
2396 Int_Ind
: Interp_Index
;
2400 -- If a selected component is overloaded because the selector has
2401 -- multiple interpretations, the node is a call to a protected
2402 -- operation or an indirect call. Retrieve the interpretation from
2403 -- the selector name. The selected component may be overloaded as well
2404 -- if the prefix is overloaded. That case is unchanged.
2406 if Nkind
(N
) = N_Selected_Component
2407 and then Is_Overloaded
(Selector_Name
(N
))
2409 O_N
:= Selector_Name
(N
);
2414 Int_Ind
:= Interp_Map
.Get
(O_N
);
2416 -- Procedure should never be called if the node has no interpretations
2419 raise Program_Error
;
2423 It
:= All_Interp
.Table
(Int_Ind
);
2424 end Get_First_Interp
;
2426 ---------------------
2427 -- Get_Next_Interp --
2428 ---------------------
2430 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2433 It
:= All_Interp
.Table
(I
);
2434 end Get_Next_Interp
;
2436 -------------------------
2437 -- Has_Compatible_Type --
2438 -------------------------
2440 function Has_Compatible_Type
2443 For_Comparison
: Boolean := False) return Boolean
2453 if Nkind
(N
) = N_Subtype_Indication
or else not Is_Overloaded
(N
) then
2454 if Covers
(Typ
, Etype
(N
))
2456 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2457 -- If the type is already frozen use the corresponding_record
2458 -- to check whether it is a proper descendant.
2461 (Is_Record_Type
(Typ
)
2462 and then Is_Concurrent_Type
(Etype
(N
))
2463 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2464 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2467 (Is_Concurrent_Type
(Typ
)
2468 and then Is_Record_Type
(Etype
(N
))
2469 and then Present
(Corresponding_Record_Type
(Typ
))
2470 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2473 (Nkind
(N
) = N_Integer_Literal
2474 and then Present
(Find_Aspect
(Typ
, Aspect_Integer_Literal
)))
2477 (Nkind
(N
) = N_Real_Literal
2478 and then Present
(Find_Aspect
(Typ
, Aspect_Real_Literal
)))
2481 (Nkind
(N
) = N_String_Literal
2482 and then Present
(Find_Aspect
(Typ
, Aspect_String_Literal
)))
2486 and then not Is_Tagged_Type
(Typ
)
2487 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2488 and then Covers
(Etype
(N
), Typ
))
2496 Get_First_Interp
(N
, I
, It
);
2497 while Present
(It
.Typ
) loop
2498 if (Covers
(Typ
, It
.Typ
)
2500 (Scope
(It
.Nam
) /= Standard_Standard
2501 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2503 -- Ada 2005 (AI-345)
2506 (Is_Record_Type
(Typ
)
2507 and then Is_Concurrent_Type
(It
.Typ
)
2508 and then Present
(Corresponding_Record_Type
2510 and then Covers
(Typ
, Corresponding_Record_Type
2515 and then not Is_Tagged_Type
(Typ
)
2516 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2517 and then Covers
(It
.Typ
, Typ
))
2522 Get_Next_Interp
(I
, It
);
2527 end Has_Compatible_Type
;
2529 ---------------------
2530 -- Has_Abstract_Op --
2531 ---------------------
2533 function Has_Abstract_Op
2535 Typ
: Entity_Id
) return Entity_Id
2541 if Is_Overloaded
(N
) then
2542 Get_First_Interp
(N
, I
, It
);
2543 while Present
(It
.Nam
) loop
2544 if Present
(It
.Abstract_Op
)
2545 and then Etype
(It
.Abstract_Op
) = Typ
2547 return It
.Abstract_Op
;
2550 Get_Next_Interp
(I
, It
);
2555 end Has_Abstract_Op
;
2561 function Hash
(N
: Node_Id
) return Header_Num
is
2563 return Header_Num
(N
mod Header_Max
);
2570 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2571 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2573 return Operator_Matches_Spec
(Op
, F
)
2574 and then (In_Open_Scopes
(Scope
(F
))
2575 or else Scope
(F
) = Scope
(Btyp
)
2576 or else (not In_Open_Scopes
(Scope
(Btyp
))
2577 and then not In_Use
(Btyp
)
2578 and then not In_Use
(Scope
(Btyp
))));
2581 ------------------------
2582 -- Init_Interp_Tables --
2583 ------------------------
2585 procedure Init_Interp_Tables
is
2589 end Init_Interp_Tables
;
2591 -----------------------------------
2592 -- Interface_Present_In_Ancestor --
2593 -----------------------------------
2595 function Interface_Present_In_Ancestor
2597 Iface
: Entity_Id
) return Boolean
2599 Target_Typ
: Entity_Id
;
2600 Iface_Typ
: Entity_Id
;
2602 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2603 -- Returns True if Typ or some ancestor of Typ implements Iface
2605 -------------------------------
2606 -- Iface_Present_In_Ancestor --
2607 -------------------------------
2609 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2615 if Typ
= Iface_Typ
then
2619 -- Handle private types
2621 if Present
(Full_View
(Typ
))
2622 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2624 E
:= Full_View
(Typ
);
2630 if Present
(Interfaces
(E
))
2631 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2633 Elmt
:= First_Elmt
(Interfaces
(E
));
2634 while Present
(Elmt
) loop
2637 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2645 exit when Etype
(E
) = E
2647 -- Handle private types
2649 or else (Present
(Full_View
(Etype
(E
)))
2650 and then Full_View
(Etype
(E
)) = E
);
2652 -- Check if the current type is a direct derivation of the
2655 if Etype
(E
) = Iface_Typ
then
2659 -- Climb to the immediate ancestor handling private types
2661 if Present
(Full_View
(Etype
(E
))) then
2662 E
:= Full_View
(Etype
(E
));
2669 end Iface_Present_In_Ancestor
;
2671 -- Start of processing for Interface_Present_In_Ancestor
2674 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2676 if Is_Class_Wide_Type
(Iface
) then
2677 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2684 Iface_Typ
:= Base_Type
(Iface_Typ
);
2686 if Is_Access_Type
(Typ
) then
2687 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2692 if Is_Concurrent_Record_Type
(Target_Typ
) then
2693 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2696 Target_Typ
:= Base_Type
(Target_Typ
);
2698 -- In case of concurrent types we can't use the Corresponding Record_Typ
2699 -- to look for the interface because it is built by the expander (and
2700 -- hence it is not always available). For this reason we traverse the
2701 -- list of interfaces (available in the parent of the concurrent type)
2703 if Is_Concurrent_Type
(Target_Typ
) then
2704 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2709 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2711 -- The progenitor itself may be a subtype of an interface type.
2713 while Present
(AI
) loop
2714 if Etype
(AI
) = Iface_Typ
2715 or else Base_Type
(Etype
(AI
)) = Iface_Typ
2719 elsif Present
(Interfaces
(Etype
(AI
)))
2720 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2733 if Is_Class_Wide_Type
(Target_Typ
) then
2734 Target_Typ
:= Etype
(Target_Typ
);
2737 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2739 -- We must have either a full view or a nonlimited view of the type
2740 -- to locate the list of ancestors.
2742 if Present
(Full_View
(Target_Typ
)) then
2743 Target_Typ
:= Full_View
(Target_Typ
);
2745 -- In a spec expression or in an expression function, the use of
2746 -- an incomplete type is legal; legality of the conversion will be
2747 -- checked at freeze point of related entity.
2749 if In_Spec_Expression
then
2753 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2754 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2758 -- Protect the front end against previously detected errors
2760 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2765 return Iface_Present_In_Ancestor
(Target_Typ
);
2766 end Interface_Present_In_Ancestor
;
2768 ---------------------
2769 -- Intersect_Types --
2770 ---------------------
2772 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2773 Index
: Interp_Index
;
2777 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2778 -- Find interpretation of right arg that has type compatible with T
2780 --------------------------
2781 -- Check_Right_Argument --
2782 --------------------------
2784 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2785 Index
: Interp_Index
;
2790 if not Is_Overloaded
(R
) then
2791 return Specific_Type
(T
, Etype
(R
));
2794 Get_First_Interp
(R
, Index
, It
);
2796 T2
:= Specific_Type
(T
, It
.Typ
);
2798 if T2
/= Any_Type
then
2802 Get_Next_Interp
(Index
, It
);
2803 exit when No
(It
.Typ
);
2808 end Check_Right_Argument
;
2810 -- Start of processing for Intersect_Types
2813 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2817 if not Is_Overloaded
(L
) then
2818 Typ
:= Check_Right_Argument
(Etype
(L
));
2822 Get_First_Interp
(L
, Index
, It
);
2823 while Present
(It
.Typ
) loop
2824 Typ
:= Check_Right_Argument
(It
.Typ
);
2825 exit when Typ
/= Any_Type
;
2826 Get_Next_Interp
(Index
, It
);
2831 -- If Typ is Any_Type, it means no compatible pair of types was found
2833 if Typ
= Any_Type
then
2834 if Nkind
(Parent
(L
)) in N_Op
then
2835 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2837 elsif Nkind
(Parent
(L
)) = N_Range
then
2838 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2840 -- Ada 2005 (AI-251): Complete the error notification
2842 elsif Is_Class_Wide_Type
(Etype
(R
))
2843 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2845 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2846 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2848 -- Specialize message if one operand is a limited view, a priori
2849 -- unrelated to all other types.
2851 elsif From_Limited_With
(Etype
(R
)) then
2852 Error_Msg_NE
("limited view of& not compatible with context",
2855 elsif From_Limited_With
(Etype
(L
)) then
2856 Error_Msg_NE
("limited view of& not compatible with context",
2859 Error_Msg_N
("incompatible types", Parent
(L
));
2864 end Intersect_Types
;
2866 -----------------------
2867 -- In_Generic_Actual --
2868 -----------------------
2870 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2871 Par
: constant Node_Id
:= Parent
(Exp
);
2877 elsif Nkind
(Par
) in N_Declaration
then
2879 Nkind
(Par
) = N_Object_Declaration
2880 and then Present
(Corresponding_Generic_Association
(Par
));
2882 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2883 return Present
(Corresponding_Generic_Association
(Par
));
2885 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2889 return In_Generic_Actual
(Par
);
2891 end In_Generic_Actual
;
2897 function Is_Ancestor
2900 Use_Full_View
: Boolean := False) return Boolean
2907 BT1
:= Base_Type
(T1
);
2908 BT2
:= Base_Type
(T2
);
2910 -- Handle underlying view of records with unknown discriminants using
2911 -- the original entity that motivated the construction of this
2912 -- underlying record view (see Build_Derived_Private_Type).
2914 if Is_Underlying_Record_View
(BT1
) then
2915 BT1
:= Underlying_Record_View
(BT1
);
2918 if Is_Underlying_Record_View
(BT2
) then
2919 BT2
:= Underlying_Record_View
(BT2
);
2925 -- The predicate must look past privacy
2927 elsif Is_Private_Type
(T1
)
2928 and then Present
(Full_View
(T1
))
2929 and then BT2
= Base_Type
(Full_View
(T1
))
2933 elsif Is_Private_Type
(T2
)
2934 and then Present
(Full_View
(T2
))
2935 and then BT1
= Base_Type
(Full_View
(T2
))
2940 -- Obtain the parent of the base type of T2 (use the full view if
2944 and then Is_Private_Type
(BT2
)
2945 and then Present
(Full_View
(BT2
))
2947 -- No climbing needed if its full view is the root type
2949 if Full_View
(BT2
) = Root_Type
(Full_View
(BT2
)) then
2953 Par
:= Etype
(Full_View
(BT2
));
2960 -- If there was a error on the type declaration, do not recurse
2962 if Error_Posted
(Par
) then
2965 elsif BT1
= Base_Type
(Par
)
2966 or else (Is_Private_Type
(T1
)
2967 and then Present
(Full_View
(T1
))
2968 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2972 elsif Is_Private_Type
(Par
)
2973 and then Present
(Full_View
(Par
))
2974 and then Full_View
(Par
) = BT1
2980 elsif Par
= Root_Type
(Par
) then
2983 -- Continue climbing
2986 -- Use the full-view of private types (if allowed). Guard
2987 -- against infinite loops when full view has same type as
2988 -- parent, as can happen with interface extensions.
2991 and then Is_Private_Type
(Par
)
2992 and then Present
(Full_View
(Par
))
2993 and then Par
/= Etype
(Full_View
(Par
))
2995 Par
:= Etype
(Full_View
(Par
));
3004 ---------------------------
3005 -- Is_Invisible_Operator --
3006 ---------------------------
3008 function Is_Invisible_Operator
3010 T
: Entity_Id
) return Boolean
3012 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
3015 if Nkind
(N
) not in N_Op
then
3018 elsif not Comes_From_Source
(N
) then
3021 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
3024 elsif Nkind
(N
) in N_Binary_Op
3025 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
3030 return Is_Numeric_Type
(T
)
3031 and then not In_Open_Scopes
(Scope
(T
))
3032 and then not Is_Potentially_Use_Visible
(T
)
3033 and then not In_Use
(T
)
3034 and then not In_Use
(Scope
(T
))
3036 (Nkind
(Orig_Node
) /= N_Function_Call
3037 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
3038 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
3039 and then not In_Instance
;
3041 end Is_Invisible_Operator
;
3043 --------------------
3045 --------------------
3047 function Is_Progenitor
3049 Typ
: Entity_Id
) return Boolean
3052 return Implements_Interface
(Typ
, Iface
, Exclude_Parents
=> True);
3059 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3063 S
:= Ancestor_Subtype
(T1
);
3064 while Present
(S
) loop
3068 S
:= Ancestor_Subtype
(S
);
3079 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
3080 Index
: Interp_Index
;
3084 Get_First_Interp
(Nam
, Index
, It
);
3085 while Present
(It
.Nam
) loop
3086 if Scope
(It
.Nam
) = Standard_Standard
3087 and then Scope
(It
.Typ
) /= Standard_Standard
3089 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
3090 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
3093 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
3094 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
3097 Get_Next_Interp
(Index
, It
);
3105 procedure New_Interps
(N
: Node_Id
) is
3107 All_Interp
.Append
(No_Interp
);
3109 -- Add or rewrite the existing node
3110 Last_Overloaded
:= N
;
3111 Interp_Map
.Set
(N
, All_Interp
.Last
);
3112 Set_Is_Overloaded
(N
, True);
3115 ---------------------------
3116 -- Operator_Matches_Spec --
3117 ---------------------------
3119 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
3120 New_First_F
: constant Entity_Id
:= First_Formal
(New_S
);
3121 Op_Name
: constant Name_Id
:= Chars
(Op
);
3122 T
: constant Entity_Id
:= Etype
(New_S
);
3130 -- To verify that a predefined operator matches a given signature, do a
3131 -- case analysis of the operator classes. Function can have one or two
3132 -- formals and must have the proper result type.
3134 New_F
:= New_First_F
;
3135 Old_F
:= First_Formal
(Op
);
3137 while Present
(New_F
) and then Present
(Old_F
) loop
3139 Next_Formal
(New_F
);
3140 Next_Formal
(Old_F
);
3143 -- Definite mismatch if different number of parameters
3145 if Present
(Old_F
) or else Present
(New_F
) then
3151 T1
:= Etype
(New_First_F
);
3153 if Op_Name
in Name_Op_Subtract | Name_Op_Add | Name_Op_Abs
then
3154 return Base_Type
(T1
) = Base_Type
(T
)
3155 and then Is_Numeric_Type
(T
);
3157 elsif Op_Name
= Name_Op_Not
then
3158 return Base_Type
(T1
) = Base_Type
(T
)
3159 and then Valid_Boolean_Arg
(Base_Type
(T
));
3168 T1
:= Etype
(New_First_F
);
3169 T2
:= Etype
(Next_Formal
(New_First_F
));
3171 if Op_Name
in Name_Op_And | Name_Op_Or | Name_Op_Xor
then
3172 return Base_Type
(T1
) = Base_Type
(T2
)
3173 and then Base_Type
(T1
) = Base_Type
(T
)
3174 and then Valid_Boolean_Arg
(Base_Type
(T
));
3176 elsif Op_Name
in Name_Op_Eq | Name_Op_Ne
then
3177 return Base_Type
(T1
) = Base_Type
(T2
)
3178 and then not Is_Limited_Type
(T1
)
3179 and then Is_Boolean_Type
(T
);
3181 elsif Op_Name
in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
3183 return Base_Type
(T1
) = Base_Type
(T2
)
3184 and then Valid_Comparison_Arg
(T1
)
3185 and then Is_Boolean_Type
(T
);
3187 elsif Op_Name
in Name_Op_Add | Name_Op_Subtract
then
3188 return Base_Type
(T1
) = Base_Type
(T2
)
3189 and then Base_Type
(T1
) = Base_Type
(T
)
3190 and then Is_Numeric_Type
(T
);
3192 -- For division and multiplication, a user-defined function does not
3193 -- match the predefined universal_fixed operation, except in Ada 83.
3195 elsif Op_Name
= Name_Op_Divide
then
3196 return (Base_Type
(T1
) = Base_Type
(T2
)
3197 and then Base_Type
(T1
) = Base_Type
(T
)
3198 and then Is_Numeric_Type
(T
)
3199 and then (not Is_Fixed_Point_Type
(T
)
3200 or else Ada_Version
= Ada_83
))
3202 -- Mixed_Mode operations on fixed-point types
3204 or else (Base_Type
(T1
) = Base_Type
(T
)
3205 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3206 and then Is_Fixed_Point_Type
(T
))
3208 -- A user defined operator can also match (and hide) a mixed
3209 -- operation on universal literals.
3211 or else (Is_Integer_Type
(T2
)
3212 and then Is_Floating_Point_Type
(T1
)
3213 and then Base_Type
(T1
) = Base_Type
(T
));
3215 elsif Op_Name
= Name_Op_Multiply
then
3216 return (Base_Type
(T1
) = Base_Type
(T2
)
3217 and then Base_Type
(T1
) = Base_Type
(T
)
3218 and then Is_Numeric_Type
(T
)
3219 and then (not Is_Fixed_Point_Type
(T
)
3220 or else Ada_Version
= Ada_83
))
3222 -- Mixed_Mode operations on fixed-point types
3224 or else (Base_Type
(T1
) = Base_Type
(T
)
3225 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3226 and then Is_Fixed_Point_Type
(T
))
3228 or else (Base_Type
(T2
) = Base_Type
(T
)
3229 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
3230 and then Is_Fixed_Point_Type
(T
))
3232 or else (Is_Integer_Type
(T2
)
3233 and then Is_Floating_Point_Type
(T1
)
3234 and then Base_Type
(T1
) = Base_Type
(T
))
3236 or else (Is_Integer_Type
(T1
)
3237 and then Is_Floating_Point_Type
(T2
)
3238 and then Base_Type
(T2
) = Base_Type
(T
));
3240 elsif Op_Name
in Name_Op_Mod | Name_Op_Rem
then
3241 return Base_Type
(T1
) = Base_Type
(T2
)
3242 and then Base_Type
(T1
) = Base_Type
(T
)
3243 and then Is_Integer_Type
(T
);
3245 elsif Op_Name
= Name_Op_Expon
then
3246 return Base_Type
(T1
) = Base_Type
(T
)
3247 and then Is_Numeric_Type
(T
)
3248 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
3250 elsif Op_Name
= Name_Op_Concat
then
3251 return Is_Array_Type
(T
)
3252 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
3253 and then (Base_Type
(T1
) = Base_Type
(T
)
3255 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
3256 and then (Base_Type
(T2
) = Base_Type
(T
)
3258 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
3264 end Operator_Matches_Spec
;
3270 procedure Remove_Interp
(I
: in out Interp_Index
) is
3274 -- Find end of interp list and copy downward to erase the discarded one
3277 while Present
(All_Interp
.Table
(II
).Typ
) loop
3281 for J
in I
+ 1 .. II
loop
3282 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
3285 -- Back up interp index to insure that iterator will pick up next
3286 -- available interpretation.
3295 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
3296 Old_Ind
: Interp_Index
;
3300 if Is_Overloaded
(Old_N
) then
3301 Set_Is_Overloaded
(New_N
);
3303 if Nkind
(Old_N
) = N_Selected_Component
3304 and then Is_Overloaded
(Selector_Name
(Old_N
))
3306 O_N
:= Selector_Name
(Old_N
);
3311 Old_Ind
:= Interp_Map
.Get
(O_N
);
3312 pragma Assert
(Old_Ind
>= 0);
3314 New_Interps
(New_N
);
3315 Interp_Map
.Set
(New_N
, Old_Ind
);
3323 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
3324 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
3325 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
3326 B1
: constant Entity_Id
:= Base_Type
(T1
);
3327 B2
: constant Entity_Id
:= Base_Type
(T2
);
3329 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
3330 -- Check whether T is the equivalent type of a remote access type.
3331 -- If distribution is enabled, T is a legal context for Null.
3333 ----------------------
3334 -- Is_Remote_Access --
3335 ----------------------
3337 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
3339 return Is_Record_Type
(T
)
3340 and then (Is_Remote_Call_Interface
(T
)
3341 or else Is_Remote_Types
(T
))
3342 and then Present
(Corresponding_Remote_Type
(T
))
3343 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
3344 end Is_Remote_Access
;
3346 -- Start of processing for Specific_Type
3349 if T1
= Any_Type
or else T2
= Any_Type
then
3356 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
3357 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
3358 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
3359 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3363 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3364 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3365 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3366 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3370 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
3373 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
3376 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
3379 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3382 elsif T1
= Any_Access
3383 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3387 elsif T2
= Any_Access
3388 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3392 -- In an instance, the specific type may have a private view. Use full
3393 -- view to check legality.
3395 elsif T2
= Any_Access
3396 and then Is_Private_Type
(T1
)
3397 and then Present
(Full_View
(T1
))
3398 and then Is_Access_Type
(Full_View
(T1
))
3399 and then In_Instance
3403 elsif T2
= Any_Composite
and then Is_Aggregate_Type
(T1
) then
3406 elsif T1
= Any_Composite
and then Is_Aggregate_Type
(T2
) then
3409 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3412 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3415 -- ----------------------------------------------------------
3416 -- Special cases for equality operators (all other predefined
3417 -- operators can never apply to tagged types)
3418 -- ----------------------------------------------------------
3420 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3423 elsif Is_Class_Wide_Type
(T1
)
3424 and then Is_Class_Wide_Type
(T2
)
3425 and then Is_Interface
(Etype
(T2
))
3429 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3430 -- class-wide interface T2
3432 elsif Is_Tagged_Type
(T1
)
3433 and then Is_Class_Wide_Type
(T2
)
3434 and then Is_Interface
(Etype
(T2
))
3435 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3436 Iface
=> Etype
(T2
))
3440 elsif Is_Class_Wide_Type
(T1
)
3441 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3445 elsif Is_Class_Wide_Type
(T2
)
3446 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3450 elsif Is_Access_Type
(T1
)
3451 and then Is_Access_Type
(T2
)
3452 and then Is_Class_Wide_Type
(Designated_Type
(T1
))
3453 and then not Is_Class_Wide_Type
(Designated_Type
(T2
))
3455 Is_Ancestor
(Root_Type
(Designated_Type
(T1
)), Designated_Type
(T2
))
3459 elsif Is_Access_Type
(T1
)
3460 and then Is_Access_Type
(T2
)
3461 and then Is_Class_Wide_Type
(Designated_Type
(T2
))
3462 and then not Is_Class_Wide_Type
(Designated_Type
(T1
))
3464 Is_Ancestor
(Root_Type
(Designated_Type
(T2
)), Designated_Type
(T1
))
3468 elsif Ekind
(B1
) in E_Access_Subprogram_Type
3469 | E_Access_Protected_Subprogram_Type
3470 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3471 and then Is_Access_Type
(T2
)
3475 elsif Ekind
(B2
) in E_Access_Subprogram_Type
3476 | E_Access_Protected_Subprogram_Type
3477 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3478 and then Is_Access_Type
(T1
)
3482 elsif Ekind
(T1
) in E_Allocator_Type | E_Access_Attribute_Type
3483 and then Is_Access_Type
(T2
)
3487 elsif Ekind
(T2
) in E_Allocator_Type | E_Access_Attribute_Type
3488 and then Is_Access_Type
(T1
)
3492 -- Ada 2005 (AI-230): Support the following operators:
3494 -- function "=" (L, R : universal_access) return Boolean;
3495 -- function "/=" (L, R : universal_access) return Boolean;
3497 -- Pool-specific access types (E_Access_Type) are not covered by these
3498 -- operators because of the legality rule of 4.5.2(9.2): "The operands
3499 -- of the equality operators for universal_access shall be convertible
3500 -- to one another (see 4.6)". For example, considering the type decla-
3501 -- ration "type P is access Integer" and an anonymous access to Integer,
3502 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
3503 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
3504 -- Note that this does not preclude one operand to be a pool-specific
3505 -- access type, as a previous version of this code enforced.
3507 elsif Ada_Version
>= Ada_2005
then
3508 if Is_Anonymous_Access_Type
(T1
)
3509 and then Is_Access_Type
(T2
)
3513 elsif Is_Anonymous_Access_Type
(T2
)
3514 and then Is_Access_Type
(T1
)
3520 -- If none of the above cases applies, types are not compatible
3525 ---------------------
3526 -- Set_Abstract_Op --
3527 ---------------------
3529 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3531 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3532 end Set_Abstract_Op
;
3534 -----------------------
3535 -- Valid_Boolean_Arg --
3536 -----------------------
3538 -- In addition to booleans and arrays of booleans, we must include
3539 -- aggregates as valid boolean arguments, because in the first pass of
3540 -- resolution their components are not examined. If it turns out not to be
3541 -- an aggregate of booleans, this will be diagnosed in Resolve.
3542 -- Any_Composite must be checked for prior to the array type checks because
3543 -- Any_Composite does not have any associated indexes.
3545 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3547 if Is_Boolean_Type
(T
)
3548 or else Is_Modular_Integer_Type
(T
)
3549 or else T
= Universal_Integer
3550 or else T
= Any_Composite
3554 elsif Is_Array_Type
(T
)
3555 and then T
/= Any_String
3556 and then Number_Dimensions
(T
) = 1
3557 and then Is_Boolean_Type
(Component_Type
(T
))
3559 ((not Is_Private_Composite
(T
) and then not Is_Limited_Composite
(T
))
3561 or else Available_Full_View_Of_Component
(T
))
3568 end Valid_Boolean_Arg
;
3570 --------------------------
3571 -- Valid_Comparison_Arg --
3572 --------------------------
3574 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3577 if T
= Any_Composite
then
3580 elsif Is_Discrete_Type
(T
)
3581 or else Is_Real_Type
(T
)
3585 elsif Is_Array_Type
(T
)
3586 and then Number_Dimensions
(T
) = 1
3587 and then Is_Discrete_Type
(Component_Type
(T
))
3588 and then (not Is_Private_Composite
(T
) or else In_Instance
)
3589 and then (not Is_Limited_Composite
(T
) or else In_Instance
)
3593 elsif Is_Array_Type
(T
)
3594 and then Number_Dimensions
(T
) = 1
3595 and then Is_Discrete_Type
(Component_Type
(T
))
3596 and then Available_Full_View_Of_Component
(T
)
3600 elsif Is_String_Type
(T
) then
3605 end Valid_Comparison_Arg
;
3611 procedure Write_Interp
(It
: Interp
) is
3613 Write_Str
("Nam: ");
3614 Print_Tree_Node
(It
.Nam
);
3615 Write_Str
("Typ: ");
3616 Print_Tree_Node
(It
.Typ
);
3617 Write_Str
("Abstract_Op: ");
3618 Print_Tree_Node
(It
.Abstract_Op
);
3621 ---------------------
3622 -- Write_Overloads --
3623 ---------------------
3625 procedure Write_Overloads
(N
: Node_Id
) is
3631 Write_Str
("Overloads: ");
3632 Print_Node_Briefly
(N
);
3634 if not Is_Overloaded
(N
) then
3635 if Is_Entity_Name
(N
) then
3636 Write_Line
("Non-overloaded entity ");
3637 Write_Entity_Info
(Entity
(N
), " ");
3640 elsif Nkind
(N
) not in N_Has_Entity
then
3641 Get_First_Interp
(N
, I
, It
);
3642 while Present
(It
.Nam
) loop
3643 Write_Int
(Int
(It
.Typ
));
3645 Write_Name
(Chars
(It
.Typ
));
3647 Get_Next_Interp
(I
, It
);
3651 Get_First_Interp
(N
, I
, It
);
3652 Write_Line
("Overloaded entity ");
3653 Write_Line
(" Name Type Abstract Op");
3654 Write_Line
("===============================================");
3657 while Present
(Nam
) loop
3658 Write_Int
(Int
(Nam
));
3660 Write_Name
(Chars
(Nam
));
3662 Write_Int
(Int
(It
.Typ
));
3664 Write_Name
(Chars
(It
.Typ
));
3666 if Present
(It
.Abstract_Op
) then
3668 Write_Int
(Int
(It
.Abstract_Op
));
3670 Write_Name
(Chars
(It
.Abstract_Op
));
3674 Get_Next_Interp
(I
, It
);
3678 end Write_Overloads
;