1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Elists
; use Elists
;
32 with Nlists
; use Nlists
;
33 with Errout
; use Errout
;
35 with Namet
; use Namet
;
37 with Output
; use Output
;
38 with Rtsfind
; use Rtsfind
;
40 with Sem_Ch6
; use Sem_Ch6
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Util
; use Sem_Util
;
43 with Stand
; use Stand
;
44 with Sinfo
; use Sinfo
;
45 with Snames
; use Snames
;
47 with Uintp
; use Uintp
;
49 package body Sem_Type
is
55 -- The following data structures establish a mapping between nodes and
56 -- their interpretations. An overloaded node has an entry in Interp_Map,
57 -- which in turn contains a pointer into the All_Interp array. The
58 -- interpretations of a given node are contiguous in All_Interp. Each
59 -- set of interpretations is terminated with the marker No_Interp.
60 -- In order to speed up the retrieval of the interpretations of an
61 -- overloaded node, the Interp_Map table is accessed by means of a simple
62 -- hashing scheme, and the entries in Interp_Map are chained. The heads
63 -- of clash lists are stored in array Headers.
65 -- Headers Interp_Map All_Interp
67 -- _ +-----+ +--------+
68 -- |_| |_____| --->|interp1 |
69 -- |_|---------->|node | | |interp2 |
70 -- |_| |index|---------| |nointerp|
75 -- This scheme does not currently reclaim interpretations. In principle,
76 -- after a unit is compiled, all overloadings have been resolved, and the
77 -- candidate interpretations should be deleted. This should be easier
78 -- now than with the previous scheme???
80 package All_Interp
is new Table
.Table
(
81 Table_Component_Type
=> Interp
,
82 Table_Index_Type
=> Int
,
84 Table_Initial
=> Alloc
.All_Interp_Initial
,
85 Table_Increment
=> Alloc
.All_Interp_Increment
,
86 Table_Name
=> "All_Interp");
88 type Interp_Ref
is record
94 Header_Size
: constant Int
:= 2 ** 12;
95 No_Entry
: constant Int
:= -1;
96 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
98 package Interp_Map
is new Table
.Table
(
99 Table_Component_Type
=> Interp_Ref
,
100 Table_Index_Type
=> Int
,
101 Table_Low_Bound
=> 0,
102 Table_Initial
=> Alloc
.Interp_Map_Initial
,
103 Table_Increment
=> Alloc
.Interp_Map_Increment
,
104 Table_Name
=> "Interp_Map");
106 function Hash
(N
: Node_Id
) return Int
;
107 -- A trivial hashing function for nodes, used to insert an overloaded
108 -- node into the Interp_Map table.
110 -------------------------------------
111 -- Handling of Overload Resolution --
112 -------------------------------------
114 -- Overload resolution uses two passes over the syntax tree of a complete
115 -- context. In the first, bottom-up pass, the types of actuals in calls
116 -- are used to resolve possibly overloaded subprogram and operator names.
117 -- In the second top-down pass, the type of the context (for example the
118 -- condition in a while statement) is used to resolve a possibly ambiguous
119 -- call, and the unique subprogram name in turn imposes a specific context
120 -- on each of its actuals.
122 -- Most expressions are in fact unambiguous, and the bottom-up pass is
123 -- sufficient to resolve most everything. To simplify the common case,
124 -- names and expressions carry a flag Is_Overloaded to indicate whether
125 -- they have more than one interpretation. If the flag is off, then each
126 -- name has already a unique meaning and type, and the bottom-up pass is
127 -- sufficient (and much simpler).
129 --------------------------
130 -- Operator Overloading --
131 --------------------------
133 -- The visibility of operators is handled differently from that of
134 -- other entities. We do not introduce explicit versions of primitive
135 -- operators for each type definition. As a result, there is only one
136 -- entity corresponding to predefined addition on all numeric types, etc.
137 -- The back-end resolves predefined operators according to their type.
138 -- The visibility of primitive operations then reduces to the visibility
139 -- of the resulting type: (a + b) is a legal interpretation of some
140 -- primitive operator + if the type of the result (which must also be
141 -- the type of a and b) is directly visible (i.e. either immediately
142 -- visible or use-visible.)
144 -- User-defined operators are treated like other functions, but the
145 -- visibility of these user-defined operations must be special-cased
146 -- to determine whether they hide or are hidden by predefined operators.
147 -- The form P."+" (x, y) requires additional handling.
149 -- Concatenation is treated more conventionally: for every one-dimensional
150 -- array type we introduce a explicit concatenation operator. This is
151 -- necessary to handle the case of (element & element => array) which
152 -- cannot be handled conveniently if there is no explicit instance of
153 -- resulting type of the operation.
155 -----------------------
156 -- Local Subprograms --
157 -----------------------
159 procedure All_Overloads
;
160 pragma Warnings
(Off
, All_Overloads
);
161 -- Debugging procedure: list full contents of Overloads table
163 procedure New_Interps
(N
: Node_Id
);
164 -- Initialize collection of interpretations for the given node, which is
165 -- either an overloaded entity, or an operation whose arguments have
166 -- multiple interpretations. Interpretations can be added to only one
169 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
170 -- If T1 and T2 are compatible, return the one that is not
171 -- universal or is not a "class" type (any_character, etc).
177 procedure Add_One_Interp
181 Opnd_Type
: Entity_Id
:= Empty
)
183 Vis_Type
: Entity_Id
;
185 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
186 -- Add one interpretation to node. Node is already known to be
187 -- overloaded. Add new interpretation if not hidden by previous
188 -- one, and remove previous one if hidden by new one.
190 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
191 -- True if the entity is a predefined operator and the operands have
192 -- a universal Interpretation.
198 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
199 Index
: Interp_Index
;
203 Get_First_Interp
(N
, Index
, It
);
204 while Present
(It
.Nam
) loop
206 -- A user-defined subprogram hides another declared at an outer
207 -- level, or one that is use-visible. So return if previous
208 -- definition hides new one (which is either in an outer
209 -- scope, or use-visible). Note that for functions use-visible
210 -- is the same as potentially use-visible. If new one hides
211 -- previous one, replace entry in table of interpretations.
212 -- If this is a universal operation, retain the operator in case
213 -- preference rule applies.
215 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
216 and then Ekind
(Name
) = Ekind
(It
.Nam
))
217 or else (Ekind
(Name
) = E_Operator
218 and then Ekind
(It
.Nam
) = E_Function
))
220 and then Is_Immediately_Visible
(It
.Nam
)
221 and then Type_Conformant
(Name
, It
.Nam
)
222 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
224 if Is_Universal_Operation
(Name
) then
227 -- If node is an operator symbol, we have no actuals with
228 -- which to check hiding, and this is done in full in the
229 -- caller (Analyze_Subprogram_Renaming) so we include the
230 -- predefined operator in any case.
232 elsif Nkind
(N
) = N_Operator_Symbol
233 or else (Nkind
(N
) = N_Expanded_Name
235 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
239 elsif not In_Open_Scopes
(Scope
(Name
))
240 or else Scope_Depth
(Scope
(Name
)) <=
241 Scope_Depth
(Scope
(It
.Nam
))
243 -- If ambiguity within instance, and entity is not an
244 -- implicit operation, save for later disambiguation.
246 if Scope
(Name
) = Scope
(It
.Nam
)
247 and then not Is_Inherited_Operation
(Name
)
256 All_Interp
.Table
(Index
).Nam
:= Name
;
260 -- Avoid making duplicate entries in overloads
263 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
267 -- Otherwise keep going
270 Get_Next_Interp
(Index
, It
);
275 -- On exit, enter new interpretation. The context, or a preference
276 -- rule, will resolve the ambiguity on the second pass.
278 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
279 All_Interp
.Increment_Last
;
280 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
283 ----------------------------
284 -- Is_Universal_Operation --
285 ----------------------------
287 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
291 if Ekind
(Op
) /= E_Operator
then
294 elsif Nkind
(N
) in N_Binary_Op
then
295 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
296 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
298 elsif Nkind
(N
) in N_Unary_Op
then
299 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
301 elsif Nkind
(N
) = N_Function_Call
then
302 Arg
:= First_Actual
(N
);
303 while Present
(Arg
) loop
304 if No
(Universal_Interpretation
(Arg
)) then
316 end Is_Universal_Operation
;
318 -- Start of processing for Add_One_Interp
321 -- If the interpretation is a predefined operator, verify that the
322 -- result type is visible, or that the entity has already been
323 -- resolved (case of an instantiation node that refers to a predefined
324 -- operation, or an internally generated operator node, or an operator
325 -- given as an expanded name). If the operator is a comparison or
326 -- equality, it is the type of the operand that matters to determine
327 -- whether the operator is visible. In an instance, the check is not
328 -- performed, given that the operator was visible in the generic.
330 if Ekind
(E
) = E_Operator
then
332 if Present
(Opnd_Type
) then
333 Vis_Type
:= Opnd_Type
;
335 Vis_Type
:= Base_Type
(T
);
338 if In_Open_Scopes
(Scope
(Vis_Type
))
339 or else Is_Potentially_Use_Visible
(Vis_Type
)
340 or else In_Use
(Vis_Type
)
341 or else (In_Use
(Scope
(Vis_Type
))
342 and then not Is_Hidden
(Vis_Type
))
343 or else Nkind
(N
) = N_Expanded_Name
344 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
349 -- If the node is given in functional notation and the prefix
350 -- is an expanded name, then the operator is visible if the
351 -- prefix is the scope of the result type as well. If the
352 -- operator is (implicitly) defined in an extension of system,
353 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
355 elsif Nkind
(N
) = N_Function_Call
356 and then Nkind
(Name
(N
)) = N_Expanded_Name
357 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
358 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
359 or else Scope
(Vis_Type
) = System_Aux_Id
)
363 -- Save type for subsequent error message, in case no other
364 -- interpretation is found.
367 Candidate_Type
:= Vis_Type
;
371 -- In an instance, an abstract non-dispatching operation cannot
372 -- be a candidate interpretation, because it could not have been
373 -- one in the generic (it may be a spurious overloading in the
377 and then Is_Abstract
(E
)
378 and then not Is_Dispatching_Operation
(E
)
382 -- An inherited interface operation that is implemented by some
383 -- derived type does not participate in overload resolution, only
384 -- the implementation operation does.
387 and then Is_Subprogram
(E
)
388 and then Present
(Abstract_Interface_Alias
(E
))
390 -- Ada 2005 (AI-251): If this primitive operation corresponds with
391 -- an inmediate ancestor interface there is no need to add it to the
392 -- list of interpretations; the corresponding aliased primitive is
393 -- also in this list of primitive operations and will be used instead
394 -- because otherwise we have a dummy between the two subprograms that
395 -- are in fact the same.
397 if Present
(DTC_Entity
(Abstract_Interface_Alias
(E
)))
398 and then Etype
(DTC_Entity
(Abstract_Interface_Alias
(E
)))
401 Add_One_Interp
(N
, Abstract_Interface_Alias
(E
), T
);
407 -- If this is the first interpretation of N, N has type Any_Type.
408 -- In that case place the new type on the node. If one interpretation
409 -- already exists, indicate that the node is overloaded, and store
410 -- both the previous and the new interpretation in All_Interp. If
411 -- this is a later interpretation, just add it to the set.
413 if Etype
(N
) = Any_Type
then
418 -- Record both the operator or subprogram name, and its type
420 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
427 -- Either there is no current interpretation in the table for any
428 -- node or the interpretation that is present is for a different
429 -- node. In both cases add a new interpretation to the table.
431 elsif Interp_Map
.Last
< 0
433 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
434 and then not Is_Overloaded
(N
))
438 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
439 and then Present
(Entity
(N
))
441 Add_Entry
(Entity
(N
), Etype
(N
));
443 elsif (Nkind
(N
) = N_Function_Call
444 or else Nkind
(N
) = N_Procedure_Call_Statement
)
445 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
446 or else Is_Entity_Name
(Name
(N
)))
448 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
451 -- Overloaded prefix in indexed or selected component,
452 -- or call whose name is an expression or another call.
454 Add_Entry
(Etype
(N
), Etype
(N
));
468 procedure All_Overloads
is
470 for J
in All_Interp
.First
.. All_Interp
.Last
loop
472 if Present
(All_Interp
.Table
(J
).Nam
) then
473 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
475 Write_Str
("No Interp");
478 Write_Str
("=================");
483 ---------------------
484 -- Collect_Interps --
485 ---------------------
487 procedure Collect_Interps
(N
: Node_Id
) is
488 Ent
: constant Entity_Id
:= Entity
(N
);
490 First_Interp
: Interp_Index
;
495 -- Unconditionally add the entity that was initially matched
497 First_Interp
:= All_Interp
.Last
;
498 Add_One_Interp
(N
, Ent
, Etype
(N
));
500 -- For expanded name, pick up all additional entities from the
501 -- same scope, since these are obviously also visible. Note that
502 -- these are not necessarily contiguous on the homonym chain.
504 if Nkind
(N
) = N_Expanded_Name
then
506 while Present
(H
) loop
507 if Scope
(H
) = Scope
(Entity
(N
)) then
508 Add_One_Interp
(N
, H
, Etype
(H
));
514 -- Case of direct name
517 -- First, search the homonym chain for directly visible entities
519 H
:= Current_Entity
(Ent
);
520 while Present
(H
) loop
521 exit when (not Is_Overloadable
(H
))
522 and then Is_Immediately_Visible
(H
);
524 if Is_Immediately_Visible
(H
)
527 -- Only add interpretation if not hidden by an inner
528 -- immediately visible one.
530 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
532 -- Current homograph is not hidden. Add to overloads
534 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
537 -- Homograph is hidden, unless it is a predefined operator
539 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
541 -- A homograph in the same scope can occur within an
542 -- instantiation, the resulting ambiguity has to be
545 if Scope
(H
) = Scope
(Ent
)
547 and then not Is_Inherited_Operation
(H
)
549 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
550 All_Interp
.Increment_Last
;
551 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
554 elsif Scope
(H
) /= Standard_Standard
then
560 -- On exit, we know that current homograph is not hidden
562 Add_One_Interp
(N
, H
, Etype
(H
));
565 Write_Str
("Add overloaded Interpretation ");
575 -- Scan list of homographs for use-visible entities only
577 H
:= Current_Entity
(Ent
);
579 while Present
(H
) loop
580 if Is_Potentially_Use_Visible
(H
)
582 and then Is_Overloadable
(H
)
584 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
586 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
589 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
590 goto Next_Use_Homograph
;
594 Add_One_Interp
(N
, H
, Etype
(H
));
597 <<Next_Use_Homograph
>>
602 if All_Interp
.Last
= First_Interp
+ 1 then
604 -- The original interpretation is in fact not overloaded
606 Set_Is_Overloaded
(N
, False);
614 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
619 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
620 -- In an instance the proper view may not always be correct for
621 -- private types, but private and full view are compatible. This
622 -- removes spurious errors from nested instantiations that involve,
623 -- among other things, types derived from private types.
625 ----------------------
626 -- Full_View_Covers --
627 ----------------------
629 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
632 Is_Private_Type
(Typ1
)
634 ((Present
(Full_View
(Typ1
))
635 and then Covers
(Full_View
(Typ1
), Typ2
))
636 or else Base_Type
(Typ1
) = Typ2
637 or else Base_Type
(Typ2
) = Typ1
);
638 end Full_View_Covers
;
640 -- Start of processing for Covers
643 -- If either operand missing, then this is an error, but ignore it (and
644 -- pretend we have a cover) if errors already detected, since this may
645 -- simply mean we have malformed trees.
647 if No
(T1
) or else No
(T2
) then
648 if Total_Errors_Detected
/= 0 then
655 BT1
:= Base_Type
(T1
);
656 BT2
:= Base_Type
(T2
);
659 -- Simplest case: same types are compatible, and types that have the
660 -- same base type and are not generic actuals are compatible. Generic
661 -- actuals belong to their class but are not compatible with other
662 -- types of their class, and in particular with other generic actuals.
663 -- They are however compatible with their own subtypes, and itypes
664 -- with the same base are compatible as well. Similarly, constrained
665 -- subtypes obtained from expressions of an unconstrained nominal type
666 -- are compatible with the base type (may lead to spurious ambiguities
667 -- in obscure cases ???)
669 -- Generic actuals require special treatment to avoid spurious ambi-
670 -- guities in an instance, when two formal types are instantiated with
671 -- the same actual, so that different subprograms end up with the same
672 -- signature in the instance.
681 if not Is_Generic_Actual_Type
(T1
) then
684 return (not Is_Generic_Actual_Type
(T2
)
685 or else Is_Itype
(T1
)
686 or else Is_Itype
(T2
)
687 or else Is_Constr_Subt_For_U_Nominal
(T1
)
688 or else Is_Constr_Subt_For_U_Nominal
(T2
)
689 or else Scope
(T1
) /= Scope
(T2
));
692 -- Literals are compatible with types in a given "class"
694 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
695 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
696 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
697 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
698 or else (T2
= Any_String
and then Is_String_Type
(T1
))
699 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
700 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
704 -- The context may be class wide
706 elsif Is_Class_Wide_Type
(T1
)
707 and then Is_Ancestor
(Root_Type
(T1
), T2
)
711 elsif Is_Class_Wide_Type
(T1
)
712 and then Is_Class_Wide_Type
(T2
)
713 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
717 -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
718 -- task_type or protected_type implementing T1
720 elsif Ada_Version
>= Ada_05
721 and then Is_Class_Wide_Type
(T1
)
722 and then Is_Interface
(Etype
(T1
))
723 and then Is_Concurrent_Type
(T2
)
724 and then Interface_Present_In_Ancestor
725 (Typ
=> Base_Type
(T2
),
730 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
731 -- object T2 implementing T1
733 elsif Ada_Version
>= Ada_05
734 and then Is_Class_Wide_Type
(T1
)
735 and then Is_Interface
(Etype
(T1
))
736 and then Is_Tagged_Type
(T2
)
738 if Interface_Present_In_Ancestor
(Typ
=> T2
,
743 elsif Present
(Abstract_Interfaces
(T2
)) then
745 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
746 -- covers an object T2 that implements a direct derivation of T1.
749 E
: Elmt_Id
:= First_Elmt
(Abstract_Interfaces
(T2
));
751 while Present
(E
) loop
752 if Is_Ancestor
(Etype
(T1
), Node
(E
)) then
760 -- We should also check the case in which T1 is an ancestor of
761 -- some implemented interface???
769 -- In a dispatching call the actual may be class-wide
771 elsif Is_Class_Wide_Type
(T2
)
772 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
776 -- Some contexts require a class of types rather than a specific type
778 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
779 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
780 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
781 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
782 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
786 -- An aggregate is compatible with an array or record type
788 elsif T2
= Any_Composite
789 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
793 -- If the expected type is an anonymous access, the designated type must
794 -- cover that of the expression.
796 elsif Ekind
(T1
) = E_Anonymous_Access_Type
797 and then Is_Access_Type
(T2
)
798 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
802 -- An Access_To_Subprogram is compatible with itself, or with an
803 -- anonymous type created for an attribute reference Access.
805 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
807 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
808 and then Is_Access_Type
(T2
)
809 and then (not Comes_From_Source
(T1
)
810 or else not Comes_From_Source
(T2
))
811 and then (Is_Overloadable
(Designated_Type
(T2
))
813 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
815 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
817 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
821 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
822 -- with itself, or with an anonymous type created for an attribute
825 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
828 = E_Anonymous_Access_Protected_Subprogram_Type
)
829 and then Is_Access_Type
(T2
)
830 and then (not Comes_From_Source
(T1
)
831 or else not Comes_From_Source
(T2
))
832 and then (Is_Overloadable
(Designated_Type
(T2
))
834 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
836 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
838 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
842 -- The context can be a remote access type, and the expression the
843 -- corresponding source type declared in a categorized package, or
846 elsif Is_Record_Type
(T1
)
847 and then (Is_Remote_Call_Interface
(T1
)
848 or else Is_Remote_Types
(T1
))
849 and then Present
(Corresponding_Remote_Type
(T1
))
851 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
853 elsif Is_Record_Type
(T2
)
854 and then (Is_Remote_Call_Interface
(T2
)
855 or else Is_Remote_Types
(T2
))
856 and then Present
(Corresponding_Remote_Type
(T2
))
858 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
860 elsif Ekind
(T2
) = E_Access_Attribute_Type
861 and then (Ekind
(BT1
) = E_General_Access_Type
862 or else Ekind
(BT1
) = E_Access_Type
)
863 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
865 -- If the target type is a RACW type while the source is an access
866 -- attribute type, we are building a RACW that may be exported.
868 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
869 Set_Has_RACW
(Current_Sem_Unit
);
874 elsif Ekind
(T2
) = E_Allocator_Type
875 and then Is_Access_Type
(T1
)
877 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
879 (From_With_Type
(Designated_Type
(T1
))
880 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
882 -- A boolean operation on integer literals is compatible with modular
885 elsif T2
= Any_Modular
886 and then Is_Modular_Integer_Type
(T1
)
890 -- The actual type may be the result of a previous error
892 elsif Base_Type
(T2
) = Any_Type
then
895 -- A packed array type covers its corresponding non-packed type. This is
896 -- not legitimate Ada, but allows the omission of a number of otherwise
897 -- useless unchecked conversions, and since this can only arise in
898 -- (known correct) expanded code, no harm is done
900 elsif Is_Array_Type
(T2
)
901 and then Is_Packed
(T2
)
902 and then T1
= Packed_Array_Type
(T2
)
906 -- Similarly an array type covers its corresponding packed array type
908 elsif Is_Array_Type
(T1
)
909 and then Is_Packed
(T1
)
910 and then T2
= Packed_Array_Type
(T1
)
914 -- In instances, or with types exported from instantiations, check
915 -- whether a partial and a full view match. Verify that types are
916 -- legal, to prevent cascaded errors.
920 (Full_View_Covers
(T1
, T2
)
921 or else Full_View_Covers
(T2
, T1
))
926 and then Is_Generic_Actual_Type
(T2
)
927 and then Full_View_Covers
(T1
, T2
)
932 and then Is_Generic_Actual_Type
(T1
)
933 and then Full_View_Covers
(T2
, T1
)
937 -- In the expansion of inlined bodies, types are compatible if they
938 -- are structurally equivalent.
940 elsif In_Inlined_Body
941 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
942 or else (Is_Access_Type
(T1
)
943 and then Is_Access_Type
(T2
)
945 Designated_Type
(T1
) = Designated_Type
(T2
))
946 or else (T1
= Any_Access
947 and then Is_Access_Type
(Underlying_Type
(T2
)))
948 or else (T2
= Any_Composite
950 Is_Composite_Type
(Underlying_Type
(T1
))))
954 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
955 -- compatible with its real entity.
957 elsif From_With_Type
(T1
) then
959 -- If the expected type is the non-limited view of a type, the
960 -- expression may have the limited view.
962 if Ekind
(T1
) = E_Incomplete_Type
then
963 return Covers
(Non_Limited_View
(T1
), T2
);
965 elsif Ekind
(T1
) = E_Class_Wide_Type
then
967 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
972 elsif From_With_Type
(T2
) then
974 -- If units in the context have Limited_With clauses on each other,
975 -- either type might have a limited view. Checks performed elsewhere
976 -- verify that the context type is the non-limited view.
978 if Ekind
(T2
) = E_Incomplete_Type
then
979 return Covers
(T1
, Non_Limited_View
(T2
));
981 elsif Ekind
(T2
) = E_Class_Wide_Type
then
983 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
988 -- Otherwise it doesn't cover!
999 function Disambiguate
1001 I1
, I2
: Interp_Index
;
1008 Nam1
, Nam2
: Entity_Id
;
1009 Predef_Subp
: Entity_Id
;
1010 User_Subp
: Entity_Id
;
1012 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1013 -- Determine whether one of the candidates is an operation inherited by
1014 -- a type that is derived from an actual in an instantiation.
1016 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean;
1017 -- Determine whether the expression is part of a generic actual. At
1018 -- the time the actual is resolved the scope is already that of the
1019 -- instance, but conceptually the resolution of the actual takes place
1020 -- in the enclosing context, and no special disambiguation rules should
1023 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1024 -- Determine whether a subprogram is an actual in an enclosing instance.
1025 -- An overloading between such a subprogram and one declared outside the
1026 -- instance is resolved in favor of the first, because it resolved in
1029 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1030 -- Look for exact type match in an instance, to remove spurious
1031 -- ambiguities when two formal types have the same actual.
1033 function Standard_Operator
return Boolean;
1034 -- Check whether subprogram is predefined operator declared in Standard.
1035 -- It may given by an operator name, or by an expanded name whose prefix
1038 function Remove_Conversions
return Interp
;
1039 -- Last chance for pathological cases involving comparisons on literals,
1040 -- and user overloadings of the same operator. Such pathologies have
1041 -- been removed from the ACVC, but still appear in two DEC tests, with
1042 -- the following notable quote from Ben Brosgol:
1044 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1045 -- this example; Robert Dewar brought it to our attention, since it is
1046 -- apparently found in the ACVC 1.5. I did not attempt to find the
1047 -- reason in the Reference Manual that makes the example legal, since I
1048 -- was too nauseated by it to want to pursue it further.]
1050 -- Accordingly, this is not a fully recursive solution, but it handles
1051 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1052 -- pathology in the other direction with calls whose multiple overloaded
1053 -- actuals make them truly unresolvable.
1055 -- The new rules concerning abstract operations create additional need
1056 -- for special handling of expressions with universal operands, see
1057 -- comments to Has_Abstract_Interpretation below.
1059 ------------------------
1060 -- In_Generic_Actual --
1061 ------------------------
1063 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
1064 Par
: constant Node_Id
:= Parent
(Exp
);
1070 elsif Nkind
(Par
) in N_Declaration
then
1071 if Nkind
(Par
) = N_Object_Declaration
1072 or else Nkind
(Par
) = N_Object_Renaming_Declaration
1074 return Present
(Corresponding_Generic_Association
(Par
));
1079 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
1083 return In_Generic_Actual
(Parent
(Par
));
1085 end In_Generic_Actual
;
1087 ---------------------------
1088 -- Inherited_From_Actual --
1089 ---------------------------
1091 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1092 Par
: constant Node_Id
:= Parent
(S
);
1094 if Nkind
(Par
) /= N_Full_Type_Declaration
1095 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1099 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1101 Is_Generic_Actual_Type
(
1102 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1104 end Inherited_From_Actual
;
1106 --------------------------
1107 -- Is_Actual_Subprogram --
1108 --------------------------
1110 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1112 return In_Open_Scopes
(Scope
(S
))
1114 (Is_Generic_Instance
(Scope
(S
))
1115 or else Is_Wrapper_Package
(Scope
(S
)));
1116 end Is_Actual_Subprogram
;
1122 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1123 T1
: constant Entity_Id
:= Etype
(Actual
);
1124 T2
: constant Entity_Id
:= Etype
(Formal
);
1128 (Is_Numeric_Type
(T2
)
1130 (T1
= Universal_Real
or else T1
= Universal_Integer
));
1133 ------------------------
1134 -- Remove_Conversions --
1135 ------------------------
1137 function Remove_Conversions
return Interp
is
1145 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1146 -- If an operation has universal operands the universal operation
1147 -- is present among its interpretations. If there is an abstract
1148 -- interpretation for the operator, with a numeric result, this
1149 -- interpretation was already removed in sem_ch4, but the universal
1150 -- one is still visible. We must rescan the list of operators and
1151 -- remove the universal interpretation to resolve the ambiguity.
1153 ---------------------------------
1154 -- Has_Abstract_Interpretation --
1155 ---------------------------------
1157 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1161 E
:= Current_Entity
(N
);
1162 while Present
(E
) loop
1164 and then Is_Numeric_Type
(Etype
(E
))
1173 end Has_Abstract_Interpretation
;
1175 -- Start of processing for Remove_Conversions
1180 Get_First_Interp
(N
, I
, It
);
1181 while Present
(It
.Typ
) loop
1182 if not Is_Overloadable
(It
.Nam
) then
1186 F1
:= First_Formal
(It
.Nam
);
1192 if Nkind
(N
) = N_Function_Call
1193 or else Nkind
(N
) = N_Procedure_Call_Statement
1195 Act1
:= First_Actual
(N
);
1197 if Present
(Act1
) then
1198 Act2
:= Next_Actual
(Act1
);
1203 elsif Nkind
(N
) in N_Unary_Op
then
1204 Act1
:= Right_Opnd
(N
);
1207 elsif Nkind
(N
) in N_Binary_Op
then
1208 Act1
:= Left_Opnd
(N
);
1209 Act2
:= Right_Opnd
(N
);
1215 if Nkind
(Act1
) in N_Op
1216 and then Is_Overloaded
(Act1
)
1217 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1218 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1219 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1220 and then Etype
(F1
) = Standard_Boolean
1222 -- If the two candidates are the original ones, the
1223 -- ambiguity is real. Otherwise keep the original, further
1224 -- calls to Disambiguate will take care of others in the
1225 -- list of candidates.
1227 if It1
/= No_Interp
then
1228 if It
= Disambiguate
.It1
1229 or else It
= Disambiguate
.It2
1231 if It1
= Disambiguate
.It1
1232 or else It1
= Disambiguate
.It2
1240 elsif Present
(Act2
)
1241 and then Nkind
(Act2
) in N_Op
1242 and then Is_Overloaded
(Act2
)
1243 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1245 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1246 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1248 -- The preference rule on the first actual is not
1249 -- sufficient to disambiguate.
1257 elsif Nkind
(Act1
) in N_Op
1258 and then Is_Overloaded
(Act1
)
1259 and then Present
(Universal_Interpretation
(Act1
))
1260 and then Is_Numeric_Type
(Etype
(F1
))
1261 and then Ada_Version
>= Ada_05
1262 and then Has_Abstract_Interpretation
(Act1
)
1264 if It
= Disambiguate
.It1
then
1265 return Disambiguate
.It2
;
1266 elsif It
= Disambiguate
.It2
then
1267 return Disambiguate
.It1
;
1273 Get_Next_Interp
(I
, It
);
1276 -- After some error, a formal may have Any_Type and yield a spurious
1277 -- match. To avoid cascaded errors if possible, check for such a
1278 -- formal in either candidate.
1280 if Serious_Errors_Detected
> 0 then
1285 Formal
:= First_Formal
(Nam1
);
1286 while Present
(Formal
) loop
1287 if Etype
(Formal
) = Any_Type
then
1288 return Disambiguate
.It2
;
1291 Next_Formal
(Formal
);
1294 Formal
:= First_Formal
(Nam2
);
1295 while Present
(Formal
) loop
1296 if Etype
(Formal
) = Any_Type
then
1297 return Disambiguate
.It1
;
1300 Next_Formal
(Formal
);
1306 end Remove_Conversions
;
1308 -----------------------
1309 -- Standard_Operator --
1310 -----------------------
1312 function Standard_Operator
return Boolean is
1316 if Nkind
(N
) in N_Op
then
1319 elsif Nkind
(N
) = N_Function_Call
then
1322 if Nkind
(Nam
) /= N_Expanded_Name
then
1325 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1330 end Standard_Operator
;
1332 -- Start of processing for Disambiguate
1335 -- Recover the two legal interpretations
1337 Get_First_Interp
(N
, I
, It
);
1339 Get_Next_Interp
(I
, It
);
1345 Get_Next_Interp
(I
, It
);
1351 if Ada_Version
< Ada_05
then
1353 -- Check whether one of the entities is an Ada 2005 entity and we are
1354 -- operating in an earlier mode, in which case we discard the Ada
1355 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1357 if Is_Ada_2005
(Nam1
) then
1359 elsif Is_Ada_2005
(Nam2
) then
1364 -- If the context is universal, the predefined operator is preferred.
1365 -- This includes bounds in numeric type declarations, and expressions
1366 -- in type conversions. If no interpretation yields a universal type,
1367 -- then we must check whether the user-defined entity hides the prede-
1370 if Chars
(Nam1
) in Any_Operator_Name
1371 and then Standard_Operator
1373 if Typ
= Universal_Integer
1374 or else Typ
= Universal_Real
1375 or else Typ
= Any_Integer
1376 or else Typ
= Any_Discrete
1377 or else Typ
= Any_Real
1378 or else Typ
= Any_Type
1380 -- Find an interpretation that yields the universal type, or else
1381 -- a predefined operator that yields a predefined numeric type.
1384 Candidate
: Interp
:= No_Interp
;
1387 Get_First_Interp
(N
, I
, It
);
1388 while Present
(It
.Typ
) loop
1389 if (Covers
(Typ
, It
.Typ
)
1390 or else Typ
= Any_Type
)
1392 (It
.Typ
= Universal_Integer
1393 or else It
.Typ
= Universal_Real
)
1397 elsif Covers
(Typ
, It
.Typ
)
1398 and then Scope
(It
.Typ
) = Standard_Standard
1399 and then Scope
(It
.Nam
) = Standard_Standard
1400 and then Is_Numeric_Type
(It
.Typ
)
1405 Get_Next_Interp
(I
, It
);
1408 if Candidate
/= No_Interp
then
1413 elsif Chars
(Nam1
) /= Name_Op_Not
1414 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1416 -- Equality or comparison operation. Choose predefined operator if
1417 -- arguments are universal. The node may be an operator, name, or
1418 -- a function call, so unpack arguments accordingly.
1421 Arg1
, Arg2
: Node_Id
;
1424 if Nkind
(N
) in N_Op
then
1425 Arg1
:= Left_Opnd
(N
);
1426 Arg2
:= Right_Opnd
(N
);
1428 elsif Is_Entity_Name
(N
)
1429 or else Nkind
(N
) = N_Operator_Symbol
1431 Arg1
:= First_Entity
(Entity
(N
));
1432 Arg2
:= Next_Entity
(Arg1
);
1435 Arg1
:= First_Actual
(N
);
1436 Arg2
:= Next_Actual
(Arg1
);
1440 and then Present
(Universal_Interpretation
(Arg1
))
1441 and then Universal_Interpretation
(Arg2
) =
1442 Universal_Interpretation
(Arg1
)
1444 Get_First_Interp
(N
, I
, It
);
1445 while Scope
(It
.Nam
) /= Standard_Standard
loop
1446 Get_Next_Interp
(I
, It
);
1455 -- If no universal interpretation, check whether user-defined operator
1456 -- hides predefined one, as well as other special cases. If the node
1457 -- is a range, then one or both bounds are ambiguous. Each will have
1458 -- to be disambiguated w.r.t. the context type. The type of the range
1459 -- itself is imposed by the context, so we can return either legal
1462 if Ekind
(Nam1
) = E_Operator
then
1463 Predef_Subp
:= Nam1
;
1466 elsif Ekind
(Nam2
) = E_Operator
then
1467 Predef_Subp
:= Nam2
;
1470 elsif Nkind
(N
) = N_Range
then
1473 -- If two user defined-subprograms are visible, it is a true ambiguity,
1474 -- unless one of them is an entry and the context is a conditional or
1475 -- timed entry call, or unless we are within an instance and this is
1476 -- results from two formals types with the same actual.
1479 if Nkind
(N
) = N_Procedure_Call_Statement
1480 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1481 and then N
= Entry_Call_Statement
(Parent
(N
))
1483 if Ekind
(Nam2
) = E_Entry
then
1485 elsif Ekind
(Nam1
) = E_Entry
then
1491 -- If the ambiguity occurs within an instance, it is due to several
1492 -- formal types with the same actual. Look for an exact match between
1493 -- the types of the formals of the overloadable entities, and the
1494 -- actuals in the call, to recover the unambiguous match in the
1495 -- original generic.
1497 -- The ambiguity can also be due to an overloading between a formal
1498 -- subprogram and a subprogram declared outside the generic. If the
1499 -- node is overloaded, it did not resolve to the global entity in
1500 -- the generic, and we choose the formal subprogram.
1502 -- Finally, the ambiguity can be between an explicit subprogram and
1503 -- one inherited (with different defaults) from an actual. In this
1504 -- case the resolution was to the explicit declaration in the
1505 -- generic, and remains so in the instance.
1508 and then not In_Generic_Actual
(N
)
1510 if Nkind
(N
) = N_Function_Call
1511 or else Nkind
(N
) = N_Procedure_Call_Statement
1516 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1517 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1520 if Is_Act1
and then not Is_Act2
then
1523 elsif Is_Act2
and then not Is_Act1
then
1526 elsif Inherited_From_Actual
(Nam1
)
1527 and then Comes_From_Source
(Nam2
)
1531 elsif Inherited_From_Actual
(Nam2
)
1532 and then Comes_From_Source
(Nam1
)
1537 Actual
:= First_Actual
(N
);
1538 Formal
:= First_Formal
(Nam1
);
1539 while Present
(Actual
) loop
1540 if Etype
(Actual
) /= Etype
(Formal
) then
1544 Next_Actual
(Actual
);
1545 Next_Formal
(Formal
);
1551 elsif Nkind
(N
) in N_Binary_Op
then
1552 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1554 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1561 elsif Nkind
(N
) in N_Unary_Op
then
1562 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1569 return Remove_Conversions
;
1572 return Remove_Conversions
;
1576 -- an implicit concatenation operator on a string type cannot be
1577 -- disambiguated from the predefined concatenation. This can only
1578 -- happen with concatenation of string literals.
1580 if Chars
(User_Subp
) = Name_Op_Concat
1581 and then Ekind
(User_Subp
) = E_Operator
1582 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1586 -- If the user-defined operator is in an open scope, or in the scope
1587 -- of the resulting type, or given by an expanded name that names its
1588 -- scope, it hides the predefined operator for the type. Exponentiation
1589 -- has to be special-cased because the implicit operator does not have
1590 -- a symmetric signature, and may not be hidden by the explicit one.
1592 elsif (Nkind
(N
) = N_Function_Call
1593 and then Nkind
(Name
(N
)) = N_Expanded_Name
1594 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1595 or else Hides_Op
(User_Subp
, Predef_Subp
))
1596 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1597 or else Hides_Op
(User_Subp
, Predef_Subp
)
1599 if It1
.Nam
= User_Subp
then
1605 -- Otherwise, the predefined operator has precedence, or if the user-
1606 -- defined operation is directly visible we have a true ambiguity. If
1607 -- this is a fixed-point multiplication and division in Ada83 mode,
1608 -- exclude the universal_fixed operator, which often causes ambiguities
1612 if (In_Open_Scopes
(Scope
(User_Subp
))
1613 or else Is_Potentially_Use_Visible
(User_Subp
))
1614 and then not In_Instance
1616 if Is_Fixed_Point_Type
(Typ
)
1617 and then (Chars
(Nam1
) = Name_Op_Multiply
1618 or else Chars
(Nam1
) = Name_Op_Divide
)
1619 and then Ada_Version
= Ada_83
1621 if It2
.Nam
= Predef_Subp
then
1627 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1628 -- states that the operator defined in Standard is not available
1629 -- if there is a user-defined equality with the proper signature,
1630 -- declared in the same declarative list as the type. The node
1631 -- may be an operator or a function call.
1633 elsif (Chars
(Nam1
) = Name_Op_Eq
1635 Chars
(Nam1
) = Name_Op_Ne
)
1636 and then Ada_Version
>= Ada_05
1637 and then Etype
(User_Subp
) = Standard_Boolean
1642 if Nkind
(N
) = N_Function_Call
then
1643 Opnd
:= First_Actual
(N
);
1645 Opnd
:= Left_Opnd
(N
);
1648 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1650 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1651 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1653 if It2
.Nam
= Predef_Subp
then
1667 elsif It1
.Nam
= Predef_Subp
then
1676 ---------------------
1677 -- End_Interp_List --
1678 ---------------------
1680 procedure End_Interp_List
is
1682 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1683 All_Interp
.Increment_Last
;
1684 end End_Interp_List
;
1686 -------------------------
1687 -- Entity_Matches_Spec --
1688 -------------------------
1690 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1692 -- Simple case: same entity kinds, type conformance is required. A
1693 -- parameterless function can also rename a literal.
1695 if Ekind
(Old_S
) = Ekind
(New_S
)
1696 or else (Ekind
(New_S
) = E_Function
1697 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1699 return Type_Conformant
(New_S
, Old_S
);
1701 elsif Ekind
(New_S
) = E_Function
1702 and then Ekind
(Old_S
) = E_Operator
1704 return Operator_Matches_Spec
(Old_S
, New_S
);
1706 elsif Ekind
(New_S
) = E_Procedure
1707 and then Is_Entry
(Old_S
)
1709 return Type_Conformant
(New_S
, Old_S
);
1714 end Entity_Matches_Spec
;
1716 ----------------------
1717 -- Find_Unique_Type --
1718 ----------------------
1720 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1721 T
: constant Entity_Id
:= Etype
(L
);
1724 TR
: Entity_Id
:= Any_Type
;
1727 if Is_Overloaded
(R
) then
1728 Get_First_Interp
(R
, I
, It
);
1729 while Present
(It
.Typ
) loop
1730 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1732 -- If several interpretations are possible and L is universal,
1733 -- apply preference rule.
1735 if TR
/= Any_Type
then
1737 if (T
= Universal_Integer
or else T
= Universal_Real
)
1748 Get_Next_Interp
(I
, It
);
1753 -- In the non-overloaded case, the Etype of R is already set correctly
1759 -- If one of the operands is Universal_Fixed, the type of the other
1760 -- operand provides the context.
1762 if Etype
(R
) = Universal_Fixed
then
1765 elsif T
= Universal_Fixed
then
1768 -- Ada 2005 (AI-230): Support the following operators:
1770 -- function "=" (L, R : universal_access) return Boolean;
1771 -- function "/=" (L, R : universal_access) return Boolean;
1773 -- Pool specific access types (E_Access_Type) are not covered by these
1774 -- operators because of the legality rule of 4.5.2(9.2): "The operands
1775 -- of the equality operators for universal_access shall be convertible
1776 -- to one another (see 4.6)". For example, considering the type decla-
1777 -- ration "type P is access Integer" and an anonymous access to Integer,
1778 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
1779 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
1781 elsif Ada_Version
>= Ada_05
1782 and then Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
1783 and then Is_Access_Type
(Etype
(R
))
1784 and then Ekind
(Etype
(R
)) /= E_Access_Type
1788 elsif Ada_Version
>= Ada_05
1789 and then Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
1790 and then Is_Access_Type
(Etype
(L
))
1791 and then Ekind
(Etype
(L
)) /= E_Access_Type
1796 return Specific_Type
(T
, Etype
(R
));
1799 end Find_Unique_Type
;
1801 ----------------------
1802 -- Get_First_Interp --
1803 ----------------------
1805 procedure Get_First_Interp
1807 I
: out Interp_Index
;
1811 Int_Ind
: Interp_Index
;
1815 -- If a selected component is overloaded because the selector has
1816 -- multiple interpretations, the node is a call to a protected
1817 -- operation or an indirect call. Retrieve the interpretation from
1818 -- the selector name. The selected component may be overloaded as well
1819 -- if the prefix is overloaded. That case is unchanged.
1821 if Nkind
(N
) = N_Selected_Component
1822 and then Is_Overloaded
(Selector_Name
(N
))
1824 O_N
:= Selector_Name
(N
);
1829 Map_Ptr
:= Headers
(Hash
(O_N
));
1830 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
1831 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
1832 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
1833 It
:= All_Interp
.Table
(Int_Ind
);
1837 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
1841 -- Procedure should never be called if the node has no interpretations
1843 raise Program_Error
;
1844 end Get_First_Interp
;
1846 ---------------------
1847 -- Get_Next_Interp --
1848 ---------------------
1850 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1853 It
:= All_Interp
.Table
(I
);
1854 end Get_Next_Interp
;
1856 -------------------------
1857 -- Has_Compatible_Type --
1858 -------------------------
1860 function Has_Compatible_Type
1873 if Nkind
(N
) = N_Subtype_Indication
1874 or else not Is_Overloaded
(N
)
1877 Covers
(Typ
, Etype
(N
))
1879 -- Ada 2005 (AI-345) The context may be a synchronized interface.
1880 -- If the type is already frozen use the corresponding_record
1881 -- to check whether it is a proper descendant.
1884 (Is_Concurrent_Type
(Etype
(N
))
1885 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
1886 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
1889 (not Is_Tagged_Type
(Typ
)
1890 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1891 and then Covers
(Etype
(N
), Typ
));
1894 Get_First_Interp
(N
, I
, It
);
1895 while Present
(It
.Typ
) loop
1896 if (Covers
(Typ
, It
.Typ
)
1898 (Scope
(It
.Nam
) /= Standard_Standard
1899 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
1901 -- Ada 2005 (AI-345)
1904 (Is_Concurrent_Type
(It
.Typ
)
1905 and then Present
(Corresponding_Record_Type
1907 and then Covers
(Typ
, Corresponding_Record_Type
1910 or else (not Is_Tagged_Type
(Typ
)
1911 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1912 and then Covers
(It
.Typ
, Typ
))
1917 Get_Next_Interp
(I
, It
);
1922 end Has_Compatible_Type
;
1928 function Hash
(N
: Node_Id
) return Int
is
1930 -- Nodes have a size that is power of two, so to select significant
1931 -- bits only we remove the low-order bits.
1933 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
1940 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
1941 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
1943 return Operator_Matches_Spec
(Op
, F
)
1944 and then (In_Open_Scopes
(Scope
(F
))
1945 or else Scope
(F
) = Scope
(Btyp
)
1946 or else (not In_Open_Scopes
(Scope
(Btyp
))
1947 and then not In_Use
(Btyp
)
1948 and then not In_Use
(Scope
(Btyp
))));
1951 ------------------------
1952 -- Init_Interp_Tables --
1953 ------------------------
1955 procedure Init_Interp_Tables
is
1959 Headers
:= (others => No_Entry
);
1960 end Init_Interp_Tables
;
1962 -----------------------------------
1963 -- Interface_Present_In_Ancestor --
1964 -----------------------------------
1966 function Interface_Present_In_Ancestor
1968 Iface
: Entity_Id
) return Boolean
1970 Target_Typ
: Entity_Id
;
1972 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
1973 -- Returns True if Typ or some ancestor of Typ implements Iface
1975 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
1985 -- Handle private types
1987 if Present
(Full_View
(Typ
))
1988 and then not Is_Concurrent_Type
(Full_View
(Typ
))
1990 E
:= Full_View
(Typ
);
1996 if Present
(Abstract_Interfaces
(E
))
1997 and then Present
(Abstract_Interfaces
(E
))
1998 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
))
2000 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
2001 while Present
(Elmt
) loop
2004 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
2012 exit when Etype
(E
) = E
2014 -- Handle private types
2016 or else (Present
(Full_View
(Etype
(E
)))
2017 and then Full_View
(Etype
(E
)) = E
);
2019 -- Check if the current type is a direct derivation of the
2022 if Etype
(E
) = Iface
then
2026 -- Climb to the immediate ancestor handling private types
2028 if Present
(Full_View
(Etype
(E
))) then
2029 E
:= Full_View
(Etype
(E
));
2036 end Iface_Present_In_Ancestor
;
2038 -- Start of processing for Interface_Present_In_Ancestor
2041 if Is_Access_Type
(Typ
) then
2042 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2047 -- In case of concurrent types we can't use the Corresponding Record_Typ
2048 -- to look for the interface because it is built by the expander (and
2049 -- hence it is not always available). For this reason we traverse the
2050 -- list of interfaces (available in the parent of the concurrent type)
2052 if Is_Concurrent_Type
(Target_Typ
) then
2053 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2058 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2059 while Present
(AI
) loop
2060 if Etype
(AI
) = Iface
then
2063 elsif Present
(Abstract_Interfaces
(Etype
(AI
)))
2064 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2077 if Is_Class_Wide_Type
(Target_Typ
) then
2078 Target_Typ
:= Etype
(Target_Typ
);
2081 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2082 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2083 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2085 -- Protect the frontend against previously detected errors
2087 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2092 return Iface_Present_In_Ancestor
(Target_Typ
);
2093 end Interface_Present_In_Ancestor
;
2095 ---------------------
2096 -- Intersect_Types --
2097 ---------------------
2099 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2100 Index
: Interp_Index
;
2104 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2105 -- Find interpretation of right arg that has type compatible with T
2107 --------------------------
2108 -- Check_Right_Argument --
2109 --------------------------
2111 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2112 Index
: Interp_Index
;
2117 if not Is_Overloaded
(R
) then
2118 return Specific_Type
(T
, Etype
(R
));
2121 Get_First_Interp
(R
, Index
, It
);
2123 T2
:= Specific_Type
(T
, It
.Typ
);
2125 if T2
/= Any_Type
then
2129 Get_Next_Interp
(Index
, It
);
2130 exit when No
(It
.Typ
);
2135 end Check_Right_Argument
;
2137 -- Start processing for Intersect_Types
2140 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2144 if not Is_Overloaded
(L
) then
2145 Typ
:= Check_Right_Argument
(Etype
(L
));
2149 Get_First_Interp
(L
, Index
, It
);
2150 while Present
(It
.Typ
) loop
2151 Typ
:= Check_Right_Argument
(It
.Typ
);
2152 exit when Typ
/= Any_Type
;
2153 Get_Next_Interp
(Index
, It
);
2158 -- If Typ is Any_Type, it means no compatible pair of types was found
2160 if Typ
= Any_Type
then
2161 if Nkind
(Parent
(L
)) in N_Op
then
2162 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2164 elsif Nkind
(Parent
(L
)) = N_Range
then
2165 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2167 -- Ada 2005 (AI-251): Complete the error notification
2169 elsif Is_Class_Wide_Type
(Etype
(R
))
2170 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2172 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2173 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2176 Error_Msg_N
("incompatible types", Parent
(L
));
2181 end Intersect_Types
;
2187 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2191 if Base_Type
(T1
) = Base_Type
(T2
) then
2194 elsif Is_Private_Type
(T1
)
2195 and then Present
(Full_View
(T1
))
2196 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
2204 -- If there was a error on the type declaration, do not recurse
2206 if Error_Posted
(Par
) then
2209 elsif Base_Type
(T1
) = Base_Type
(Par
)
2210 or else (Is_Private_Type
(T1
)
2211 and then Present
(Full_View
(T1
))
2212 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2216 elsif Is_Private_Type
(Par
)
2217 and then Present
(Full_View
(Par
))
2218 and then Full_View
(Par
) = Base_Type
(T1
)
2222 elsif Etype
(Par
) /= Par
then
2231 ---------------------------
2232 -- Is_Invisible_Operator --
2233 ---------------------------
2235 function Is_Invisible_Operator
2240 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2243 if Nkind
(N
) not in N_Op
then
2246 elsif not Comes_From_Source
(N
) then
2249 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2252 elsif Nkind
(N
) in N_Binary_Op
2253 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2259 and then not In_Open_Scopes
(Scope
(T
))
2260 and then not Is_Potentially_Use_Visible
(T
)
2261 and then not In_Use
(T
)
2262 and then not In_Use
(Scope
(T
))
2264 (Nkind
(Orig_Node
) /= N_Function_Call
2265 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2266 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2268 and then not In_Instance
;
2270 end Is_Invisible_Operator
;
2276 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2280 S
:= Ancestor_Subtype
(T1
);
2281 while Present
(S
) loop
2285 S
:= Ancestor_Subtype
(S
);
2296 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2297 Index
: Interp_Index
;
2301 Get_First_Interp
(Nam
, Index
, It
);
2302 while Present
(It
.Nam
) loop
2303 if Scope
(It
.Nam
) = Standard_Standard
2304 and then Scope
(It
.Typ
) /= Standard_Standard
2306 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2307 Error_Msg_NE
(" & (inherited) declared#!", Err
, It
.Nam
);
2310 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2311 Error_Msg_NE
(" & declared#!", Err
, It
.Nam
);
2314 Get_Next_Interp
(Index
, It
);
2322 procedure New_Interps
(N
: Node_Id
) is
2326 All_Interp
.Increment_Last
;
2327 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
2329 Map_Ptr
:= Headers
(Hash
(N
));
2331 if Map_Ptr
= No_Entry
then
2333 -- Place new node at end of table
2335 Interp_Map
.Increment_Last
;
2336 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2339 -- Place node at end of chain, or locate its previous entry
2342 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2344 -- Node is already in the table, and is being rewritten.
2345 -- Start a new interp section, retain hash link.
2347 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2348 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2349 Set_Is_Overloaded
(N
, True);
2353 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2354 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2358 -- Chain the new node
2360 Interp_Map
.Increment_Last
;
2361 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2364 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2365 Set_Is_Overloaded
(N
, True);
2368 ---------------------------
2369 -- Operator_Matches_Spec --
2370 ---------------------------
2372 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2373 Op_Name
: constant Name_Id
:= Chars
(Op
);
2374 T
: constant Entity_Id
:= Etype
(New_S
);
2382 -- To verify that a predefined operator matches a given signature,
2383 -- do a case analysis of the operator classes. Function can have one
2384 -- or two formals and must have the proper result type.
2386 New_F
:= First_Formal
(New_S
);
2387 Old_F
:= First_Formal
(Op
);
2389 while Present
(New_F
) and then Present
(Old_F
) loop
2391 Next_Formal
(New_F
);
2392 Next_Formal
(Old_F
);
2395 -- Definite mismatch if different number of parameters
2397 if Present
(Old_F
) or else Present
(New_F
) then
2403 T1
:= Etype
(First_Formal
(New_S
));
2405 if Op_Name
= Name_Op_Subtract
2406 or else Op_Name
= Name_Op_Add
2407 or else Op_Name
= Name_Op_Abs
2409 return Base_Type
(T1
) = Base_Type
(T
)
2410 and then Is_Numeric_Type
(T
);
2412 elsif Op_Name
= Name_Op_Not
then
2413 return Base_Type
(T1
) = Base_Type
(T
)
2414 and then Valid_Boolean_Arg
(Base_Type
(T
));
2423 T1
:= Etype
(First_Formal
(New_S
));
2424 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2426 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2427 or else Op_Name
= Name_Op_Xor
2429 return Base_Type
(T1
) = Base_Type
(T2
)
2430 and then Base_Type
(T1
) = Base_Type
(T
)
2431 and then Valid_Boolean_Arg
(Base_Type
(T
));
2433 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2434 return Base_Type
(T1
) = Base_Type
(T2
)
2435 and then not Is_Limited_Type
(T1
)
2436 and then Is_Boolean_Type
(T
);
2438 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2439 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2441 return Base_Type
(T1
) = Base_Type
(T2
)
2442 and then Valid_Comparison_Arg
(T1
)
2443 and then Is_Boolean_Type
(T
);
2445 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2446 return Base_Type
(T1
) = Base_Type
(T2
)
2447 and then Base_Type
(T1
) = Base_Type
(T
)
2448 and then Is_Numeric_Type
(T
);
2450 -- for division and multiplication, a user-defined function does
2451 -- not match the predefined universal_fixed operation, except in
2454 elsif Op_Name
= Name_Op_Divide
then
2455 return (Base_Type
(T1
) = Base_Type
(T2
)
2456 and then Base_Type
(T1
) = Base_Type
(T
)
2457 and then Is_Numeric_Type
(T
)
2458 and then (not Is_Fixed_Point_Type
(T
)
2459 or else Ada_Version
= Ada_83
))
2461 -- Mixed_Mode operations on fixed-point types
2463 or else (Base_Type
(T1
) = Base_Type
(T
)
2464 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2465 and then Is_Fixed_Point_Type
(T
))
2467 -- A user defined operator can also match (and hide) a mixed
2468 -- operation on universal literals.
2470 or else (Is_Integer_Type
(T2
)
2471 and then Is_Floating_Point_Type
(T1
)
2472 and then Base_Type
(T1
) = Base_Type
(T
));
2474 elsif Op_Name
= Name_Op_Multiply
then
2475 return (Base_Type
(T1
) = Base_Type
(T2
)
2476 and then Base_Type
(T1
) = Base_Type
(T
)
2477 and then Is_Numeric_Type
(T
)
2478 and then (not Is_Fixed_Point_Type
(T
)
2479 or else Ada_Version
= Ada_83
))
2481 -- Mixed_Mode operations on fixed-point types
2483 or else (Base_Type
(T1
) = Base_Type
(T
)
2484 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2485 and then Is_Fixed_Point_Type
(T
))
2487 or else (Base_Type
(T2
) = Base_Type
(T
)
2488 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2489 and then Is_Fixed_Point_Type
(T
))
2491 or else (Is_Integer_Type
(T2
)
2492 and then Is_Floating_Point_Type
(T1
)
2493 and then Base_Type
(T1
) = Base_Type
(T
))
2495 or else (Is_Integer_Type
(T1
)
2496 and then Is_Floating_Point_Type
(T2
)
2497 and then Base_Type
(T2
) = Base_Type
(T
));
2499 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2500 return Base_Type
(T1
) = Base_Type
(T2
)
2501 and then Base_Type
(T1
) = Base_Type
(T
)
2502 and then Is_Integer_Type
(T
);
2504 elsif Op_Name
= Name_Op_Expon
then
2505 return Base_Type
(T1
) = Base_Type
(T
)
2506 and then Is_Numeric_Type
(T
)
2507 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2509 elsif Op_Name
= Name_Op_Concat
then
2510 return Is_Array_Type
(T
)
2511 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2512 and then (Base_Type
(T1
) = Base_Type
(T
)
2514 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2515 and then (Base_Type
(T2
) = Base_Type
(T
)
2517 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2523 end Operator_Matches_Spec
;
2529 procedure Remove_Interp
(I
: in out Interp_Index
) is
2533 -- Find end of Interp list and copy downward to erase the discarded one
2536 while Present
(All_Interp
.Table
(II
).Typ
) loop
2540 for J
in I
+ 1 .. II
loop
2541 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2544 -- Back up interp. index to insure that iterator will pick up next
2545 -- available interpretation.
2554 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2556 O_N
: Node_Id
:= Old_N
;
2559 if Is_Overloaded
(Old_N
) then
2560 if Nkind
(Old_N
) = N_Selected_Component
2561 and then Is_Overloaded
(Selector_Name
(Old_N
))
2563 O_N
:= Selector_Name
(Old_N
);
2566 Map_Ptr
:= Headers
(Hash
(O_N
));
2568 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2569 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2570 pragma Assert
(Map_Ptr
/= No_Entry
);
2573 New_Interps
(New_N
);
2574 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2575 Interp_Map
.Table
(Map_Ptr
).Index
;
2583 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
2584 B1
: constant Entity_Id
:= Base_Type
(T1
);
2585 B2
: constant Entity_Id
:= Base_Type
(T2
);
2587 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2588 -- Check whether T is the equivalent type of a remote access type.
2589 -- If distribution is enabled, T is a legal context for Null.
2591 ----------------------
2592 -- Is_Remote_Access --
2593 ----------------------
2595 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2597 return Is_Record_Type
(T
)
2598 and then (Is_Remote_Call_Interface
(T
)
2599 or else Is_Remote_Types
(T
))
2600 and then Present
(Corresponding_Remote_Type
(T
))
2601 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2602 end Is_Remote_Access
;
2604 -- Start of processing for Specific_Type
2607 if T1
= Any_Type
or else T2
= Any_Type
then
2615 or else (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2616 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2617 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2618 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2623 or else (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2624 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2625 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2626 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2630 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2633 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2636 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2639 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
2642 elsif T1
= Any_Access
2643 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
2647 elsif T2
= Any_Access
2648 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
2652 elsif T2
= Any_Composite
2653 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
2657 elsif T1
= Any_Composite
2658 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
2662 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
2665 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
2668 -- ----------------------------------------------------------
2669 -- Special cases for equality operators (all other predefined
2670 -- operators can never apply to tagged types)
2671 -- ----------------------------------------------------------
2673 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
2676 elsif Is_Class_Wide_Type
(T1
)
2677 and then Is_Class_Wide_Type
(T2
)
2678 and then Is_Interface
(Etype
(T2
))
2682 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
2683 -- class-wide interface T2
2685 elsif Is_Class_Wide_Type
(T2
)
2686 and then Is_Interface
(Etype
(T2
))
2687 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
2688 Iface
=> Etype
(T2
))
2692 elsif Is_Class_Wide_Type
(T1
)
2693 and then Is_Ancestor
(Root_Type
(T1
), T2
)
2697 elsif Is_Class_Wide_Type
(T2
)
2698 and then Is_Ancestor
(Root_Type
(T2
), T1
)
2702 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
2704 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
2705 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
2706 and then Is_Access_Type
(T2
)
2710 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
2712 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
2713 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
2714 and then Is_Access_Type
(T1
)
2718 elsif (Ekind
(T1
) = E_Allocator_Type
2719 or else Ekind
(T1
) = E_Access_Attribute_Type
2720 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
2721 and then Is_Access_Type
(T2
)
2725 elsif (Ekind
(T2
) = E_Allocator_Type
2726 or else Ekind
(T2
) = E_Access_Attribute_Type
2727 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
2728 and then Is_Access_Type
(T1
)
2732 -- If none of the above cases applies, types are not compatible
2739 -----------------------
2740 -- Valid_Boolean_Arg --
2741 -----------------------
2743 -- In addition to booleans and arrays of booleans, we must include
2744 -- aggregates as valid boolean arguments, because in the first pass of
2745 -- resolution their components are not examined. If it turns out not to be
2746 -- an aggregate of booleans, this will be diagnosed in Resolve.
2747 -- Any_Composite must be checked for prior to the array type checks because
2748 -- Any_Composite does not have any associated indexes.
2750 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
2752 return Is_Boolean_Type
(T
)
2753 or else T
= Any_Composite
2754 or else (Is_Array_Type
(T
)
2755 and then T
/= Any_String
2756 and then Number_Dimensions
(T
) = 1
2757 and then Is_Boolean_Type
(Component_Type
(T
))
2758 and then (not Is_Private_Composite
(T
)
2759 or else In_Instance
)
2760 and then (not Is_Limited_Composite
(T
)
2761 or else In_Instance
))
2762 or else Is_Modular_Integer_Type
(T
)
2763 or else T
= Universal_Integer
;
2764 end Valid_Boolean_Arg
;
2766 --------------------------
2767 -- Valid_Comparison_Arg --
2768 --------------------------
2770 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
2773 if T
= Any_Composite
then
2775 elsif Is_Discrete_Type
(T
)
2776 or else Is_Real_Type
(T
)
2779 elsif Is_Array_Type
(T
)
2780 and then Number_Dimensions
(T
) = 1
2781 and then Is_Discrete_Type
(Component_Type
(T
))
2782 and then (not Is_Private_Composite
(T
)
2783 or else In_Instance
)
2784 and then (not Is_Limited_Composite
(T
)
2785 or else In_Instance
)
2788 elsif Is_String_Type
(T
) then
2793 end Valid_Comparison_Arg
;
2795 ---------------------
2796 -- Write_Overloads --
2797 ---------------------
2799 procedure Write_Overloads
(N
: Node_Id
) is
2805 if not Is_Overloaded
(N
) then
2806 Write_Str
("Non-overloaded entity ");
2808 Write_Entity_Info
(Entity
(N
), " ");
2811 Get_First_Interp
(N
, I
, It
);
2812 Write_Str
("Overloaded entity ");
2814 Write_Str
(" Name Type");
2816 Write_Str
("===============================");
2820 while Present
(Nam
) loop
2821 Write_Int
(Int
(Nam
));
2823 Write_Name
(Chars
(Nam
));
2825 Write_Int
(Int
(It
.Typ
));
2827 Write_Name
(Chars
(It
.Typ
));
2829 Get_Next_Interp
(I
, It
);
2833 end Write_Overloads
;
2835 ----------------------
2836 -- Write_Interp_Ref --
2837 ----------------------
2839 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
2841 Write_Str
(" Node: ");
2842 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
2843 Write_Str
(" Index: ");
2844 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
2845 Write_Str
(" Next: ");
2846 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
2848 end Write_Interp_Ref
;