1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Nlists
; use Nlists
;
32 with Errout
; use Errout
;
34 with Namet
; use Namet
;
36 with Output
; use Output
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch6
; use Sem_Ch6
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Ch12
; use Sem_Ch12
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Util
; use Sem_Util
;
45 with Stand
; use Stand
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
49 with Treepr
; use Treepr
;
50 with Uintp
; use Uintp
;
52 package body Sem_Type
is
58 -- The following data structures establish a mapping between nodes and
59 -- their interpretations. An overloaded node has an entry in Interp_Map,
60 -- which in turn contains a pointer into the All_Interp array. The
61 -- interpretations of a given node are contiguous in All_Interp. Each set
62 -- of interpretations is terminated with the marker No_Interp. In order to
63 -- speed up the retrieval of the interpretations of an overloaded node, the
64 -- Interp_Map table is accessed by means of a simple hashing scheme, and
65 -- the entries in Interp_Map are chained. The heads of clash lists are
66 -- stored in array Headers.
68 -- Headers Interp_Map All_Interp
70 -- _ +-----+ +--------+
71 -- |_| |_____| --->|interp1 |
72 -- |_|---------->|node | | |interp2 |
73 -- |_| |index|---------| |nointerp|
78 -- This scheme does not currently reclaim interpretations. In principle,
79 -- after a unit is compiled, all overloadings have been resolved, and the
80 -- candidate interpretations should be deleted. This should be easier
81 -- now than with the previous scheme???
83 package All_Interp
is new Table
.Table
(
84 Table_Component_Type
=> Interp
,
85 Table_Index_Type
=> Interp_Index
,
87 Table_Initial
=> Alloc
.All_Interp_Initial
,
88 Table_Increment
=> Alloc
.All_Interp_Increment
,
89 Table_Name
=> "All_Interp");
91 type Interp_Ref
is record
97 Header_Size
: constant Int
:= 2 ** 12;
98 No_Entry
: constant Int
:= -1;
99 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
101 package Interp_Map
is new Table
.Table
(
102 Table_Component_Type
=> Interp_Ref
,
103 Table_Index_Type
=> Int
,
104 Table_Low_Bound
=> 0,
105 Table_Initial
=> Alloc
.Interp_Map_Initial
,
106 Table_Increment
=> Alloc
.Interp_Map_Increment
,
107 Table_Name
=> "Interp_Map");
109 function Hash
(N
: Node_Id
) return Int
;
110 -- A trivial hashing function for nodes, used to insert an overloaded
111 -- node into the Interp_Map table.
113 -------------------------------------
114 -- Handling of Overload Resolution --
115 -------------------------------------
117 -- Overload resolution uses two passes over the syntax tree of a complete
118 -- context. In the first, bottom-up pass, the types of actuals in calls
119 -- are used to resolve possibly overloaded subprogram and operator names.
120 -- In the second top-down pass, the type of the context (for example the
121 -- condition in a while statement) is used to resolve a possibly ambiguous
122 -- call, and the unique subprogram name in turn imposes a specific context
123 -- on each of its actuals.
125 -- Most expressions are in fact unambiguous, and the bottom-up pass is
126 -- sufficient to resolve most everything. To simplify the common case,
127 -- names and expressions carry a flag Is_Overloaded to indicate whether
128 -- they have more than one interpretation. If the flag is off, then each
129 -- name has already a unique meaning and type, and the bottom-up pass is
130 -- sufficient (and much simpler).
132 --------------------------
133 -- Operator Overloading --
134 --------------------------
136 -- The visibility of operators is handled differently from that of other
137 -- entities. We do not introduce explicit versions of primitive operators
138 -- for each type definition. As a result, there is only one entity
139 -- corresponding to predefined addition on all numeric types, etc. The
140 -- back end resolves predefined operators according to their type. The
141 -- visibility of primitive operations then reduces to the visibility of the
142 -- resulting type: (a + b) is a legal interpretation of some primitive
143 -- operator + if the type of the result (which must also be the type of a
144 -- and b) is directly visible (either immediately visible or use-visible).
146 -- User-defined operators are treated like other functions, but the
147 -- visibility of these user-defined operations must be special-cased
148 -- to determine whether they hide or are hidden by predefined operators.
149 -- The form P."+" (x, y) requires additional handling.
151 -- Concatenation is treated more conventionally: for every one-dimensional
152 -- array type we introduce a explicit concatenation operator. This is
153 -- necessary to handle the case of (element & element => array) which
154 -- cannot be handled conveniently if there is no explicit instance of
155 -- resulting type of the operation.
157 -----------------------
158 -- Local Subprograms --
159 -----------------------
161 procedure All_Overloads
;
162 pragma Warnings
(Off
, All_Overloads
);
163 -- Debugging procedure: list full contents of Overloads table
165 function Binary_Op_Interp_Has_Abstract_Op
167 E
: Entity_Id
) return Entity_Id
;
168 -- Given the node and entity of a binary operator, determine whether the
169 -- actuals of E contain an abstract interpretation with regards to the
170 -- types of their corresponding formals. Return the abstract operation or
173 function Function_Interp_Has_Abstract_Op
175 E
: Entity_Id
) return Entity_Id
;
176 -- Given the node and entity of a function call, determine whether the
177 -- actuals of E contain an abstract interpretation with regards to the
178 -- types of their corresponding formals. Return the abstract operation or
181 function Has_Abstract_Op
183 Typ
: Entity_Id
) return Entity_Id
;
184 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
185 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
186 -- abstract interpretation which yields type Typ.
188 procedure New_Interps
(N
: Node_Id
);
189 -- Initialize collection of interpretations for the given node, which is
190 -- either an overloaded entity, or an operation whose arguments have
191 -- multiple interpretations. Interpretations can be added to only one
194 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
;
195 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
196 -- or is not a "class" type (any_character, etc).
202 procedure Add_One_Interp
206 Opnd_Type
: Entity_Id
:= Empty
)
208 Vis_Type
: Entity_Id
;
210 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
211 -- Add one interpretation to an overloaded node. Add a new entry if
212 -- not hidden by previous one, and remove previous one if hidden by
215 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
216 -- True if the entity is a predefined operator and the operands have
217 -- a universal Interpretation.
223 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
224 Abstr_Op
: Entity_Id
:= Empty
;
228 -- Start of processing for Add_Entry
231 -- Find out whether the new entry references interpretations that
232 -- are abstract or disabled by abstract operators.
234 if Ada_Version
>= Ada_2005
then
235 if Nkind
(N
) in N_Binary_Op
then
236 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
237 elsif Nkind
(N
) = N_Function_Call
then
238 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
242 Get_First_Interp
(N
, I
, It
);
243 while Present
(It
.Nam
) loop
245 -- A user-defined subprogram hides another declared at an outer
246 -- level, or one that is use-visible. So return if previous
247 -- definition hides new one (which is either in an outer
248 -- scope, or use-visible). Note that for functions use-visible
249 -- is the same as potentially use-visible. If new one hides
250 -- previous one, replace entry in table of interpretations.
251 -- If this is a universal operation, retain the operator in case
252 -- preference rule applies.
254 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
255 and then Ekind
(Name
) = Ekind
(It
.Nam
))
256 or else (Ekind
(Name
) = E_Operator
257 and then Ekind
(It
.Nam
) = E_Function
))
258 and then Is_Immediately_Visible
(It
.Nam
)
259 and then Type_Conformant
(Name
, It
.Nam
)
260 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
262 if Is_Universal_Operation
(Name
) then
265 -- If node is an operator symbol, we have no actuals with
266 -- which to check hiding, and this is done in full in the
267 -- caller (Analyze_Subprogram_Renaming) so we include the
268 -- predefined operator in any case.
270 elsif Nkind
(N
) = N_Operator_Symbol
272 (Nkind
(N
) = N_Expanded_Name
273 and then Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
277 elsif not In_Open_Scopes
(Scope
(Name
))
278 or else Scope_Depth
(Scope
(Name
)) <=
279 Scope_Depth
(Scope
(It
.Nam
))
281 -- If ambiguity within instance, and entity is not an
282 -- implicit operation, save for later disambiguation.
284 if Scope
(Name
) = Scope
(It
.Nam
)
285 and then not Is_Inherited_Operation
(Name
)
294 All_Interp
.Table
(I
).Nam
:= Name
;
298 -- Avoid making duplicate entries in overloads
301 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
305 -- Otherwise keep going
308 Get_Next_Interp
(I
, It
);
313 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
314 All_Interp
.Append
(No_Interp
);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
325 if Ekind
(Op
) /= E_Operator
then
328 elsif Nkind
(N
) in N_Binary_Op
then
329 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
330 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
332 elsif Nkind
(N
) in N_Unary_Op
then
333 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
335 elsif Nkind
(N
) = N_Function_Call
then
336 Arg
:= First_Actual
(N
);
337 while Present
(Arg
) loop
338 if No
(Universal_Interpretation
(Arg
)) then
350 end Is_Universal_Operation
;
352 -- Start of processing for Add_One_Interp
355 -- If the interpretation is a predefined operator, verify that the
356 -- result type is visible, or that the entity has already been
357 -- resolved (case of an instantiation node that refers to a predefined
358 -- operation, or an internally generated operator node, or an operator
359 -- given as an expanded name). If the operator is a comparison or
360 -- equality, it is the type of the operand that matters to determine
361 -- whether the operator is visible. In an instance, the check is not
362 -- performed, given that the operator was visible in the generic.
364 if Ekind
(E
) = E_Operator
then
365 if Present
(Opnd_Type
) then
366 Vis_Type
:= Opnd_Type
;
368 Vis_Type
:= Base_Type
(T
);
371 if In_Open_Scopes
(Scope
(Vis_Type
))
372 or else Is_Potentially_Use_Visible
(Vis_Type
)
373 or else In_Use
(Vis_Type
)
374 or else (In_Use
(Scope
(Vis_Type
))
375 and then not Is_Hidden
(Vis_Type
))
376 or else Nkind
(N
) = N_Expanded_Name
377 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
379 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
383 -- If the node is given in functional notation and the prefix
384 -- is an expanded name, then the operator is visible if the
385 -- prefix is the scope of the result type as well. If the
386 -- operator is (implicitly) defined in an extension of system,
387 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
389 elsif Nkind
(N
) = N_Function_Call
390 and then Nkind
(Name
(N
)) = N_Expanded_Name
391 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
392 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
393 or else Scope
(Vis_Type
) = System_Aux_Id
)
397 -- Save type for subsequent error message, in case no other
398 -- interpretation is found.
401 Candidate_Type
:= Vis_Type
;
405 -- In an instance, an abstract non-dispatching operation cannot be a
406 -- candidate interpretation, because it could not have been one in the
407 -- generic (it may be a spurious overloading in the instance).
410 and then Is_Overloadable
(E
)
411 and then Is_Abstract_Subprogram
(E
)
412 and then not Is_Dispatching_Operation
(E
)
416 -- An inherited interface operation that is implemented by some derived
417 -- type does not participate in overload resolution, only the
418 -- implementation operation does.
421 and then Is_Subprogram
(E
)
422 and then Present
(Interface_Alias
(E
))
424 -- Ada 2005 (AI-251): If this primitive operation corresponds with
425 -- an immediate ancestor interface there is no need to add it to the
426 -- list of interpretations. The corresponding aliased primitive is
427 -- also in this list of primitive operations and will be used instead
428 -- because otherwise we have a dummy ambiguity between the two
429 -- subprograms which are in fact the same.
432 (Find_Dispatching_Type
(Interface_Alias
(E
)),
433 Find_Dispatching_Type
(E
))
435 Add_One_Interp
(N
, Interface_Alias
(E
), T
);
440 -- Calling stubs for an RACW operation never participate in resolution,
441 -- they are executed only through dispatching calls.
443 elsif Is_RACW_Stub_Type_Operation
(E
) then
447 -- If this is the first interpretation of N, N has type Any_Type.
448 -- In that case place the new type on the node. If one interpretation
449 -- already exists, indicate that the node is overloaded, and store
450 -- both the previous and the new interpretation in All_Interp. If
451 -- this is a later interpretation, just add it to the set.
453 if Etype
(N
) = Any_Type
then
458 -- Record both the operator or subprogram name, and its type
460 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
467 -- Either there is no current interpretation in the table for any
468 -- node or the interpretation that is present is for a different
469 -- node. In both cases add a new interpretation to the table.
471 elsif Interp_Map
.Last
< 0
473 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
474 and then not Is_Overloaded
(N
))
478 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
479 and then Present
(Entity
(N
))
481 Add_Entry
(Entity
(N
), Etype
(N
));
483 elsif Nkind
(N
) in N_Subprogram_Call
484 and then Is_Entity_Name
(Name
(N
))
486 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
488 -- If this is an indirect call there will be no name associated
489 -- with the previous entry. To make diagnostics clearer, save
490 -- Subprogram_Type of first interpretation, so that the error will
491 -- point to the anonymous access to subprogram, not to the result
492 -- type of the call itself.
494 elsif (Nkind
(N
)) = N_Function_Call
495 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
496 and then Is_Overloaded
(Name
(N
))
502 pragma Warnings
(Off
, Itn
);
505 Get_First_Interp
(Name
(N
), Itn
, It
);
506 Add_Entry
(It
.Nam
, Etype
(N
));
510 -- Overloaded prefix in indexed or selected component, or call
511 -- whose name is an expression or another call.
513 Add_Entry
(Etype
(N
), Etype
(N
));
527 procedure All_Overloads
is
529 for J
in All_Interp
.First
.. All_Interp
.Last
loop
531 if Present
(All_Interp
.Table
(J
).Nam
) then
532 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
534 Write_Str
("No Interp");
538 Write_Str
("=================");
543 --------------------------------------
544 -- Binary_Op_Interp_Has_Abstract_Op --
545 --------------------------------------
547 function Binary_Op_Interp_Has_Abstract_Op
549 E
: Entity_Id
) return Entity_Id
551 Abstr_Op
: Entity_Id
;
552 E_Left
: constant Node_Id
:= First_Formal
(E
);
553 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
556 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
557 if Present
(Abstr_Op
) then
561 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
562 end Binary_Op_Interp_Has_Abstract_Op
;
564 ---------------------
565 -- Collect_Interps --
566 ---------------------
568 procedure Collect_Interps
(N
: Node_Id
) is
569 Ent
: constant Entity_Id
:= Entity
(N
);
571 First_Interp
: Interp_Index
;
573 function Within_Instance
(E
: Entity_Id
) return Boolean;
574 -- Within an instance there can be spurious ambiguities between a local
575 -- entity and one declared outside of the instance. This can only happen
576 -- for subprograms, because otherwise the local entity hides the outer
577 -- one. For an overloadable entity, this predicate determines whether it
578 -- is a candidate within the instance, or must be ignored.
580 ---------------------
581 -- Within_Instance --
582 ---------------------
584 function Within_Instance
(E
: Entity_Id
) return Boolean is
589 if not In_Instance
then
593 Inst
:= Current_Scope
;
594 while Present
(Inst
) and then not Is_Generic_Instance
(Inst
) loop
595 Inst
:= Scope
(Inst
);
599 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
604 Scop
:= Scope
(Scop
);
610 -- Start of processing for Collect_Interps
615 -- Unconditionally add the entity that was initially matched
617 First_Interp
:= All_Interp
.Last
;
618 Add_One_Interp
(N
, Ent
, Etype
(N
));
620 -- For expanded name, pick up all additional entities from the
621 -- same scope, since these are obviously also visible. Note that
622 -- these are not necessarily contiguous on the homonym chain.
624 if Nkind
(N
) = N_Expanded_Name
then
626 while Present
(H
) loop
627 if Scope
(H
) = Scope
(Entity
(N
)) then
628 Add_One_Interp
(N
, H
, Etype
(H
));
634 -- Case of direct name
637 -- First, search the homonym chain for directly visible entities
639 H
:= Current_Entity
(Ent
);
640 while Present
(H
) loop
641 exit when (not Is_Overloadable
(H
))
642 and then Is_Immediately_Visible
(H
);
644 if Is_Immediately_Visible
(H
) and then H
/= Ent
then
646 -- Only add interpretation if not hidden by an inner
647 -- immediately visible one.
649 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
651 -- Current homograph is not hidden. Add to overloads
653 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
656 -- Homograph is hidden, unless it is a predefined operator
658 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
660 -- A homograph in the same scope can occur within an
661 -- instantiation, the resulting ambiguity has to be
662 -- resolved later. The homographs may both be local
663 -- functions or actuals, or may be declared at different
664 -- levels within the instance. The renaming of an actual
665 -- within the instance must not be included.
667 if Within_Instance
(H
)
668 and then H
/= Renamed_Entity
(Ent
)
669 and then not Is_Inherited_Operation
(H
)
671 All_Interp
.Table
(All_Interp
.Last
) :=
672 (H
, Etype
(H
), Empty
);
673 All_Interp
.Append
(No_Interp
);
676 elsif Scope
(H
) /= Standard_Standard
then
682 -- On exit, we know that current homograph is not hidden
684 Add_One_Interp
(N
, H
, Etype
(H
));
687 Write_Str
("Add overloaded interpretation ");
697 -- Scan list of homographs for use-visible entities only
699 H
:= Current_Entity
(Ent
);
701 while Present
(H
) loop
702 if Is_Potentially_Use_Visible
(H
)
704 and then Is_Overloadable
(H
)
706 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
708 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
711 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
712 goto Next_Use_Homograph
;
716 Add_One_Interp
(N
, H
, Etype
(H
));
719 <<Next_Use_Homograph
>>
724 if All_Interp
.Last
= First_Interp
+ 1 then
726 -- The final interpretation is in fact not overloaded. Note that the
727 -- unique legal interpretation may or may not be the original one,
728 -- so we need to update N's entity and etype now, because once N
729 -- is marked as not overloaded it is also expected to carry the
730 -- proper interpretation.
732 Set_Is_Overloaded
(N
, False);
733 Set_Entity
(N
, All_Interp
.Table
(First_Interp
).Nam
);
734 Set_Etype
(N
, All_Interp
.Table
(First_Interp
).Typ
);
742 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
746 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
747 -- In an instance the proper view may not always be correct for
748 -- private types, but private and full view are compatible. This
749 -- removes spurious errors from nested instantiations that involve,
750 -- among other things, types derived from private types.
752 function Real_Actual
(T
: Entity_Id
) return Entity_Id
;
753 -- If an actual in an inner instance is the formal of an enclosing
754 -- generic, the actual in the enclosing instance is the one that can
755 -- create an accidental ambiguity, and the check on compatibily of
756 -- generic actual types must use this enclosing actual.
758 ----------------------
759 -- Full_View_Covers --
760 ----------------------
762 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
765 Is_Private_Type
(Typ1
)
767 ((Present
(Full_View
(Typ1
))
768 and then Covers
(Full_View
(Typ1
), Typ2
))
769 or else (Present
(Underlying_Full_View
(Typ1
))
770 and then Covers
(Underlying_Full_View
(Typ1
), Typ2
))
771 or else Base_Type
(Typ1
) = Typ2
772 or else Base_Type
(Typ2
) = Typ1
);
773 end Full_View_Covers
;
779 function Real_Actual
(T
: Entity_Id
) return Entity_Id
is
780 Par
: constant Node_Id
:= Parent
(T
);
784 -- Retrieve parent subtype from subtype declaration for actual
786 if Nkind
(Par
) = N_Subtype_Declaration
787 and then not Comes_From_Source
(Par
)
788 and then Is_Entity_Name
(Subtype_Indication
(Par
))
790 RA
:= Entity
(Subtype_Indication
(Par
));
792 if Is_Generic_Actual_Type
(RA
) then
797 -- Otherwise actual is not the actual of an enclosing instance
802 -- Start of processing for Covers
805 -- If either operand missing, then this is an error, but ignore it (and
806 -- pretend we have a cover) if errors already detected, since this may
807 -- simply mean we have malformed trees or a semantic error upstream.
809 if No
(T1
) or else No
(T2
) then
810 if Total_Errors_Detected
/= 0 then
817 -- Trivial case: same types are always compatible
823 -- First check for Standard_Void_Type, which is special. Subsequent
824 -- processing in this routine assumes T1 and T2 are bona fide types;
825 -- Standard_Void_Type is a special entity that has some, but not all,
826 -- properties of types.
828 if (T1
= Standard_Void_Type
) /= (T2
= Standard_Void_Type
) then
832 BT1
:= Base_Type
(T1
);
833 BT2
:= Base_Type
(T2
);
835 -- Handle underlying view of records with unknown discriminants
836 -- using the original entity that motivated the construction of
837 -- this underlying record view (see Build_Derived_Private_Type).
839 if Is_Underlying_Record_View
(BT1
) then
840 BT1
:= Underlying_Record_View
(BT1
);
843 if Is_Underlying_Record_View
(BT2
) then
844 BT2
:= Underlying_Record_View
(BT2
);
847 -- Simplest case: types that have the same base type and are not generic
848 -- actuals are compatible. Generic actuals belong to their class but are
849 -- not compatible with other types of their class, and in particular
850 -- with other generic actuals. They are however compatible with their
851 -- own subtypes, and itypes with the same base are compatible as well.
852 -- Similarly, constrained subtypes obtained from expressions of an
853 -- unconstrained nominal type are compatible with the base type (may
854 -- lead to spurious ambiguities in obscure cases ???)
856 -- Generic actuals require special treatment to avoid spurious ambi-
857 -- guities in an instance, when two formal types are instantiated with
858 -- the same actual, so that different subprograms end up with the same
859 -- signature in the instance. If a generic actual is the actual of an
860 -- enclosing instance, it is that actual that we must compare: generic
861 -- actuals are only incompatible if they appear in the same instance.
867 if not Is_Generic_Actual_Type
(T1
)
869 not Is_Generic_Actual_Type
(T2
)
873 -- Both T1 and T2 are generic actual types
877 RT1
: constant Entity_Id
:= Real_Actual
(T1
);
878 RT2
: constant Entity_Id
:= Real_Actual
(T2
);
881 or else Is_Itype
(T1
)
882 or else Is_Itype
(T2
)
883 or else Is_Constr_Subt_For_U_Nominal
(T1
)
884 or else Is_Constr_Subt_For_U_Nominal
(T2
)
885 or else Scope
(RT1
) /= Scope
(RT2
);
889 -- Literals are compatible with types in a given "class"
891 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
892 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
893 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
894 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
895 or else (T2
= Any_String
and then Is_String_Type
(T1
))
896 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
897 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
901 -- The context may be class wide, and a class-wide type is compatible
902 -- with any member of the class.
904 elsif Is_Class_Wide_Type
(T1
)
905 and then Is_Ancestor
(Root_Type
(T1
), T2
)
909 elsif Is_Class_Wide_Type
(T1
)
910 and then Is_Class_Wide_Type
(T2
)
911 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
915 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
916 -- task_type or protected_type that implements the interface.
918 elsif Ada_Version
>= Ada_2005
919 and then Is_Class_Wide_Type
(T1
)
920 and then Is_Interface
(Etype
(T1
))
921 and then Is_Concurrent_Type
(T2
)
922 and then Interface_Present_In_Ancestor
923 (Typ
=> BT2
, Iface
=> Etype
(T1
))
927 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
928 -- object T2 implementing T1.
930 elsif Ada_Version
>= Ada_2005
931 and then Is_Class_Wide_Type
(T1
)
932 and then Is_Interface
(Etype
(T1
))
933 and then Is_Tagged_Type
(T2
)
935 if Interface_Present_In_Ancestor
(Typ
=> T2
,
946 if Is_Concurrent_Type
(BT2
) then
947 E
:= Corresponding_Record_Type
(BT2
);
952 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
953 -- covers an object T2 that implements a direct derivation of T1.
954 -- Note: test for presence of E is defense against previous error.
958 -- If expansion is disabled the Corresponding_Record_Type may
959 -- not be available yet, so use the interface list in the
960 -- declaration directly.
963 and then Nkind
(Parent
(BT2
)) = N_Protected_Type_Declaration
964 and then Present
(Interface_List
(Parent
(BT2
)))
967 Intf
: Node_Id
:= First
(Interface_List
(Parent
(BT2
)));
969 while Present
(Intf
) loop
970 if Is_Ancestor
(Etype
(T1
), Entity
(Intf
)) then
981 Check_Error_Detected
;
984 -- Here we have a corresponding record type
986 elsif Present
(Interfaces
(E
)) then
987 Elmt
:= First_Elmt
(Interfaces
(E
));
988 while Present
(Elmt
) loop
989 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
997 -- We should also check the case in which T1 is an ancestor of
998 -- some implemented interface???
1003 -- In a dispatching call, the formal is of some specific type, and the
1004 -- actual is of the corresponding class-wide type, including a subtype
1005 -- of the class-wide type.
1007 elsif Is_Class_Wide_Type
(T2
)
1009 (Class_Wide_Type
(T1
) = Class_Wide_Type
(T2
)
1010 or else Base_Type
(Root_Type
(T2
)) = BT1
)
1014 -- Some contexts require a class of types rather than a specific type.
1015 -- For example, conditions require any boolean type, fixed point
1016 -- attributes require some real type, etc. The built-in types Any_XXX
1017 -- represent these classes.
1019 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
1020 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
1021 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
1022 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
1023 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
1027 -- An aggregate is compatible with an array or record type
1029 elsif T2
= Any_Composite
and then Is_Aggregate_Type
(T1
) then
1032 -- If the expected type is an anonymous access, the designated type must
1033 -- cover that of the expression. Use the base type for this check: even
1034 -- though access subtypes are rare in sources, they are generated for
1035 -- actuals in instantiations.
1037 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
1038 and then Is_Access_Type
(T2
)
1039 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1043 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1044 -- of a named general access type. An implicit conversion will be
1045 -- applied. For the resolution, one designated type must cover the
1048 elsif Ada_Version
>= Ada_2012
1049 and then Ekind
(BT1
) = E_General_Access_Type
1050 and then Ekind
(BT2
) = E_Anonymous_Access_Type
1051 and then (Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1053 Covers
(Designated_Type
(T2
), Designated_Type
(T1
)))
1057 -- An Access_To_Subprogram is compatible with itself, or with an
1058 -- anonymous type created for an attribute reference Access.
1060 elsif Ekind_In
(BT1
, E_Access_Subprogram_Type
,
1061 E_Access_Protected_Subprogram_Type
)
1062 and then Is_Access_Type
(T2
)
1063 and then (not Comes_From_Source
(T1
)
1064 or else not Comes_From_Source
(T2
))
1065 and then (Is_Overloadable
(Designated_Type
(T2
))
1066 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1067 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1068 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1072 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1073 -- with itself, or with an anonymous type created for an attribute
1074 -- reference Access.
1076 elsif Ekind_In
(BT1
, E_Anonymous_Access_Subprogram_Type
,
1077 E_Anonymous_Access_Protected_Subprogram_Type
)
1078 and then Is_Access_Type
(T2
)
1079 and then (not Comes_From_Source
(T1
)
1080 or else not Comes_From_Source
(T2
))
1081 and then (Is_Overloadable
(Designated_Type
(T2
))
1082 or else Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
1083 and then Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1084 and then Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
1088 -- The context can be a remote access type, and the expression the
1089 -- corresponding source type declared in a categorized package, or
1092 elsif Is_Record_Type
(T1
)
1093 and then (Is_Remote_Call_Interface
(T1
) or else Is_Remote_Types
(T1
))
1094 and then Present
(Corresponding_Remote_Type
(T1
))
1096 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
1100 elsif Is_Record_Type
(T2
)
1101 and then (Is_Remote_Call_Interface
(T2
) or else Is_Remote_Types
(T2
))
1102 and then Present
(Corresponding_Remote_Type
(T2
))
1104 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
1106 -- Synchronized types are represented at run time by their corresponding
1107 -- record type. During expansion one is replaced with the other, but
1108 -- they are compatible views of the same type.
1110 elsif Is_Record_Type
(T1
)
1111 and then Is_Concurrent_Type
(T2
)
1112 and then Present
(Corresponding_Record_Type
(T2
))
1114 return Covers
(T1
, Corresponding_Record_Type
(T2
));
1116 elsif Is_Concurrent_Type
(T1
)
1117 and then Present
(Corresponding_Record_Type
(T1
))
1118 and then Is_Record_Type
(T2
)
1120 return Covers
(Corresponding_Record_Type
(T1
), T2
);
1122 -- During analysis, an attribute reference 'Access has a special type
1123 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1124 -- imposed by context.
1126 elsif Ekind
(T2
) = E_Access_Attribute_Type
1127 and then Ekind_In
(BT1
, E_General_Access_Type
, E_Access_Type
)
1128 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1130 -- If the target type is a RACW type while the source is an access
1131 -- attribute type, we are building a RACW that may be exported.
1133 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
1134 Set_Has_RACW
(Current_Sem_Unit
);
1139 -- Ditto for allocators, which eventually resolve to the context type
1141 elsif Ekind
(T2
) = E_Allocator_Type
and then Is_Access_Type
(T1
) then
1142 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
1144 (From_Limited_With
(Designated_Type
(T1
))
1145 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
1147 -- A boolean operation on integer literals is compatible with modular
1150 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
1153 -- The actual type may be the result of a previous error
1155 elsif BT2
= Any_Type
then
1158 -- A Raise_Expressions is legal in any expression context
1160 elsif BT2
= Raise_Type
then
1163 -- A packed array type covers its corresponding non-packed type. This is
1164 -- not legitimate Ada, but allows the omission of a number of otherwise
1165 -- useless unchecked conversions, and since this can only arise in
1166 -- (known correct) expanded code, no harm is done.
1168 elsif Is_Array_Type
(T2
)
1169 and then Is_Packed
(T2
)
1170 and then T1
= Packed_Array_Impl_Type
(T2
)
1174 -- Similarly an array type covers its corresponding packed array type
1176 elsif Is_Array_Type
(T1
)
1177 and then Is_Packed
(T1
)
1178 and then T2
= Packed_Array_Impl_Type
(T1
)
1182 -- In instances, or with types exported from instantiations, check
1183 -- whether a partial and a full view match. Verify that types are
1184 -- legal, to prevent cascaded errors.
1187 and then (Full_View_Covers
(T1
, T2
) or else Full_View_Covers
(T2
, T1
))
1192 and then Is_Generic_Actual_Type
(T2
)
1193 and then Full_View_Covers
(T1
, T2
)
1198 and then Is_Generic_Actual_Type
(T1
)
1199 and then Full_View_Covers
(T2
, T1
)
1203 -- In the expansion of inlined bodies, types are compatible if they
1204 -- are structurally equivalent.
1206 elsif In_Inlined_Body
1207 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1209 (Is_Access_Type
(T1
)
1210 and then Is_Access_Type
(T2
)
1211 and then Designated_Type
(T1
) = Designated_Type
(T2
))
1214 and then Is_Access_Type
(Underlying_Type
(T2
)))
1217 and then Is_Composite_Type
(Underlying_Type
(T1
))))
1221 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1222 -- obtained through a limited_with compatible with its real entity.
1224 elsif From_Limited_With
(T1
) then
1226 -- If the expected type is the nonlimited view of a type, the
1227 -- expression may have the limited view. If that one in turn is
1228 -- incomplete, get full view if available.
1230 return Has_Non_Limited_View
(T1
)
1231 and then Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1233 elsif From_Limited_With
(T2
) then
1235 -- If units in the context have Limited_With clauses on each other,
1236 -- either type might have a limited view. Checks performed elsewhere
1237 -- verify that the context type is the nonlimited view.
1239 return Has_Non_Limited_View
(T2
)
1240 and then Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1242 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1244 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1245 return Covers
(Full_View
(Etype
(T1
)), T2
);
1247 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1248 return Covers
(T1
, Full_View
(Etype
(T2
)));
1250 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1251 -- and actual anonymous access types in the context of generic
1252 -- instantiations. We have the following situation:
1255 -- type Formal is private;
1256 -- Formal_Obj : access Formal; -- T1
1260 -- type Actual is ...
1261 -- Actual_Obj : access Actual; -- T2
1262 -- package Instance is new G (Formal => Actual,
1263 -- Formal_Obj => Actual_Obj);
1265 elsif Ada_Version
>= Ada_2005
1266 and then Ekind
(T1
) = E_Anonymous_Access_Type
1267 and then Ekind
(T2
) = E_Anonymous_Access_Type
1268 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1269 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1270 Directly_Designated_Type
(T2
)
1274 -- Otherwise, types are not compatible
1285 function Disambiguate
1287 I1
, I2
: Interp_Index
;
1288 Typ
: Entity_Id
) return Interp
1293 Nam1
, Nam2
: Entity_Id
;
1294 Predef_Subp
: Entity_Id
;
1295 User_Subp
: Entity_Id
;
1297 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1298 -- Determine whether one of the candidates is an operation inherited by
1299 -- a type that is derived from an actual in an instantiation.
1301 function In_Same_Declaration_List
1303 Op_Decl
: Entity_Id
) return Boolean;
1304 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1305 -- access types is declared on the partial view of a designated type, so
1306 -- that the type declaration and equality are not in the same list of
1307 -- declarations. This AI gives a preference rule for the user-defined
1308 -- operation. Same rule applies for arithmetic operations on private
1309 -- types completed with fixed-point types: the predefined operation is
1310 -- hidden; this is already handled properly in GNAT.
1312 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1313 -- Determine whether a subprogram is an actual in an enclosing instance.
1314 -- An overloading between such a subprogram and one declared outside the
1315 -- instance is resolved in favor of the first, because it resolved in
1316 -- the generic. Within the instance the actual is represented by a
1317 -- constructed subprogram renaming.
1319 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean;
1320 -- Determine whether function Func_Id is an exact match for binary or
1321 -- unary operator Op.
1323 function Operand_Type
return Entity_Id
;
1324 -- Determine type of operand for an equality operation, to apply Ada
1325 -- 2005 rules to equality on anonymous access types.
1327 function Standard_Operator
return Boolean;
1328 -- Check whether subprogram is predefined operator declared in Standard.
1329 -- It may given by an operator name, or by an expanded name whose prefix
1332 function Remove_Conversions
return Interp
;
1333 -- Last chance for pathological cases involving comparisons on literals,
1334 -- and user overloadings of the same operator. Such pathologies have
1335 -- been removed from the ACVC, but still appear in two DEC tests, with
1336 -- the following notable quote from Ben Brosgol:
1338 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1339 -- this example; Robert Dewar brought it to our attention, since it is
1340 -- apparently found in the ACVC 1.5. I did not attempt to find the
1341 -- reason in the Reference Manual that makes the example legal, since I
1342 -- was too nauseated by it to want to pursue it further.]
1344 -- Accordingly, this is not a fully recursive solution, but it handles
1345 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1346 -- pathology in the other direction with calls whose multiple overloaded
1347 -- actuals make them truly unresolvable.
1349 -- The new rules concerning abstract operations create additional need
1350 -- for special handling of expressions with universal operands, see
1351 -- comments to Has_Abstract_Interpretation below.
1353 ---------------------------
1354 -- Inherited_From_Actual --
1355 ---------------------------
1357 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1358 Par
: constant Node_Id
:= Parent
(S
);
1360 if Nkind
(Par
) /= N_Full_Type_Declaration
1361 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1365 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1367 Is_Generic_Actual_Type
(
1368 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1370 end Inherited_From_Actual
;
1372 ------------------------------
1373 -- In_Same_Declaration_List --
1374 ------------------------------
1376 function In_Same_Declaration_List
1378 Op_Decl
: Entity_Id
) return Boolean
1380 Scop
: constant Entity_Id
:= Scope
(Typ
);
1383 return In_Same_List
(Parent
(Typ
), Op_Decl
)
1385 (Ekind_In
(Scop
, E_Package
, E_Generic_Package
)
1386 and then List_Containing
(Op_Decl
) =
1387 Visible_Declarations
(Parent
(Scop
))
1388 and then List_Containing
(Parent
(Typ
)) =
1389 Private_Declarations
(Parent
(Scop
)));
1390 end In_Same_Declaration_List
;
1392 --------------------------
1393 -- Is_Actual_Subprogram --
1394 --------------------------
1396 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1398 return In_Open_Scopes
(Scope
(S
))
1399 and then Nkind
(Unit_Declaration_Node
(S
)) =
1400 N_Subprogram_Renaming_Declaration
1402 -- Why the Comes_From_Source test here???
1404 and then not Comes_From_Source
(Unit_Declaration_Node
(S
))
1407 (Is_Generic_Instance
(Scope
(S
))
1408 or else Is_Wrapper_Package
(Scope
(S
)));
1409 end Is_Actual_Subprogram
;
1415 function Matches
(Op
: Node_Id
; Func_Id
: Entity_Id
) return Boolean is
1416 function Matching_Types
1417 (Opnd_Typ
: Entity_Id
;
1418 Formal_Typ
: Entity_Id
) return Boolean;
1419 -- Determine whether operand type Opnd_Typ and formal parameter type
1420 -- Formal_Typ are either the same or compatible.
1422 --------------------
1423 -- Matching_Types --
1424 --------------------
1426 function Matching_Types
1427 (Opnd_Typ
: Entity_Id
;
1428 Formal_Typ
: Entity_Id
) return Boolean
1433 if Opnd_Typ
= Formal_Typ
then
1436 -- Any integer type matches universal integer
1438 elsif Opnd_Typ
= Universal_Integer
1439 and then Is_Integer_Type
(Formal_Typ
)
1443 -- Any floating point type matches universal real
1445 elsif Opnd_Typ
= Universal_Real
1446 and then Is_Floating_Point_Type
(Formal_Typ
)
1450 -- The type of the formal parameter maps a generic actual type to
1451 -- a generic formal type. If the operand type is the type being
1452 -- mapped in an instance, then this is a match.
1454 elsif Is_Generic_Actual_Type
(Formal_Typ
)
1455 and then Etype
(Formal_Typ
) = Opnd_Typ
1459 -- ??? There are possibly other cases to consider
1468 F1
: constant Entity_Id
:= First_Formal
(Func_Id
);
1469 F1_Typ
: constant Entity_Id
:= Etype
(F1
);
1470 F2
: constant Entity_Id
:= Next_Formal
(F1
);
1471 F2_Typ
: constant Entity_Id
:= Etype
(F2
);
1472 Lop_Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(Op
));
1473 Rop_Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(Op
));
1475 -- Start of processing for Matches
1478 if Lop_Typ
= F1_Typ
then
1479 return Matching_Types
(Rop_Typ
, F2_Typ
);
1481 elsif Rop_Typ
= F2_Typ
then
1482 return Matching_Types
(Lop_Typ
, F1_Typ
);
1484 -- Otherwise this is not a good match because each operand-formal
1485 -- pair is compatible only on base-type basis, which is not specific
1497 function Operand_Type
return Entity_Id
is
1501 if Nkind
(N
) = N_Function_Call
then
1502 Opnd
:= First_Actual
(N
);
1504 Opnd
:= Left_Opnd
(N
);
1507 return Etype
(Opnd
);
1510 ------------------------
1511 -- Remove_Conversions --
1512 ------------------------
1514 function Remove_Conversions
return Interp
is
1522 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1523 -- If an operation has universal operands the universal operation
1524 -- is present among its interpretations. If there is an abstract
1525 -- interpretation for the operator, with a numeric result, this
1526 -- interpretation was already removed in sem_ch4, but the universal
1527 -- one is still visible. We must rescan the list of operators and
1528 -- remove the universal interpretation to resolve the ambiguity.
1530 ---------------------------------
1531 -- Has_Abstract_Interpretation --
1532 ---------------------------------
1534 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1538 if Nkind
(N
) not in N_Op
1539 or else Ada_Version
< Ada_2005
1540 or else not Is_Overloaded
(N
)
1541 or else No
(Universal_Interpretation
(N
))
1546 E
:= Get_Name_Entity_Id
(Chars
(N
));
1547 while Present
(E
) loop
1548 if Is_Overloadable
(E
)
1549 and then Is_Abstract_Subprogram
(E
)
1550 and then Is_Numeric_Type
(Etype
(E
))
1558 -- Finally, if an operand of the binary operator is itself
1559 -- an operator, recurse to see whether its own abstract
1560 -- interpretation is responsible for the spurious ambiguity.
1562 if Nkind
(N
) in N_Binary_Op
then
1563 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1564 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1566 elsif Nkind
(N
) in N_Unary_Op
then
1567 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1573 end Has_Abstract_Interpretation
;
1575 -- Start of processing for Remove_Conversions
1580 Get_First_Interp
(N
, I
, It
);
1581 while Present
(It
.Typ
) loop
1582 if not Is_Overloadable
(It
.Nam
) then
1586 F1
:= First_Formal
(It
.Nam
);
1592 if Nkind
(N
) in N_Subprogram_Call
then
1593 Act1
:= First_Actual
(N
);
1595 if Present
(Act1
) then
1596 Act2
:= Next_Actual
(Act1
);
1601 elsif Nkind
(N
) in N_Unary_Op
then
1602 Act1
:= Right_Opnd
(N
);
1605 elsif Nkind
(N
) in N_Binary_Op
then
1606 Act1
:= Left_Opnd
(N
);
1607 Act2
:= Right_Opnd
(N
);
1609 -- Use type of second formal, so as to include
1610 -- exponentiation, where the exponent may be
1611 -- ambiguous and the result non-universal.
1619 if Nkind
(Act1
) in N_Op
1620 and then Is_Overloaded
(Act1
)
1621 and then Nkind_In
(Left_Opnd
(Act1
), N_Integer_Literal
,
1623 and then Nkind_In
(Right_Opnd
(Act1
), N_Integer_Literal
,
1625 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1626 and then Etype
(F1
) = Standard_Boolean
1628 -- If the two candidates are the original ones, the
1629 -- ambiguity is real. Otherwise keep the original, further
1630 -- calls to Disambiguate will take care of others in the
1631 -- list of candidates.
1633 if It1
/= No_Interp
then
1634 if It
= Disambiguate
.It1
1635 or else It
= Disambiguate
.It2
1637 if It1
= Disambiguate
.It1
1638 or else It1
= Disambiguate
.It2
1646 elsif Present
(Act2
)
1647 and then Nkind
(Act2
) in N_Op
1648 and then Is_Overloaded
(Act2
)
1649 and then Nkind_In
(Right_Opnd
(Act2
), N_Integer_Literal
,
1651 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1653 -- The preference rule on the first actual is not
1654 -- sufficient to disambiguate.
1662 elsif Is_Numeric_Type
(Etype
(F1
))
1663 and then Has_Abstract_Interpretation
(Act1
)
1665 -- Current interpretation is not the right one because it
1666 -- expects a numeric operand. Examine all the other ones.
1673 Get_First_Interp
(N
, I
, It
);
1674 while Present
(It
.Typ
) loop
1676 not Is_Numeric_Type
(Etype
(First_Formal
(It
.Nam
)))
1679 or else not Has_Abstract_Interpretation
(Act2
)
1682 (Etype
(Next_Formal
(First_Formal
(It
.Nam
))))
1688 Get_Next_Interp
(I
, It
);
1697 Get_Next_Interp
(I
, It
);
1700 -- After some error, a formal may have Any_Type and yield a spurious
1701 -- match. To avoid cascaded errors if possible, check for such a
1702 -- formal in either candidate.
1704 if Serious_Errors_Detected
> 0 then
1709 Formal
:= First_Formal
(Nam1
);
1710 while Present
(Formal
) loop
1711 if Etype
(Formal
) = Any_Type
then
1712 return Disambiguate
.It2
;
1715 Next_Formal
(Formal
);
1718 Formal
:= First_Formal
(Nam2
);
1719 while Present
(Formal
) loop
1720 if Etype
(Formal
) = Any_Type
then
1721 return Disambiguate
.It1
;
1724 Next_Formal
(Formal
);
1730 end Remove_Conversions
;
1732 -----------------------
1733 -- Standard_Operator --
1734 -----------------------
1736 function Standard_Operator
return Boolean is
1740 if Nkind
(N
) in N_Op
then
1743 elsif Nkind
(N
) = N_Function_Call
then
1746 if Nkind
(Nam
) /= N_Expanded_Name
then
1749 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1754 end Standard_Operator
;
1756 -- Start of processing for Disambiguate
1759 -- Recover the two legal interpretations
1761 Get_First_Interp
(N
, I
, It
);
1763 Get_Next_Interp
(I
, It
);
1770 Get_Next_Interp
(I
, It
);
1776 -- Check whether one of the entities is an Ada 2005/2012 and we are
1777 -- operating in an earlier mode, in which case we discard the Ada
1778 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
1780 if Ada_Version
< Ada_2005
then
1781 if Is_Ada_2005_Only
(Nam1
) or else Is_Ada_2012_Only
(Nam1
) then
1783 elsif Is_Ada_2005_Only
(Nam2
) or else Is_Ada_2012_Only
(Nam1
) then
1788 -- Check whether one of the entities is an Ada 2012 entity and we are
1789 -- operating in Ada 2005 mode, in which case we discard the Ada 2012
1790 -- entity, so that we get proper Ada 2005 overload resolution.
1792 if Ada_Version
= Ada_2005
then
1793 if Is_Ada_2012_Only
(Nam1
) then
1795 elsif Is_Ada_2012_Only
(Nam2
) then
1800 -- If the context is universal, the predefined operator is preferred.
1801 -- This includes bounds in numeric type declarations, and expressions
1802 -- in type conversions. If no interpretation yields a universal type,
1803 -- then we must check whether the user-defined entity hides the prede-
1806 if Chars
(Nam1
) in Any_Operator_Name
and then Standard_Operator
then
1807 if Typ
= Universal_Integer
1808 or else Typ
= Universal_Real
1809 or else Typ
= Any_Integer
1810 or else Typ
= Any_Discrete
1811 or else Typ
= Any_Real
1812 or else Typ
= Any_Type
1814 -- Find an interpretation that yields the universal type, or else
1815 -- a predefined operator that yields a predefined numeric type.
1818 Candidate
: Interp
:= No_Interp
;
1821 Get_First_Interp
(N
, I
, It
);
1822 while Present
(It
.Typ
) loop
1823 if (It
.Typ
= Universal_Integer
1824 or else It
.Typ
= Universal_Real
)
1825 and then (Typ
= Any_Type
or else Covers
(Typ
, It
.Typ
))
1829 elsif Is_Numeric_Type
(It
.Typ
)
1830 and then Scope
(It
.Typ
) = Standard_Standard
1831 and then Scope
(It
.Nam
) = Standard_Standard
1832 and then Covers
(Typ
, It
.Typ
)
1837 Get_Next_Interp
(I
, It
);
1840 if Candidate
/= No_Interp
then
1845 elsif Chars
(Nam1
) /= Name_Op_Not
1846 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1848 -- Equality or comparison operation. Choose predefined operator if
1849 -- arguments are universal. The node may be an operator, name, or
1850 -- a function call, so unpack arguments accordingly.
1853 Arg1
, Arg2
: Node_Id
;
1856 if Nkind
(N
) in N_Op
then
1857 Arg1
:= Left_Opnd
(N
);
1858 Arg2
:= Right_Opnd
(N
);
1860 elsif Is_Entity_Name
(N
) then
1861 Arg1
:= First_Entity
(Entity
(N
));
1862 Arg2
:= Next_Entity
(Arg1
);
1865 Arg1
:= First_Actual
(N
);
1866 Arg2
:= Next_Actual
(Arg1
);
1870 and then Present
(Universal_Interpretation
(Arg1
))
1871 and then Universal_Interpretation
(Arg2
) =
1872 Universal_Interpretation
(Arg1
)
1874 Get_First_Interp
(N
, I
, It
);
1875 while Scope
(It
.Nam
) /= Standard_Standard
loop
1876 Get_Next_Interp
(I
, It
);
1885 -- If no universal interpretation, check whether user-defined operator
1886 -- hides predefined one, as well as other special cases. If the node
1887 -- is a range, then one or both bounds are ambiguous. Each will have
1888 -- to be disambiguated w.r.t. the context type. The type of the range
1889 -- itself is imposed by the context, so we can return either legal
1892 if Ekind
(Nam1
) = E_Operator
then
1893 Predef_Subp
:= Nam1
;
1896 elsif Ekind
(Nam2
) = E_Operator
then
1897 Predef_Subp
:= Nam2
;
1900 elsif Nkind
(N
) = N_Range
then
1903 -- Implement AI05-105: A renaming declaration with an access
1904 -- definition must resolve to an anonymous access type. This
1905 -- is a resolution rule and can be used to disambiguate.
1907 elsif Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
1908 and then Present
(Access_Definition
(Parent
(N
)))
1910 if Ekind_In
(It1
.Typ
, E_Anonymous_Access_Type
,
1911 E_Anonymous_Access_Subprogram_Type
)
1913 if Ekind
(It2
.Typ
) = Ekind
(It1
.Typ
) then
1923 elsif Ekind_In
(It2
.Typ
, E_Anonymous_Access_Type
,
1924 E_Anonymous_Access_Subprogram_Type
)
1928 -- No legal interpretation
1934 -- If two user defined-subprograms are visible, it is a true ambiguity,
1935 -- unless one of them is an entry and the context is a conditional or
1936 -- timed entry call, or unless we are within an instance and this is
1937 -- results from two formals types with the same actual.
1940 if Nkind
(N
) = N_Procedure_Call_Statement
1941 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1942 and then N
= Entry_Call_Statement
(Parent
(N
))
1944 if Ekind
(Nam2
) = E_Entry
then
1946 elsif Ekind
(Nam1
) = E_Entry
then
1952 -- If the ambiguity occurs within an instance, it is due to several
1953 -- formal types with the same actual. Look for an exact match between
1954 -- the types of the formals of the overloadable entities, and the
1955 -- actuals in the call, to recover the unambiguous match in the
1956 -- original generic.
1958 -- The ambiguity can also be due to an overloading between a formal
1959 -- subprogram and a subprogram declared outside the generic. If the
1960 -- node is overloaded, it did not resolve to the global entity in
1961 -- the generic, and we choose the formal subprogram.
1963 -- Finally, the ambiguity can be between an explicit subprogram and
1964 -- one inherited (with different defaults) from an actual. In this
1965 -- case the resolution was to the explicit declaration in the
1966 -- generic, and remains so in the instance.
1968 -- The same sort of disambiguation needed for calls is also required
1969 -- for the name given in a subprogram renaming, and that case is
1970 -- handled here as well. We test Comes_From_Source to exclude this
1971 -- treatment for implicit renamings created for formal subprograms.
1973 elsif In_Instance
and then not In_Generic_Actual
(N
) then
1974 if Nkind
(N
) in N_Subprogram_Call
1976 (Nkind
(N
) in N_Has_Entity
1978 Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
1979 and then Comes_From_Source
(Parent
(N
)))
1984 Renam
: Entity_Id
:= Empty
;
1985 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1986 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1989 if Is_Act1
and then not Is_Act2
then
1992 elsif Is_Act2
and then not Is_Act1
then
1995 elsif Inherited_From_Actual
(Nam1
)
1996 and then Comes_From_Source
(Nam2
)
2000 elsif Inherited_From_Actual
(Nam2
)
2001 and then Comes_From_Source
(Nam1
)
2006 -- In the case of a renamed subprogram, pick up the entity
2007 -- of the renaming declaration so we can traverse its
2008 -- formal parameters.
2010 if Nkind
(N
) in N_Has_Entity
then
2011 Renam
:= Defining_Unit_Name
(Specification
(Parent
(N
)));
2014 if Present
(Renam
) then
2015 Actual
:= First_Formal
(Renam
);
2017 Actual
:= First_Actual
(N
);
2020 Formal
:= First_Formal
(Nam1
);
2021 while Present
(Actual
) loop
2022 if Etype
(Actual
) /= Etype
(Formal
) then
2026 if Present
(Renam
) then
2027 Next_Formal
(Actual
);
2029 Next_Actual
(Actual
);
2032 Next_Formal
(Formal
);
2038 elsif Nkind
(N
) in N_Binary_Op
then
2039 if Matches
(N
, Nam1
) then
2045 elsif Nkind
(N
) in N_Unary_Op
then
2046 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
2053 return Remove_Conversions
;
2056 return Remove_Conversions
;
2060 -- An implicit concatenation operator on a string type cannot be
2061 -- disambiguated from the predefined concatenation. This can only
2062 -- happen with concatenation of string literals.
2064 if Chars
(User_Subp
) = Name_Op_Concat
2065 and then Ekind
(User_Subp
) = E_Operator
2066 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
2070 -- If the user-defined operator is in an open scope, or in the scope
2071 -- of the resulting type, or given by an expanded name that names its
2072 -- scope, it hides the predefined operator for the type. Exponentiation
2073 -- has to be special-cased because the implicit operator does not have
2074 -- a symmetric signature, and may not be hidden by the explicit one.
2076 elsif (Nkind
(N
) = N_Function_Call
2077 and then Nkind
(Name
(N
)) = N_Expanded_Name
2078 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
2079 or else Hides_Op
(User_Subp
, Predef_Subp
))
2080 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
2081 or else Hides_Op
(User_Subp
, Predef_Subp
)
2083 if It1
.Nam
= User_Subp
then
2089 -- Otherwise, the predefined operator has precedence, or if the user-
2090 -- defined operation is directly visible we have a true ambiguity.
2092 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2093 -- exclude the universal_fixed operator, which often causes ambiguities
2096 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2097 -- on a partial view that is completed with a fixed point type. See
2098 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2099 -- user-defined type and subprogram, so that a client of the package
2100 -- has the same resolution as the body of the package.
2103 if (In_Open_Scopes
(Scope
(User_Subp
))
2104 or else Is_Potentially_Use_Visible
(User_Subp
))
2105 and then not In_Instance
2107 if Is_Fixed_Point_Type
(Typ
)
2108 and then Nam_In
(Chars
(Nam1
), Name_Op_Multiply
, Name_Op_Divide
)
2110 (Ada_Version
= Ada_83
2111 or else (Ada_Version
>= Ada_2012
2112 and then In_Same_Declaration_List
2113 (First_Subtype
(Typ
),
2114 Unit_Declaration_Node
(User_Subp
))))
2116 if It2
.Nam
= Predef_Subp
then
2122 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
2123 -- states that the operator defined in Standard is not available
2124 -- if there is a user-defined equality with the proper signature,
2125 -- declared in the same declarative list as the type. The node
2126 -- may be an operator or a function call.
2128 elsif Nam_In
(Chars
(Nam1
), Name_Op_Eq
, Name_Op_Ne
)
2129 and then Ada_Version
>= Ada_2005
2130 and then Etype
(User_Subp
) = Standard_Boolean
2131 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
2133 In_Same_Declaration_List
2134 (Designated_Type
(Operand_Type
),
2135 Unit_Declaration_Node
(User_Subp
))
2137 if It2
.Nam
= Predef_Subp
then
2143 -- An immediately visible operator hides a use-visible user-
2144 -- defined operation. This disambiguation cannot take place
2145 -- earlier because the visibility of the predefined operator
2146 -- can only be established when operand types are known.
2148 elsif Ekind
(User_Subp
) = E_Function
2149 and then Ekind
(Predef_Subp
) = E_Operator
2150 and then Nkind
(N
) in N_Op
2151 and then not Is_Overloaded
(Right_Opnd
(N
))
2153 Is_Immediately_Visible
(Base_Type
(Etype
(Right_Opnd
(N
))))
2154 and then Is_Potentially_Use_Visible
(User_Subp
)
2156 if It2
.Nam
= Predef_Subp
then
2166 elsif It1
.Nam
= Predef_Subp
then
2175 ---------------------
2176 -- End_Interp_List --
2177 ---------------------
2179 procedure End_Interp_List
is
2181 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
2182 All_Interp
.Increment_Last
;
2183 end End_Interp_List
;
2185 -------------------------
2186 -- Entity_Matches_Spec --
2187 -------------------------
2189 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
2191 -- Simple case: same entity kinds, type conformance is required. A
2192 -- parameterless function can also rename a literal.
2194 if Ekind
(Old_S
) = Ekind
(New_S
)
2195 or else (Ekind
(New_S
) = E_Function
2196 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
2198 return Type_Conformant
(New_S
, Old_S
);
2200 elsif Ekind
(New_S
) = E_Function
and then Ekind
(Old_S
) = E_Operator
then
2201 return Operator_Matches_Spec
(Old_S
, New_S
);
2203 elsif Ekind
(New_S
) = E_Procedure
and then Is_Entry
(Old_S
) then
2204 return Type_Conformant
(New_S
, Old_S
);
2209 end Entity_Matches_Spec
;
2211 ----------------------
2212 -- Find_Unique_Type --
2213 ----------------------
2215 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
2216 T
: constant Entity_Id
:= Etype
(L
);
2219 TR
: Entity_Id
:= Any_Type
;
2222 if Is_Overloaded
(R
) then
2223 Get_First_Interp
(R
, I
, It
);
2224 while Present
(It
.Typ
) loop
2225 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
2227 -- If several interpretations are possible and L is universal,
2228 -- apply preference rule.
2230 if TR
/= Any_Type
then
2231 if (T
= Universal_Integer
or else T
= Universal_Real
)
2242 Get_Next_Interp
(I
, It
);
2247 -- In the non-overloaded case, the Etype of R is already set correctly
2253 -- If one of the operands is Universal_Fixed, the type of the other
2254 -- operand provides the context.
2256 if Etype
(R
) = Universal_Fixed
then
2259 elsif T
= Universal_Fixed
then
2262 -- Ada 2005 (AI-230): Support the following operators:
2264 -- function "=" (L, R : universal_access) return Boolean;
2265 -- function "/=" (L, R : universal_access) return Boolean;
2267 -- Pool specific access types (E_Access_Type) are not covered by these
2268 -- operators because of the legality rule of 4.5.2(9.2): "The operands
2269 -- of the equality operators for universal_access shall be convertible
2270 -- to one another (see 4.6)". For example, considering the type decla-
2271 -- ration "type P is access Integer" and an anonymous access to Integer,
2272 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2273 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
2275 elsif Ada_Version
>= Ada_2005
2276 and then Ekind_In
(Etype
(L
), E_Anonymous_Access_Type
,
2277 E_Anonymous_Access_Subprogram_Type
)
2278 and then Is_Access_Type
(Etype
(R
))
2279 and then Ekind
(Etype
(R
)) /= E_Access_Type
2283 elsif Ada_Version
>= Ada_2005
2284 and then Ekind_In
(Etype
(R
), E_Anonymous_Access_Type
,
2285 E_Anonymous_Access_Subprogram_Type
)
2286 and then Is_Access_Type
(Etype
(L
))
2287 and then Ekind
(Etype
(L
)) /= E_Access_Type
2291 -- If one operand is a raise_expression, use type of other operand
2293 elsif Nkind
(L
) = N_Raise_Expression
then
2297 return Specific_Type
(T
, Etype
(R
));
2299 end Find_Unique_Type
;
2301 -------------------------------------
2302 -- Function_Interp_Has_Abstract_Op --
2303 -------------------------------------
2305 function Function_Interp_Has_Abstract_Op
2307 E
: Entity_Id
) return Entity_Id
2309 Abstr_Op
: Entity_Id
;
2312 Form_Parm
: Node_Id
;
2315 -- Why is check on E needed below ???
2316 -- In any case this para needs comments ???
2318 if Is_Overloaded
(N
) and then Is_Overloadable
(E
) then
2319 Act_Parm
:= First_Actual
(N
);
2320 Form_Parm
:= First_Formal
(E
);
2321 while Present
(Act_Parm
) and then Present
(Form_Parm
) loop
2324 if Nkind
(Act
) = N_Parameter_Association
then
2325 Act
:= Explicit_Actual_Parameter
(Act
);
2328 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
2330 if Present
(Abstr_Op
) then
2334 Next_Actual
(Act_Parm
);
2335 Next_Formal
(Form_Parm
);
2340 end Function_Interp_Has_Abstract_Op
;
2342 ----------------------
2343 -- Get_First_Interp --
2344 ----------------------
2346 procedure Get_First_Interp
2348 I
: out Interp_Index
;
2351 Int_Ind
: Interp_Index
;
2356 -- If a selected component is overloaded because the selector has
2357 -- multiple interpretations, the node is a call to a protected
2358 -- operation or an indirect call. Retrieve the interpretation from
2359 -- the selector name. The selected component may be overloaded as well
2360 -- if the prefix is overloaded. That case is unchanged.
2362 if Nkind
(N
) = N_Selected_Component
2363 and then Is_Overloaded
(Selector_Name
(N
))
2365 O_N
:= Selector_Name
(N
);
2370 Map_Ptr
:= Headers
(Hash
(O_N
));
2371 while Map_Ptr
/= No_Entry
loop
2372 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2373 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2374 It
:= All_Interp
.Table
(Int_Ind
);
2378 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2382 -- Procedure should never be called if the node has no interpretations
2384 raise Program_Error
;
2385 end Get_First_Interp
;
2387 ---------------------
2388 -- Get_Next_Interp --
2389 ---------------------
2391 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2394 It
:= All_Interp
.Table
(I
);
2395 end Get_Next_Interp
;
2397 -------------------------
2398 -- Has_Compatible_Type --
2399 -------------------------
2401 function Has_Compatible_Type
2403 Typ
: Entity_Id
) return Boolean
2413 if Nkind
(N
) = N_Subtype_Indication
2414 or else not Is_Overloaded
(N
)
2417 Covers
(Typ
, Etype
(N
))
2419 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2420 -- If the type is already frozen use the corresponding_record
2421 -- to check whether it is a proper descendant.
2424 (Is_Record_Type
(Typ
)
2425 and then Is_Concurrent_Type
(Etype
(N
))
2426 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2427 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2430 (Is_Concurrent_Type
(Typ
)
2431 and then Is_Record_Type
(Etype
(N
))
2432 and then Present
(Corresponding_Record_Type
(Typ
))
2433 and then Covers
(Corresponding_Record_Type
(Typ
), Etype
(N
)))
2436 (not Is_Tagged_Type
(Typ
)
2437 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2438 and then Covers
(Etype
(N
), Typ
));
2443 Get_First_Interp
(N
, I
, It
);
2444 while Present
(It
.Typ
) loop
2445 if (Covers
(Typ
, It
.Typ
)
2447 (Scope
(It
.Nam
) /= Standard_Standard
2448 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2450 -- Ada 2005 (AI-345)
2453 (Is_Concurrent_Type
(It
.Typ
)
2454 and then Present
(Corresponding_Record_Type
2456 and then Covers
(Typ
, Corresponding_Record_Type
2459 or else (not Is_Tagged_Type
(Typ
)
2460 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2461 and then Covers
(It
.Typ
, Typ
))
2466 Get_Next_Interp
(I
, It
);
2471 end Has_Compatible_Type
;
2473 ---------------------
2474 -- Has_Abstract_Op --
2475 ---------------------
2477 function Has_Abstract_Op
2479 Typ
: Entity_Id
) return Entity_Id
2485 if Is_Overloaded
(N
) then
2486 Get_First_Interp
(N
, I
, It
);
2487 while Present
(It
.Nam
) loop
2488 if Present
(It
.Abstract_Op
)
2489 and then Etype
(It
.Abstract_Op
) = Typ
2491 return It
.Abstract_Op
;
2494 Get_Next_Interp
(I
, It
);
2499 end Has_Abstract_Op
;
2505 function Hash
(N
: Node_Id
) return Int
is
2507 -- Nodes have a size that is power of two, so to select significant
2508 -- bits only we remove the low-order bits.
2510 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2517 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2518 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2520 return Operator_Matches_Spec
(Op
, F
)
2521 and then (In_Open_Scopes
(Scope
(F
))
2522 or else Scope
(F
) = Scope
(Btyp
)
2523 or else (not In_Open_Scopes
(Scope
(Btyp
))
2524 and then not In_Use
(Btyp
)
2525 and then not In_Use
(Scope
(Btyp
))));
2528 ------------------------
2529 -- Init_Interp_Tables --
2530 ------------------------
2532 procedure Init_Interp_Tables
is
2536 Headers
:= (others => No_Entry
);
2537 end Init_Interp_Tables
;
2539 -----------------------------------
2540 -- Interface_Present_In_Ancestor --
2541 -----------------------------------
2543 function Interface_Present_In_Ancestor
2545 Iface
: Entity_Id
) return Boolean
2547 Target_Typ
: Entity_Id
;
2548 Iface_Typ
: Entity_Id
;
2550 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2551 -- Returns True if Typ or some ancestor of Typ implements Iface
2553 -------------------------------
2554 -- Iface_Present_In_Ancestor --
2555 -------------------------------
2557 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2563 if Typ
= Iface_Typ
then
2567 -- Handle private types
2569 if Present
(Full_View
(Typ
))
2570 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2572 E
:= Full_View
(Typ
);
2578 if Present
(Interfaces
(E
))
2579 and then Present
(Interfaces
(E
))
2580 and then not Is_Empty_Elmt_List
(Interfaces
(E
))
2582 Elmt
:= First_Elmt
(Interfaces
(E
));
2583 while Present
(Elmt
) loop
2586 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2594 exit when Etype
(E
) = E
2596 -- Handle private types
2598 or else (Present
(Full_View
(Etype
(E
)))
2599 and then Full_View
(Etype
(E
)) = E
);
2601 -- Check if the current type is a direct derivation of the
2604 if Etype
(E
) = Iface_Typ
then
2608 -- Climb to the immediate ancestor handling private types
2610 if Present
(Full_View
(Etype
(E
))) then
2611 E
:= Full_View
(Etype
(E
));
2618 end Iface_Present_In_Ancestor
;
2620 -- Start of processing for Interface_Present_In_Ancestor
2623 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2625 if Is_Class_Wide_Type
(Iface
) then
2626 Iface_Typ
:= Etype
(Base_Type
(Iface
));
2633 Iface_Typ
:= Base_Type
(Iface_Typ
);
2635 if Is_Access_Type
(Typ
) then
2636 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2641 if Is_Concurrent_Record_Type
(Target_Typ
) then
2642 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2645 Target_Typ
:= Base_Type
(Target_Typ
);
2647 -- In case of concurrent types we can't use the Corresponding Record_Typ
2648 -- to look for the interface because it is built by the expander (and
2649 -- hence it is not always available). For this reason we traverse the
2650 -- list of interfaces (available in the parent of the concurrent type)
2652 if Is_Concurrent_Type
(Target_Typ
) then
2653 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2658 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2660 -- The progenitor itself may be a subtype of an interface type.
2662 while Present
(AI
) loop
2663 if Etype
(AI
) = Iface_Typ
2664 or else Base_Type
(Etype
(AI
)) = Iface_Typ
2668 elsif Present
(Interfaces
(Etype
(AI
)))
2669 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2682 if Is_Class_Wide_Type
(Target_Typ
) then
2683 Target_Typ
:= Etype
(Target_Typ
);
2686 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2688 -- We must have either a full view or a nonlimited view of the type
2689 -- to locate the list of ancestors.
2691 if Present
(Full_View
(Target_Typ
)) then
2692 Target_Typ
:= Full_View
(Target_Typ
);
2694 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2695 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2698 -- Protect the front end against previously detected errors
2700 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2705 return Iface_Present_In_Ancestor
(Target_Typ
);
2706 end Interface_Present_In_Ancestor
;
2708 ---------------------
2709 -- Intersect_Types --
2710 ---------------------
2712 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2713 Index
: Interp_Index
;
2717 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2718 -- Find interpretation of right arg that has type compatible with T
2720 --------------------------
2721 -- Check_Right_Argument --
2722 --------------------------
2724 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2725 Index
: Interp_Index
;
2730 if not Is_Overloaded
(R
) then
2731 return Specific_Type
(T
, Etype
(R
));
2734 Get_First_Interp
(R
, Index
, It
);
2736 T2
:= Specific_Type
(T
, It
.Typ
);
2738 if T2
/= Any_Type
then
2742 Get_Next_Interp
(Index
, It
);
2743 exit when No
(It
.Typ
);
2748 end Check_Right_Argument
;
2750 -- Start of processing for Intersect_Types
2753 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2757 if not Is_Overloaded
(L
) then
2758 Typ
:= Check_Right_Argument
(Etype
(L
));
2762 Get_First_Interp
(L
, Index
, It
);
2763 while Present
(It
.Typ
) loop
2764 Typ
:= Check_Right_Argument
(It
.Typ
);
2765 exit when Typ
/= Any_Type
;
2766 Get_Next_Interp
(Index
, It
);
2771 -- If Typ is Any_Type, it means no compatible pair of types was found
2773 if Typ
= Any_Type
then
2774 if Nkind
(Parent
(L
)) in N_Op
then
2775 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2777 elsif Nkind
(Parent
(L
)) = N_Range
then
2778 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2780 -- Ada 2005 (AI-251): Complete the error notification
2782 elsif Is_Class_Wide_Type
(Etype
(R
))
2783 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2785 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2786 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2788 -- Specialize message if one operand is a limited view, a priori
2789 -- unrelated to all other types.
2791 elsif From_Limited_With
(Etype
(R
)) then
2792 Error_Msg_NE
("limited view of& not compatible with context",
2795 elsif From_Limited_With
(Etype
(L
)) then
2796 Error_Msg_NE
("limited view of& not compatible with context",
2799 Error_Msg_N
("incompatible types", Parent
(L
));
2804 end Intersect_Types
;
2806 -----------------------
2807 -- In_Generic_Actual --
2808 -----------------------
2810 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
2811 Par
: constant Node_Id
:= Parent
(Exp
);
2817 elsif Nkind
(Par
) in N_Declaration
then
2818 if Nkind
(Par
) = N_Object_Declaration
then
2819 return Present
(Corresponding_Generic_Association
(Par
));
2824 elsif Nkind
(Par
) = N_Object_Renaming_Declaration
then
2825 return Present
(Corresponding_Generic_Association
(Par
));
2827 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
2831 return In_Generic_Actual
(Parent
(Par
));
2833 end In_Generic_Actual
;
2839 function Is_Ancestor
2842 Use_Full_View
: Boolean := False) return Boolean
2849 BT1
:= Base_Type
(T1
);
2850 BT2
:= Base_Type
(T2
);
2852 -- Handle underlying view of records with unknown discriminants using
2853 -- the original entity that motivated the construction of this
2854 -- underlying record view (see Build_Derived_Private_Type).
2856 if Is_Underlying_Record_View
(BT1
) then
2857 BT1
:= Underlying_Record_View
(BT1
);
2860 if Is_Underlying_Record_View
(BT2
) then
2861 BT2
:= Underlying_Record_View
(BT2
);
2867 -- The predicate must look past privacy
2869 elsif Is_Private_Type
(T1
)
2870 and then Present
(Full_View
(T1
))
2871 and then BT2
= Base_Type
(Full_View
(T1
))
2875 elsif Is_Private_Type
(T2
)
2876 and then Present
(Full_View
(T2
))
2877 and then BT1
= Base_Type
(Full_View
(T2
))
2882 -- Obtain the parent of the base type of T2 (use the full view if
2886 and then Is_Private_Type
(BT2
)
2887 and then Present
(Full_View
(BT2
))
2889 -- No climbing needed if its full view is the root type
2891 if Full_View
(BT2
) = Root_Type
(Full_View
(BT2
)) then
2895 Par
:= Etype
(Full_View
(BT2
));
2902 -- If there was a error on the type declaration, do not recurse
2904 if Error_Posted
(Par
) then
2907 elsif BT1
= Base_Type
(Par
)
2908 or else (Is_Private_Type
(T1
)
2909 and then Present
(Full_View
(T1
))
2910 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2914 elsif Is_Private_Type
(Par
)
2915 and then Present
(Full_View
(Par
))
2916 and then Full_View
(Par
) = BT1
2922 elsif Par
= Root_Type
(Par
) then
2925 -- Continue climbing
2928 -- Use the full-view of private types (if allowed)
2931 and then Is_Private_Type
(Par
)
2932 and then Present
(Full_View
(Par
))
2934 Par
:= Etype
(Full_View
(Par
));
2943 ---------------------------
2944 -- Is_Invisible_Operator --
2945 ---------------------------
2947 function Is_Invisible_Operator
2949 T
: Entity_Id
) return Boolean
2951 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2954 if Nkind
(N
) not in N_Op
then
2957 elsif not Comes_From_Source
(N
) then
2960 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2963 elsif Nkind
(N
) in N_Binary_Op
2964 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2969 return Is_Numeric_Type
(T
)
2970 and then not In_Open_Scopes
(Scope
(T
))
2971 and then not Is_Potentially_Use_Visible
(T
)
2972 and then not In_Use
(T
)
2973 and then not In_Use
(Scope
(T
))
2975 (Nkind
(Orig_Node
) /= N_Function_Call
2976 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2977 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2978 and then not In_Instance
;
2980 end Is_Invisible_Operator
;
2982 --------------------
2984 --------------------
2986 function Is_Progenitor
2988 Typ
: Entity_Id
) return Boolean
2991 return Implements_Interface
(Typ
, Iface
, Exclude_Parents
=> True);
2998 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3002 S
:= Ancestor_Subtype
(T1
);
3003 while Present
(S
) loop
3007 S
:= Ancestor_Subtype
(S
);
3018 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
3019 Index
: Interp_Index
;
3023 Get_First_Interp
(Nam
, Index
, It
);
3024 while Present
(It
.Nam
) loop
3025 if Scope
(It
.Nam
) = Standard_Standard
3026 and then Scope
(It
.Typ
) /= Standard_Standard
3028 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
3029 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
3032 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
3033 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
3036 Get_Next_Interp
(Index
, It
);
3044 procedure New_Interps
(N
: Node_Id
) is
3048 All_Interp
.Append
(No_Interp
);
3050 Map_Ptr
:= Headers
(Hash
(N
));
3052 if Map_Ptr
= No_Entry
then
3054 -- Place new node at end of table
3056 Interp_Map
.Increment_Last
;
3057 Headers
(Hash
(N
)) := Interp_Map
.Last
;
3060 -- Place node at end of chain, or locate its previous entry
3063 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
3065 -- Node is already in the table, and is being rewritten.
3066 -- Start a new interp section, retain hash link.
3068 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
3069 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
3070 Set_Is_Overloaded
(N
, True);
3074 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
3075 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
3079 -- Chain the new node
3081 Interp_Map
.Increment_Last
;
3082 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
3085 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
3086 Set_Is_Overloaded
(N
, True);
3089 ---------------------------
3090 -- Operator_Matches_Spec --
3091 ---------------------------
3093 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
3094 New_First_F
: constant Entity_Id
:= First_Formal
(New_S
);
3095 Op_Name
: constant Name_Id
:= Chars
(Op
);
3096 T
: constant Entity_Id
:= Etype
(New_S
);
3104 -- To verify that a predefined operator matches a given signature, do a
3105 -- case analysis of the operator classes. Function can have one or two
3106 -- formals and must have the proper result type.
3108 New_F
:= New_First_F
;
3109 Old_F
:= First_Formal
(Op
);
3111 while Present
(New_F
) and then Present
(Old_F
) loop
3113 Next_Formal
(New_F
);
3114 Next_Formal
(Old_F
);
3117 -- Definite mismatch if different number of parameters
3119 if Present
(Old_F
) or else Present
(New_F
) then
3125 T1
:= Etype
(New_First_F
);
3127 if Nam_In
(Op_Name
, Name_Op_Subtract
, Name_Op_Add
, Name_Op_Abs
) then
3128 return Base_Type
(T1
) = Base_Type
(T
)
3129 and then Is_Numeric_Type
(T
);
3131 elsif Op_Name
= Name_Op_Not
then
3132 return Base_Type
(T1
) = Base_Type
(T
)
3133 and then Valid_Boolean_Arg
(Base_Type
(T
));
3142 T1
:= Etype
(New_First_F
);
3143 T2
:= Etype
(Next_Formal
(New_First_F
));
3145 if Nam_In
(Op_Name
, Name_Op_And
, Name_Op_Or
, Name_Op_Xor
) then
3146 return Base_Type
(T1
) = Base_Type
(T2
)
3147 and then Base_Type
(T1
) = Base_Type
(T
)
3148 and then Valid_Boolean_Arg
(Base_Type
(T
));
3150 elsif Nam_In
(Op_Name
, Name_Op_Eq
, Name_Op_Ne
) then
3151 return Base_Type
(T1
) = Base_Type
(T2
)
3152 and then not Is_Limited_Type
(T1
)
3153 and then Is_Boolean_Type
(T
);
3155 elsif Nam_In
(Op_Name
, Name_Op_Lt
, Name_Op_Le
,
3156 Name_Op_Gt
, Name_Op_Ge
)
3158 return Base_Type
(T1
) = Base_Type
(T2
)
3159 and then Valid_Comparison_Arg
(T1
)
3160 and then Is_Boolean_Type
(T
);
3162 elsif Nam_In
(Op_Name
, Name_Op_Add
, Name_Op_Subtract
) then
3163 return Base_Type
(T1
) = Base_Type
(T2
)
3164 and then Base_Type
(T1
) = Base_Type
(T
)
3165 and then Is_Numeric_Type
(T
);
3167 -- For division and multiplication, a user-defined function does not
3168 -- match the predefined universal_fixed operation, except in Ada 83.
3170 elsif Op_Name
= Name_Op_Divide
then
3171 return (Base_Type
(T1
) = Base_Type
(T2
)
3172 and then Base_Type
(T1
) = Base_Type
(T
)
3173 and then Is_Numeric_Type
(T
)
3174 and then (not Is_Fixed_Point_Type
(T
)
3175 or else Ada_Version
= Ada_83
))
3177 -- Mixed_Mode operations on fixed-point types
3179 or else (Base_Type
(T1
) = Base_Type
(T
)
3180 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3181 and then Is_Fixed_Point_Type
(T
))
3183 -- A user defined operator can also match (and hide) a mixed
3184 -- operation on universal literals.
3186 or else (Is_Integer_Type
(T2
)
3187 and then Is_Floating_Point_Type
(T1
)
3188 and then Base_Type
(T1
) = Base_Type
(T
));
3190 elsif Op_Name
= Name_Op_Multiply
then
3191 return (Base_Type
(T1
) = Base_Type
(T2
)
3192 and then Base_Type
(T1
) = Base_Type
(T
)
3193 and then Is_Numeric_Type
(T
)
3194 and then (not Is_Fixed_Point_Type
(T
)
3195 or else Ada_Version
= Ada_83
))
3197 -- Mixed_Mode operations on fixed-point types
3199 or else (Base_Type
(T1
) = Base_Type
(T
)
3200 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
3201 and then Is_Fixed_Point_Type
(T
))
3203 or else (Base_Type
(T2
) = Base_Type
(T
)
3204 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
3205 and then Is_Fixed_Point_Type
(T
))
3207 or else (Is_Integer_Type
(T2
)
3208 and then Is_Floating_Point_Type
(T1
)
3209 and then Base_Type
(T1
) = Base_Type
(T
))
3211 or else (Is_Integer_Type
(T1
)
3212 and then Is_Floating_Point_Type
(T2
)
3213 and then Base_Type
(T2
) = Base_Type
(T
));
3215 elsif Nam_In
(Op_Name
, Name_Op_Mod
, Name_Op_Rem
) then
3216 return Base_Type
(T1
) = Base_Type
(T2
)
3217 and then Base_Type
(T1
) = Base_Type
(T
)
3218 and then Is_Integer_Type
(T
);
3220 elsif Op_Name
= Name_Op_Expon
then
3221 return Base_Type
(T1
) = Base_Type
(T
)
3222 and then Is_Numeric_Type
(T
)
3223 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
3225 elsif Op_Name
= Name_Op_Concat
then
3226 return Is_Array_Type
(T
)
3227 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
3228 and then (Base_Type
(T1
) = Base_Type
(T
)
3230 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
3231 and then (Base_Type
(T2
) = Base_Type
(T
)
3233 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
3239 end Operator_Matches_Spec
;
3245 procedure Remove_Interp
(I
: in out Interp_Index
) is
3249 -- Find end of interp list and copy downward to erase the discarded one
3252 while Present
(All_Interp
.Table
(II
).Typ
) loop
3256 for J
in I
+ 1 .. II
loop
3257 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
3260 -- Back up interp index to insure that iterator will pick up next
3261 -- available interpretation.
3270 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
3272 O_N
: Node_Id
:= Old_N
;
3275 if Is_Overloaded
(Old_N
) then
3276 Set_Is_Overloaded
(New_N
);
3278 if Nkind
(Old_N
) = N_Selected_Component
3279 and then Is_Overloaded
(Selector_Name
(Old_N
))
3281 O_N
:= Selector_Name
(Old_N
);
3284 Map_Ptr
:= Headers
(Hash
(O_N
));
3286 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
3287 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
3288 pragma Assert
(Map_Ptr
/= No_Entry
);
3291 New_Interps
(New_N
);
3292 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
3293 Interp_Map
.Table
(Map_Ptr
).Index
;
3301 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
3302 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
3303 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
3304 B1
: constant Entity_Id
:= Base_Type
(T1
);
3305 B2
: constant Entity_Id
:= Base_Type
(T2
);
3307 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
3308 -- Check whether T is the equivalent type of a remote access type.
3309 -- If distribution is enabled, T is a legal context for Null.
3311 ----------------------
3312 -- Is_Remote_Access --
3313 ----------------------
3315 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
3317 return Is_Record_Type
(T
)
3318 and then (Is_Remote_Call_Interface
(T
)
3319 or else Is_Remote_Types
(T
))
3320 and then Present
(Corresponding_Remote_Type
(T
))
3321 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
3322 end Is_Remote_Access
;
3324 -- Start of processing for Specific_Type
3327 if T1
= Any_Type
or else T2
= Any_Type
then
3334 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
3335 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
3336 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
3337 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
3341 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
3342 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
3343 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
3344 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
3348 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
3351 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
3354 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
3357 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
3360 elsif T1
= Any_Access
3361 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
3365 elsif T2
= Any_Access
3366 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
3370 -- In an instance, the specific type may have a private view. Use full
3371 -- view to check legality.
3373 elsif T2
= Any_Access
3374 and then Is_Private_Type
(T1
)
3375 and then Present
(Full_View
(T1
))
3376 and then Is_Access_Type
(Full_View
(T1
))
3377 and then In_Instance
3381 elsif T2
= Any_Composite
and then Is_Aggregate_Type
(T1
) then
3384 elsif T1
= Any_Composite
and then Is_Aggregate_Type
(T2
) then
3387 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
3390 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
3393 -- ----------------------------------------------------------
3394 -- Special cases for equality operators (all other predefined
3395 -- operators can never apply to tagged types)
3396 -- ----------------------------------------------------------
3398 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3401 elsif Is_Class_Wide_Type
(T1
)
3402 and then Is_Class_Wide_Type
(T2
)
3403 and then Is_Interface
(Etype
(T2
))
3407 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3408 -- class-wide interface T2
3410 elsif Is_Class_Wide_Type
(T2
)
3411 and then Is_Interface
(Etype
(T2
))
3412 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
3413 Iface
=> Etype
(T2
))
3417 elsif Is_Class_Wide_Type
(T1
)
3418 and then Is_Ancestor
(Root_Type
(T1
), T2
)
3422 elsif Is_Class_Wide_Type
(T2
)
3423 and then Is_Ancestor
(Root_Type
(T2
), T1
)
3427 elsif Ekind_In
(B1
, E_Access_Subprogram_Type
,
3428 E_Access_Protected_Subprogram_Type
)
3429 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
3430 and then Is_Access_Type
(T2
)
3434 elsif Ekind_In
(B2
, E_Access_Subprogram_Type
,
3435 E_Access_Protected_Subprogram_Type
)
3436 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
3437 and then Is_Access_Type
(T1
)
3441 elsif Ekind_In
(T1
, E_Allocator_Type
,
3442 E_Access_Attribute_Type
,
3443 E_Anonymous_Access_Type
)
3444 and then Is_Access_Type
(T2
)
3448 elsif Ekind_In
(T2
, E_Allocator_Type
,
3449 E_Access_Attribute_Type
,
3450 E_Anonymous_Access_Type
)
3451 and then Is_Access_Type
(T1
)
3455 -- If none of the above cases applies, types are not compatible
3462 ---------------------
3463 -- Set_Abstract_Op --
3464 ---------------------
3466 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3468 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3469 end Set_Abstract_Op
;
3471 -----------------------
3472 -- Valid_Boolean_Arg --
3473 -----------------------
3475 -- In addition to booleans and arrays of booleans, we must include
3476 -- aggregates as valid boolean arguments, because in the first pass of
3477 -- resolution their components are not examined. If it turns out not to be
3478 -- an aggregate of booleans, this will be diagnosed in Resolve.
3479 -- Any_Composite must be checked for prior to the array type checks because
3480 -- Any_Composite does not have any associated indexes.
3482 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3484 if Is_Boolean_Type
(T
)
3485 or else Is_Modular_Integer_Type
(T
)
3486 or else T
= Universal_Integer
3487 or else T
= Any_Composite
3491 elsif Is_Array_Type
(T
)
3492 and then T
/= Any_String
3493 and then Number_Dimensions
(T
) = 1
3494 and then Is_Boolean_Type
(Component_Type
(T
))
3496 ((not Is_Private_Composite
(T
) and then not Is_Limited_Composite
(T
))
3498 or else Available_Full_View_Of_Component
(T
))
3505 end Valid_Boolean_Arg
;
3507 --------------------------
3508 -- Valid_Comparison_Arg --
3509 --------------------------
3511 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3514 if T
= Any_Composite
then
3517 elsif Is_Discrete_Type
(T
)
3518 or else Is_Real_Type
(T
)
3522 elsif Is_Array_Type
(T
)
3523 and then Number_Dimensions
(T
) = 1
3524 and then Is_Discrete_Type
(Component_Type
(T
))
3525 and then (not Is_Private_Composite
(T
) or else In_Instance
)
3526 and then (not Is_Limited_Composite
(T
) or else In_Instance
)
3530 elsif Is_Array_Type
(T
)
3531 and then Number_Dimensions
(T
) = 1
3532 and then Is_Discrete_Type
(Component_Type
(T
))
3533 and then Available_Full_View_Of_Component
(T
)
3537 elsif Is_String_Type
(T
) then
3542 end Valid_Comparison_Arg
;
3548 procedure Write_Interp
(It
: Interp
) is
3550 Write_Str
("Nam: ");
3551 Print_Tree_Node
(It
.Nam
);
3552 Write_Str
("Typ: ");
3553 Print_Tree_Node
(It
.Typ
);
3554 Write_Str
("Abstract_Op: ");
3555 Print_Tree_Node
(It
.Abstract_Op
);
3558 ----------------------
3559 -- Write_Interp_Ref --
3560 ----------------------
3562 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3564 Write_Str
(" Node: ");
3565 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3566 Write_Str
(" Index: ");
3567 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3568 Write_Str
(" Next: ");
3569 Write_Int
(Interp_Map
.Table
(Map_Ptr
).Next
);
3571 end Write_Interp_Ref
;
3573 ---------------------
3574 -- Write_Overloads --
3575 ---------------------
3577 procedure Write_Overloads
(N
: Node_Id
) is
3583 Write_Str
("Overloads: ");
3584 Print_Node_Briefly
(N
);
3586 if not Is_Overloaded
(N
) then
3587 Write_Line
("Non-overloaded entity ");
3588 Write_Entity_Info
(Entity
(N
), " ");
3590 elsif Nkind
(N
) not in N_Has_Entity
then
3591 Get_First_Interp
(N
, I
, It
);
3592 while Present
(It
.Nam
) loop
3593 Write_Int
(Int
(It
.Typ
));
3595 Write_Name
(Chars
(It
.Typ
));
3597 Get_Next_Interp
(I
, It
);
3601 Get_First_Interp
(N
, I
, It
);
3602 Write_Line
("Overloaded entity ");
3603 Write_Line
(" Name Type Abstract Op");
3604 Write_Line
("===============================================");
3607 while Present
(Nam
) loop
3608 Write_Int
(Int
(Nam
));
3610 Write_Name
(Chars
(Nam
));
3612 Write_Int
(Int
(It
.Typ
));
3614 Write_Name
(Chars
(It
.Typ
));
3616 if Present
(It
.Abstract_Op
) then
3618 Write_Int
(Int
(It
.Abstract_Op
));
3620 Write_Name
(Chars
(It
.Abstract_Op
));
3624 Get_Next_Interp
(I
, It
);
3628 end Write_Overloads
;