1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
34 with Output
; use Output
;
36 with Sem_Ch6
; use Sem_Ch6
;
37 with Sem_Ch8
; use Sem_Ch8
;
38 with Sem_Util
; use Sem_Util
;
39 with Stand
; use Stand
;
40 with Sinfo
; use Sinfo
;
41 with Snames
; use Snames
;
42 with Uintp
; use Uintp
;
44 package body Sem_Type
is
46 -------------------------------------
47 -- Handling of Overload Resolution --
48 -------------------------------------
50 -- Overload resolution uses two passes over the syntax tree of a complete
51 -- context. In the first, bottom-up pass, the types of actuals in calls
52 -- are used to resolve possibly overloaded subprogram and operator names.
53 -- In the second top-down pass, the type of the context (for example the
54 -- condition in a while statement) is used to resolve a possibly ambiguous
55 -- call, and the unique subprogram name in turn imposes a specific context
56 -- on each of its actuals.
58 -- Most expressions are in fact unambiguous, and the bottom-up pass is
59 -- sufficient to resolve most everything. To simplify the common case,
60 -- names and expressions carry a flag Is_Overloaded to indicate whether
61 -- they have more than one interpretation. If the flag is off, then each
62 -- name has already a unique meaning and type, and the bottom-up pass is
63 -- sufficient (and much simpler).
65 --------------------------
66 -- Operator Overloading --
67 --------------------------
69 -- The visibility of operators is handled differently from that of
70 -- other entities. We do not introduce explicit versions of primitive
71 -- operators for each type definition. As a result, there is only one
72 -- entity corresponding to predefined addition on all numeric types, etc.
73 -- The back-end resolves predefined operators according to their type.
74 -- The visibility of primitive operations then reduces to the visibility
75 -- of the resulting type: (a + b) is a legal interpretation of some
76 -- primitive operator + if the type of the result (which must also be
77 -- the type of a and b) is directly visible (i.e. either immediately
78 -- visible or use-visible.)
80 -- User-defined operators are treated like other functions, but the
81 -- visibility of these user-defined operations must be special-cased
82 -- to determine whether they hide or are hidden by predefined operators.
83 -- The form P."+" (x, y) requires additional handling.
85 -- Concatenation is treated more conventionally: for every one-dimensional
86 -- array type we introduce a explicit concatenation operator. This is
87 -- necessary to handle the case of (element & element => array) which
88 -- cannot be handled conveniently if there is no explicit instance of
89 -- resulting type of the operation.
91 -----------------------
92 -- Local Subprograms --
93 -----------------------
95 procedure All_Overloads
;
96 pragma Warnings
(Off
, All_Overloads
);
97 -- Debugging procedure: list full contents of Overloads table.
99 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
;
100 -- Yields universal_Integer or Universal_Real if this is a candidate.
102 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
103 -- If T1 and T2 are compatible, return the one that is not
104 -- universal or is not a "class" type (any_character, etc).
110 procedure Add_One_Interp
114 Opnd_Type
: Entity_Id
:= Empty
)
116 Vis_Type
: Entity_Id
;
118 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
119 -- Add one interpretation to node. Node is already known to be
120 -- overloaded. Add new interpretation if not hidden by previous
121 -- one, and remove previous one if hidden by new one.
123 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
124 -- True if the entity is a predefined operator and the operands have
125 -- a universal Interpretation.
131 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
132 Index
: Interp_Index
;
136 Get_First_Interp
(N
, Index
, It
);
138 while Present
(It
.Nam
) loop
140 -- A user-defined subprogram hides another declared at an outer
141 -- level, or one that is use-visible. So return if previous
142 -- definition hides new one (which is either in an outer
143 -- scope, or use-visible). Note that for functions use-visible
144 -- is the same as potentially use-visible. If new one hides
145 -- previous one, replace entry in table of interpretations.
146 -- If this is a universal operation, retain the operator in case
147 -- preference rule applies.
149 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
150 and then Ekind
(Name
) = Ekind
(It
.Nam
))
151 or else (Ekind
(Name
) = E_Operator
152 and then Ekind
(It
.Nam
) = E_Function
))
154 and then Is_Immediately_Visible
(It
.Nam
)
155 and then Type_Conformant
(Name
, It
.Nam
)
156 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
158 if Is_Universal_Operation
(Name
) then
161 -- If node is an operator symbol, we have no actuals with
162 -- which to check hiding, and this is done in full in the
163 -- caller (Analyze_Subprogram_Renaming) so we include the
164 -- predefined operator in any case.
166 elsif Nkind
(N
) = N_Operator_Symbol
167 or else (Nkind
(N
) = N_Expanded_Name
169 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
173 elsif not In_Open_Scopes
(Scope
(Name
))
174 or else Scope_Depth
(Scope
(Name
))
175 <= Scope_Depth
(Scope
(It
.Nam
))
177 -- If ambiguity within instance, and entity is not an
178 -- implicit operation, save for later disambiguation.
180 if Scope
(Name
) = Scope
(It
.Nam
)
181 and then not Is_Inherited_Operation
(Name
)
190 All_Interp
.Table
(Index
).Nam
:= Name
;
194 -- Avoid making duplicate entries in overloads
197 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
201 -- Otherwise keep going
204 Get_Next_Interp
(Index
, It
);
209 -- On exit, enter new interpretation. The context, or a preference
210 -- rule, will resolve the ambiguity on the second pass.
212 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
213 All_Interp
.Increment_Last
;
214 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
218 ----------------------------
219 -- Is_Universal_Operation --
220 ----------------------------
222 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
226 if Ekind
(Op
) /= E_Operator
then
229 elsif Nkind
(N
) in N_Binary_Op
then
230 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
231 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
233 elsif Nkind
(N
) in N_Unary_Op
then
234 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
236 elsif Nkind
(N
) = N_Function_Call
then
237 Arg
:= First_Actual
(N
);
239 while Present
(Arg
) loop
241 if No
(Universal_Interpretation
(Arg
)) then
253 end Is_Universal_Operation
;
255 -- Start of processing for Add_One_Interp
258 -- If the interpretation is a predefined operator, verify that the
259 -- result type is visible, or that the entity has already been
260 -- resolved (case of an instantiation node that refers to a predefined
261 -- operation, or an internally generated operator node, or an operator
262 -- given as an expanded name). If the operator is a comparison or
263 -- equality, it is the type of the operand that matters to determine
264 -- whether the operator is visible. In an instance, the check is not
265 -- performed, given that the operator was visible in the generic.
267 if Ekind
(E
) = E_Operator
then
269 if Present
(Opnd_Type
) then
270 Vis_Type
:= Opnd_Type
;
272 Vis_Type
:= Base_Type
(T
);
275 if In_Open_Scopes
(Scope
(Vis_Type
))
276 or else Is_Potentially_Use_Visible
(Vis_Type
)
277 or else In_Use
(Vis_Type
)
278 or else (In_Use
(Scope
(Vis_Type
))
279 and then not Is_Hidden
(Vis_Type
))
280 or else Nkind
(N
) = N_Expanded_Name
281 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
286 -- If the node is given in functional notation and the prefix
287 -- is an expanded name, then the operator is visible if the
288 -- prefix is the scope of the result type as well. If the
289 -- operator is (implicitly) defined in an extension of system,
290 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
292 elsif Nkind
(N
) = N_Function_Call
293 and then Nkind
(Name
(N
)) = N_Expanded_Name
294 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
295 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
296 or else Scope
(Vis_Type
) = System_Aux_Id
)
300 -- Save type for subsequent error message, in case no other
301 -- interpretation is found.
304 Candidate_Type
:= Vis_Type
;
308 -- In an instance, an abstract non-dispatching operation cannot
309 -- be a candidate interpretation, because it could not have been
310 -- one in the generic (it may be a spurious overloading in the
314 and then Is_Abstract
(E
)
315 and then not Is_Dispatching_Operation
(E
)
320 -- If this is the first interpretation of N, N has type Any_Type.
321 -- In that case place the new type on the node. If one interpretation
322 -- already exists, indicate that the node is overloaded, and store
323 -- both the previous and the new interpretation in All_Interp. If
324 -- this is a later interpretation, just add it to the set.
326 if Etype
(N
) = Any_Type
then
331 -- Record both the operator or subprogram name, and its type.
333 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
340 -- Either there is no current interpretation in the table for any
341 -- node or the interpretation that is present is for a different
342 -- node. In both cases add a new interpretation to the table.
344 elsif Interp_Map
.Last
< 0
345 or else Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
349 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
350 and then Present
(Entity
(N
))
352 Add_Entry
(Entity
(N
), Etype
(N
));
354 elsif (Nkind
(N
) = N_Function_Call
355 or else Nkind
(N
) = N_Procedure_Call_Statement
)
356 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
357 or else Is_Entity_Name
(Name
(N
)))
359 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
362 -- Overloaded prefix in indexed or selected component,
363 -- or call whose name is an expression or another call.
365 Add_Entry
(Etype
(N
), Etype
(N
));
379 procedure All_Overloads
is
381 for J
in All_Interp
.First
.. All_Interp
.Last
loop
383 if Present
(All_Interp
.Table
(J
).Nam
) then
384 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
386 Write_Str
("No Interp");
389 Write_Str
("=================");
394 ---------------------
395 -- Collect_Interps --
396 ---------------------
398 procedure Collect_Interps
(N
: Node_Id
) is
399 Ent
: constant Entity_Id
:= Entity
(N
);
401 First_Interp
: Interp_Index
;
406 -- Unconditionally add the entity that was initially matched
408 First_Interp
:= All_Interp
.Last
;
409 Add_One_Interp
(N
, Ent
, Etype
(N
));
411 -- For expanded name, pick up all additional entities from the
412 -- same scope, since these are obviously also visible. Note that
413 -- these are not necessarily contiguous on the homonym chain.
415 if Nkind
(N
) = N_Expanded_Name
then
417 while Present
(H
) loop
418 if Scope
(H
) = Scope
(Entity
(N
)) then
419 Add_One_Interp
(N
, H
, Etype
(H
));
425 -- Case of direct name
428 -- First, search the homonym chain for directly visible entities
430 H
:= Current_Entity
(Ent
);
431 while Present
(H
) loop
432 exit when (not Is_Overloadable
(H
))
433 and then Is_Immediately_Visible
(H
);
435 if Is_Immediately_Visible
(H
)
438 -- Only add interpretation if not hidden by an inner
439 -- immediately visible one.
441 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
443 -- Current homograph is not hidden. Add to overloads.
445 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
448 -- Homograph is hidden, unless it is a predefined operator.
450 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
452 -- A homograph in the same scope can occur within an
453 -- instantiation, the resulting ambiguity has to be
456 if Scope
(H
) = Scope
(Ent
)
458 and then not Is_Inherited_Operation
(H
)
460 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
461 All_Interp
.Increment_Last
;
462 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
465 elsif Scope
(H
) /= Standard_Standard
then
471 -- On exit, we know that current homograph is not hidden.
473 Add_One_Interp
(N
, H
, Etype
(H
));
476 Write_Str
("Add overloaded Interpretation ");
486 -- Scan list of homographs for use-visible entities only.
488 H
:= Current_Entity
(Ent
);
490 while Present
(H
) loop
491 if Is_Potentially_Use_Visible
(H
)
493 and then Is_Overloadable
(H
)
495 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
497 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
500 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
501 goto Next_Use_Homograph
;
505 Add_One_Interp
(N
, H
, Etype
(H
));
508 <<Next_Use_Homograph
>>
513 if All_Interp
.Last
= First_Interp
+ 1 then
515 -- The original interpretation is in fact not overloaded.
517 Set_Is_Overloaded
(N
, False);
525 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
527 -- If either operand missing, then this is an error, but ignore
528 -- it (and pretend we have a cover) if errors already detected,
529 -- since this may simply mean we have malformed trees.
531 if No
(T1
) or else No
(T2
) then
532 if Total_Errors_Detected
/= 0 then
539 -- Simplest case: same types are compatible, and types that have the
540 -- same base type and are not generic actuals are compatible. Generic
541 -- actuals belong to their class but are not compatible with other
542 -- types of their class, and in particular with other generic actuals.
543 -- They are however compatible with their own subtypes, and itypes
544 -- with the same base are compatible as well. Similary, constrained
545 -- subtypes obtained from expressions of an unconstrained nominal type
546 -- are compatible with the base type (may lead to spurious ambiguities
547 -- in obscure cases ???)
549 -- Generic actuals require special treatment to avoid spurious ambi-
550 -- guities in an instance, when two formal types are instantiated with
551 -- the same actual, so that different subprograms end up with the same
552 -- signature in the instance.
557 elsif Base_Type
(T1
) = Base_Type
(T2
) then
558 if not Is_Generic_Actual_Type
(T1
) then
561 return (not Is_Generic_Actual_Type
(T2
)
562 or else Is_Itype
(T1
)
563 or else Is_Itype
(T2
)
564 or else Is_Constr_Subt_For_U_Nominal
(T1
)
565 or else Is_Constr_Subt_For_U_Nominal
(T2
)
566 or else Scope
(T1
) /= Scope
(T2
));
569 -- Literals are compatible with types in a given "class"
571 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
572 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
573 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
574 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
575 or else (T2
= Any_String
and then Is_String_Type
(T1
))
576 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
577 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
581 -- The context may be class wide.
583 elsif Is_Class_Wide_Type
(T1
)
584 and then Is_Ancestor
(Root_Type
(T1
), T2
)
588 elsif Is_Class_Wide_Type
(T1
)
589 and then Is_Class_Wide_Type
(T2
)
590 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
594 -- In a dispatching call the actual may be class-wide
596 elsif Is_Class_Wide_Type
(T2
)
597 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
601 -- Some contexts require a class of types rather than a specific type
603 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
604 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
605 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
606 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
607 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
611 -- An aggregate is compatible with an array or record type
613 elsif T2
= Any_Composite
614 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
618 -- If the expected type is an anonymous access, the designated
619 -- type must cover that of the expression.
621 elsif Ekind
(T1
) = E_Anonymous_Access_Type
622 and then Is_Access_Type
(T2
)
623 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
627 -- An Access_To_Subprogram is compatible with itself, or with an
628 -- anonymous type created for an attribute reference Access.
630 elsif (Ekind
(Base_Type
(T1
)) = E_Access_Subprogram_Type
632 Ekind
(Base_Type
(T1
)) = E_Access_Protected_Subprogram_Type
)
633 and then Is_Access_Type
(T2
)
634 and then (not Comes_From_Source
(T1
)
635 or else not Comes_From_Source
(T2
))
636 and then (Is_Overloadable
(Designated_Type
(T2
))
638 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
640 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
642 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
646 elsif Is_Record_Type
(T1
)
647 and then (Is_Remote_Call_Interface
(T1
)
648 or else Is_Remote_Types
(T1
))
649 and then Present
(Corresponding_Remote_Type
(T1
))
651 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
653 elsif Ekind
(T2
) = E_Access_Attribute_Type
654 and then (Ekind
(Base_Type
(T1
)) = E_General_Access_Type
655 or else Ekind
(Base_Type
(T1
)) = E_Access_Type
)
656 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
658 -- If the target type is a RACW type while the source is an access
659 -- attribute type, we are building a RACW that may be exported.
661 if Is_Remote_Access_To_Class_Wide_Type
(Base_Type
(T1
)) then
662 Set_Has_RACW
(Current_Sem_Unit
);
667 elsif Ekind
(T2
) = E_Allocator_Type
668 and then Is_Access_Type
(T1
)
669 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
673 -- A boolean operation on integer literals is compatible with a
676 elsif T2
= Any_Modular
677 and then Is_Modular_Integer_Type
(T1
)
681 -- The actual type may be the result of a previous error
683 elsif Base_Type
(T2
) = Any_Type
then
686 -- A packed array type covers its corresponding non-packed type.
687 -- This is not legitimate Ada, but allows the omission of a number
688 -- of otherwise useless unchecked conversions, and since this can
689 -- only arise in (known correct) expanded code, no harm is done
691 elsif Is_Array_Type
(T2
)
692 and then Is_Packed
(T2
)
693 and then T1
= Packed_Array_Type
(T2
)
697 -- Similarly an array type covers its corresponding packed array type
699 elsif Is_Array_Type
(T1
)
700 and then Is_Packed
(T1
)
701 and then T2
= Packed_Array_Type
(T1
)
705 -- In an instance the proper view may not always be correct for
706 -- private types, but private and full view are compatible. This
707 -- removes spurious errors from nested instantiations that involve,
708 -- among other things, types derived from privated types.
711 and then Is_Private_Type
(T1
)
712 and then ((Present
(Full_View
(T1
))
713 and then Covers
(Full_View
(T1
), T2
))
714 or else Base_Type
(T1
) = T2
715 or else Base_Type
(T2
) = T1
)
719 -- In the expansion of inlined bodies, types are compatible if they
720 -- are structurally equivalent.
722 elsif In_Inlined_Body
723 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
724 or else (Is_Access_Type
(T1
)
725 and then Is_Access_Type
(T2
)
727 Designated_Type
(T1
) = Designated_Type
(T2
))
728 or else (T1
= Any_Access
729 and then Is_Access_Type
(Underlying_Type
(T2
))))
733 -- Otherwise it doesn't cover!
744 function Disambiguate
746 I1
, I2
: Interp_Index
;
753 Nam1
, Nam2
: Entity_Id
;
754 Predef_Subp
: Entity_Id
;
755 User_Subp
: Entity_Id
;
757 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
758 -- Look for exact type match in an instance, to remove spurious
759 -- ambiguities when two formal types have the same actual.
761 function Standard_Operator
return Boolean;
763 function Remove_Conversions
return Interp
;
764 -- Last chance for pathological cases involving comparisons on
765 -- literals, and user overloadings of the same operator. Such
766 -- pathologies have been removed from the ACVC, but still appear in
767 -- two DEC tests, with the following notable quote from Ben Brosgol:
769 -- [Note: I disclaim all credit/responsibility/blame for coming up with
770 -- this example; Robert Dewar brought it to our attention, since it
771 -- is apparently found in the ACVC 1.5. I did not attempt to find
772 -- the reason in the Reference Manual that makes the example legal,
773 -- since I was too nauseated by it to want to pursue it further.]
775 -- Accordingly, this is not a fully recursive solution, but it handles
776 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
777 -- pathology in the other direction with calls whose multiple overloaded
778 -- actuals make them truly unresolvable.
784 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
785 T1
: constant Entity_Id
:= Etype
(Actual
);
786 T2
: constant Entity_Id
:= Etype
(Formal
);
791 (Is_Numeric_Type
(T2
)
793 (T1
= Universal_Real
or else T1
= Universal_Integer
));
796 ------------------------
797 -- Remove_Conversions --
798 ------------------------
800 function Remove_Conversions
return Interp
is
810 Get_First_Interp
(N
, I
, It
);
812 while Present
(It
.Typ
) loop
814 if not Is_Overloadable
(It
.Nam
) then
818 F1
:= First_Formal
(It
.Nam
);
824 if Nkind
(N
) = N_Function_Call
825 or else Nkind
(N
) = N_Procedure_Call_Statement
827 Act1
:= First_Actual
(N
);
829 if Present
(Act1
) then
830 Act2
:= Next_Actual
(Act1
);
835 elsif Nkind
(N
) in N_Unary_Op
then
836 Act1
:= Right_Opnd
(N
);
839 elsif Nkind
(N
) in N_Binary_Op
then
840 Act1
:= Left_Opnd
(N
);
841 Act2
:= Right_Opnd
(N
);
847 if Nkind
(Act1
) in N_Op
848 and then Is_Overloaded
(Act1
)
849 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
850 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
851 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
852 and then Etype
(F1
) = Standard_Boolean
855 if It1
/= No_Interp
then
859 and then Nkind
(Act2
) in N_Op
860 and then Is_Overloaded
(Act2
)
861 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
863 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
864 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
866 -- The preference rule on the first actual is not
867 -- sufficient to disambiguate.
878 Get_Next_Interp
(I
, It
);
881 if Serious_Errors_Detected
> 0 then
883 -- After some error, a formal may have Any_Type and yield
884 -- a spurious match. To avoid cascaded errors if possible,
885 -- check for such a formal in either candidate.
891 Formal
:= First_Formal
(Nam1
);
892 while Present
(Formal
) loop
893 if Etype
(Formal
) = Any_Type
then
894 return Disambiguate
.It2
;
897 Next_Formal
(Formal
);
900 Formal
:= First_Formal
(Nam2
);
901 while Present
(Formal
) loop
902 if Etype
(Formal
) = Any_Type
then
903 return Disambiguate
.It1
;
906 Next_Formal
(Formal
);
912 end Remove_Conversions
;
914 -----------------------
915 -- Standard_Operator --
916 -----------------------
918 function Standard_Operator
return Boolean is
922 if Nkind
(N
) in N_Op
then
925 elsif Nkind
(N
) = N_Function_Call
then
928 if Nkind
(Nam
) /= N_Expanded_Name
then
931 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
936 end Standard_Operator
;
938 -- Start of processing for Disambiguate
941 -- Recover the two legal interpretations.
943 Get_First_Interp
(N
, I
, It
);
946 Get_Next_Interp
(I
, It
);
953 Get_Next_Interp
(I
, It
);
959 -- If the context is universal, the predefined operator is preferred.
960 -- This includes bounds in numeric type declarations, and expressions
961 -- in type conversions. If no interpretation yields a universal type,
962 -- then we must check whether the user-defined entity hides the prede-
965 if Chars
(Nam1
) in Any_Operator_Name
966 and then Standard_Operator
968 if Typ
= Universal_Integer
969 or else Typ
= Universal_Real
970 or else Typ
= Any_Integer
971 or else Typ
= Any_Discrete
972 or else Typ
= Any_Real
973 or else Typ
= Any_Type
975 -- Find an interpretation that yields the universal type, or else
976 -- a predefined operator that yields a predefined numeric type.
979 Candidate
: Interp
:= No_Interp
;
981 Get_First_Interp
(N
, I
, It
);
983 while Present
(It
.Typ
) loop
984 if (Covers
(Typ
, It
.Typ
)
985 or else Typ
= Any_Type
)
987 (It
.Typ
= Universal_Integer
988 or else It
.Typ
= Universal_Real
)
992 elsif Covers
(Typ
, It
.Typ
)
993 and then Scope
(It
.Typ
) = Standard_Standard
994 and then Scope
(It
.Nam
) = Standard_Standard
995 and then Is_Numeric_Type
(It
.Typ
)
1000 Get_Next_Interp
(I
, It
);
1003 if Candidate
/= No_Interp
then
1008 elsif Chars
(Nam1
) /= Name_Op_Not
1009 and then (Typ
= Standard_Boolean
1010 or else Typ
= Any_Boolean
)
1012 -- Equality or comparison operation. Choose predefined operator
1013 -- if arguments are universal. The node may be an operator, a
1014 -- name, or a function call, so unpack arguments accordingly.
1017 Arg1
, Arg2
: Node_Id
;
1020 if Nkind
(N
) in N_Op
then
1021 Arg1
:= Left_Opnd
(N
);
1022 Arg2
:= Right_Opnd
(N
);
1024 elsif Is_Entity_Name
(N
)
1025 or else Nkind
(N
) = N_Operator_Symbol
1027 Arg1
:= First_Entity
(Entity
(N
));
1028 Arg2
:= Next_Entity
(Arg1
);
1031 Arg1
:= First_Actual
(N
);
1032 Arg2
:= Next_Actual
(Arg1
);
1036 and then Present
(Universal_Interpretation
(Arg1
))
1037 and then Universal_Interpretation
(Arg2
) =
1038 Universal_Interpretation
(Arg1
)
1040 Get_First_Interp
(N
, I
, It
);
1042 while Scope
(It
.Nam
) /= Standard_Standard
loop
1043 Get_Next_Interp
(I
, It
);
1052 -- If no universal interpretation, check whether user-defined operator
1053 -- hides predefined one, as well as other special cases. If the node
1054 -- is a range, then one or both bounds are ambiguous. Each will have
1055 -- to be disambiguated w.r.t. the context type. The type of the range
1056 -- itself is imposed by the context, so we can return either legal
1059 if Ekind
(Nam1
) = E_Operator
then
1060 Predef_Subp
:= Nam1
;
1063 elsif Ekind
(Nam2
) = E_Operator
then
1064 Predef_Subp
:= Nam2
;
1067 elsif Nkind
(N
) = N_Range
then
1070 -- If two user defined-subprograms are visible, it is a true ambiguity,
1071 -- unless one of them is an entry and the context is a conditional or
1072 -- timed entry call, or unless we are within an instance and this is
1073 -- results from two formals types with the same actual.
1076 if Nkind
(N
) = N_Procedure_Call_Statement
1077 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1078 and then N
= Entry_Call_Statement
(Parent
(N
))
1080 if Ekind
(Nam2
) = E_Entry
then
1082 elsif Ekind
(Nam1
) = E_Entry
then
1088 -- If the ambiguity occurs within an instance, it is due to several
1089 -- formal types with the same actual. Look for an exact match
1090 -- between the types of the formals of the overloadable entities,
1091 -- and the actuals in the call, to recover the unambiguous match
1092 -- in the original generic.
1094 elsif In_Instance
then
1095 if (Nkind
(N
) = N_Function_Call
1096 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1103 Actual
:= First_Actual
(N
);
1104 Formal
:= First_Formal
(Nam1
);
1105 while Present
(Actual
) loop
1106 if Etype
(Actual
) /= Etype
(Formal
) then
1110 Next_Actual
(Actual
);
1111 Next_Formal
(Formal
);
1117 elsif Nkind
(N
) in N_Binary_Op
then
1119 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1121 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1128 elsif Nkind
(N
) in N_Unary_Op
then
1130 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1137 return Remove_Conversions
;
1140 return Remove_Conversions
;
1144 -- an implicit concatenation operator on a string type cannot be
1145 -- disambiguated from the predefined concatenation. This can only
1146 -- happen with concatenation of string literals.
1148 if Chars
(User_Subp
) = Name_Op_Concat
1149 and then Ekind
(User_Subp
) = E_Operator
1150 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1154 -- If the user-defined operator is in an open scope, or in the scope
1155 -- of the resulting type, or given by an expanded name that names its
1156 -- scope, it hides the predefined operator for the type. Exponentiation
1157 -- has to be special-cased because the implicit operator does not have
1158 -- a symmetric signature, and may not be hidden by the explicit one.
1160 elsif (Nkind
(N
) = N_Function_Call
1161 and then Nkind
(Name
(N
)) = N_Expanded_Name
1162 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1163 or else Hides_Op
(User_Subp
, Predef_Subp
))
1164 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1165 or else Hides_Op
(User_Subp
, Predef_Subp
)
1167 if It1
.Nam
= User_Subp
then
1173 -- Otherwise, the predefined operator has precedence, or if the
1174 -- user-defined operation is directly visible we have a true ambiguity.
1175 -- If this is a fixed-point multiplication and division in Ada83 mode,
1176 -- exclude the universal_fixed operator, which often causes ambiguities
1180 if (In_Open_Scopes
(Scope
(User_Subp
))
1181 or else Is_Potentially_Use_Visible
(User_Subp
))
1182 and then not In_Instance
1184 if Is_Fixed_Point_Type
(Typ
)
1185 and then (Chars
(Nam1
) = Name_Op_Multiply
1186 or else Chars
(Nam1
) = Name_Op_Divide
)
1189 if It2
.Nam
= Predef_Subp
then
1199 elsif It1
.Nam
= Predef_Subp
then
1209 ---------------------
1210 -- End_Interp_List --
1211 ---------------------
1213 procedure End_Interp_List
is
1215 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1216 All_Interp
.Increment_Last
;
1217 end End_Interp_List
;
1219 -------------------------
1220 -- Entity_Matches_Spec --
1221 -------------------------
1223 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1225 -- Simple case: same entity kinds, type conformance is required.
1226 -- A parameterless function can also rename a literal.
1228 if Ekind
(Old_S
) = Ekind
(New_S
)
1229 or else (Ekind
(New_S
) = E_Function
1230 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1232 return Type_Conformant
(New_S
, Old_S
);
1234 elsif Ekind
(New_S
) = E_Function
1235 and then Ekind
(Old_S
) = E_Operator
1237 return Operator_Matches_Spec
(Old_S
, New_S
);
1239 elsif Ekind
(New_S
) = E_Procedure
1240 and then Is_Entry
(Old_S
)
1242 return Type_Conformant
(New_S
, Old_S
);
1247 end Entity_Matches_Spec
;
1249 ----------------------
1250 -- Find_Unique_Type --
1251 ----------------------
1253 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1256 T
: Entity_Id
:= Etype
(L
);
1257 TR
: Entity_Id
:= Any_Type
;
1260 if Is_Overloaded
(R
) then
1261 Get_First_Interp
(R
, I
, It
);
1263 while Present
(It
.Typ
) loop
1264 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1266 -- If several interpretations are possible and L is universal,
1267 -- apply preference rule.
1269 if TR
/= Any_Type
then
1271 if (T
= Universal_Integer
or else T
= Universal_Real
)
1282 Get_Next_Interp
(I
, It
);
1287 -- In the non-overloaded case, the Etype of R is already set
1294 -- If one of the operands is Universal_Fixed, the type of the
1295 -- other operand provides the context.
1297 if Etype
(R
) = Universal_Fixed
then
1300 elsif T
= Universal_Fixed
then
1304 return Specific_Type
(T
, Etype
(R
));
1307 end Find_Unique_Type
;
1309 ----------------------
1310 -- Get_First_Interp --
1311 ----------------------
1313 procedure Get_First_Interp
1315 I
: out Interp_Index
;
1318 Int_Ind
: Interp_Index
;
1322 -- If a selected component is overloaded because the selector has
1323 -- multiple interpretations, the node is a call to a protected
1324 -- operation or an indirect call. Retrieve the interpretation from
1325 -- the selector name. The selected component may be overloaded as well
1326 -- if the prefix is overloaded. That case is unchanged.
1328 if Nkind
(N
) = N_Selected_Component
1329 and then Is_Overloaded
(Selector_Name
(N
))
1331 O_N
:= Selector_Name
(N
);
1336 for Index
in 0 .. Interp_Map
.Last
loop
1337 if Interp_Map
.Table
(Index
).Node
= O_N
then
1338 Int_Ind
:= Interp_Map
.Table
(Index
).Index
;
1339 It
:= All_Interp
.Table
(Int_Ind
);
1345 -- Procedure should never be called if the node has no interpretations
1347 raise Program_Error
;
1348 end Get_First_Interp
;
1350 ----------------------
1351 -- Get_Next_Interp --
1352 ----------------------
1354 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1357 It
:= All_Interp
.Table
(I
);
1358 end Get_Next_Interp
;
1360 -------------------------
1361 -- Has_Compatible_Type --
1362 -------------------------
1364 function Has_Compatible_Type
1377 if Nkind
(N
) = N_Subtype_Indication
1378 or else not Is_Overloaded
(N
)
1380 return Covers
(Typ
, Etype
(N
))
1381 or else (not Is_Tagged_Type
(Typ
)
1382 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1383 and then Covers
(Etype
(N
), Typ
));
1386 Get_First_Interp
(N
, I
, It
);
1388 while Present
(It
.Typ
) loop
1389 if Covers
(Typ
, It
.Typ
)
1390 or else (not Is_Tagged_Type
(Typ
)
1391 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1392 and then Covers
(It
.Typ
, Typ
))
1397 Get_Next_Interp
(I
, It
);
1402 end Has_Compatible_Type
;
1408 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
1409 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
1412 return Operator_Matches_Spec
(Op
, F
)
1413 and then (In_Open_Scopes
(Scope
(F
))
1414 or else Scope
(F
) = Scope
(Btyp
)
1415 or else (not In_Open_Scopes
(Scope
(Btyp
))
1416 and then not In_Use
(Btyp
)
1417 and then not In_Use
(Scope
(Btyp
))));
1420 ------------------------
1421 -- Init_Interp_Tables --
1422 ------------------------
1424 procedure Init_Interp_Tables
is
1428 end Init_Interp_Tables
;
1430 ---------------------
1431 -- Intersect_Types --
1432 ---------------------
1434 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
1435 Index
: Interp_Index
;
1439 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
1440 -- Find interpretation of right arg that has type compatible with T
1442 --------------------------
1443 -- Check_Right_Argument --
1444 --------------------------
1446 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
1447 Index
: Interp_Index
;
1452 if not Is_Overloaded
(R
) then
1453 return Specific_Type
(T
, Etype
(R
));
1456 Get_First_Interp
(R
, Index
, It
);
1459 T2
:= Specific_Type
(T
, It
.Typ
);
1461 if T2
/= Any_Type
then
1465 Get_Next_Interp
(Index
, It
);
1466 exit when No
(It
.Typ
);
1471 end Check_Right_Argument
;
1473 -- Start processing for Intersect_Types
1476 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
1480 if not Is_Overloaded
(L
) then
1481 Typ
:= Check_Right_Argument
(Etype
(L
));
1485 Get_First_Interp
(L
, Index
, It
);
1487 while Present
(It
.Typ
) loop
1488 Typ
:= Check_Right_Argument
(It
.Typ
);
1489 exit when Typ
/= Any_Type
;
1490 Get_Next_Interp
(Index
, It
);
1495 -- If Typ is Any_Type, it means no compatible pair of types was found
1497 if Typ
= Any_Type
then
1499 if Nkind
(Parent
(L
)) in N_Op
then
1500 Error_Msg_N
("incompatible types for operator", Parent
(L
));
1502 elsif Nkind
(Parent
(L
)) = N_Range
then
1503 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
1506 Error_Msg_N
("incompatible types", Parent
(L
));
1511 end Intersect_Types
;
1517 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
1521 if Base_Type
(T1
) = Base_Type
(T2
) then
1524 elsif Is_Private_Type
(T1
)
1525 and then Present
(Full_View
(T1
))
1526 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
1534 if Base_Type
(T1
) = Base_Type
(Par
)
1535 or else (Is_Private_Type
(T1
)
1536 and then Present
(Full_View
(T1
))
1537 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
1541 elsif Is_Private_Type
(Par
)
1542 and then Present
(Full_View
(Par
))
1543 and then Full_View
(Par
) = Base_Type
(T1
)
1547 elsif Etype
(Par
) /= Par
then
1560 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
1564 S
:= Ancestor_Subtype
(T1
);
1565 while Present
(S
) loop
1569 S
:= Ancestor_Subtype
(S
);
1580 procedure New_Interps
(N
: Node_Id
) is
1582 Interp_Map
.Increment_Last
;
1583 All_Interp
.Increment_Last
;
1584 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
);
1585 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1586 Set_Is_Overloaded
(N
, True);
1589 ---------------------------
1590 -- Operator_Matches_Spec --
1591 ---------------------------
1593 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
1594 Op_Name
: constant Name_Id
:= Chars
(Op
);
1595 T
: constant Entity_Id
:= Etype
(New_S
);
1603 -- To verify that a predefined operator matches a given signature,
1604 -- do a case analysis of the operator classes. Function can have one
1605 -- or two formals and must have the proper result type.
1607 New_F
:= First_Formal
(New_S
);
1608 Old_F
:= First_Formal
(Op
);
1611 while Present
(New_F
) and then Present
(Old_F
) loop
1613 Next_Formal
(New_F
);
1614 Next_Formal
(Old_F
);
1617 -- Definite mismatch if different number of parameters
1619 if Present
(Old_F
) or else Present
(New_F
) then
1625 T1
:= Etype
(First_Formal
(New_S
));
1627 if Op_Name
= Name_Op_Subtract
1628 or else Op_Name
= Name_Op_Add
1629 or else Op_Name
= Name_Op_Abs
1631 return Base_Type
(T1
) = Base_Type
(T
)
1632 and then Is_Numeric_Type
(T
);
1634 elsif Op_Name
= Name_Op_Not
then
1635 return Base_Type
(T1
) = Base_Type
(T
)
1636 and then Valid_Boolean_Arg
(Base_Type
(T
));
1645 T1
:= Etype
(First_Formal
(New_S
));
1646 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
1648 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
1649 or else Op_Name
= Name_Op_Xor
1651 return Base_Type
(T1
) = Base_Type
(T2
)
1652 and then Base_Type
(T1
) = Base_Type
(T
)
1653 and then Valid_Boolean_Arg
(Base_Type
(T
));
1655 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
1656 return Base_Type
(T1
) = Base_Type
(T2
)
1657 and then not Is_Limited_Type
(T1
)
1658 and then Is_Boolean_Type
(T
);
1660 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
1661 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
1663 return Base_Type
(T1
) = Base_Type
(T2
)
1664 and then Valid_Comparison_Arg
(T1
)
1665 and then Is_Boolean_Type
(T
);
1667 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
1668 return Base_Type
(T1
) = Base_Type
(T2
)
1669 and then Base_Type
(T1
) = Base_Type
(T
)
1670 and then Is_Numeric_Type
(T
);
1672 -- for division and multiplication, a user-defined function does
1673 -- not match the predefined universal_fixed operation, except in
1676 elsif Op_Name
= Name_Op_Divide
then
1677 return (Base_Type
(T1
) = Base_Type
(T2
)
1678 and then Base_Type
(T1
) = Base_Type
(T
)
1679 and then Is_Numeric_Type
(T
)
1680 and then (not Is_Fixed_Point_Type
(T
)
1683 -- Mixed_Mode operations on fixed-point types.
1685 or else (Base_Type
(T1
) = Base_Type
(T
)
1686 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
1687 and then Is_Fixed_Point_Type
(T
))
1689 -- A user defined operator can also match (and hide) a mixed
1690 -- operation on universal literals.
1692 or else (Is_Integer_Type
(T2
)
1693 and then Is_Floating_Point_Type
(T1
)
1694 and then Base_Type
(T1
) = Base_Type
(T
));
1696 elsif Op_Name
= Name_Op_Multiply
then
1697 return (Base_Type
(T1
) = Base_Type
(T2
)
1698 and then Base_Type
(T1
) = Base_Type
(T
)
1699 and then Is_Numeric_Type
(T
)
1700 and then (not Is_Fixed_Point_Type
(T
)
1703 -- Mixed_Mode operations on fixed-point types.
1705 or else (Base_Type
(T1
) = Base_Type
(T
)
1706 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
1707 and then Is_Fixed_Point_Type
(T
))
1709 or else (Base_Type
(T2
) = Base_Type
(T
)
1710 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
1711 and then Is_Fixed_Point_Type
(T
))
1713 or else (Is_Integer_Type
(T2
)
1714 and then Is_Floating_Point_Type
(T1
)
1715 and then Base_Type
(T1
) = Base_Type
(T
))
1717 or else (Is_Integer_Type
(T1
)
1718 and then Is_Floating_Point_Type
(T2
)
1719 and then Base_Type
(T2
) = Base_Type
(T
));
1721 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
1722 return Base_Type
(T1
) = Base_Type
(T2
)
1723 and then Base_Type
(T1
) = Base_Type
(T
)
1724 and then Is_Integer_Type
(T
);
1726 elsif Op_Name
= Name_Op_Expon
then
1727 return Base_Type
(T1
) = Base_Type
(T
)
1728 and then Is_Numeric_Type
(T
)
1729 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
1731 elsif Op_Name
= Name_Op_Concat
then
1732 return Is_Array_Type
(T
)
1733 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
1734 and then (Base_Type
(T1
) = Base_Type
(T
)
1736 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
1737 and then (Base_Type
(T2
) = Base_Type
(T
)
1739 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
1745 end Operator_Matches_Spec
;
1751 procedure Remove_Interp
(I
: in out Interp_Index
) is
1755 -- Find end of Interp list and copy downward to erase the discarded one
1759 while Present
(All_Interp
.Table
(II
).Typ
) loop
1763 for J
in I
+ 1 .. II
loop
1764 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
1767 -- Back up interp. index to insure that iterator will pick up next
1768 -- available interpretation.
1777 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
1779 if Is_Overloaded
(Old_N
) then
1780 for Index
in 0 .. Interp_Map
.Last
loop
1781 if Interp_Map
.Table
(Index
).Node
= Old_N
then
1782 Interp_Map
.Table
(Index
).Node
:= New_N
;
1793 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
1794 B1
: constant Entity_Id
:= Base_Type
(T1
);
1795 B2
: constant Entity_Id
:= Base_Type
(T2
);
1797 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
1798 -- Check whether T is the equivalent type of a remote access type.
1799 -- If distribution is enabled, T is a legal context for Null.
1801 ----------------------
1802 -- Is_Remote_Access --
1803 ----------------------
1805 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
1807 return Is_Record_Type
(T
)
1808 and then (Is_Remote_Call_Interface
(T
)
1809 or else Is_Remote_Types
(T
))
1810 and then Present
(Corresponding_Remote_Type
(T
))
1811 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
1812 end Is_Remote_Access
;
1814 -- Start of processing for Specific_Type
1817 if (T1
= Any_Type
or else T2
= Any_Type
) then
1824 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
1825 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
1826 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
1830 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
1831 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
1832 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
1836 elsif (T2
= Any_String
and then Is_String_Type
(T1
)) then
1839 elsif (T1
= Any_String
and then Is_String_Type
(T2
)) then
1842 elsif (T2
= Any_Character
and then Is_Character_Type
(T1
)) then
1845 elsif (T1
= Any_Character
and then Is_Character_Type
(T2
)) then
1848 elsif (T1
= Any_Access
1849 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
)))
1853 elsif (T2
= Any_Access
1854 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
)))
1858 elsif (T2
= Any_Composite
1859 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
)
1863 elsif (T1
= Any_Composite
1864 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
)
1868 elsif (T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
)) then
1871 elsif (T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
)) then
1874 -- Special cases for equality operators (all other predefined
1875 -- operators can never apply to tagged types)
1877 elsif Is_Class_Wide_Type
(T1
)
1878 and then Is_Ancestor
(Root_Type
(T1
), T2
)
1882 elsif Is_Class_Wide_Type
(T2
)
1883 and then Is_Ancestor
(Root_Type
(T2
), T1
)
1887 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
1889 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
1890 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
1891 and then Is_Access_Type
(T2
)
1895 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
1897 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
1898 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
1899 and then Is_Access_Type
(T1
)
1903 elsif (Ekind
(T1
) = E_Allocator_Type
1904 or else Ekind
(T1
) = E_Access_Attribute_Type
1905 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
1906 and then Is_Access_Type
(T2
)
1910 elsif (Ekind
(T2
) = E_Allocator_Type
1911 or else Ekind
(T2
) = E_Access_Attribute_Type
1912 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
1913 and then Is_Access_Type
(T1
)
1917 -- If none of the above cases applies, types are not compatible.
1924 ------------------------------
1925 -- Universal_Interpretation --
1926 ------------------------------
1928 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
1929 Index
: Interp_Index
;
1933 -- The argument may be a formal parameter of an operator or subprogram
1934 -- with multiple interpretations, or else an expression for an actual.
1936 if Nkind
(Opnd
) = N_Defining_Identifier
1937 or else not Is_Overloaded
(Opnd
)
1939 if Etype
(Opnd
) = Universal_Integer
1940 or else Etype
(Opnd
) = Universal_Real
1942 return Etype
(Opnd
);
1948 Get_First_Interp
(Opnd
, Index
, It
);
1950 while Present
(It
.Typ
) loop
1952 if It
.Typ
= Universal_Integer
1953 or else It
.Typ
= Universal_Real
1958 Get_Next_Interp
(Index
, It
);
1963 end Universal_Interpretation
;
1965 -----------------------
1966 -- Valid_Boolean_Arg --
1967 -----------------------
1969 -- In addition to booleans and arrays of booleans, we must include
1970 -- aggregates as valid boolean arguments, because in the first pass
1971 -- of resolution their components are not examined. If it turns out not
1972 -- to be an aggregate of booleans, this will be diagnosed in Resolve.
1973 -- Any_Composite must be checked for prior to the array type checks
1974 -- because Any_Composite does not have any associated indexes.
1976 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
1978 return Is_Boolean_Type
(T
)
1979 or else T
= Any_Composite
1980 or else (Is_Array_Type
(T
)
1981 and then T
/= Any_String
1982 and then Number_Dimensions
(T
) = 1
1983 and then Is_Boolean_Type
(Component_Type
(T
))
1984 and then (not Is_Private_Composite
(T
)
1985 or else In_Instance
)
1986 and then (not Is_Limited_Composite
(T
)
1987 or else In_Instance
))
1988 or else Is_Modular_Integer_Type
(T
)
1989 or else T
= Universal_Integer
;
1990 end Valid_Boolean_Arg
;
1992 --------------------------
1993 -- Valid_Comparison_Arg --
1994 --------------------------
1996 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
1998 return Is_Discrete_Type
(T
)
1999 or else Is_Real_Type
(T
)
2000 or else (Is_Array_Type
(T
) and then Number_Dimensions
(T
) = 1
2001 and then Is_Discrete_Type
(Component_Type
(T
))
2002 and then (not Is_Private_Composite
(T
)
2003 or else In_Instance
)
2004 and then (not Is_Limited_Composite
(T
)
2005 or else In_Instance
))
2006 or else Is_String_Type
(T
);
2007 end Valid_Comparison_Arg
;
2009 ---------------------
2010 -- Write_Overloads --
2011 ---------------------
2013 procedure Write_Overloads
(N
: Node_Id
) is
2019 if not Is_Overloaded
(N
) then
2020 Write_Str
("Non-overloaded entity ");
2022 Write_Entity_Info
(Entity
(N
), " ");
2025 Get_First_Interp
(N
, I
, It
);
2026 Write_Str
("Overloaded entity ");
2030 while Present
(Nam
) loop
2031 Write_Entity_Info
(Nam
, " ");
2032 Write_Str
("=================");
2034 Get_Next_Interp
(I
, It
);
2038 end Write_Overloads
;