1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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
;
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
;
43 with Uintp
; use Uintp
;
45 package body Sem_Type
is
51 -- The following data structures establish a mapping between nodes and
52 -- their interpretations. An overloaded node has an entry in Interp_Map,
53 -- which in turn contains a pointer into the All_Interp array. The
54 -- interpretations of a given node are contiguous in All_Interp. Each
55 -- set of interpretations is terminated with the marker No_Interp.
56 -- In order to speed up the retrieval of the interpretations of an
57 -- overloaded node, the Interp_Map table is accessed by means of a simple
58 -- hashing scheme, and the entries in Interp_Map are chained. The heads
59 -- of clash lists are stored in array Headers.
61 -- Headers Interp_Map All_Interp
63 -- _ +-----+ +--------+
64 -- |_| |_____| --->|interp1 |
65 -- |_|---------->|node | | |interp2 |
66 -- |_| |index|---------| |nointerp|
71 -- This scheme does not currently reclaim interpretations. In principle,
72 -- after a unit is compiled, all overloadings have been resolved, and the
73 -- candidate interpretations should be deleted. This should be easier
74 -- now than with the previous scheme???
76 package All_Interp
is new Table
.Table
(
77 Table_Component_Type
=> Interp
,
78 Table_Index_Type
=> Int
,
80 Table_Initial
=> Alloc
.All_Interp_Initial
,
81 Table_Increment
=> Alloc
.All_Interp_Increment
,
82 Table_Name
=> "All_Interp");
84 type Interp_Ref
is record
90 Header_Size
: constant Int
:= 2 ** 12;
91 No_Entry
: constant Int
:= -1;
92 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
94 package Interp_Map
is new Table
.Table
(
95 Table_Component_Type
=> Interp_Ref
,
96 Table_Index_Type
=> Int
,
98 Table_Initial
=> Alloc
.Interp_Map_Initial
,
99 Table_Increment
=> Alloc
.Interp_Map_Increment
,
100 Table_Name
=> "Interp_Map");
102 function Hash
(N
: Node_Id
) return Int
;
103 -- A trivial hashing function for nodes, used to insert an overloaded
104 -- node into the Interp_Map table.
106 -------------------------------------
107 -- Handling of Overload Resolution --
108 -------------------------------------
110 -- Overload resolution uses two passes over the syntax tree of a complete
111 -- context. In the first, bottom-up pass, the types of actuals in calls
112 -- are used to resolve possibly overloaded subprogram and operator names.
113 -- In the second top-down pass, the type of the context (for example the
114 -- condition in a while statement) is used to resolve a possibly ambiguous
115 -- call, and the unique subprogram name in turn imposes a specific context
116 -- on each of its actuals.
118 -- Most expressions are in fact unambiguous, and the bottom-up pass is
119 -- sufficient to resolve most everything. To simplify the common case,
120 -- names and expressions carry a flag Is_Overloaded to indicate whether
121 -- they have more than one interpretation. If the flag is off, then each
122 -- name has already a unique meaning and type, and the bottom-up pass is
123 -- sufficient (and much simpler).
125 --------------------------
126 -- Operator Overloading --
127 --------------------------
129 -- The visibility of operators is handled differently from that of
130 -- other entities. We do not introduce explicit versions of primitive
131 -- operators for each type definition. As a result, there is only one
132 -- entity corresponding to predefined addition on all numeric types, etc.
133 -- The back-end resolves predefined operators according to their type.
134 -- The visibility of primitive operations then reduces to the visibility
135 -- of the resulting type: (a + b) is a legal interpretation of some
136 -- primitive operator + if the type of the result (which must also be
137 -- the type of a and b) is directly visible (i.e. either immediately
138 -- visible or use-visible.)
140 -- User-defined operators are treated like other functions, but the
141 -- visibility of these user-defined operations must be special-cased
142 -- to determine whether they hide or are hidden by predefined operators.
143 -- The form P."+" (x, y) requires additional handling.
145 -- Concatenation is treated more conventionally: for every one-dimensional
146 -- array type we introduce a explicit concatenation operator. This is
147 -- necessary to handle the case of (element & element => array) which
148 -- cannot be handled conveniently if there is no explicit instance of
149 -- resulting type of the operation.
151 -----------------------
152 -- Local Subprograms --
153 -----------------------
155 procedure All_Overloads
;
156 pragma Warnings
(Off
, All_Overloads
);
157 -- Debugging procedure: list full contents of Overloads table.
159 procedure New_Interps
(N
: Node_Id
);
160 -- Initialize collection of interpretations for the given node, which is
161 -- either an overloaded entity, or an operation whose arguments have
162 -- multiple intepretations. Interpretations can be added to only one
165 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
166 -- If T1 and T2 are compatible, return the one that is not
167 -- universal or is not a "class" type (any_character, etc).
173 procedure Add_One_Interp
177 Opnd_Type
: Entity_Id
:= Empty
)
179 Vis_Type
: Entity_Id
;
181 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
182 -- Add one interpretation to node. Node is already known to be
183 -- overloaded. Add new interpretation if not hidden by previous
184 -- one, and remove previous one if hidden by new one.
186 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
187 -- True if the entity is a predefined operator and the operands have
188 -- a universal Interpretation.
194 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
195 Index
: Interp_Index
;
199 Get_First_Interp
(N
, Index
, It
);
201 while Present
(It
.Nam
) loop
203 -- A user-defined subprogram hides another declared at an outer
204 -- level, or one that is use-visible. So return if previous
205 -- definition hides new one (which is either in an outer
206 -- scope, or use-visible). Note that for functions use-visible
207 -- is the same as potentially use-visible. If new one hides
208 -- previous one, replace entry in table of interpretations.
209 -- If this is a universal operation, retain the operator in case
210 -- preference rule applies.
212 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
213 and then Ekind
(Name
) = Ekind
(It
.Nam
))
214 or else (Ekind
(Name
) = E_Operator
215 and then Ekind
(It
.Nam
) = E_Function
))
217 and then Is_Immediately_Visible
(It
.Nam
)
218 and then Type_Conformant
(Name
, It
.Nam
)
219 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
221 if Is_Universal_Operation
(Name
) then
224 -- If node is an operator symbol, we have no actuals with
225 -- which to check hiding, and this is done in full in the
226 -- caller (Analyze_Subprogram_Renaming) so we include the
227 -- predefined operator in any case.
229 elsif Nkind
(N
) = N_Operator_Symbol
230 or else (Nkind
(N
) = N_Expanded_Name
232 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
236 elsif not In_Open_Scopes
(Scope
(Name
))
237 or else Scope_Depth
(Scope
(Name
))
238 <= Scope_Depth
(Scope
(It
.Nam
))
240 -- If ambiguity within instance, and entity is not an
241 -- implicit operation, save for later disambiguation.
243 if Scope
(Name
) = Scope
(It
.Nam
)
244 and then not Is_Inherited_Operation
(Name
)
253 All_Interp
.Table
(Index
).Nam
:= Name
;
257 -- Avoid making duplicate entries in overloads
260 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
264 -- Otherwise keep going
267 Get_Next_Interp
(Index
, It
);
272 -- On exit, enter new interpretation. The context, or a preference
273 -- rule, will resolve the ambiguity on the second pass.
275 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
276 All_Interp
.Increment_Last
;
277 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
280 ----------------------------
281 -- Is_Universal_Operation --
282 ----------------------------
284 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
288 if Ekind
(Op
) /= E_Operator
then
291 elsif Nkind
(N
) in N_Binary_Op
then
292 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
293 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
295 elsif Nkind
(N
) in N_Unary_Op
then
296 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
298 elsif Nkind
(N
) = N_Function_Call
then
299 Arg
:= First_Actual
(N
);
301 while Present
(Arg
) loop
303 if No
(Universal_Interpretation
(Arg
)) then
315 end Is_Universal_Operation
;
317 -- Start of processing for Add_One_Interp
320 -- If the interpretation is a predefined operator, verify that the
321 -- result type is visible, or that the entity has already been
322 -- resolved (case of an instantiation node that refers to a predefined
323 -- operation, or an internally generated operator node, or an operator
324 -- given as an expanded name). If the operator is a comparison or
325 -- equality, it is the type of the operand that matters to determine
326 -- whether the operator is visible. In an instance, the check is not
327 -- performed, given that the operator was visible in the generic.
329 if Ekind
(E
) = E_Operator
then
331 if Present
(Opnd_Type
) then
332 Vis_Type
:= Opnd_Type
;
334 Vis_Type
:= Base_Type
(T
);
337 if In_Open_Scopes
(Scope
(Vis_Type
))
338 or else Is_Potentially_Use_Visible
(Vis_Type
)
339 or else In_Use
(Vis_Type
)
340 or else (In_Use
(Scope
(Vis_Type
))
341 and then not Is_Hidden
(Vis_Type
))
342 or else Nkind
(N
) = N_Expanded_Name
343 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
348 -- If the node is given in functional notation and the prefix
349 -- is an expanded name, then the operator is visible if the
350 -- prefix is the scope of the result type as well. If the
351 -- operator is (implicitly) defined in an extension of system,
352 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
354 elsif Nkind
(N
) = N_Function_Call
355 and then Nkind
(Name
(N
)) = N_Expanded_Name
356 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
357 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
358 or else Scope
(Vis_Type
) = System_Aux_Id
)
362 -- Save type for subsequent error message, in case no other
363 -- interpretation is found.
366 Candidate_Type
:= Vis_Type
;
370 -- In an instance, an abstract non-dispatching operation cannot
371 -- be a candidate interpretation, because it could not have been
372 -- one in the generic (it may be a spurious overloading in the
376 and then Is_Abstract
(E
)
377 and then not Is_Dispatching_Operation
(E
)
382 -- If this is the first interpretation of N, N has type Any_Type.
383 -- In that case place the new type on the node. If one interpretation
384 -- already exists, indicate that the node is overloaded, and store
385 -- both the previous and the new interpretation in All_Interp. If
386 -- this is a later interpretation, just add it to the set.
388 if Etype
(N
) = Any_Type
then
393 -- Record both the operator or subprogram name, and its type.
395 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
402 -- Either there is no current interpretation in the table for any
403 -- node or the interpretation that is present is for a different
404 -- node. In both cases add a new interpretation to the table.
406 elsif Interp_Map
.Last
< 0
408 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
409 and then not Is_Overloaded
(N
))
413 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
414 and then Present
(Entity
(N
))
416 Add_Entry
(Entity
(N
), Etype
(N
));
418 elsif (Nkind
(N
) = N_Function_Call
419 or else Nkind
(N
) = N_Procedure_Call_Statement
)
420 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
421 or else Is_Entity_Name
(Name
(N
)))
423 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
426 -- Overloaded prefix in indexed or selected component,
427 -- or call whose name is an expresion or another call.
429 Add_Entry
(Etype
(N
), Etype
(N
));
443 procedure All_Overloads
is
445 for J
in All_Interp
.First
.. All_Interp
.Last
loop
447 if Present
(All_Interp
.Table
(J
).Nam
) then
448 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
450 Write_Str
("No Interp");
453 Write_Str
("=================");
458 ---------------------
459 -- Collect_Interps --
460 ---------------------
462 procedure Collect_Interps
(N
: Node_Id
) is
463 Ent
: constant Entity_Id
:= Entity
(N
);
465 First_Interp
: Interp_Index
;
470 -- Unconditionally add the entity that was initially matched
472 First_Interp
:= All_Interp
.Last
;
473 Add_One_Interp
(N
, Ent
, Etype
(N
));
475 -- For expanded name, pick up all additional entities from the
476 -- same scope, since these are obviously also visible. Note that
477 -- these are not necessarily contiguous on the homonym chain.
479 if Nkind
(N
) = N_Expanded_Name
then
481 while Present
(H
) loop
482 if Scope
(H
) = Scope
(Entity
(N
)) then
483 Add_One_Interp
(N
, H
, Etype
(H
));
489 -- Case of direct name
492 -- First, search the homonym chain for directly visible entities
494 H
:= Current_Entity
(Ent
);
495 while Present
(H
) loop
496 exit when (not Is_Overloadable
(H
))
497 and then Is_Immediately_Visible
(H
);
499 if Is_Immediately_Visible
(H
)
502 -- Only add interpretation if not hidden by an inner
503 -- immediately visible one.
505 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
507 -- Current homograph is not hidden. Add to overloads.
509 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
512 -- Homograph is hidden, unless it is a predefined operator.
514 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
516 -- A homograph in the same scope can occur within an
517 -- instantiation, the resulting ambiguity has to be
520 if Scope
(H
) = Scope
(Ent
)
522 and then not Is_Inherited_Operation
(H
)
524 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
525 All_Interp
.Increment_Last
;
526 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
529 elsif Scope
(H
) /= Standard_Standard
then
535 -- On exit, we know that current homograph is not hidden.
537 Add_One_Interp
(N
, H
, Etype
(H
));
540 Write_Str
("Add overloaded Interpretation ");
550 -- Scan list of homographs for use-visible entities only.
552 H
:= Current_Entity
(Ent
);
554 while Present
(H
) loop
555 if Is_Potentially_Use_Visible
(H
)
557 and then Is_Overloadable
(H
)
559 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
561 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
564 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
565 goto Next_Use_Homograph
;
569 Add_One_Interp
(N
, H
, Etype
(H
));
572 <<Next_Use_Homograph
>>
577 if All_Interp
.Last
= First_Interp
+ 1 then
579 -- The original interpretation is in fact not overloaded.
581 Set_Is_Overloaded
(N
, False);
589 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
591 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
592 -- In an instance the proper view may not always be correct for
593 -- private types, but private and full view are compatible. This
594 -- removes spurious errors from nested instantiations that involve,
595 -- among other things, types derived from private types.
597 ----------------------
598 -- Full_View_Covers --
599 ----------------------
601 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
604 Is_Private_Type
(Typ1
)
606 ((Present
(Full_View
(Typ1
))
607 and then Covers
(Full_View
(Typ1
), Typ2
))
608 or else Base_Type
(Typ1
) = Typ2
609 or else Base_Type
(Typ2
) = Typ1
);
610 end Full_View_Covers
;
612 -- Start of processing for Covers
615 -- If either operand missing, then this is an error, but ignore
616 -- it (and pretend we have a cover) if errors already detected,
617 -- since this may simply mean we have malformed trees.
619 if No
(T1
) or else No
(T2
) then
620 if Total_Errors_Detected
/= 0 then
627 -- Simplest case: same types are compatible, and types that have the
628 -- same base type and are not generic actuals are compatible. Generic
629 -- actuals belong to their class but are not compatible with other
630 -- types of their class, and in particular with other generic actuals.
631 -- They are however compatible with their own subtypes, and itypes
632 -- with the same base are compatible as well. Similary, constrained
633 -- subtypes obtained from expressions of an unconstrained nominal type
634 -- are compatible with the base type (may lead to spurious ambiguities
635 -- in obscure cases ???)
637 -- Generic actuals require special treatment to avoid spurious ambi-
638 -- guities in an instance, when two formal types are instantiated with
639 -- the same actual, so that different subprograms end up with the same
640 -- signature in the instance.
645 elsif Base_Type
(T1
) = Base_Type
(T2
) then
646 if not Is_Generic_Actual_Type
(T1
) then
649 return (not Is_Generic_Actual_Type
(T2
)
650 or else Is_Itype
(T1
)
651 or else Is_Itype
(T2
)
652 or else Is_Constr_Subt_For_U_Nominal
(T1
)
653 or else Is_Constr_Subt_For_U_Nominal
(T2
)
654 or else Scope
(T1
) /= Scope
(T2
));
657 -- Literals are compatible with types in a given "class"
659 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
660 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
661 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
662 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
663 or else (T2
= Any_String
and then Is_String_Type
(T1
))
664 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
665 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
669 -- The context may be class wide.
671 elsif Is_Class_Wide_Type
(T1
)
672 and then Is_Ancestor
(Root_Type
(T1
), T2
)
676 elsif Is_Class_Wide_Type
(T1
)
677 and then Is_Class_Wide_Type
(T2
)
678 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
682 -- In a dispatching call the actual may be class-wide
684 elsif Is_Class_Wide_Type
(T2
)
685 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
689 -- Some contexts require a class of types rather than a specific type
691 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
692 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
693 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
694 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
695 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
699 -- An aggregate is compatible with an array or record type
701 elsif T2
= Any_Composite
702 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
706 -- If the expected type is an anonymous access, the designated
707 -- type must cover that of the expression.
709 elsif Ekind
(T1
) = E_Anonymous_Access_Type
710 and then Is_Access_Type
(T2
)
711 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
715 -- An Access_To_Subprogram is compatible with itself, or with an
716 -- anonymous type created for an attribute reference Access.
718 elsif (Ekind
(Base_Type
(T1
)) = E_Access_Subprogram_Type
720 Ekind
(Base_Type
(T1
)) = E_Access_Protected_Subprogram_Type
)
721 and then Is_Access_Type
(T2
)
722 and then (not Comes_From_Source
(T1
)
723 or else not Comes_From_Source
(T2
))
724 and then (Is_Overloadable
(Designated_Type
(T2
))
726 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
728 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
730 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
734 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
735 -- with itself, or with an anonymous type created for an attribute
738 elsif (Ekind
(Base_Type
(T1
)) = E_Anonymous_Access_Subprogram_Type
740 Ekind
(Base_Type
(T1
))
741 = E_Anonymous_Access_Protected_Subprogram_Type
)
742 and then Is_Access_Type
(T2
)
743 and then (not Comes_From_Source
(T1
)
744 or else not Comes_From_Source
(T2
))
745 and then (Is_Overloadable
(Designated_Type
(T2
))
747 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
749 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
751 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
755 -- The context can be a remote access type, and the expression the
756 -- corresponding source type declared in a categorized package, or
759 elsif Is_Record_Type
(T1
)
760 and then (Is_Remote_Call_Interface
(T1
)
761 or else Is_Remote_Types
(T1
))
762 and then Present
(Corresponding_Remote_Type
(T1
))
764 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
766 elsif Is_Record_Type
(T2
)
767 and then (Is_Remote_Call_Interface
(T2
)
768 or else Is_Remote_Types
(T2
))
769 and then Present
(Corresponding_Remote_Type
(T2
))
771 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
773 elsif Ekind
(T2
) = E_Access_Attribute_Type
774 and then (Ekind
(Base_Type
(T1
)) = E_General_Access_Type
775 or else Ekind
(Base_Type
(T1
)) = E_Access_Type
)
776 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
778 -- If the target type is a RACW type while the source is an access
779 -- attribute type, we are building a RACW that may be exported.
781 if Is_Remote_Access_To_Class_Wide_Type
(Base_Type
(T1
)) then
782 Set_Has_RACW
(Current_Sem_Unit
);
787 elsif Ekind
(T2
) = E_Allocator_Type
788 and then Is_Access_Type
(T1
)
790 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
792 (From_With_Type
(Designated_Type
(T1
))
793 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
795 -- A boolean operation on integer literals is compatible with a
798 elsif T2
= Any_Modular
799 and then Is_Modular_Integer_Type
(T1
)
803 -- The actual type may be the result of a previous error
805 elsif Base_Type
(T2
) = Any_Type
then
808 -- A packed array type covers its corresponding non-packed type.
809 -- This is not legitimate Ada, but allows the omission of a number
810 -- of otherwise useless unchecked conversions, and since this can
811 -- only arise in (known correct) expanded code, no harm is done
813 elsif Is_Array_Type
(T2
)
814 and then Is_Packed
(T2
)
815 and then T1
= Packed_Array_Type
(T2
)
819 -- Similarly an array type covers its corresponding packed array type
821 elsif Is_Array_Type
(T1
)
822 and then Is_Packed
(T1
)
823 and then T2
= Packed_Array_Type
(T1
)
829 (Full_View_Covers
(T1
, T2
)
830 or else Full_View_Covers
(T2
, T1
))
834 -- In the expansion of inlined bodies, types are compatible if they
835 -- are structurally equivalent.
837 elsif In_Inlined_Body
838 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
839 or else (Is_Access_Type
(T1
)
840 and then Is_Access_Type
(T2
)
842 Designated_Type
(T1
) = Designated_Type
(T2
))
843 or else (T1
= Any_Access
844 and then Is_Access_Type
(Underlying_Type
(T2
))))
848 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
849 -- compatible with its real entity.
851 elsif From_With_Type
(T1
) then
853 -- If the expected type is the non-limited view of a type, the
854 -- expression may have the limited view.
856 if Ekind
(T1
) = E_Incomplete_Type
then
857 return Covers
(Non_Limited_View
(T1
), T2
);
859 elsif Ekind
(T1
) = E_Class_Wide_Type
then
861 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
866 elsif From_With_Type
(T2
) then
868 -- If units in the context have Limited_With clauses on each other,
869 -- either type might have a limited view. Checks performed elsewhere
870 -- verify that the context type is the non-limited view.
872 if Ekind
(T2
) = E_Incomplete_Type
then
873 return Covers
(T1
, Non_Limited_View
(T2
));
875 elsif Ekind
(T2
) = E_Class_Wide_Type
then
877 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
882 -- Otherwise it doesn't cover!
893 function Disambiguate
895 I1
, I2
: Interp_Index
;
902 Nam1
, Nam2
: Entity_Id
;
903 Predef_Subp
: Entity_Id
;
904 User_Subp
: Entity_Id
;
906 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
907 -- Determine whether a subprogram is an actual in an enclosing
908 -- instance. An overloading between such a subprogram and one
909 -- declared outside the instance is resolved in favor of the first,
910 -- because it resolved in the generic.
912 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
913 -- Look for exact type match in an instance, to remove spurious
914 -- ambiguities when two formal types have the same actual.
916 function Standard_Operator
return Boolean;
918 function Remove_Conversions
return Interp
;
919 -- Last chance for pathological cases involving comparisons on
920 -- literals, and user overloadings of the same operator. Such
921 -- pathologies have been removed from the ACVC, but still appear in
922 -- two DEC tests, with the following notable quote from Ben Brosgol:
924 -- [Note: I disclaim all credit/responsibility/blame for coming up with
925 -- this example; Robert Dewar brought it to our attention, since it
926 -- is apparently found in the ACVC 1.5. I did not attempt to find
927 -- the reason in the Reference Manual that makes the example legal,
928 -- since I was too nauseated by it to want to pursue it further.]
930 -- Accordingly, this is not a fully recursive solution, but it handles
931 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
932 -- pathology in the other direction with calls whose multiple overloaded
933 -- actuals make them truly unresolvable.
935 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
937 return In_Open_Scopes
(Scope
(S
))
939 (Is_Generic_Instance
(Scope
(S
))
940 or else Is_Wrapper_Package
(Scope
(S
)));
941 end Is_Actual_Subprogram
;
947 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
948 T1
: constant Entity_Id
:= Etype
(Actual
);
949 T2
: constant Entity_Id
:= Etype
(Formal
);
954 (Is_Numeric_Type
(T2
)
956 (T1
= Universal_Real
or else T1
= Universal_Integer
));
959 ------------------------
960 -- Remove_Conversions --
961 ------------------------
963 function Remove_Conversions
return Interp
is
973 Get_First_Interp
(N
, I
, It
);
975 while Present
(It
.Typ
) loop
977 if not Is_Overloadable
(It
.Nam
) then
981 F1
:= First_Formal
(It
.Nam
);
987 if Nkind
(N
) = N_Function_Call
988 or else Nkind
(N
) = N_Procedure_Call_Statement
990 Act1
:= First_Actual
(N
);
992 if Present
(Act1
) then
993 Act2
:= Next_Actual
(Act1
);
998 elsif Nkind
(N
) in N_Unary_Op
then
999 Act1
:= Right_Opnd
(N
);
1002 elsif Nkind
(N
) in N_Binary_Op
then
1003 Act1
:= Left_Opnd
(N
);
1004 Act2
:= Right_Opnd
(N
);
1010 if Nkind
(Act1
) in N_Op
1011 and then Is_Overloaded
(Act1
)
1012 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1013 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1014 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1015 and then Etype
(F1
) = Standard_Boolean
1017 -- If the two candidates are the original ones, the
1018 -- ambiguity is real. Otherwise keep the original,
1019 -- further calls to Disambiguate will take care of
1020 -- others in the list of candidates.
1022 if It1
/= No_Interp
then
1023 if It
= Disambiguate
.It1
1024 or else It
= Disambiguate
.It2
1026 if It1
= Disambiguate
.It1
1027 or else It1
= Disambiguate
.It2
1035 elsif Present
(Act2
)
1036 and then Nkind
(Act2
) in N_Op
1037 and then Is_Overloaded
(Act2
)
1038 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1040 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1041 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1043 -- The preference rule on the first actual is not
1044 -- sufficient to disambiguate.
1055 Get_Next_Interp
(I
, It
);
1058 if Serious_Errors_Detected
> 0 then
1060 -- After some error, a formal may have Any_Type and yield
1061 -- a spurious match. To avoid cascaded errors if possible,
1062 -- check for such a formal in either candidate.
1068 Formal
:= First_Formal
(Nam1
);
1069 while Present
(Formal
) loop
1070 if Etype
(Formal
) = Any_Type
then
1071 return Disambiguate
.It2
;
1074 Next_Formal
(Formal
);
1077 Formal
:= First_Formal
(Nam2
);
1078 while Present
(Formal
) loop
1079 if Etype
(Formal
) = Any_Type
then
1080 return Disambiguate
.It1
;
1083 Next_Formal
(Formal
);
1089 end Remove_Conversions
;
1091 -----------------------
1092 -- Standard_Operator --
1093 -----------------------
1095 function Standard_Operator
return Boolean is
1099 if Nkind
(N
) in N_Op
then
1102 elsif Nkind
(N
) = N_Function_Call
then
1105 if Nkind
(Nam
) /= N_Expanded_Name
then
1108 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1113 end Standard_Operator
;
1115 -- Start of processing for Disambiguate
1118 -- Recover the two legal interpretations.
1120 Get_First_Interp
(N
, I
, It
);
1123 Get_Next_Interp
(I
, It
);
1130 Get_Next_Interp
(I
, It
);
1136 -- If the context is universal, the predefined operator is preferred.
1137 -- This includes bounds in numeric type declarations, and expressions
1138 -- in type conversions. If no interpretation yields a universal type,
1139 -- then we must check whether the user-defined entity hides the prede-
1142 if Chars
(Nam1
) in Any_Operator_Name
1143 and then Standard_Operator
1145 if Typ
= Universal_Integer
1146 or else Typ
= Universal_Real
1147 or else Typ
= Any_Integer
1148 or else Typ
= Any_Discrete
1149 or else Typ
= Any_Real
1150 or else Typ
= Any_Type
1152 -- Find an interpretation that yields the universal type, or else
1153 -- a predefined operator that yields a predefined numeric type.
1156 Candidate
: Interp
:= No_Interp
;
1158 Get_First_Interp
(N
, I
, It
);
1160 while Present
(It
.Typ
) loop
1161 if (Covers
(Typ
, It
.Typ
)
1162 or else Typ
= Any_Type
)
1164 (It
.Typ
= Universal_Integer
1165 or else It
.Typ
= Universal_Real
)
1169 elsif Covers
(Typ
, It
.Typ
)
1170 and then Scope
(It
.Typ
) = Standard_Standard
1171 and then Scope
(It
.Nam
) = Standard_Standard
1172 and then Is_Numeric_Type
(It
.Typ
)
1177 Get_Next_Interp
(I
, It
);
1180 if Candidate
/= No_Interp
then
1185 elsif Chars
(Nam1
) /= Name_Op_Not
1186 and then (Typ
= Standard_Boolean
1187 or else Typ
= Any_Boolean
)
1189 -- Equality or comparison operation. Choose predefined operator
1190 -- if arguments are universal. The node may be an operator, a
1191 -- name, or a function call, so unpack arguments accordingly.
1194 Arg1
, Arg2
: Node_Id
;
1197 if Nkind
(N
) in N_Op
then
1198 Arg1
:= Left_Opnd
(N
);
1199 Arg2
:= Right_Opnd
(N
);
1201 elsif Is_Entity_Name
(N
)
1202 or else Nkind
(N
) = N_Operator_Symbol
1204 Arg1
:= First_Entity
(Entity
(N
));
1205 Arg2
:= Next_Entity
(Arg1
);
1208 Arg1
:= First_Actual
(N
);
1209 Arg2
:= Next_Actual
(Arg1
);
1213 and then Present
(Universal_Interpretation
(Arg1
))
1214 and then Universal_Interpretation
(Arg2
) =
1215 Universal_Interpretation
(Arg1
)
1217 Get_First_Interp
(N
, I
, It
);
1219 while Scope
(It
.Nam
) /= Standard_Standard
loop
1220 Get_Next_Interp
(I
, It
);
1229 -- If no universal interpretation, check whether user-defined operator
1230 -- hides predefined one, as well as other special cases. If the node
1231 -- is a range, then one or both bounds are ambiguous. Each will have
1232 -- to be disambiguated w.r.t. the context type. The type of the range
1233 -- itself is imposed by the context, so we can return either legal
1236 if Ekind
(Nam1
) = E_Operator
then
1237 Predef_Subp
:= Nam1
;
1240 elsif Ekind
(Nam2
) = E_Operator
then
1241 Predef_Subp
:= Nam2
;
1244 elsif Nkind
(N
) = N_Range
then
1247 -- If two user defined-subprograms are visible, it is a true ambiguity,
1248 -- unless one of them is an entry and the context is a conditional or
1249 -- timed entry call, or unless we are within an instance and this is
1250 -- results from two formals types with the same actual.
1253 if Nkind
(N
) = N_Procedure_Call_Statement
1254 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1255 and then N
= Entry_Call_Statement
(Parent
(N
))
1257 if Ekind
(Nam2
) = E_Entry
then
1259 elsif Ekind
(Nam1
) = E_Entry
then
1265 -- If the ambiguity occurs within an instance, it is due to several
1266 -- formal types with the same actual. Look for an exact match
1267 -- between the types of the formals of the overloadable entities,
1268 -- and the actuals in the call, to recover the unambiguous match
1269 -- in the original generic.
1271 -- The ambiguity can also be due to an overloading between a formal
1272 -- subprogram and a subprogram declared outside the generic. If the
1273 -- node is overloaded, it did not resolve to the global entity in
1274 -- the generic, and we choose the formal subprogram.
1276 elsif In_Instance
then
1277 if Nkind
(N
) = N_Function_Call
1278 or else Nkind
(N
) = N_Procedure_Call_Statement
1283 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1284 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1287 if Is_Act1
and then not Is_Act2
then
1290 elsif Is_Act2
and then not Is_Act1
then
1294 Actual
:= First_Actual
(N
);
1295 Formal
:= First_Formal
(Nam1
);
1296 while Present
(Actual
) loop
1297 if Etype
(Actual
) /= Etype
(Formal
) then
1301 Next_Actual
(Actual
);
1302 Next_Formal
(Formal
);
1308 elsif Nkind
(N
) in N_Binary_Op
then
1310 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1312 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1319 elsif Nkind
(N
) in N_Unary_Op
then
1321 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1328 return Remove_Conversions
;
1331 return Remove_Conversions
;
1335 -- an implicit concatenation operator on a string type cannot be
1336 -- disambiguated from the predefined concatenation. This can only
1337 -- happen with concatenation of string literals.
1339 if Chars
(User_Subp
) = Name_Op_Concat
1340 and then Ekind
(User_Subp
) = E_Operator
1341 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1345 -- If the user-defined operator is in an open scope, or in the scope
1346 -- of the resulting type, or given by an expanded name that names its
1347 -- scope, it hides the predefined operator for the type. Exponentiation
1348 -- has to be special-cased because the implicit operator does not have
1349 -- a symmetric signature, and may not be hidden by the explicit one.
1351 elsif (Nkind
(N
) = N_Function_Call
1352 and then Nkind
(Name
(N
)) = N_Expanded_Name
1353 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1354 or else Hides_Op
(User_Subp
, Predef_Subp
))
1355 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1356 or else Hides_Op
(User_Subp
, Predef_Subp
)
1358 if It1
.Nam
= User_Subp
then
1364 -- Otherwise, the predefined operator has precedence, or if the
1365 -- user-defined operation is directly visible we have a true ambiguity.
1366 -- If this is a fixed-point multiplication and division in Ada83 mode,
1367 -- exclude the universal_fixed operator, which often causes ambiguities
1371 if (In_Open_Scopes
(Scope
(User_Subp
))
1372 or else Is_Potentially_Use_Visible
(User_Subp
))
1373 and then not In_Instance
1375 if Is_Fixed_Point_Type
(Typ
)
1376 and then (Chars
(Nam1
) = Name_Op_Multiply
1377 or else Chars
(Nam1
) = Name_Op_Divide
)
1378 and then Ada_Version
= Ada_83
1380 if It2
.Nam
= Predef_Subp
then
1389 elsif It1
.Nam
= Predef_Subp
then
1399 ---------------------
1400 -- End_Interp_List --
1401 ---------------------
1403 procedure End_Interp_List
is
1405 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1406 All_Interp
.Increment_Last
;
1407 end End_Interp_List
;
1409 -------------------------
1410 -- Entity_Matches_Spec --
1411 -------------------------
1413 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1415 -- Simple case: same entity kinds, type conformance is required.
1416 -- A parameterless function can also rename a literal.
1418 if Ekind
(Old_S
) = Ekind
(New_S
)
1419 or else (Ekind
(New_S
) = E_Function
1420 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1422 return Type_Conformant
(New_S
, Old_S
);
1424 elsif Ekind
(New_S
) = E_Function
1425 and then Ekind
(Old_S
) = E_Operator
1427 return Operator_Matches_Spec
(Old_S
, New_S
);
1429 elsif Ekind
(New_S
) = E_Procedure
1430 and then Is_Entry
(Old_S
)
1432 return Type_Conformant
(New_S
, Old_S
);
1437 end Entity_Matches_Spec
;
1439 ----------------------
1440 -- Find_Unique_Type --
1441 ----------------------
1443 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1444 T
: constant Entity_Id
:= Etype
(L
);
1447 TR
: Entity_Id
:= Any_Type
;
1450 if Is_Overloaded
(R
) then
1451 Get_First_Interp
(R
, I
, It
);
1453 while Present
(It
.Typ
) loop
1454 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1456 -- If several interpretations are possible and L is universal,
1457 -- apply preference rule.
1459 if TR
/= Any_Type
then
1461 if (T
= Universal_Integer
or else T
= Universal_Real
)
1472 Get_Next_Interp
(I
, It
);
1477 -- In the non-overloaded case, the Etype of R is already set
1484 -- If one of the operands is Universal_Fixed, the type of the
1485 -- other operand provides the context.
1487 if Etype
(R
) = Universal_Fixed
then
1490 elsif T
= Universal_Fixed
then
1493 -- Ada 2005 (AI-230): Support the following operators:
1495 -- function "=" (L, R : universal_access) return Boolean;
1496 -- function "/=" (L, R : universal_access) return Boolean;
1498 elsif Ada_Version
>= Ada_05
1499 and then Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
1500 and then Is_Access_Type
(Etype
(R
))
1504 elsif Ada_Version
>= Ada_05
1505 and then Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
1506 and then Is_Access_Type
(Etype
(L
))
1511 return Specific_Type
(T
, Etype
(R
));
1514 end Find_Unique_Type
;
1516 ----------------------
1517 -- Get_First_Interp --
1518 ----------------------
1520 procedure Get_First_Interp
1522 I
: out Interp_Index
;
1526 Int_Ind
: Interp_Index
;
1530 -- If a selected component is overloaded because the selector has
1531 -- multiple interpretations, the node is a call to a protected
1532 -- operation or an indirect call. Retrieve the interpretation from
1533 -- the selector name. The selected component may be overloaded as well
1534 -- if the prefix is overloaded. That case is unchanged.
1536 if Nkind
(N
) = N_Selected_Component
1537 and then Is_Overloaded
(Selector_Name
(N
))
1539 O_N
:= Selector_Name
(N
);
1544 Map_Ptr
:= Headers
(Hash
(O_N
));
1546 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
1547 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
1548 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
1549 It
:= All_Interp
.Table
(Int_Ind
);
1553 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
1557 -- Procedure should never be called if the node has no interpretations
1559 raise Program_Error
;
1560 end Get_First_Interp
;
1562 ---------------------
1563 -- Get_Next_Interp --
1564 ---------------------
1566 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1569 It
:= All_Interp
.Table
(I
);
1570 end Get_Next_Interp
;
1572 -------------------------
1573 -- Has_Compatible_Type --
1574 -------------------------
1576 function Has_Compatible_Type
1589 if Nkind
(N
) = N_Subtype_Indication
1590 or else not Is_Overloaded
(N
)
1593 Covers
(Typ
, Etype
(N
))
1595 (not Is_Tagged_Type
(Typ
)
1596 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1597 and then Covers
(Etype
(N
), Typ
));
1600 Get_First_Interp
(N
, I
, It
);
1602 while Present
(It
.Typ
) loop
1603 if (Covers
(Typ
, It
.Typ
)
1605 (Scope
(It
.Nam
) /= Standard_Standard
1606 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
1608 or else (not Is_Tagged_Type
(Typ
)
1609 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1610 and then Covers
(It
.Typ
, Typ
))
1615 Get_Next_Interp
(I
, It
);
1620 end Has_Compatible_Type
;
1626 function Hash
(N
: Node_Id
) return Int
is
1628 -- Nodes have a size that is power of two, so to select significant
1629 -- bits only we remove the low-order bits.
1631 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
1638 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
1639 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
1642 return Operator_Matches_Spec
(Op
, F
)
1643 and then (In_Open_Scopes
(Scope
(F
))
1644 or else Scope
(F
) = Scope
(Btyp
)
1645 or else (not In_Open_Scopes
(Scope
(Btyp
))
1646 and then not In_Use
(Btyp
)
1647 and then not In_Use
(Scope
(Btyp
))));
1650 ------------------------
1651 -- Init_Interp_Tables --
1652 ------------------------
1654 procedure Init_Interp_Tables
is
1658 Headers
:= (others => No_Entry
);
1659 end Init_Interp_Tables
;
1661 ---------------------
1662 -- Intersect_Types --
1663 ---------------------
1665 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
1666 Index
: Interp_Index
;
1670 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
1671 -- Find interpretation of right arg that has type compatible with T
1673 --------------------------
1674 -- Check_Right_Argument --
1675 --------------------------
1677 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
1678 Index
: Interp_Index
;
1683 if not Is_Overloaded
(R
) then
1684 return Specific_Type
(T
, Etype
(R
));
1687 Get_First_Interp
(R
, Index
, It
);
1690 T2
:= Specific_Type
(T
, It
.Typ
);
1692 if T2
/= Any_Type
then
1696 Get_Next_Interp
(Index
, It
);
1697 exit when No
(It
.Typ
);
1702 end Check_Right_Argument
;
1704 -- Start processing for Intersect_Types
1707 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
1711 if not Is_Overloaded
(L
) then
1712 Typ
:= Check_Right_Argument
(Etype
(L
));
1716 Get_First_Interp
(L
, Index
, It
);
1718 while Present
(It
.Typ
) loop
1719 Typ
:= Check_Right_Argument
(It
.Typ
);
1720 exit when Typ
/= Any_Type
;
1721 Get_Next_Interp
(Index
, It
);
1726 -- If Typ is Any_Type, it means no compatible pair of types was found
1728 if Typ
= Any_Type
then
1730 if Nkind
(Parent
(L
)) in N_Op
then
1731 Error_Msg_N
("incompatible types for operator", Parent
(L
));
1733 elsif Nkind
(Parent
(L
)) = N_Range
then
1734 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
1737 Error_Msg_N
("incompatible types", Parent
(L
));
1742 end Intersect_Types
;
1748 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
1752 if Base_Type
(T1
) = Base_Type
(T2
) then
1755 elsif Is_Private_Type
(T1
)
1756 and then Present
(Full_View
(T1
))
1757 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
1765 -- If there was a error on the type declaration, do not recurse
1767 if Error_Posted
(Par
) then
1770 elsif Base_Type
(T1
) = Base_Type
(Par
)
1771 or else (Is_Private_Type
(T1
)
1772 and then Present
(Full_View
(T1
))
1773 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
1777 elsif Is_Private_Type
(Par
)
1778 and then Present
(Full_View
(Par
))
1779 and then Full_View
(Par
) = Base_Type
(T1
)
1783 elsif Etype
(Par
) /= Par
then
1792 ---------------------------
1793 -- Is_Invisible_Operator --
1794 ---------------------------
1796 function Is_Invisible_Operator
1801 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
1804 if Nkind
(N
) not in N_Op
then
1807 elsif not Comes_From_Source
(N
) then
1810 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
1813 elsif Nkind
(N
) in N_Binary_Op
1814 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
1820 and then not In_Open_Scopes
(Scope
(T
))
1821 and then not Is_Potentially_Use_Visible
(T
)
1822 and then not In_Use
(T
)
1823 and then not In_Use
(Scope
(T
))
1825 (Nkind
(Orig_Node
) /= N_Function_Call
1826 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
1827 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
1829 and then not In_Instance
;
1831 end Is_Invisible_Operator
;
1837 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
1841 S
:= Ancestor_Subtype
(T1
);
1842 while Present
(S
) loop
1846 S
:= Ancestor_Subtype
(S
);
1857 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
1858 Index
: Interp_Index
;
1862 Get_First_Interp
(Nam
, Index
, It
);
1863 while Present
(It
.Nam
) loop
1864 if Scope
(It
.Nam
) = Standard_Standard
1865 and then Scope
(It
.Typ
) /= Standard_Standard
1867 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
1868 Error_Msg_NE
(" & (inherited) declared#!", Err
, It
.Nam
);
1871 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
1872 Error_Msg_NE
(" & declared#!", Err
, It
.Nam
);
1875 Get_Next_Interp
(Index
, It
);
1883 procedure New_Interps
(N
: Node_Id
) is
1887 All_Interp
.Increment_Last
;
1888 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1890 Map_Ptr
:= Headers
(Hash
(N
));
1892 if Map_Ptr
= No_Entry
then
1894 -- Place new node at end of table
1896 Interp_Map
.Increment_Last
;
1897 Headers
(Hash
(N
)) := Interp_Map
.Last
;
1900 -- Place node at end of chain, or locate its previous entry.
1903 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
1905 -- Node is already in the table, and is being rewritten.
1906 -- Start a new interp section, retain hash link.
1908 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
1909 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
1910 Set_Is_Overloaded
(N
, True);
1914 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
1915 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
1919 -- Chain the new node.
1921 Interp_Map
.Increment_Last
;
1922 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
1925 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
1926 Set_Is_Overloaded
(N
, True);
1929 ---------------------------
1930 -- Operator_Matches_Spec --
1931 ---------------------------
1933 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
1934 Op_Name
: constant Name_Id
:= Chars
(Op
);
1935 T
: constant Entity_Id
:= Etype
(New_S
);
1943 -- To verify that a predefined operator matches a given signature,
1944 -- do a case analysis of the operator classes. Function can have one
1945 -- or two formals and must have the proper result type.
1947 New_F
:= First_Formal
(New_S
);
1948 Old_F
:= First_Formal
(Op
);
1951 while Present
(New_F
) and then Present
(Old_F
) loop
1953 Next_Formal
(New_F
);
1954 Next_Formal
(Old_F
);
1957 -- Definite mismatch if different number of parameters
1959 if Present
(Old_F
) or else Present
(New_F
) then
1965 T1
:= Etype
(First_Formal
(New_S
));
1967 if Op_Name
= Name_Op_Subtract
1968 or else Op_Name
= Name_Op_Add
1969 or else Op_Name
= Name_Op_Abs
1971 return Base_Type
(T1
) = Base_Type
(T
)
1972 and then Is_Numeric_Type
(T
);
1974 elsif Op_Name
= Name_Op_Not
then
1975 return Base_Type
(T1
) = Base_Type
(T
)
1976 and then Valid_Boolean_Arg
(Base_Type
(T
));
1985 T1
:= Etype
(First_Formal
(New_S
));
1986 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
1988 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
1989 or else Op_Name
= Name_Op_Xor
1991 return Base_Type
(T1
) = Base_Type
(T2
)
1992 and then Base_Type
(T1
) = Base_Type
(T
)
1993 and then Valid_Boolean_Arg
(Base_Type
(T
));
1995 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
1996 return Base_Type
(T1
) = Base_Type
(T2
)
1997 and then not Is_Limited_Type
(T1
)
1998 and then Is_Boolean_Type
(T
);
2000 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2001 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2003 return Base_Type
(T1
) = Base_Type
(T2
)
2004 and then Valid_Comparison_Arg
(T1
)
2005 and then Is_Boolean_Type
(T
);
2007 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2008 return Base_Type
(T1
) = Base_Type
(T2
)
2009 and then Base_Type
(T1
) = Base_Type
(T
)
2010 and then Is_Numeric_Type
(T
);
2012 -- for division and multiplication, a user-defined function does
2013 -- not match the predefined universal_fixed operation, except in
2016 elsif Op_Name
= Name_Op_Divide
then
2017 return (Base_Type
(T1
) = Base_Type
(T2
)
2018 and then Base_Type
(T1
) = Base_Type
(T
)
2019 and then Is_Numeric_Type
(T
)
2020 and then (not Is_Fixed_Point_Type
(T
)
2021 or else Ada_Version
= Ada_83
))
2023 -- Mixed_Mode operations on fixed-point types
2025 or else (Base_Type
(T1
) = Base_Type
(T
)
2026 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2027 and then Is_Fixed_Point_Type
(T
))
2029 -- A user defined operator can also match (and hide) a mixed
2030 -- operation on universal literals.
2032 or else (Is_Integer_Type
(T2
)
2033 and then Is_Floating_Point_Type
(T1
)
2034 and then Base_Type
(T1
) = Base_Type
(T
));
2036 elsif Op_Name
= Name_Op_Multiply
then
2037 return (Base_Type
(T1
) = Base_Type
(T2
)
2038 and then Base_Type
(T1
) = Base_Type
(T
)
2039 and then Is_Numeric_Type
(T
)
2040 and then (not Is_Fixed_Point_Type
(T
)
2041 or else Ada_Version
= Ada_83
))
2043 -- Mixed_Mode operations on fixed-point types
2045 or else (Base_Type
(T1
) = Base_Type
(T
)
2046 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2047 and then Is_Fixed_Point_Type
(T
))
2049 or else (Base_Type
(T2
) = Base_Type
(T
)
2050 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2051 and then Is_Fixed_Point_Type
(T
))
2053 or else (Is_Integer_Type
(T2
)
2054 and then Is_Floating_Point_Type
(T1
)
2055 and then Base_Type
(T1
) = Base_Type
(T
))
2057 or else (Is_Integer_Type
(T1
)
2058 and then Is_Floating_Point_Type
(T2
)
2059 and then Base_Type
(T2
) = Base_Type
(T
));
2061 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2062 return Base_Type
(T1
) = Base_Type
(T2
)
2063 and then Base_Type
(T1
) = Base_Type
(T
)
2064 and then Is_Integer_Type
(T
);
2066 elsif Op_Name
= Name_Op_Expon
then
2067 return Base_Type
(T1
) = Base_Type
(T
)
2068 and then Is_Numeric_Type
(T
)
2069 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2071 elsif Op_Name
= Name_Op_Concat
then
2072 return Is_Array_Type
(T
)
2073 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2074 and then (Base_Type
(T1
) = Base_Type
(T
)
2076 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2077 and then (Base_Type
(T2
) = Base_Type
(T
)
2079 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2085 end Operator_Matches_Spec
;
2091 procedure Remove_Interp
(I
: in out Interp_Index
) is
2095 -- Find end of Interp list and copy downward to erase the discarded one
2099 while Present
(All_Interp
.Table
(II
).Typ
) loop
2103 for J
in I
+ 1 .. II
loop
2104 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2107 -- Back up interp. index to insure that iterator will pick up next
2108 -- available interpretation.
2117 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2119 O_N
: Node_Id
:= Old_N
;
2122 if Is_Overloaded
(Old_N
) then
2123 if Nkind
(Old_N
) = N_Selected_Component
2124 and then Is_Overloaded
(Selector_Name
(Old_N
))
2126 O_N
:= Selector_Name
(Old_N
);
2129 Map_Ptr
:= Headers
(Hash
(O_N
));
2131 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2132 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2133 pragma Assert
(Map_Ptr
/= No_Entry
);
2136 New_Interps
(New_N
);
2137 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2138 Interp_Map
.Table
(Map_Ptr
).Index
;
2146 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
2147 B1
: constant Entity_Id
:= Base_Type
(T1
);
2148 B2
: constant Entity_Id
:= Base_Type
(T2
);
2150 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2151 -- Check whether T is the equivalent type of a remote access type.
2152 -- If distribution is enabled, T is a legal context for Null.
2154 ----------------------
2155 -- Is_Remote_Access --
2156 ----------------------
2158 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2160 return Is_Record_Type
(T
)
2161 and then (Is_Remote_Call_Interface
(T
)
2162 or else Is_Remote_Types
(T
))
2163 and then Present
(Corresponding_Remote_Type
(T
))
2164 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2165 end Is_Remote_Access
;
2167 -- Start of processing for Specific_Type
2170 if T1
= Any_Type
or else T2
= Any_Type
then
2178 or else (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2179 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2180 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2181 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2186 or else (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2187 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2188 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2189 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2193 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2196 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2199 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2202 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
2205 elsif T1
= Any_Access
2206 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
2210 elsif T2
= Any_Access
2211 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
2215 elsif T2
= Any_Composite
2216 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
2220 elsif T1
= Any_Composite
2221 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
2225 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
2228 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
2231 -- Special cases for equality operators (all other predefined
2232 -- operators can never apply to tagged types)
2234 elsif Is_Class_Wide_Type
(T1
)
2235 and then Is_Ancestor
(Root_Type
(T1
), T2
)
2239 elsif Is_Class_Wide_Type
(T2
)
2240 and then Is_Ancestor
(Root_Type
(T2
), T1
)
2244 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
2246 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
2247 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
2248 and then Is_Access_Type
(T2
)
2252 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
2254 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
2255 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
2256 and then Is_Access_Type
(T1
)
2260 elsif (Ekind
(T1
) = E_Allocator_Type
2261 or else Ekind
(T1
) = E_Access_Attribute_Type
2262 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
2263 and then Is_Access_Type
(T2
)
2267 elsif (Ekind
(T2
) = E_Allocator_Type
2268 or else Ekind
(T2
) = E_Access_Attribute_Type
2269 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
2270 and then Is_Access_Type
(T1
)
2274 -- If none of the above cases applies, types are not compatible.
2281 -----------------------
2282 -- Valid_Boolean_Arg --
2283 -----------------------
2285 -- In addition to booleans and arrays of booleans, we must include
2286 -- aggregates as valid boolean arguments, because in the first pass
2287 -- of resolution their components are not examined. If it turns out not
2288 -- to be an aggregate of booleans, this will be diagnosed in Resolve.
2289 -- Any_Composite must be checked for prior to the array type checks
2290 -- because Any_Composite does not have any associated indexes.
2292 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
2294 return Is_Boolean_Type
(T
)
2295 or else T
= Any_Composite
2296 or else (Is_Array_Type
(T
)
2297 and then T
/= Any_String
2298 and then Number_Dimensions
(T
) = 1
2299 and then Is_Boolean_Type
(Component_Type
(T
))
2300 and then (not Is_Private_Composite
(T
)
2301 or else In_Instance
)
2302 and then (not Is_Limited_Composite
(T
)
2303 or else In_Instance
))
2304 or else Is_Modular_Integer_Type
(T
)
2305 or else T
= Universal_Integer
;
2306 end Valid_Boolean_Arg
;
2308 --------------------------
2309 -- Valid_Comparison_Arg --
2310 --------------------------
2312 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
2315 if T
= Any_Composite
then
2317 elsif Is_Discrete_Type
(T
)
2318 or else Is_Real_Type
(T
)
2321 elsif Is_Array_Type
(T
)
2322 and then Number_Dimensions
(T
) = 1
2323 and then Is_Discrete_Type
(Component_Type
(T
))
2324 and then (not Is_Private_Composite
(T
)
2325 or else In_Instance
)
2326 and then (not Is_Limited_Composite
(T
)
2327 or else In_Instance
)
2330 elsif Is_String_Type
(T
) then
2335 end Valid_Comparison_Arg
;
2337 ---------------------
2338 -- Write_Overloads --
2339 ---------------------
2341 procedure Write_Overloads
(N
: Node_Id
) is
2347 if not Is_Overloaded
(N
) then
2348 Write_Str
("Non-overloaded entity ");
2350 Write_Entity_Info
(Entity
(N
), " ");
2353 Get_First_Interp
(N
, I
, It
);
2354 Write_Str
("Overloaded entity ");
2358 while Present
(Nam
) loop
2359 Write_Entity_Info
(Nam
, " ");
2360 Write_Str
("=================");
2362 Get_Next_Interp
(I
, It
);
2366 end Write_Overloads
;
2368 ----------------------
2369 -- Write_Interp_Ref --
2370 ----------------------
2372 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
2374 Write_Str
(" Node: ");
2375 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
2376 Write_Str
(" Index: ");
2377 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
2378 Write_Str
(" Next: ");
2379 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
2381 end Write_Interp_Ref
;