1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
33 with Output
; use Output
;
35 with Sem_Ch6
; use Sem_Ch6
;
36 with Sem_Ch8
; use Sem_Ch8
;
37 with Sem_Util
; use Sem_Util
;
38 with Stand
; use Stand
;
39 with Sinfo
; use Sinfo
;
40 with Snames
; use Snames
;
41 with Uintp
; use Uintp
;
43 package body Sem_Type
is
45 -------------------------------------
46 -- Handling of Overload Resolution --
47 -------------------------------------
49 -- Overload resolution uses two passes over the syntax tree of a complete
50 -- context. In the first, bottom-up pass, the types of actuals in calls
51 -- are used to resolve possibly overloaded subprogram and operator names.
52 -- In the second top-down pass, the type of the context (for example the
53 -- condition in a while statement) is used to resolve a possibly ambiguous
54 -- call, and the unique subprogram name in turn imposes a specific context
55 -- on each of its actuals.
57 -- Most expressions are in fact unambiguous, and the bottom-up pass is
58 -- sufficient to resolve most everything. To simplify the common case,
59 -- names and expressions carry a flag Is_Overloaded to indicate whether
60 -- they have more than one interpretation. If the flag is off, then each
61 -- name has already a unique meaning and type, and the bottom-up pass is
62 -- sufficient (and much simpler).
64 --------------------------
65 -- Operator Overloading --
66 --------------------------
68 -- The visibility of operators is handled differently from that of
69 -- other entities. We do not introduce explicit versions of primitive
70 -- operators for each type definition. As a result, there is only one
71 -- entity corresponding to predefined addition on all numeric types, etc.
72 -- The back-end resolves predefined operators according to their type.
73 -- The visibility of primitive operations then reduces to the visibility
74 -- of the resulting type: (a + b) is a legal interpretation of some
75 -- primitive operator + if the type of the result (which must also be
76 -- the type of a and b) is directly visible (i.e. either immediately
77 -- visible or use-visible.)
79 -- User-defined operators are treated like other functions, but the
80 -- visibility of these user-defined operations must be special-cased
81 -- to determine whether they hide or are hidden by predefined operators.
82 -- The form P."+" (x, y) requires additional handling.
84 -- Concatenation is treated more conventionally: for every one-dimensional
85 -- array type we introduce a explicit concatenation operator. This is
86 -- necessary to handle the case of (element & element => array) which
87 -- cannot be handled conveniently if there is no explicit instance of
88 -- resulting type of the operation.
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 procedure All_Overloads
;
95 pragma Warnings
(Off
, All_Overloads
);
96 -- Debugging procedure: list full contents of Overloads table.
98 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
;
99 -- Yields universal_Integer or Universal_Real if this is a candidate.
101 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
102 -- If T1 and T2 are compatible, return the one that is not
103 -- universal or is not a "class" type (any_character, etc).
109 procedure Add_One_Interp
113 Opnd_Type
: Entity_Id
:= Empty
)
115 Vis_Type
: Entity_Id
;
117 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
118 -- Add one interpretation to node. Node is already known to be
119 -- overloaded. Add new interpretation if not hidden by previous
120 -- one, and remove previous one if hidden by new one.
122 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
123 -- True if the entity is a predefined operator and the operands have
124 -- a universal Interpretation.
130 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
131 Index
: Interp_Index
;
135 Get_First_Interp
(N
, Index
, It
);
137 while Present
(It
.Nam
) loop
139 -- A user-defined subprogram hides another declared at an outer
140 -- level, or one that is use-visible. So return if previous
141 -- definition hides new one (which is either in an outer
142 -- scope, or use-visible). Note that for functions use-visible
143 -- is the same as potentially use-visible. If new one hides
144 -- previous one, replace entry in table of interpretations.
145 -- If this is a universal operation, retain the operator in case
146 -- preference rule applies.
148 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
149 and then Ekind
(Name
) = Ekind
(It
.Nam
))
150 or else (Ekind
(Name
) = E_Operator
151 and then Ekind
(It
.Nam
) = E_Function
))
153 and then Is_Immediately_Visible
(It
.Nam
)
154 and then Type_Conformant
(Name
, It
.Nam
)
155 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
157 if Is_Universal_Operation
(Name
) then
160 -- If node is an operator symbol, we have no actuals with
161 -- which to check hiding, and this is done in full in the
162 -- caller (Analyze_Subprogram_Renaming) so we include the
163 -- predefined operator in any case.
165 elsif Nkind
(N
) = N_Operator_Symbol
166 or else (Nkind
(N
) = N_Expanded_Name
168 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
172 elsif not In_Open_Scopes
(Scope
(Name
))
173 or else Scope_Depth
(Scope
(Name
))
174 <= Scope_Depth
(Scope
(It
.Nam
))
176 -- If ambiguity within instance, and entity is not an
177 -- implicit operation, save for later disambiguation.
179 if Scope
(Name
) = Scope
(It
.Nam
)
180 and then not Is_Inherited_Operation
(Name
)
189 All_Interp
.Table
(Index
).Nam
:= Name
;
193 -- Avoid making duplicate entries in overloads
196 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
200 -- Otherwise keep going
203 Get_Next_Interp
(Index
, It
);
208 -- On exit, enter new interpretation. The context, or a preference
209 -- rule, will resolve the ambiguity on the second pass.
211 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
212 All_Interp
.Increment_Last
;
213 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
217 ----------------------------
218 -- Is_Universal_Operation --
219 ----------------------------
221 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
225 if Ekind
(Op
) /= E_Operator
then
228 elsif Nkind
(N
) in N_Binary_Op
then
229 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
230 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
232 elsif Nkind
(N
) in N_Unary_Op
then
233 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
235 elsif Nkind
(N
) = N_Function_Call
then
236 Arg
:= First_Actual
(N
);
238 while Present
(Arg
) loop
240 if No
(Universal_Interpretation
(Arg
)) then
252 end Is_Universal_Operation
;
254 -- Start of processing for Add_One_Interp
257 -- If the interpretation is a predefined operator, verify that the
258 -- result type is visible, or that the entity has already been
259 -- resolved (case of an instantiation node that refers to a predefined
260 -- operation, or an internally generated operator node, or an operator
261 -- given as an expanded name). If the operator is a comparison or
262 -- equality, it is the type of the operand that matters to determine
263 -- whether the operator is visible. In an instance, the check is not
264 -- performed, given that the operator was visible in the generic.
266 if Ekind
(E
) = E_Operator
then
268 if Present
(Opnd_Type
) then
269 Vis_Type
:= Opnd_Type
;
271 Vis_Type
:= Base_Type
(T
);
274 if In_Open_Scopes
(Scope
(Vis_Type
))
275 or else Is_Potentially_Use_Visible
(Vis_Type
)
276 or else In_Use
(Vis_Type
)
277 or else (In_Use
(Scope
(Vis_Type
))
278 and then not Is_Hidden
(Vis_Type
))
279 or else Nkind
(N
) = N_Expanded_Name
280 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
285 -- If the node is given in functional notation and the prefix
286 -- is an expanded name, then the operator is visible if the
287 -- prefix is the scope of the result type as well. If the
288 -- operator is (implicitly) defined in an extension of system,
289 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
291 elsif Nkind
(N
) = N_Function_Call
292 and then Nkind
(Name
(N
)) = N_Expanded_Name
293 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
294 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
295 or else Scope
(Vis_Type
) = System_Aux_Id
)
299 -- Save type for subsequent error message, in case no other
300 -- interpretation is found.
303 Candidate_Type
:= Vis_Type
;
307 -- In an instance, an abstract non-dispatching operation cannot
308 -- be a candidate interpretation, because it could not have been
309 -- one in the generic (it may be a spurious overloading in the
313 and then Is_Abstract
(E
)
314 and then not Is_Dispatching_Operation
(E
)
319 -- If this is the first interpretation of N, N has type Any_Type.
320 -- In that case place the new type on the node. If one interpretation
321 -- already exists, indicate that the node is overloaded, and store
322 -- both the previous and the new interpretation in All_Interp. If
323 -- this is a later interpretation, just add it to the set.
325 if Etype
(N
) = Any_Type
then
330 -- Record both the operator or subprogram name, and its type.
332 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
339 -- Either there is no current interpretation in the table for any
340 -- node or the interpretation that is present is for a different
341 -- node. In both cases add a new interpretation to the table.
343 elsif Interp_Map
.Last
< 0
344 or else Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
348 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
349 and then Present
(Entity
(N
))
351 Add_Entry
(Entity
(N
), Etype
(N
));
353 elsif (Nkind
(N
) = N_Function_Call
354 or else Nkind
(N
) = N_Procedure_Call_Statement
)
355 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
356 or else Is_Entity_Name
(Name
(N
)))
358 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
361 -- Overloaded prefix in indexed or selected component,
362 -- or call whose name is an expression or another call.
364 Add_Entry
(Etype
(N
), Etype
(N
));
378 procedure All_Overloads
is
380 for J
in All_Interp
.First
.. All_Interp
.Last
loop
382 if Present
(All_Interp
.Table
(J
).Nam
) then
383 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
385 Write_Str
("No Interp");
388 Write_Str
("=================");
393 ---------------------
394 -- Collect_Interps --
395 ---------------------
397 procedure Collect_Interps
(N
: Node_Id
) is
398 Ent
: constant Entity_Id
:= Entity
(N
);
400 First_Interp
: Interp_Index
;
405 -- Unconditionally add the entity that was initially matched
407 First_Interp
:= All_Interp
.Last
;
408 Add_One_Interp
(N
, Ent
, Etype
(N
));
410 -- For expanded name, pick up all additional entities from the
411 -- same scope, since these are obviously also visible. Note that
412 -- these are not necessarily contiguous on the homonym chain.
414 if Nkind
(N
) = N_Expanded_Name
then
416 while Present
(H
) loop
417 if Scope
(H
) = Scope
(Entity
(N
)) then
418 Add_One_Interp
(N
, H
, Etype
(H
));
424 -- Case of direct name
427 -- First, search the homonym chain for directly visible entities
429 H
:= Current_Entity
(Ent
);
430 while Present
(H
) loop
431 exit when (not Is_Overloadable
(H
))
432 and then Is_Immediately_Visible
(H
);
434 if Is_Immediately_Visible
(H
)
437 -- Only add interpretation if not hidden by an inner
438 -- immediately visible one.
440 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
442 -- Current homograph is not hidden. Add to overloads.
444 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
447 -- Homograph is hidden, unless it is a predefined operator.
449 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
451 -- A homograph in the same scope can occur within an
452 -- instantiation, the resulting ambiguity has to be
455 if Scope
(H
) = Scope
(Ent
)
457 and then not Is_Inherited_Operation
(H
)
459 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
460 All_Interp
.Increment_Last
;
461 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
464 elsif Scope
(H
) /= Standard_Standard
then
470 -- On exit, we know that current homograph is not hidden.
472 Add_One_Interp
(N
, H
, Etype
(H
));
475 Write_Str
("Add overloaded Interpretation ");
485 -- Scan list of homographs for use-visible entities only.
487 H
:= Current_Entity
(Ent
);
489 while Present
(H
) loop
490 if Is_Potentially_Use_Visible
(H
)
492 and then Is_Overloadable
(H
)
494 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
496 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
499 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
500 goto Next_Use_Homograph
;
504 Add_One_Interp
(N
, H
, Etype
(H
));
507 <<Next_Use_Homograph
>>
512 if All_Interp
.Last
= First_Interp
+ 1 then
514 -- The original interpretation is in fact not overloaded.
516 Set_Is_Overloaded
(N
, False);
524 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
526 -- If either operand missing, then this is an error, but ignore
527 -- it (and pretend we have a cover) if errors already detected,
528 -- since this may simply mean we have malformed trees.
530 if No
(T1
) or else No
(T2
) then
531 if Total_Errors_Detected
/= 0 then
538 -- Simplest case: same types are compatible, and types that have the
539 -- same base type and are not generic actuals are compatible. Generic
540 -- actuals belong to their class but are not compatible with other
541 -- types of their class, and in particular with other generic actuals.
542 -- They are however compatible with their own subtypes, and itypes
543 -- with the same base are compatible as well. Similary, constrained
544 -- subtypes obtained from expressions of an unconstrained nominal type
545 -- are compatible with the base type (may lead to spurious ambiguities
546 -- in obscure cases ???)
548 -- Generic actuals require special treatment to avoid spurious ambi-
549 -- guities in an instance, when two formal types are instantiated with
550 -- the same actual, so that different subprograms end up with the same
551 -- signature in the instance.
556 elsif Base_Type
(T1
) = Base_Type
(T2
) then
557 if not Is_Generic_Actual_Type
(T1
) then
560 return (not Is_Generic_Actual_Type
(T2
)
561 or else Is_Itype
(T1
)
562 or else Is_Itype
(T2
)
563 or else Is_Constr_Subt_For_U_Nominal
(T1
)
564 or else Is_Constr_Subt_For_U_Nominal
(T2
)
565 or else Scope
(T1
) /= Scope
(T2
));
568 -- Literals are compatible with types in a given "class"
570 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
571 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
572 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
573 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
574 or else (T2
= Any_String
and then Is_String_Type
(T1
))
575 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
576 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
580 -- The context may be class wide.
582 elsif Is_Class_Wide_Type
(T1
)
583 and then Is_Ancestor
(Root_Type
(T1
), T2
)
587 elsif Is_Class_Wide_Type
(T1
)
588 and then Is_Class_Wide_Type
(T2
)
589 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
593 -- In a dispatching call the actual may be class-wide
595 elsif Is_Class_Wide_Type
(T2
)
596 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
600 -- Some contexts require a class of types rather than a specific type
602 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
603 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
604 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
605 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
606 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
610 -- An aggregate is compatible with an array or record type
612 elsif T2
= Any_Composite
613 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
617 -- If the expected type is an anonymous access, the designated
618 -- type must cover that of the expression.
620 elsif Ekind
(T1
) = E_Anonymous_Access_Type
621 and then Is_Access_Type
(T2
)
622 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
626 -- An Access_To_Subprogram is compatible with itself, or with an
627 -- anonymous type created for an attribute reference Access.
629 elsif (Ekind
(Base_Type
(T1
)) = E_Access_Subprogram_Type
631 Ekind
(Base_Type
(T1
)) = E_Access_Protected_Subprogram_Type
)
632 and then Is_Access_Type
(T2
)
633 and then (not Comes_From_Source
(T1
)
634 or else not Comes_From_Source
(T2
))
635 and then (Is_Overloadable
(Designated_Type
(T2
))
637 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
639 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
641 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
645 elsif Is_Record_Type
(T1
)
646 and then (Is_Remote_Call_Interface
(T1
)
647 or else Is_Remote_Types
(T1
))
648 and then Present
(Corresponding_Remote_Type
(T1
))
650 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
652 elsif Ekind
(T2
) = E_Access_Attribute_Type
653 and then (Ekind
(Base_Type
(T1
)) = E_General_Access_Type
654 or else Ekind
(Base_Type
(T1
)) = E_Access_Type
)
655 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
657 -- If the target type is a RACW type while the source is an access
658 -- attribute type, we are building a RACW that may be exported.
660 if Is_Remote_Access_To_Class_Wide_Type
(Base_Type
(T1
)) then
661 Set_Has_RACW
(Current_Sem_Unit
);
666 elsif Ekind
(T2
) = E_Allocator_Type
667 and then Is_Access_Type
(T1
)
668 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
672 -- A boolean operation on integer literals is compatible with a
675 elsif T2
= Any_Modular
676 and then Is_Modular_Integer_Type
(T1
)
680 -- The actual type may be the result of a previous error
682 elsif Base_Type
(T2
) = Any_Type
then
685 -- A packed array type covers its corresponding non-packed type.
686 -- This is not legitimate Ada, but allows the omission of a number
687 -- of otherwise useless unchecked conversions, and since this can
688 -- only arise in (known correct) expanded code, no harm is done
690 elsif Is_Array_Type
(T2
)
691 and then Is_Packed
(T2
)
692 and then T1
= Packed_Array_Type
(T2
)
696 -- Similarly an array type covers its corresponding packed array type
698 elsif Is_Array_Type
(T1
)
699 and then Is_Packed
(T1
)
700 and then T2
= Packed_Array_Type
(T1
)
704 -- In an instance the proper view may not always be correct for
705 -- private types, but private and full view are compatible. This
706 -- removes spurious errors from nested instantiations that involve,
707 -- among other things, types derived from privated types.
710 and then Is_Private_Type
(T1
)
711 and then ((Present
(Full_View
(T1
))
712 and then Covers
(Full_View
(T1
), T2
))
713 or else Base_Type
(T1
) = T2
714 or else Base_Type
(T2
) = T1
)
718 -- In the expansion of inlined bodies, types are compatible if they
719 -- are structurally equivalent.
721 elsif In_Inlined_Body
722 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
723 or else (Is_Access_Type
(T1
)
724 and then Is_Access_Type
(T2
)
726 Designated_Type
(T1
) = Designated_Type
(T2
))
727 or else (T1
= Any_Access
728 and then Is_Access_Type
(Underlying_Type
(T2
))))
732 -- Otherwise it doesn't cover!
743 function Disambiguate
745 I1
, I2
: Interp_Index
;
752 Nam1
, Nam2
: Entity_Id
;
753 Predef_Subp
: Entity_Id
;
754 User_Subp
: Entity_Id
;
756 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
757 -- Look for exact type match in an instance, to remove spurious
758 -- ambiguities when two formal types have the same actual.
760 function Standard_Operator
return Boolean;
762 function Remove_Conversions
return Interp
;
763 -- Last chance for pathological cases involving comparisons on
764 -- literals, and user overloadings of the same operator. Such
765 -- pathologies have been removed from the ACVC, but still appear in
766 -- two DEC tests, with the following notable quote from Ben Brosgol:
768 -- [Note: I disclaim all credit/responsibility/blame for coming up with
769 -- this example; Robert Dewar brought it to our attention, since it
770 -- is apparently found in the ACVC 1.5. I did not attempt to find
771 -- the reason in the Reference Manual that makes the example legal,
772 -- since I was too nauseated by it to want to pursue it further.]
774 -- Accordingly, this is not a fully recursive solution, but it handles
775 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
776 -- pathology in the other direction with calls whose multiple overloaded
777 -- actuals make them truly unresolvable.
783 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
784 T1
: constant Entity_Id
:= Etype
(Actual
);
785 T2
: constant Entity_Id
:= Etype
(Formal
);
790 (Is_Numeric_Type
(T2
)
792 (T1
= Universal_Real
or else T1
= Universal_Integer
));
795 ------------------------
796 -- Remove_Conversions --
797 ------------------------
799 function Remove_Conversions
return Interp
is
809 Get_First_Interp
(N
, I
, It
);
811 while Present
(It
.Typ
) loop
813 if not Is_Overloadable
(It
.Nam
) then
817 F1
:= First_Formal
(It
.Nam
);
823 if Nkind
(N
) = N_Function_Call
824 or else Nkind
(N
) = N_Procedure_Call_Statement
826 Act1
:= First_Actual
(N
);
828 if Present
(Act1
) then
829 Act2
:= Next_Actual
(Act1
);
834 elsif Nkind
(N
) in N_Unary_Op
then
835 Act1
:= Right_Opnd
(N
);
838 elsif Nkind
(N
) in N_Binary_Op
then
839 Act1
:= Left_Opnd
(N
);
840 Act2
:= Right_Opnd
(N
);
846 if Nkind
(Act1
) in N_Op
847 and then Is_Overloaded
(Act1
)
848 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
849 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
850 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
851 and then Etype
(F1
) = Standard_Boolean
854 if It1
/= No_Interp
then
858 and then Nkind
(Act2
) in N_Op
859 and then Is_Overloaded
(Act2
)
860 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
862 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
863 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
865 -- The preference rule on the first actual is not
866 -- sufficient to disambiguate.
877 Get_Next_Interp
(I
, It
);
880 if Serious_Errors_Detected
> 0 then
882 -- After some error, a formal may have Any_Type and yield
883 -- a spurious match. To avoid cascaded errors if possible,
884 -- check for such a formal in either candidate.
890 Formal
:= First_Formal
(Nam1
);
891 while Present
(Formal
) loop
892 if Etype
(Formal
) = Any_Type
then
893 return Disambiguate
.It2
;
896 Next_Formal
(Formal
);
899 Formal
:= First_Formal
(Nam2
);
900 while Present
(Formal
) loop
901 if Etype
(Formal
) = Any_Type
then
902 return Disambiguate
.It1
;
905 Next_Formal
(Formal
);
911 end Remove_Conversions
;
913 -----------------------
914 -- Standard_Operator --
915 -----------------------
917 function Standard_Operator
return Boolean is
921 if Nkind
(N
) in N_Op
then
924 elsif Nkind
(N
) = N_Function_Call
then
927 if Nkind
(Nam
) /= N_Expanded_Name
then
930 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
935 end Standard_Operator
;
937 -- Start of processing for Disambiguate
940 -- Recover the two legal interpretations.
942 Get_First_Interp
(N
, I
, It
);
945 Get_Next_Interp
(I
, It
);
952 Get_Next_Interp
(I
, It
);
958 -- If the context is universal, the predefined operator is preferred.
959 -- This includes bounds in numeric type declarations, and expressions
960 -- in type conversions. If no interpretation yields a universal type,
961 -- then we must check whether the user-defined entity hides the prede-
964 if Chars
(Nam1
) in Any_Operator_Name
965 and then Standard_Operator
967 if Typ
= Universal_Integer
968 or else Typ
= Universal_Real
969 or else Typ
= Any_Integer
970 or else Typ
= Any_Discrete
971 or else Typ
= Any_Real
972 or else Typ
= Any_Type
974 -- Find an interpretation that yields the universal type, or else
975 -- a predefined operator that yields a predefined numeric type.
978 Candidate
: Interp
:= No_Interp
;
980 Get_First_Interp
(N
, I
, It
);
982 while Present
(It
.Typ
) loop
983 if (Covers
(Typ
, It
.Typ
)
984 or else Typ
= Any_Type
)
986 (It
.Typ
= Universal_Integer
987 or else It
.Typ
= Universal_Real
)
991 elsif Covers
(Typ
, It
.Typ
)
992 and then Scope
(It
.Typ
) = Standard_Standard
993 and then Scope
(It
.Nam
) = Standard_Standard
994 and then Is_Numeric_Type
(It
.Typ
)
999 Get_Next_Interp
(I
, It
);
1002 if Candidate
/= No_Interp
then
1007 elsif Chars
(Nam1
) /= Name_Op_Not
1008 and then (Typ
= Standard_Boolean
1009 or else Typ
= Any_Boolean
)
1011 -- Equality or comparison operation. Choose predefined operator
1012 -- if arguments are universal. The node may be an operator, a
1013 -- name, or a function call, so unpack arguments accordingly.
1016 Arg1
, Arg2
: Node_Id
;
1019 if Nkind
(N
) in N_Op
then
1020 Arg1
:= Left_Opnd
(N
);
1021 Arg2
:= Right_Opnd
(N
);
1023 elsif Is_Entity_Name
(N
)
1024 or else Nkind
(N
) = N_Operator_Symbol
1026 Arg1
:= First_Entity
(Entity
(N
));
1027 Arg2
:= Next_Entity
(Arg1
);
1030 Arg1
:= First_Actual
(N
);
1031 Arg2
:= Next_Actual
(Arg1
);
1035 and then Present
(Universal_Interpretation
(Arg1
))
1036 and then Universal_Interpretation
(Arg2
) =
1037 Universal_Interpretation
(Arg1
)
1039 Get_First_Interp
(N
, I
, It
);
1041 while Scope
(It
.Nam
) /= Standard_Standard
loop
1042 Get_Next_Interp
(I
, It
);
1051 -- If no universal interpretation, check whether user-defined operator
1052 -- hides predefined one, as well as other special cases. If the node
1053 -- is a range, then one or both bounds are ambiguous. Each will have
1054 -- to be disambiguated w.r.t. the context type. The type of the range
1055 -- itself is imposed by the context, so we can return either legal
1058 if Ekind
(Nam1
) = E_Operator
then
1059 Predef_Subp
:= Nam1
;
1062 elsif Ekind
(Nam2
) = E_Operator
then
1063 Predef_Subp
:= Nam2
;
1066 elsif Nkind
(N
) = N_Range
then
1069 -- If two user defined-subprograms are visible, it is a true ambiguity,
1070 -- unless one of them is an entry and the context is a conditional or
1071 -- timed entry call, or unless we are within an instance and this is
1072 -- results from two formals types with the same actual.
1075 if Nkind
(N
) = N_Procedure_Call_Statement
1076 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1077 and then N
= Entry_Call_Statement
(Parent
(N
))
1079 if Ekind
(Nam2
) = E_Entry
then
1081 elsif Ekind
(Nam1
) = E_Entry
then
1087 -- If the ambiguity occurs within an instance, it is due to several
1088 -- formal types with the same actual. Look for an exact match
1089 -- between the types of the formals of the overloadable entities,
1090 -- and the actuals in the call, to recover the unambiguous match
1091 -- in the original generic.
1093 elsif In_Instance
then
1094 if (Nkind
(N
) = N_Function_Call
1095 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1102 Actual
:= First_Actual
(N
);
1103 Formal
:= First_Formal
(Nam1
);
1104 while Present
(Actual
) loop
1105 if Etype
(Actual
) /= Etype
(Formal
) then
1109 Next_Actual
(Actual
);
1110 Next_Formal
(Formal
);
1116 elsif Nkind
(N
) in N_Binary_Op
then
1118 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1120 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1127 elsif Nkind
(N
) in N_Unary_Op
then
1129 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1136 return Remove_Conversions
;
1139 return Remove_Conversions
;
1143 -- an implicit concatenation operator on a string type cannot be
1144 -- disambiguated from the predefined concatenation. This can only
1145 -- happen with concatenation of string literals.
1147 if Chars
(User_Subp
) = Name_Op_Concat
1148 and then Ekind
(User_Subp
) = E_Operator
1149 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1153 -- If the user-defined operator is in an open scope, or in the scope
1154 -- of the resulting type, or given by an expanded name that names its
1155 -- scope, it hides the predefined operator for the type. Exponentiation
1156 -- has to be special-cased because the implicit operator does not have
1157 -- a symmetric signature, and may not be hidden by the explicit one.
1159 elsif (Nkind
(N
) = N_Function_Call
1160 and then Nkind
(Name
(N
)) = N_Expanded_Name
1161 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1162 or else Hides_Op
(User_Subp
, Predef_Subp
))
1163 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1164 or else Hides_Op
(User_Subp
, Predef_Subp
)
1166 if It1
.Nam
= User_Subp
then
1172 -- Otherwise, the predefined operator has precedence, or if the
1173 -- user-defined operation is directly visible we have a true ambiguity.
1174 -- If this is a fixed-point multiplication and division in Ada83 mode,
1175 -- exclude the universal_fixed operator, which often causes ambiguities
1179 if (In_Open_Scopes
(Scope
(User_Subp
))
1180 or else Is_Potentially_Use_Visible
(User_Subp
))
1181 and then not In_Instance
1183 if Is_Fixed_Point_Type
(Typ
)
1184 and then (Chars
(Nam1
) = Name_Op_Multiply
1185 or else Chars
(Nam1
) = Name_Op_Divide
)
1188 if It2
.Nam
= Predef_Subp
then
1198 elsif It1
.Nam
= Predef_Subp
then
1208 ---------------------
1209 -- End_Interp_List --
1210 ---------------------
1212 procedure End_Interp_List
is
1214 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1215 All_Interp
.Increment_Last
;
1216 end End_Interp_List
;
1218 -------------------------
1219 -- Entity_Matches_Spec --
1220 -------------------------
1222 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1224 -- Simple case: same entity kinds, type conformance is required.
1225 -- A parameterless function can also rename a literal.
1227 if Ekind
(Old_S
) = Ekind
(New_S
)
1228 or else (Ekind
(New_S
) = E_Function
1229 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1231 return Type_Conformant
(New_S
, Old_S
);
1233 elsif Ekind
(New_S
) = E_Function
1234 and then Ekind
(Old_S
) = E_Operator
1236 return Operator_Matches_Spec
(Old_S
, New_S
);
1238 elsif Ekind
(New_S
) = E_Procedure
1239 and then Is_Entry
(Old_S
)
1241 return Type_Conformant
(New_S
, Old_S
);
1246 end Entity_Matches_Spec
;
1248 ----------------------
1249 -- Find_Unique_Type --
1250 ----------------------
1252 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1255 T
: Entity_Id
:= Etype
(L
);
1256 TR
: Entity_Id
:= Any_Type
;
1259 if Is_Overloaded
(R
) then
1260 Get_First_Interp
(R
, I
, It
);
1262 while Present
(It
.Typ
) loop
1263 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1265 -- If several interpretations are possible and L is universal,
1266 -- apply preference rule.
1268 if TR
/= Any_Type
then
1270 if (T
= Universal_Integer
or else T
= Universal_Real
)
1281 Get_Next_Interp
(I
, It
);
1286 -- In the non-overloaded case, the Etype of R is already set
1293 -- If one of the operands is Universal_Fixed, the type of the
1294 -- other operand provides the context.
1296 if Etype
(R
) = Universal_Fixed
then
1299 elsif T
= Universal_Fixed
then
1303 return Specific_Type
(T
, Etype
(R
));
1306 end Find_Unique_Type
;
1308 ----------------------
1309 -- Get_First_Interp --
1310 ----------------------
1312 procedure Get_First_Interp
1314 I
: out Interp_Index
;
1317 Int_Ind
: Interp_Index
;
1321 -- If a selected component is overloaded because the selector has
1322 -- multiple interpretations, the node is a call to a protected
1323 -- operation or an indirect call. Retrieve the interpretation from
1324 -- the selector name. The selected component may be overloaded as well
1325 -- if the prefix is overloaded. That case is unchanged.
1327 if Nkind
(N
) = N_Selected_Component
1328 and then Is_Overloaded
(Selector_Name
(N
))
1330 O_N
:= Selector_Name
(N
);
1335 for Index
in 0 .. Interp_Map
.Last
loop
1336 if Interp_Map
.Table
(Index
).Node
= O_N
then
1337 Int_Ind
:= Interp_Map
.Table
(Index
).Index
;
1338 It
:= All_Interp
.Table
(Int_Ind
);
1344 -- Procedure should never be called if the node has no interpretations
1346 raise Program_Error
;
1347 end Get_First_Interp
;
1349 ----------------------
1350 -- Get_Next_Interp --
1351 ----------------------
1353 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1356 It
:= All_Interp
.Table
(I
);
1357 end Get_Next_Interp
;
1359 -------------------------
1360 -- Has_Compatible_Type --
1361 -------------------------
1363 function Has_Compatible_Type
1376 if Nkind
(N
) = N_Subtype_Indication
1377 or else not Is_Overloaded
(N
)
1379 return Covers
(Typ
, Etype
(N
))
1380 or else (not Is_Tagged_Type
(Typ
)
1381 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1382 and then Covers
(Etype
(N
), Typ
));
1385 Get_First_Interp
(N
, I
, It
);
1387 while Present
(It
.Typ
) loop
1388 if Covers
(Typ
, It
.Typ
)
1389 or else (not Is_Tagged_Type
(Typ
)
1390 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1391 and then Covers
(It
.Typ
, Typ
))
1396 Get_Next_Interp
(I
, It
);
1401 end Has_Compatible_Type
;
1407 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
1408 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
1411 return Operator_Matches_Spec
(Op
, F
)
1412 and then (In_Open_Scopes
(Scope
(F
))
1413 or else Scope
(F
) = Scope
(Btyp
)
1414 or else (not In_Open_Scopes
(Scope
(Btyp
))
1415 and then not In_Use
(Btyp
)
1416 and then not In_Use
(Scope
(Btyp
))));
1419 ------------------------
1420 -- Init_Interp_Tables --
1421 ------------------------
1423 procedure Init_Interp_Tables
is
1427 end Init_Interp_Tables
;
1429 ---------------------
1430 -- Intersect_Types --
1431 ---------------------
1433 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
1434 Index
: Interp_Index
;
1438 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
1439 -- Find interpretation of right arg that has type compatible with T
1441 --------------------------
1442 -- Check_Right_Argument --
1443 --------------------------
1445 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
1446 Index
: Interp_Index
;
1451 if not Is_Overloaded
(R
) then
1452 return Specific_Type
(T
, Etype
(R
));
1455 Get_First_Interp
(R
, Index
, It
);
1458 T2
:= Specific_Type
(T
, It
.Typ
);
1460 if T2
/= Any_Type
then
1464 Get_Next_Interp
(Index
, It
);
1465 exit when No
(It
.Typ
);
1470 end Check_Right_Argument
;
1472 -- Start processing for Intersect_Types
1475 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
1479 if not Is_Overloaded
(L
) then
1480 Typ
:= Check_Right_Argument
(Etype
(L
));
1484 Get_First_Interp
(L
, Index
, It
);
1486 while Present
(It
.Typ
) loop
1487 Typ
:= Check_Right_Argument
(It
.Typ
);
1488 exit when Typ
/= Any_Type
;
1489 Get_Next_Interp
(Index
, It
);
1494 -- If Typ is Any_Type, it means no compatible pair of types was found
1496 if Typ
= Any_Type
then
1498 if Nkind
(Parent
(L
)) in N_Op
then
1499 Error_Msg_N
("incompatible types for operator", Parent
(L
));
1501 elsif Nkind
(Parent
(L
)) = N_Range
then
1502 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
1505 Error_Msg_N
("incompatible types", Parent
(L
));
1510 end Intersect_Types
;
1516 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
1520 if Base_Type
(T1
) = Base_Type
(T2
) then
1523 elsif Is_Private_Type
(T1
)
1524 and then Present
(Full_View
(T1
))
1525 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
1533 if Base_Type
(T1
) = Base_Type
(Par
)
1534 or else (Is_Private_Type
(T1
)
1535 and then Present
(Full_View
(T1
))
1536 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
1540 elsif Is_Private_Type
(Par
)
1541 and then Present
(Full_View
(Par
))
1542 and then Full_View
(Par
) = Base_Type
(T1
)
1546 elsif Etype
(Par
) /= Par
then
1559 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
1563 S
:= Ancestor_Subtype
(T1
);
1564 while Present
(S
) loop
1568 S
:= Ancestor_Subtype
(S
);
1579 procedure New_Interps
(N
: Node_Id
) is
1581 Interp_Map
.Increment_Last
;
1582 All_Interp
.Increment_Last
;
1583 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
);
1584 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1585 Set_Is_Overloaded
(N
, True);
1588 ---------------------------
1589 -- Operator_Matches_Spec --
1590 ---------------------------
1592 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
1593 Op_Name
: constant Name_Id
:= Chars
(Op
);
1594 T
: constant Entity_Id
:= Etype
(New_S
);
1602 -- To verify that a predefined operator matches a given signature,
1603 -- do a case analysis of the operator classes. Function can have one
1604 -- or two formals and must have the proper result type.
1606 New_F
:= First_Formal
(New_S
);
1607 Old_F
:= First_Formal
(Op
);
1610 while Present
(New_F
) and then Present
(Old_F
) loop
1612 Next_Formal
(New_F
);
1613 Next_Formal
(Old_F
);
1616 -- Definite mismatch if different number of parameters
1618 if Present
(Old_F
) or else Present
(New_F
) then
1624 T1
:= Etype
(First_Formal
(New_S
));
1626 if Op_Name
= Name_Op_Subtract
1627 or else Op_Name
= Name_Op_Add
1628 or else Op_Name
= Name_Op_Abs
1630 return Base_Type
(T1
) = Base_Type
(T
)
1631 and then Is_Numeric_Type
(T
);
1633 elsif Op_Name
= Name_Op_Not
then
1634 return Base_Type
(T1
) = Base_Type
(T
)
1635 and then Valid_Boolean_Arg
(Base_Type
(T
));
1644 T1
:= Etype
(First_Formal
(New_S
));
1645 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
1647 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
1648 or else Op_Name
= Name_Op_Xor
1650 return Base_Type
(T1
) = Base_Type
(T2
)
1651 and then Base_Type
(T1
) = Base_Type
(T
)
1652 and then Valid_Boolean_Arg
(Base_Type
(T
));
1654 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
1655 return Base_Type
(T1
) = Base_Type
(T2
)
1656 and then not Is_Limited_Type
(T1
)
1657 and then Is_Boolean_Type
(T
);
1659 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
1660 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
1662 return Base_Type
(T1
) = Base_Type
(T2
)
1663 and then Valid_Comparison_Arg
(T1
)
1664 and then Is_Boolean_Type
(T
);
1666 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
1667 return Base_Type
(T1
) = Base_Type
(T2
)
1668 and then Base_Type
(T1
) = Base_Type
(T
)
1669 and then Is_Numeric_Type
(T
);
1671 -- for division and multiplication, a user-defined function does
1672 -- not match the predefined universal_fixed operation, except in
1675 elsif Op_Name
= Name_Op_Divide
then
1676 return (Base_Type
(T1
) = Base_Type
(T2
)
1677 and then Base_Type
(T1
) = Base_Type
(T
)
1678 and then Is_Numeric_Type
(T
)
1679 and then (not Is_Fixed_Point_Type
(T
)
1682 -- Mixed_Mode operations on fixed-point types.
1684 or else (Base_Type
(T1
) = Base_Type
(T
)
1685 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
1686 and then Is_Fixed_Point_Type
(T
))
1688 -- A user defined operator can also match (and hide) a mixed
1689 -- operation on universal literals.
1691 or else (Is_Integer_Type
(T2
)
1692 and then Is_Floating_Point_Type
(T1
)
1693 and then Base_Type
(T1
) = Base_Type
(T
));
1695 elsif Op_Name
= Name_Op_Multiply
then
1696 return (Base_Type
(T1
) = Base_Type
(T2
)
1697 and then Base_Type
(T1
) = Base_Type
(T
)
1698 and then Is_Numeric_Type
(T
)
1699 and then (not Is_Fixed_Point_Type
(T
)
1702 -- Mixed_Mode operations on fixed-point types.
1704 or else (Base_Type
(T1
) = Base_Type
(T
)
1705 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
1706 and then Is_Fixed_Point_Type
(T
))
1708 or else (Base_Type
(T2
) = Base_Type
(T
)
1709 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
1710 and then Is_Fixed_Point_Type
(T
))
1712 or else (Is_Integer_Type
(T2
)
1713 and then Is_Floating_Point_Type
(T1
)
1714 and then Base_Type
(T1
) = Base_Type
(T
))
1716 or else (Is_Integer_Type
(T1
)
1717 and then Is_Floating_Point_Type
(T2
)
1718 and then Base_Type
(T2
) = Base_Type
(T
));
1720 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
1721 return Base_Type
(T1
) = Base_Type
(T2
)
1722 and then Base_Type
(T1
) = Base_Type
(T
)
1723 and then Is_Integer_Type
(T
);
1725 elsif Op_Name
= Name_Op_Expon
then
1726 return Base_Type
(T1
) = Base_Type
(T
)
1727 and then Is_Numeric_Type
(T
)
1728 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
1730 elsif Op_Name
= Name_Op_Concat
then
1731 return Is_Array_Type
(T
)
1732 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
1733 and then (Base_Type
(T1
) = Base_Type
(T
)
1735 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
1736 and then (Base_Type
(T2
) = Base_Type
(T
)
1738 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
1744 end Operator_Matches_Spec
;
1750 procedure Remove_Interp
(I
: in out Interp_Index
) is
1754 -- Find end of Interp list and copy downward to erase the discarded one
1758 while Present
(All_Interp
.Table
(II
).Typ
) loop
1762 for J
in I
+ 1 .. II
loop
1763 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
1766 -- Back up interp. index to insure that iterator will pick up next
1767 -- available interpretation.
1776 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
1778 if Is_Overloaded
(Old_N
) then
1779 for Index
in 0 .. Interp_Map
.Last
loop
1780 if Interp_Map
.Table
(Index
).Node
= Old_N
then
1781 Interp_Map
.Table
(Index
).Node
:= New_N
;
1792 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
1793 B1
: constant Entity_Id
:= Base_Type
(T1
);
1794 B2
: constant Entity_Id
:= Base_Type
(T2
);
1796 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
1797 -- Check whether T is the equivalent type of a remote access type.
1798 -- If distribution is enabled, T is a legal context for Null.
1800 ----------------------
1801 -- Is_Remote_Access --
1802 ----------------------
1804 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
1806 return Is_Record_Type
(T
)
1807 and then (Is_Remote_Call_Interface
(T
)
1808 or else Is_Remote_Types
(T
))
1809 and then Present
(Corresponding_Remote_Type
(T
))
1810 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
1811 end Is_Remote_Access
;
1813 -- Start of processing for Specific_Type
1816 if (T1
= Any_Type
or else T2
= Any_Type
) then
1823 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
1824 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
1825 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
1829 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
1830 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
1831 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
1835 elsif (T2
= Any_String
and then Is_String_Type
(T1
)) then
1838 elsif (T1
= Any_String
and then Is_String_Type
(T2
)) then
1841 elsif (T2
= Any_Character
and then Is_Character_Type
(T1
)) then
1844 elsif (T1
= Any_Character
and then Is_Character_Type
(T2
)) then
1847 elsif (T1
= Any_Access
1848 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
)))
1852 elsif (T2
= Any_Access
1853 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
)))
1857 elsif (T2
= Any_Composite
1858 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
)
1862 elsif (T1
= Any_Composite
1863 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
)
1867 elsif (T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
)) then
1870 elsif (T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
)) then
1873 -- Special cases for equality operators (all other predefined
1874 -- operators can never apply to tagged types)
1876 elsif Is_Class_Wide_Type
(T1
)
1877 and then Is_Ancestor
(Root_Type
(T1
), T2
)
1881 elsif Is_Class_Wide_Type
(T2
)
1882 and then Is_Ancestor
(Root_Type
(T2
), T1
)
1886 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
1888 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
1889 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
1890 and then Is_Access_Type
(T2
)
1894 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
1896 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
1897 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
1898 and then Is_Access_Type
(T1
)
1902 elsif (Ekind
(T1
) = E_Allocator_Type
1903 or else Ekind
(T1
) = E_Access_Attribute_Type
1904 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
1905 and then Is_Access_Type
(T2
)
1909 elsif (Ekind
(T2
) = E_Allocator_Type
1910 or else Ekind
(T2
) = E_Access_Attribute_Type
1911 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
1912 and then Is_Access_Type
(T1
)
1916 -- If none of the above cases applies, types are not compatible.
1923 ------------------------------
1924 -- Universal_Interpretation --
1925 ------------------------------
1927 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
1928 Index
: Interp_Index
;
1932 -- The argument may be a formal parameter of an operator or subprogram
1933 -- with multiple interpretations, or else an expression for an actual.
1935 if Nkind
(Opnd
) = N_Defining_Identifier
1936 or else not Is_Overloaded
(Opnd
)
1938 if Etype
(Opnd
) = Universal_Integer
1939 or else Etype
(Opnd
) = Universal_Real
1941 return Etype
(Opnd
);
1947 Get_First_Interp
(Opnd
, Index
, It
);
1949 while Present
(It
.Typ
) loop
1951 if It
.Typ
= Universal_Integer
1952 or else It
.Typ
= Universal_Real
1957 Get_Next_Interp
(Index
, It
);
1962 end Universal_Interpretation
;
1964 -----------------------
1965 -- Valid_Boolean_Arg --
1966 -----------------------
1968 -- In addition to booleans and arrays of booleans, we must include
1969 -- aggregates as valid boolean arguments, because in the first pass
1970 -- of resolution their components are not examined. If it turns out not
1971 -- to be an aggregate of booleans, this will be diagnosed in Resolve.
1972 -- Any_Composite must be checked for prior to the array type checks
1973 -- because Any_Composite does not have any associated indexes.
1975 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
1977 return Is_Boolean_Type
(T
)
1978 or else T
= Any_Composite
1979 or else (Is_Array_Type
(T
)
1980 and then T
/= Any_String
1981 and then Number_Dimensions
(T
) = 1
1982 and then Is_Boolean_Type
(Component_Type
(T
))
1983 and then (not Is_Private_Composite
(T
)
1984 or else In_Instance
)
1985 and then (not Is_Limited_Composite
(T
)
1986 or else In_Instance
))
1987 or else Is_Modular_Integer_Type
(T
)
1988 or else T
= Universal_Integer
;
1989 end Valid_Boolean_Arg
;
1991 --------------------------
1992 -- Valid_Comparison_Arg --
1993 --------------------------
1995 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
1997 return Is_Discrete_Type
(T
)
1998 or else Is_Real_Type
(T
)
1999 or else (Is_Array_Type
(T
) and then Number_Dimensions
(T
) = 1
2000 and then Is_Discrete_Type
(Component_Type
(T
))
2001 and then (not Is_Private_Composite
(T
)
2002 or else In_Instance
)
2003 and then (not Is_Limited_Composite
(T
)
2004 or else In_Instance
))
2005 or else Is_String_Type
(T
);
2006 end Valid_Comparison_Arg
;
2008 ---------------------
2009 -- Write_Overloads --
2010 ---------------------
2012 procedure Write_Overloads
(N
: Node_Id
) is
2018 if not Is_Overloaded
(N
) then
2019 Write_Str
("Non-overloaded entity ");
2021 Write_Entity_Info
(Entity
(N
), " ");
2024 Get_First_Interp
(N
, I
, It
);
2025 Write_Str
("Overloaded entity ");
2029 while Present
(Nam
) loop
2030 Write_Entity_Info
(Nam
, " ");
2031 Write_Str
("=================");
2033 Get_Next_Interp
(I
, It
);
2037 end Write_Overloads
;