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
;
39 with Sem_Ch6
; use Sem_Ch6
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Ch12
; use Sem_Ch12
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Util
; use Sem_Util
;
44 with Stand
; use Stand
;
45 with Sinfo
; use Sinfo
;
46 with Snames
; use Snames
;
48 with Uintp
; use Uintp
;
50 package body Sem_Type
is
56 -- The following data structures establish a mapping between nodes and
57 -- their interpretations. An overloaded node has an entry in Interp_Map,
58 -- which in turn contains a pointer into the All_Interp array. The
59 -- interpretations of a given node are contiguous in All_Interp. Each
60 -- set of interpretations is terminated with the marker No_Interp.
61 -- In order to speed up the retrieval of the interpretations of an
62 -- overloaded node, the Interp_Map table is accessed by means of a simple
63 -- hashing scheme, and the entries in Interp_Map are chained. The heads
64 -- of clash lists are stored in array Headers.
66 -- Headers Interp_Map All_Interp
68 -- _ +-----+ +--------+
69 -- |_| |_____| --->|interp1 |
70 -- |_|---------->|node | | |interp2 |
71 -- |_| |index|---------| |nointerp|
76 -- This scheme does not currently reclaim interpretations. In principle,
77 -- after a unit is compiled, all overloadings have been resolved, and the
78 -- candidate interpretations should be deleted. This should be easier
79 -- now than with the previous scheme???
81 package All_Interp
is new Table
.Table
(
82 Table_Component_Type
=> Interp
,
83 Table_Index_Type
=> Int
,
85 Table_Initial
=> Alloc
.All_Interp_Initial
,
86 Table_Increment
=> Alloc
.All_Interp_Increment
,
87 Table_Name
=> "All_Interp");
89 type Interp_Ref
is record
95 Header_Size
: constant Int
:= 2 ** 12;
96 No_Entry
: constant Int
:= -1;
97 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
99 package Interp_Map
is new Table
.Table
(
100 Table_Component_Type
=> Interp_Ref
,
101 Table_Index_Type
=> Int
,
102 Table_Low_Bound
=> 0,
103 Table_Initial
=> Alloc
.Interp_Map_Initial
,
104 Table_Increment
=> Alloc
.Interp_Map_Increment
,
105 Table_Name
=> "Interp_Map");
107 function Hash
(N
: Node_Id
) return Int
;
108 -- A trivial hashing function for nodes, used to insert an overloaded
109 -- node into the Interp_Map table.
111 -------------------------------------
112 -- Handling of Overload Resolution --
113 -------------------------------------
115 -- Overload resolution uses two passes over the syntax tree of a complete
116 -- context. In the first, bottom-up pass, the types of actuals in calls
117 -- are used to resolve possibly overloaded subprogram and operator names.
118 -- In the second top-down pass, the type of the context (for example the
119 -- condition in a while statement) is used to resolve a possibly ambiguous
120 -- call, and the unique subprogram name in turn imposes a specific context
121 -- on each of its actuals.
123 -- Most expressions are in fact unambiguous, and the bottom-up pass is
124 -- sufficient to resolve most everything. To simplify the common case,
125 -- names and expressions carry a flag Is_Overloaded to indicate whether
126 -- they have more than one interpretation. If the flag is off, then each
127 -- name has already a unique meaning and type, and the bottom-up pass is
128 -- sufficient (and much simpler).
130 --------------------------
131 -- Operator Overloading --
132 --------------------------
134 -- The visibility of operators is handled differently from that of
135 -- other entities. We do not introduce explicit versions of primitive
136 -- operators for each type definition. As a result, there is only one
137 -- entity corresponding to predefined addition on all numeric types, etc.
138 -- The back-end resolves predefined operators according to their type.
139 -- The visibility of primitive operations then reduces to the visibility
140 -- of the resulting type: (a + b) is a legal interpretation of some
141 -- primitive operator + if the type of the result (which must also be
142 -- the type of a and b) is directly visible (i.e. either immediately
143 -- visible or use-visible.)
145 -- User-defined operators are treated like other functions, but the
146 -- visibility of these user-defined operations must be special-cased
147 -- to determine whether they hide or are hidden by predefined operators.
148 -- The form P."+" (x, y) requires additional handling.
150 -- Concatenation is treated more conventionally: for every one-dimensional
151 -- array type we introduce a explicit concatenation operator. This is
152 -- necessary to handle the case of (element & element => array) which
153 -- cannot be handled conveniently if there is no explicit instance of
154 -- resulting type of the operation.
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure All_Overloads
;
161 pragma Warnings
(Off
, All_Overloads
);
162 -- Debugging procedure: list full contents of Overloads table
164 procedure New_Interps
(N
: Node_Id
);
165 -- Initialize collection of interpretations for the given node, which is
166 -- either an overloaded entity, or an operation whose arguments have
167 -- multiple interpretations. Interpretations can be added to only one
170 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
171 -- If T1 and T2 are compatible, return the one that is not
172 -- universal or is not a "class" type (any_character, etc).
178 procedure Add_One_Interp
182 Opnd_Type
: Entity_Id
:= Empty
)
184 Vis_Type
: Entity_Id
;
186 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
187 -- Add one interpretation to node. Node is already known to be
188 -- overloaded. Add new interpretation if not hidden by previous
189 -- one, and remove previous one if hidden by new one.
191 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
192 -- True if the entity is a predefined operator and the operands have
193 -- a universal Interpretation.
199 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
200 Index
: Interp_Index
;
204 Get_First_Interp
(N
, Index
, It
);
205 while Present
(It
.Nam
) loop
207 -- A user-defined subprogram hides another declared at an outer
208 -- level, or one that is use-visible. So return if previous
209 -- definition hides new one (which is either in an outer
210 -- scope, or use-visible). Note that for functions use-visible
211 -- is the same as potentially use-visible. If new one hides
212 -- previous one, replace entry in table of interpretations.
213 -- If this is a universal operation, retain the operator in case
214 -- preference rule applies.
216 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
217 and then Ekind
(Name
) = Ekind
(It
.Nam
))
218 or else (Ekind
(Name
) = E_Operator
219 and then Ekind
(It
.Nam
) = E_Function
))
221 and then Is_Immediately_Visible
(It
.Nam
)
222 and then Type_Conformant
(Name
, It
.Nam
)
223 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
225 if Is_Universal_Operation
(Name
) then
228 -- If node is an operator symbol, we have no actuals with
229 -- which to check hiding, and this is done in full in the
230 -- caller (Analyze_Subprogram_Renaming) so we include the
231 -- predefined operator in any case.
233 elsif Nkind
(N
) = N_Operator_Symbol
234 or else (Nkind
(N
) = N_Expanded_Name
236 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
240 elsif not In_Open_Scopes
(Scope
(Name
))
241 or else Scope_Depth
(Scope
(Name
)) <=
242 Scope_Depth
(Scope
(It
.Nam
))
244 -- If ambiguity within instance, and entity is not an
245 -- implicit operation, save for later disambiguation.
247 if Scope
(Name
) = Scope
(It
.Nam
)
248 and then not Is_Inherited_Operation
(Name
)
257 All_Interp
.Table
(Index
).Nam
:= Name
;
261 -- Avoid making duplicate entries in overloads
264 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
268 -- Otherwise keep going
271 Get_Next_Interp
(Index
, It
);
276 -- On exit, enter new interpretation. The context, or a preference
277 -- rule, will resolve the ambiguity on the second pass.
279 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
280 All_Interp
.Increment_Last
;
281 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
284 ----------------------------
285 -- Is_Universal_Operation --
286 ----------------------------
288 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
292 if Ekind
(Op
) /= E_Operator
then
295 elsif Nkind
(N
) in N_Binary_Op
then
296 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
297 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
299 elsif Nkind
(N
) in N_Unary_Op
then
300 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
302 elsif Nkind
(N
) = N_Function_Call
then
303 Arg
:= First_Actual
(N
);
304 while Present
(Arg
) loop
305 if No
(Universal_Interpretation
(Arg
)) then
317 end Is_Universal_Operation
;
319 -- Start of processing for Add_One_Interp
322 -- If the interpretation is a predefined operator, verify that the
323 -- result type is visible, or that the entity has already been
324 -- resolved (case of an instantiation node that refers to a predefined
325 -- operation, or an internally generated operator node, or an operator
326 -- given as an expanded name). If the operator is a comparison or
327 -- equality, it is the type of the operand that matters to determine
328 -- whether the operator is visible. In an instance, the check is not
329 -- performed, given that the operator was visible in the generic.
331 if Ekind
(E
) = E_Operator
then
333 if Present
(Opnd_Type
) then
334 Vis_Type
:= Opnd_Type
;
336 Vis_Type
:= Base_Type
(T
);
339 if In_Open_Scopes
(Scope
(Vis_Type
))
340 or else Is_Potentially_Use_Visible
(Vis_Type
)
341 or else In_Use
(Vis_Type
)
342 or else (In_Use
(Scope
(Vis_Type
))
343 and then not Is_Hidden
(Vis_Type
))
344 or else Nkind
(N
) = N_Expanded_Name
345 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
350 -- If the node is given in functional notation and the prefix
351 -- is an expanded name, then the operator is visible if the
352 -- prefix is the scope of the result type as well. If the
353 -- operator is (implicitly) defined in an extension of system,
354 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
356 elsif Nkind
(N
) = N_Function_Call
357 and then Nkind
(Name
(N
)) = N_Expanded_Name
358 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
359 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
360 or else Scope
(Vis_Type
) = System_Aux_Id
)
364 -- Save type for subsequent error message, in case no other
365 -- interpretation is found.
368 Candidate_Type
:= Vis_Type
;
372 -- In an instance, an abstract non-dispatching operation cannot
373 -- be a candidate interpretation, because it could not have been
374 -- one in the generic (it may be a spurious overloading in the
378 and then Is_Abstract
(E
)
379 and then not Is_Dispatching_Operation
(E
)
383 -- An inherited interface operation that is implemented by some
384 -- derived type does not participate in overload resolution, only
385 -- the implementation operation does.
388 and then Is_Subprogram
(E
)
389 and then Present
(Abstract_Interface_Alias
(E
))
391 -- Ada 2005 (AI-251): If this primitive operation corresponds with
392 -- an inmediate ancestor interface there is no need to add it to the
393 -- list of interpretations; the corresponding aliased primitive is
394 -- also in this list of primitive operations and will be used instead
395 -- because otherwise we have a dummy between the two subprograms that
396 -- are in fact the same.
399 (Find_Dispatching_Type
(Abstract_Interface_Alias
(E
)),
400 Find_Dispatching_Type
(E
))
402 Add_One_Interp
(N
, Abstract_Interface_Alias
(E
), T
);
408 -- If this is the first interpretation of N, N has type Any_Type.
409 -- In that case place the new type on the node. If one interpretation
410 -- already exists, indicate that the node is overloaded, and store
411 -- both the previous and the new interpretation in All_Interp. If
412 -- this is a later interpretation, just add it to the set.
414 if Etype
(N
) = Any_Type
then
419 -- Record both the operator or subprogram name, and its type
421 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
428 -- Either there is no current interpretation in the table for any
429 -- node or the interpretation that is present is for a different
430 -- node. In both cases add a new interpretation to the table.
432 elsif Interp_Map
.Last
< 0
434 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
435 and then not Is_Overloaded
(N
))
439 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
440 and then Present
(Entity
(N
))
442 Add_Entry
(Entity
(N
), Etype
(N
));
444 elsif (Nkind
(N
) = N_Function_Call
445 or else Nkind
(N
) = N_Procedure_Call_Statement
)
446 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
447 or else Is_Entity_Name
(Name
(N
)))
449 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
451 -- If this is an indirect call there will be no name associated
452 -- with the previous entry. To make diagnostics clearer, save
453 -- Subprogram_Type of first interpretation, so that the error will
454 -- point to the anonymous access to subprogram, not to the result
455 -- type of the call itself.
457 elsif (Nkind
(N
)) = N_Function_Call
458 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
459 and then Is_Overloaded
(Name
(N
))
465 Get_First_Interp
(Name
(N
), I
, It
);
466 Add_Entry
(It
.Nam
, Etype
(N
));
470 -- Overloaded prefix in indexed or selected component,
471 -- or call whose name is an expression or another call.
473 Add_Entry
(Etype
(N
), Etype
(N
));
487 procedure All_Overloads
is
489 for J
in All_Interp
.First
.. All_Interp
.Last
loop
491 if Present
(All_Interp
.Table
(J
).Nam
) then
492 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
494 Write_Str
("No Interp");
497 Write_Str
("=================");
502 ---------------------
503 -- Collect_Interps --
504 ---------------------
506 procedure Collect_Interps
(N
: Node_Id
) is
507 Ent
: constant Entity_Id
:= Entity
(N
);
509 First_Interp
: Interp_Index
;
514 -- Unconditionally add the entity that was initially matched
516 First_Interp
:= All_Interp
.Last
;
517 Add_One_Interp
(N
, Ent
, Etype
(N
));
519 -- For expanded name, pick up all additional entities from the
520 -- same scope, since these are obviously also visible. Note that
521 -- these are not necessarily contiguous on the homonym chain.
523 if Nkind
(N
) = N_Expanded_Name
then
525 while Present
(H
) loop
526 if Scope
(H
) = Scope
(Entity
(N
)) then
527 Add_One_Interp
(N
, H
, Etype
(H
));
533 -- Case of direct name
536 -- First, search the homonym chain for directly visible entities
538 H
:= Current_Entity
(Ent
);
539 while Present
(H
) loop
540 exit when (not Is_Overloadable
(H
))
541 and then Is_Immediately_Visible
(H
);
543 if Is_Immediately_Visible
(H
)
546 -- Only add interpretation if not hidden by an inner
547 -- immediately visible one.
549 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
551 -- Current homograph is not hidden. Add to overloads
553 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
556 -- Homograph is hidden, unless it is a predefined operator
558 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
560 -- A homograph in the same scope can occur within an
561 -- instantiation, the resulting ambiguity has to be
564 if Scope
(H
) = Scope
(Ent
)
566 and then not Is_Inherited_Operation
(H
)
568 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
569 All_Interp
.Increment_Last
;
570 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
573 elsif Scope
(H
) /= Standard_Standard
then
579 -- On exit, we know that current homograph is not hidden
581 Add_One_Interp
(N
, H
, Etype
(H
));
584 Write_Str
("Add overloaded Interpretation ");
594 -- Scan list of homographs for use-visible entities only
596 H
:= Current_Entity
(Ent
);
598 while Present
(H
) loop
599 if Is_Potentially_Use_Visible
(H
)
601 and then Is_Overloadable
(H
)
603 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
605 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
608 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
609 goto Next_Use_Homograph
;
613 Add_One_Interp
(N
, H
, Etype
(H
));
616 <<Next_Use_Homograph
>>
621 if All_Interp
.Last
= First_Interp
+ 1 then
623 -- The original interpretation is in fact not overloaded
625 Set_Is_Overloaded
(N
, False);
633 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
638 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
639 -- In an instance the proper view may not always be correct for
640 -- private types, but private and full view are compatible. This
641 -- removes spurious errors from nested instantiations that involve,
642 -- among other things, types derived from private types.
644 ----------------------
645 -- Full_View_Covers --
646 ----------------------
648 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
651 Is_Private_Type
(Typ1
)
653 ((Present
(Full_View
(Typ1
))
654 and then Covers
(Full_View
(Typ1
), Typ2
))
655 or else Base_Type
(Typ1
) = Typ2
656 or else Base_Type
(Typ2
) = Typ1
);
657 end Full_View_Covers
;
659 -- Start of processing for Covers
662 -- If either operand missing, then this is an error, but ignore it (and
663 -- pretend we have a cover) if errors already detected, since this may
664 -- simply mean we have malformed trees.
666 if No
(T1
) or else No
(T2
) then
667 if Total_Errors_Detected
/= 0 then
674 BT1
:= Base_Type
(T1
);
675 BT2
:= Base_Type
(T2
);
678 -- Simplest case: same types are compatible, and types that have the
679 -- same base type and are not generic actuals are compatible. Generic
680 -- actuals belong to their class but are not compatible with other
681 -- types of their class, and in particular with other generic actuals.
682 -- They are however compatible with their own subtypes, and itypes
683 -- with the same base are compatible as well. Similarly, constrained
684 -- subtypes obtained from expressions of an unconstrained nominal type
685 -- are compatible with the base type (may lead to spurious ambiguities
686 -- in obscure cases ???)
688 -- Generic actuals require special treatment to avoid spurious ambi-
689 -- guities in an instance, when two formal types are instantiated with
690 -- the same actual, so that different subprograms end up with the same
691 -- signature in the instance.
700 if not Is_Generic_Actual_Type
(T1
) then
703 return (not Is_Generic_Actual_Type
(T2
)
704 or else Is_Itype
(T1
)
705 or else Is_Itype
(T2
)
706 or else Is_Constr_Subt_For_U_Nominal
(T1
)
707 or else Is_Constr_Subt_For_U_Nominal
(T2
)
708 or else Scope
(T1
) /= Scope
(T2
));
711 -- Literals are compatible with types in a given "class"
713 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
714 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
715 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
716 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
717 or else (T2
= Any_String
and then Is_String_Type
(T1
))
718 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
719 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
723 -- The context may be class wide
725 elsif Is_Class_Wide_Type
(T1
)
726 and then Is_Ancestor
(Root_Type
(T1
), T2
)
730 elsif Is_Class_Wide_Type
(T1
)
731 and then Is_Class_Wide_Type
(T2
)
732 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
736 -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
737 -- task_type or protected_type implementing T1
739 elsif Ada_Version
>= Ada_05
740 and then Is_Class_Wide_Type
(T1
)
741 and then Is_Interface
(Etype
(T1
))
742 and then Is_Concurrent_Type
(T2
)
743 and then Interface_Present_In_Ancestor
744 (Typ
=> Base_Type
(T2
),
749 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
750 -- object T2 implementing T1
752 elsif Ada_Version
>= Ada_05
753 and then Is_Class_Wide_Type
(T1
)
754 and then Is_Interface
(Etype
(T1
))
755 and then Is_Tagged_Type
(T2
)
757 if Interface_Present_In_Ancestor
(Typ
=> T2
,
768 if Is_Concurrent_Type
(BT2
) then
769 E
:= Corresponding_Record_Type
(BT2
);
774 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
775 -- covers an object T2 that implements a direct derivation of T1.
776 -- Note: test for presence of E is defense against previous error.
779 and then Present
(Abstract_Interfaces
(E
))
781 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
782 while Present
(Elmt
) loop
783 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
791 -- We should also check the case in which T1 is an ancestor of
792 -- some implemented interface???
797 -- In a dispatching call the actual may be class-wide
799 elsif Is_Class_Wide_Type
(T2
)
800 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
804 -- Some contexts require a class of types rather than a specific type
806 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
807 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
808 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
809 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
810 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
814 -- An aggregate is compatible with an array or record type
816 elsif T2
= Any_Composite
817 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
821 -- If the expected type is an anonymous access, the designated type must
822 -- cover that of the expression.
824 elsif Ekind
(T1
) = E_Anonymous_Access_Type
825 and then Is_Access_Type
(T2
)
826 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
830 -- An Access_To_Subprogram is compatible with itself, or with an
831 -- anonymous type created for an attribute reference Access.
833 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
835 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
836 and then Is_Access_Type
(T2
)
837 and then (not Comes_From_Source
(T1
)
838 or else not Comes_From_Source
(T2
))
839 and then (Is_Overloadable
(Designated_Type
(T2
))
841 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
843 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
845 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
849 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
850 -- with itself, or with an anonymous type created for an attribute
853 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
856 = E_Anonymous_Access_Protected_Subprogram_Type
)
857 and then Is_Access_Type
(T2
)
858 and then (not Comes_From_Source
(T1
)
859 or else not Comes_From_Source
(T2
))
860 and then (Is_Overloadable
(Designated_Type
(T2
))
862 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
864 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
866 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
870 -- The context can be a remote access type, and the expression the
871 -- corresponding source type declared in a categorized package, or
874 elsif Is_Record_Type
(T1
)
875 and then (Is_Remote_Call_Interface
(T1
)
876 or else Is_Remote_Types
(T1
))
877 and then Present
(Corresponding_Remote_Type
(T1
))
879 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
881 elsif Is_Record_Type
(T2
)
882 and then (Is_Remote_Call_Interface
(T2
)
883 or else Is_Remote_Types
(T2
))
884 and then Present
(Corresponding_Remote_Type
(T2
))
886 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
888 elsif Ekind
(T2
) = E_Access_Attribute_Type
889 and then (Ekind
(BT1
) = E_General_Access_Type
890 or else Ekind
(BT1
) = E_Access_Type
)
891 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
893 -- If the target type is a RACW type while the source is an access
894 -- attribute type, we are building a RACW that may be exported.
896 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
897 Set_Has_RACW
(Current_Sem_Unit
);
902 elsif Ekind
(T2
) = E_Allocator_Type
903 and then Is_Access_Type
(T1
)
905 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
907 (From_With_Type
(Designated_Type
(T1
))
908 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
910 -- A boolean operation on integer literals is compatible with modular
913 elsif T2
= Any_Modular
914 and then Is_Modular_Integer_Type
(T1
)
918 -- The actual type may be the result of a previous error
920 elsif Base_Type
(T2
) = Any_Type
then
923 -- A packed array type covers its corresponding non-packed type. This is
924 -- not legitimate Ada, but allows the omission of a number of otherwise
925 -- useless unchecked conversions, and since this can only arise in
926 -- (known correct) expanded code, no harm is done
928 elsif Is_Array_Type
(T2
)
929 and then Is_Packed
(T2
)
930 and then T1
= Packed_Array_Type
(T2
)
934 -- Similarly an array type covers its corresponding packed array type
936 elsif Is_Array_Type
(T1
)
937 and then Is_Packed
(T1
)
938 and then T2
= Packed_Array_Type
(T1
)
942 -- In instances, or with types exported from instantiations, check
943 -- whether a partial and a full view match. Verify that types are
944 -- legal, to prevent cascaded errors.
948 (Full_View_Covers
(T1
, T2
)
949 or else Full_View_Covers
(T2
, T1
))
954 and then Is_Generic_Actual_Type
(T2
)
955 and then Full_View_Covers
(T1
, T2
)
960 and then Is_Generic_Actual_Type
(T1
)
961 and then Full_View_Covers
(T2
, T1
)
965 -- In the expansion of inlined bodies, types are compatible if they
966 -- are structurally equivalent.
968 elsif In_Inlined_Body
969 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
970 or else (Is_Access_Type
(T1
)
971 and then Is_Access_Type
(T2
)
973 Designated_Type
(T1
) = Designated_Type
(T2
))
974 or else (T1
= Any_Access
975 and then Is_Access_Type
(Underlying_Type
(T2
)))
976 or else (T2
= Any_Composite
978 Is_Composite_Type
(Underlying_Type
(T1
))))
982 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
983 -- compatible with its real entity.
985 elsif From_With_Type
(T1
) then
987 -- If the expected type is the non-limited view of a type, the
988 -- expression may have the limited view.
990 if Is_Incomplete_Type
(T1
) then
991 return Covers
(Non_Limited_View
(T1
), T2
);
993 elsif Ekind
(T1
) = E_Class_Wide_Type
then
995 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1000 elsif From_With_Type
(T2
) then
1002 -- If units in the context have Limited_With clauses on each other,
1003 -- either type might have a limited view. Checks performed elsewhere
1004 -- verify that the context type is the non-limited view.
1006 if Is_Incomplete_Type
(T2
) then
1007 return Covers
(T1
, Non_Limited_View
(T2
));
1009 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1011 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1016 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1018 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1019 return Covers
(Full_View
(Etype
(T1
)), T2
);
1021 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1022 return Covers
(T1
, Full_View
(Etype
(T2
)));
1024 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1025 -- and actual anonymous access types in the context of generic
1026 -- instantiation. We have the following situation:
1029 -- type Formal is private;
1030 -- Formal_Obj : access Formal; -- T1
1034 -- type Actual is ...
1035 -- Actual_Obj : access Actual; -- T2
1036 -- package Instance is new G (Formal => Actual,
1037 -- Formal_Obj => Actual_Obj);
1039 elsif Ada_Version
>= Ada_05
1040 and then Ekind
(T1
) = E_Anonymous_Access_Type
1041 and then Ekind
(T2
) = E_Anonymous_Access_Type
1042 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1043 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1044 Directly_Designated_Type
(T2
)
1048 -- Otherwise it doesn't cover!
1059 function Disambiguate
1061 I1
, I2
: Interp_Index
;
1068 Nam1
, Nam2
: Entity_Id
;
1069 Predef_Subp
: Entity_Id
;
1070 User_Subp
: Entity_Id
;
1072 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1073 -- Determine whether one of the candidates is an operation inherited by
1074 -- a type that is derived from an actual in an instantiation.
1076 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean;
1077 -- Determine whether the expression is part of a generic actual. At
1078 -- the time the actual is resolved the scope is already that of the
1079 -- instance, but conceptually the resolution of the actual takes place
1080 -- in the enclosing context, and no special disambiguation rules should
1083 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1084 -- Determine whether a subprogram is an actual in an enclosing instance.
1085 -- An overloading between such a subprogram and one declared outside the
1086 -- instance is resolved in favor of the first, because it resolved in
1089 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1090 -- Look for exact type match in an instance, to remove spurious
1091 -- ambiguities when two formal types have the same actual.
1093 function Standard_Operator
return Boolean;
1094 -- Check whether subprogram is predefined operator declared in Standard.
1095 -- It may given by an operator name, or by an expanded name whose prefix
1098 function Remove_Conversions
return Interp
;
1099 -- Last chance for pathological cases involving comparisons on literals,
1100 -- and user overloadings of the same operator. Such pathologies have
1101 -- been removed from the ACVC, but still appear in two DEC tests, with
1102 -- the following notable quote from Ben Brosgol:
1104 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1105 -- this example; Robert Dewar brought it to our attention, since it is
1106 -- apparently found in the ACVC 1.5. I did not attempt to find the
1107 -- reason in the Reference Manual that makes the example legal, since I
1108 -- was too nauseated by it to want to pursue it further.]
1110 -- Accordingly, this is not a fully recursive solution, but it handles
1111 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1112 -- pathology in the other direction with calls whose multiple overloaded
1113 -- actuals make them truly unresolvable.
1115 -- The new rules concerning abstract operations create additional need
1116 -- for special handling of expressions with universal operands, see
1117 -- comments to Has_Abstract_Interpretation below.
1119 ------------------------
1120 -- In_Generic_Actual --
1121 ------------------------
1123 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
1124 Par
: constant Node_Id
:= Parent
(Exp
);
1130 elsif Nkind
(Par
) in N_Declaration
then
1131 if Nkind
(Par
) = N_Object_Declaration
1132 or else Nkind
(Par
) = N_Object_Renaming_Declaration
1134 return Present
(Corresponding_Generic_Association
(Par
));
1139 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
1143 return In_Generic_Actual
(Parent
(Par
));
1145 end In_Generic_Actual
;
1147 ---------------------------
1148 -- Inherited_From_Actual --
1149 ---------------------------
1151 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1152 Par
: constant Node_Id
:= Parent
(S
);
1154 if Nkind
(Par
) /= N_Full_Type_Declaration
1155 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1159 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1161 Is_Generic_Actual_Type
(
1162 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1164 end Inherited_From_Actual
;
1166 --------------------------
1167 -- Is_Actual_Subprogram --
1168 --------------------------
1170 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1172 return In_Open_Scopes
(Scope
(S
))
1174 (Is_Generic_Instance
(Scope
(S
))
1175 or else Is_Wrapper_Package
(Scope
(S
)));
1176 end Is_Actual_Subprogram
;
1182 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1183 T1
: constant Entity_Id
:= Etype
(Actual
);
1184 T2
: constant Entity_Id
:= Etype
(Formal
);
1188 (Is_Numeric_Type
(T2
)
1190 (T1
= Universal_Real
or else T1
= Universal_Integer
));
1193 ------------------------
1194 -- Remove_Conversions --
1195 ------------------------
1197 function Remove_Conversions
return Interp
is
1205 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1206 -- If an operation has universal operands the universal operation
1207 -- is present among its interpretations. If there is an abstract
1208 -- interpretation for the operator, with a numeric result, this
1209 -- interpretation was already removed in sem_ch4, but the universal
1210 -- one is still visible. We must rescan the list of operators and
1211 -- remove the universal interpretation to resolve the ambiguity.
1213 ---------------------------------
1214 -- Has_Abstract_Interpretation --
1215 ---------------------------------
1217 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1221 E
:= Current_Entity
(N
);
1222 while Present
(E
) loop
1224 and then Is_Numeric_Type
(Etype
(E
))
1233 end Has_Abstract_Interpretation
;
1235 -- Start of processing for Remove_Conversions
1240 Get_First_Interp
(N
, I
, It
);
1241 while Present
(It
.Typ
) loop
1242 if not Is_Overloadable
(It
.Nam
) then
1246 F1
:= First_Formal
(It
.Nam
);
1252 if Nkind
(N
) = N_Function_Call
1253 or else Nkind
(N
) = N_Procedure_Call_Statement
1255 Act1
:= First_Actual
(N
);
1257 if Present
(Act1
) then
1258 Act2
:= Next_Actual
(Act1
);
1263 elsif Nkind
(N
) in N_Unary_Op
then
1264 Act1
:= Right_Opnd
(N
);
1267 elsif Nkind
(N
) in N_Binary_Op
then
1268 Act1
:= Left_Opnd
(N
);
1269 Act2
:= Right_Opnd
(N
);
1275 if Nkind
(Act1
) in N_Op
1276 and then Is_Overloaded
(Act1
)
1277 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1278 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1279 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1280 and then Etype
(F1
) = Standard_Boolean
1282 -- If the two candidates are the original ones, the
1283 -- ambiguity is real. Otherwise keep the original, further
1284 -- calls to Disambiguate will take care of others in the
1285 -- list of candidates.
1287 if It1
/= No_Interp
then
1288 if It
= Disambiguate
.It1
1289 or else It
= Disambiguate
.It2
1291 if It1
= Disambiguate
.It1
1292 or else It1
= Disambiguate
.It2
1300 elsif Present
(Act2
)
1301 and then Nkind
(Act2
) in N_Op
1302 and then Is_Overloaded
(Act2
)
1303 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1305 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1306 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1308 -- The preference rule on the first actual is not
1309 -- sufficient to disambiguate.
1317 elsif Nkind
(Act1
) in N_Op
1318 and then Is_Overloaded
(Act1
)
1319 and then Present
(Universal_Interpretation
(Act1
))
1320 and then Is_Numeric_Type
(Etype
(F1
))
1321 and then Ada_Version
>= Ada_05
1322 and then Has_Abstract_Interpretation
(Act1
)
1324 if It
= Disambiguate
.It1
then
1325 return Disambiguate
.It2
;
1326 elsif It
= Disambiguate
.It2
then
1327 return Disambiguate
.It1
;
1333 Get_Next_Interp
(I
, It
);
1336 -- After some error, a formal may have Any_Type and yield a spurious
1337 -- match. To avoid cascaded errors if possible, check for such a
1338 -- formal in either candidate.
1340 if Serious_Errors_Detected
> 0 then
1345 Formal
:= First_Formal
(Nam1
);
1346 while Present
(Formal
) loop
1347 if Etype
(Formal
) = Any_Type
then
1348 return Disambiguate
.It2
;
1351 Next_Formal
(Formal
);
1354 Formal
:= First_Formal
(Nam2
);
1355 while Present
(Formal
) loop
1356 if Etype
(Formal
) = Any_Type
then
1357 return Disambiguate
.It1
;
1360 Next_Formal
(Formal
);
1366 end Remove_Conversions
;
1368 -----------------------
1369 -- Standard_Operator --
1370 -----------------------
1372 function Standard_Operator
return Boolean is
1376 if Nkind
(N
) in N_Op
then
1379 elsif Nkind
(N
) = N_Function_Call
then
1382 if Nkind
(Nam
) /= N_Expanded_Name
then
1385 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1390 end Standard_Operator
;
1392 -- Start of processing for Disambiguate
1395 -- Recover the two legal interpretations
1397 Get_First_Interp
(N
, I
, It
);
1399 Get_Next_Interp
(I
, It
);
1405 Get_Next_Interp
(I
, It
);
1411 if Ada_Version
< Ada_05
then
1413 -- Check whether one of the entities is an Ada 2005 entity and we are
1414 -- operating in an earlier mode, in which case we discard the Ada
1415 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1417 if Is_Ada_2005_Only
(Nam1
) then
1419 elsif Is_Ada_2005_Only
(Nam2
) then
1424 -- If the context is universal, the predefined operator is preferred.
1425 -- This includes bounds in numeric type declarations, and expressions
1426 -- in type conversions. If no interpretation yields a universal type,
1427 -- then we must check whether the user-defined entity hides the prede-
1430 if Chars
(Nam1
) in Any_Operator_Name
1431 and then Standard_Operator
1433 if Typ
= Universal_Integer
1434 or else Typ
= Universal_Real
1435 or else Typ
= Any_Integer
1436 or else Typ
= Any_Discrete
1437 or else Typ
= Any_Real
1438 or else Typ
= Any_Type
1440 -- Find an interpretation that yields the universal type, or else
1441 -- a predefined operator that yields a predefined numeric type.
1444 Candidate
: Interp
:= No_Interp
;
1447 Get_First_Interp
(N
, I
, It
);
1448 while Present
(It
.Typ
) loop
1449 if (Covers
(Typ
, It
.Typ
)
1450 or else Typ
= Any_Type
)
1452 (It
.Typ
= Universal_Integer
1453 or else It
.Typ
= Universal_Real
)
1457 elsif Covers
(Typ
, It
.Typ
)
1458 and then Scope
(It
.Typ
) = Standard_Standard
1459 and then Scope
(It
.Nam
) = Standard_Standard
1460 and then Is_Numeric_Type
(It
.Typ
)
1465 Get_Next_Interp
(I
, It
);
1468 if Candidate
/= No_Interp
then
1473 elsif Chars
(Nam1
) /= Name_Op_Not
1474 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1476 -- Equality or comparison operation. Choose predefined operator if
1477 -- arguments are universal. The node may be an operator, name, or
1478 -- a function call, so unpack arguments accordingly.
1481 Arg1
, Arg2
: Node_Id
;
1484 if Nkind
(N
) in N_Op
then
1485 Arg1
:= Left_Opnd
(N
);
1486 Arg2
:= Right_Opnd
(N
);
1488 elsif Is_Entity_Name
(N
)
1489 or else Nkind
(N
) = N_Operator_Symbol
1491 Arg1
:= First_Entity
(Entity
(N
));
1492 Arg2
:= Next_Entity
(Arg1
);
1495 Arg1
:= First_Actual
(N
);
1496 Arg2
:= Next_Actual
(Arg1
);
1500 and then Present
(Universal_Interpretation
(Arg1
))
1501 and then Universal_Interpretation
(Arg2
) =
1502 Universal_Interpretation
(Arg1
)
1504 Get_First_Interp
(N
, I
, It
);
1505 while Scope
(It
.Nam
) /= Standard_Standard
loop
1506 Get_Next_Interp
(I
, It
);
1515 -- If no universal interpretation, check whether user-defined operator
1516 -- hides predefined one, as well as other special cases. If the node
1517 -- is a range, then one or both bounds are ambiguous. Each will have
1518 -- to be disambiguated w.r.t. the context type. The type of the range
1519 -- itself is imposed by the context, so we can return either legal
1522 if Ekind
(Nam1
) = E_Operator
then
1523 Predef_Subp
:= Nam1
;
1526 elsif Ekind
(Nam2
) = E_Operator
then
1527 Predef_Subp
:= Nam2
;
1530 elsif Nkind
(N
) = N_Range
then
1533 -- If two user defined-subprograms are visible, it is a true ambiguity,
1534 -- unless one of them is an entry and the context is a conditional or
1535 -- timed entry call, or unless we are within an instance and this is
1536 -- results from two formals types with the same actual.
1539 if Nkind
(N
) = N_Procedure_Call_Statement
1540 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1541 and then N
= Entry_Call_Statement
(Parent
(N
))
1543 if Ekind
(Nam2
) = E_Entry
then
1545 elsif Ekind
(Nam1
) = E_Entry
then
1551 -- If the ambiguity occurs within an instance, it is due to several
1552 -- formal types with the same actual. Look for an exact match between
1553 -- the types of the formals of the overloadable entities, and the
1554 -- actuals in the call, to recover the unambiguous match in the
1555 -- original generic.
1557 -- The ambiguity can also be due to an overloading between a formal
1558 -- subprogram and a subprogram declared outside the generic. If the
1559 -- node is overloaded, it did not resolve to the global entity in
1560 -- the generic, and we choose the formal subprogram.
1562 -- Finally, the ambiguity can be between an explicit subprogram and
1563 -- one inherited (with different defaults) from an actual. In this
1564 -- case the resolution was to the explicit declaration in the
1565 -- generic, and remains so in the instance.
1568 and then not In_Generic_Actual
(N
)
1570 if Nkind
(N
) = N_Function_Call
1571 or else Nkind
(N
) = N_Procedure_Call_Statement
1576 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1577 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1580 if Is_Act1
and then not Is_Act2
then
1583 elsif Is_Act2
and then not Is_Act1
then
1586 elsif Inherited_From_Actual
(Nam1
)
1587 and then Comes_From_Source
(Nam2
)
1591 elsif Inherited_From_Actual
(Nam2
)
1592 and then Comes_From_Source
(Nam1
)
1597 Actual
:= First_Actual
(N
);
1598 Formal
:= First_Formal
(Nam1
);
1599 while Present
(Actual
) loop
1600 if Etype
(Actual
) /= Etype
(Formal
) then
1604 Next_Actual
(Actual
);
1605 Next_Formal
(Formal
);
1611 elsif Nkind
(N
) in N_Binary_Op
then
1612 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1614 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1621 elsif Nkind
(N
) in N_Unary_Op
then
1622 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1629 return Remove_Conversions
;
1632 return Remove_Conversions
;
1636 -- an implicit concatenation operator on a string type cannot be
1637 -- disambiguated from the predefined concatenation. This can only
1638 -- happen with concatenation of string literals.
1640 if Chars
(User_Subp
) = Name_Op_Concat
1641 and then Ekind
(User_Subp
) = E_Operator
1642 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1646 -- If the user-defined operator is in an open scope, or in the scope
1647 -- of the resulting type, or given by an expanded name that names its
1648 -- scope, it hides the predefined operator for the type. Exponentiation
1649 -- has to be special-cased because the implicit operator does not have
1650 -- a symmetric signature, and may not be hidden by the explicit one.
1652 elsif (Nkind
(N
) = N_Function_Call
1653 and then Nkind
(Name
(N
)) = N_Expanded_Name
1654 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1655 or else Hides_Op
(User_Subp
, Predef_Subp
))
1656 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1657 or else Hides_Op
(User_Subp
, Predef_Subp
)
1659 if It1
.Nam
= User_Subp
then
1665 -- Otherwise, the predefined operator has precedence, or if the user-
1666 -- defined operation is directly visible we have a true ambiguity. If
1667 -- this is a fixed-point multiplication and division in Ada83 mode,
1668 -- exclude the universal_fixed operator, which often causes ambiguities
1672 if (In_Open_Scopes
(Scope
(User_Subp
))
1673 or else Is_Potentially_Use_Visible
(User_Subp
))
1674 and then not In_Instance
1676 if Is_Fixed_Point_Type
(Typ
)
1677 and then (Chars
(Nam1
) = Name_Op_Multiply
1678 or else Chars
(Nam1
) = Name_Op_Divide
)
1679 and then Ada_Version
= Ada_83
1681 if It2
.Nam
= Predef_Subp
then
1687 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1688 -- states that the operator defined in Standard is not available
1689 -- if there is a user-defined equality with the proper signature,
1690 -- declared in the same declarative list as the type. The node
1691 -- may be an operator or a function call.
1693 elsif (Chars
(Nam1
) = Name_Op_Eq
1695 Chars
(Nam1
) = Name_Op_Ne
)
1696 and then Ada_Version
>= Ada_05
1697 and then Etype
(User_Subp
) = Standard_Boolean
1702 if Nkind
(N
) = N_Function_Call
then
1703 Opnd
:= First_Actual
(N
);
1705 Opnd
:= Left_Opnd
(N
);
1708 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1710 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1711 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1713 if It2
.Nam
= Predef_Subp
then
1727 elsif It1
.Nam
= Predef_Subp
then
1736 ---------------------
1737 -- End_Interp_List --
1738 ---------------------
1740 procedure End_Interp_List
is
1742 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1743 All_Interp
.Increment_Last
;
1744 end End_Interp_List
;
1746 -------------------------
1747 -- Entity_Matches_Spec --
1748 -------------------------
1750 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1752 -- Simple case: same entity kinds, type conformance is required. A
1753 -- parameterless function can also rename a literal.
1755 if Ekind
(Old_S
) = Ekind
(New_S
)
1756 or else (Ekind
(New_S
) = E_Function
1757 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1759 return Type_Conformant
(New_S
, Old_S
);
1761 elsif Ekind
(New_S
) = E_Function
1762 and then Ekind
(Old_S
) = E_Operator
1764 return Operator_Matches_Spec
(Old_S
, New_S
);
1766 elsif Ekind
(New_S
) = E_Procedure
1767 and then Is_Entry
(Old_S
)
1769 return Type_Conformant
(New_S
, Old_S
);
1774 end Entity_Matches_Spec
;
1776 ----------------------
1777 -- Find_Unique_Type --
1778 ----------------------
1780 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1781 T
: constant Entity_Id
:= Etype
(L
);
1784 TR
: Entity_Id
:= Any_Type
;
1787 if Is_Overloaded
(R
) then
1788 Get_First_Interp
(R
, I
, It
);
1789 while Present
(It
.Typ
) loop
1790 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1792 -- If several interpretations are possible and L is universal,
1793 -- apply preference rule.
1795 if TR
/= Any_Type
then
1797 if (T
= Universal_Integer
or else T
= Universal_Real
)
1808 Get_Next_Interp
(I
, It
);
1813 -- In the non-overloaded case, the Etype of R is already set correctly
1819 -- If one of the operands is Universal_Fixed, the type of the other
1820 -- operand provides the context.
1822 if Etype
(R
) = Universal_Fixed
then
1825 elsif T
= Universal_Fixed
then
1828 -- Ada 2005 (AI-230): Support the following operators:
1830 -- function "=" (L, R : universal_access) return Boolean;
1831 -- function "/=" (L, R : universal_access) return Boolean;
1833 -- Pool specific access types (E_Access_Type) are not covered by these
1834 -- operators because of the legality rule of 4.5.2(9.2): "The operands
1835 -- of the equality operators for universal_access shall be convertible
1836 -- to one another (see 4.6)". For example, considering the type decla-
1837 -- ration "type P is access Integer" and an anonymous access to Integer,
1838 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
1839 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
1841 elsif Ada_Version
>= Ada_05
1842 and then Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
1843 and then Is_Access_Type
(Etype
(R
))
1844 and then Ekind
(Etype
(R
)) /= E_Access_Type
1848 elsif Ada_Version
>= Ada_05
1849 and then Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
1850 and then Is_Access_Type
(Etype
(L
))
1851 and then Ekind
(Etype
(L
)) /= E_Access_Type
1856 return Specific_Type
(T
, Etype
(R
));
1859 end Find_Unique_Type
;
1861 ----------------------
1862 -- Get_First_Interp --
1863 ----------------------
1865 procedure Get_First_Interp
1867 I
: out Interp_Index
;
1871 Int_Ind
: Interp_Index
;
1875 -- If a selected component is overloaded because the selector has
1876 -- multiple interpretations, the node is a call to a protected
1877 -- operation or an indirect call. Retrieve the interpretation from
1878 -- the selector name. The selected component may be overloaded as well
1879 -- if the prefix is overloaded. That case is unchanged.
1881 if Nkind
(N
) = N_Selected_Component
1882 and then Is_Overloaded
(Selector_Name
(N
))
1884 O_N
:= Selector_Name
(N
);
1889 Map_Ptr
:= Headers
(Hash
(O_N
));
1890 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
1891 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
1892 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
1893 It
:= All_Interp
.Table
(Int_Ind
);
1897 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
1901 -- Procedure should never be called if the node has no interpretations
1903 raise Program_Error
;
1904 end Get_First_Interp
;
1906 ---------------------
1907 -- Get_Next_Interp --
1908 ---------------------
1910 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1913 It
:= All_Interp
.Table
(I
);
1914 end Get_Next_Interp
;
1916 -------------------------
1917 -- Has_Compatible_Type --
1918 -------------------------
1920 function Has_Compatible_Type
1933 if Nkind
(N
) = N_Subtype_Indication
1934 or else not Is_Overloaded
(N
)
1937 Covers
(Typ
, Etype
(N
))
1939 -- Ada 2005 (AI-345) The context may be a synchronized interface.
1940 -- If the type is already frozen use the corresponding_record
1941 -- to check whether it is a proper descendant.
1944 (Is_Concurrent_Type
(Etype
(N
))
1945 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
1946 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
1949 (not Is_Tagged_Type
(Typ
)
1950 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1951 and then Covers
(Etype
(N
), Typ
));
1954 Get_First_Interp
(N
, I
, It
);
1955 while Present
(It
.Typ
) loop
1956 if (Covers
(Typ
, It
.Typ
)
1958 (Scope
(It
.Nam
) /= Standard_Standard
1959 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
1961 -- Ada 2005 (AI-345)
1964 (Is_Concurrent_Type
(It
.Typ
)
1965 and then Present
(Corresponding_Record_Type
1967 and then Covers
(Typ
, Corresponding_Record_Type
1970 or else (not Is_Tagged_Type
(Typ
)
1971 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1972 and then Covers
(It
.Typ
, Typ
))
1977 Get_Next_Interp
(I
, It
);
1982 end Has_Compatible_Type
;
1988 function Hash
(N
: Node_Id
) return Int
is
1990 -- Nodes have a size that is power of two, so to select significant
1991 -- bits only we remove the low-order bits.
1993 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2000 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2001 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2003 return Operator_Matches_Spec
(Op
, F
)
2004 and then (In_Open_Scopes
(Scope
(F
))
2005 or else Scope
(F
) = Scope
(Btyp
)
2006 or else (not In_Open_Scopes
(Scope
(Btyp
))
2007 and then not In_Use
(Btyp
)
2008 and then not In_Use
(Scope
(Btyp
))));
2011 ------------------------
2012 -- Init_Interp_Tables --
2013 ------------------------
2015 procedure Init_Interp_Tables
is
2019 Headers
:= (others => No_Entry
);
2020 end Init_Interp_Tables
;
2022 -----------------------------------
2023 -- Interface_Present_In_Ancestor --
2024 -----------------------------------
2026 function Interface_Present_In_Ancestor
2028 Iface
: Entity_Id
) return Boolean
2030 Target_Typ
: Entity_Id
;
2032 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2033 -- Returns True if Typ or some ancestor of Typ implements Iface
2035 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2045 -- Handle private types
2047 if Present
(Full_View
(Typ
))
2048 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2050 E
:= Full_View
(Typ
);
2056 if Present
(Abstract_Interfaces
(E
))
2057 and then Present
(Abstract_Interfaces
(E
))
2058 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
))
2060 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
2061 while Present
(Elmt
) loop
2064 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
2072 exit when Etype
(E
) = E
2074 -- Handle private types
2076 or else (Present
(Full_View
(Etype
(E
)))
2077 and then Full_View
(Etype
(E
)) = E
);
2079 -- Check if the current type is a direct derivation of the
2082 if Etype
(E
) = Iface
then
2086 -- Climb to the immediate ancestor handling private types
2088 if Present
(Full_View
(Etype
(E
))) then
2089 E
:= Full_View
(Etype
(E
));
2096 end Iface_Present_In_Ancestor
;
2098 -- Start of processing for Interface_Present_In_Ancestor
2101 if Is_Access_Type
(Typ
) then
2102 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2107 -- In case of concurrent types we can't use the Corresponding Record_Typ
2108 -- to look for the interface because it is built by the expander (and
2109 -- hence it is not always available). For this reason we traverse the
2110 -- list of interfaces (available in the parent of the concurrent type)
2112 if Is_Concurrent_Type
(Target_Typ
) then
2113 if Present
(Interface_List
(Parent
(Base_Type
(Target_Typ
)))) then
2118 AI
:= First
(Interface_List
(Parent
(Base_Type
(Target_Typ
))));
2119 while Present
(AI
) loop
2120 if Etype
(AI
) = Iface
then
2123 elsif Present
(Abstract_Interfaces
(Etype
(AI
)))
2124 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2137 if Is_Class_Wide_Type
(Target_Typ
) then
2138 Target_Typ
:= Etype
(Target_Typ
);
2141 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2142 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2143 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2145 -- Protect the frontend against previously detected errors
2147 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2152 return Iface_Present_In_Ancestor
(Target_Typ
);
2153 end Interface_Present_In_Ancestor
;
2155 ---------------------
2156 -- Intersect_Types --
2157 ---------------------
2159 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2160 Index
: Interp_Index
;
2164 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2165 -- Find interpretation of right arg that has type compatible with T
2167 --------------------------
2168 -- Check_Right_Argument --
2169 --------------------------
2171 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2172 Index
: Interp_Index
;
2177 if not Is_Overloaded
(R
) then
2178 return Specific_Type
(T
, Etype
(R
));
2181 Get_First_Interp
(R
, Index
, It
);
2183 T2
:= Specific_Type
(T
, It
.Typ
);
2185 if T2
/= Any_Type
then
2189 Get_Next_Interp
(Index
, It
);
2190 exit when No
(It
.Typ
);
2195 end Check_Right_Argument
;
2197 -- Start processing for Intersect_Types
2200 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2204 if not Is_Overloaded
(L
) then
2205 Typ
:= Check_Right_Argument
(Etype
(L
));
2209 Get_First_Interp
(L
, Index
, It
);
2210 while Present
(It
.Typ
) loop
2211 Typ
:= Check_Right_Argument
(It
.Typ
);
2212 exit when Typ
/= Any_Type
;
2213 Get_Next_Interp
(Index
, It
);
2218 -- If Typ is Any_Type, it means no compatible pair of types was found
2220 if Typ
= Any_Type
then
2221 if Nkind
(Parent
(L
)) in N_Op
then
2222 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2224 elsif Nkind
(Parent
(L
)) = N_Range
then
2225 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2227 -- Ada 2005 (AI-251): Complete the error notification
2229 elsif Is_Class_Wide_Type
(Etype
(R
))
2230 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2232 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2233 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2236 Error_Msg_N
("incompatible types", Parent
(L
));
2241 end Intersect_Types
;
2247 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2251 if Base_Type
(T1
) = Base_Type
(T2
) then
2254 elsif Is_Private_Type
(T1
)
2255 and then Present
(Full_View
(T1
))
2256 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
2264 -- If there was a error on the type declaration, do not recurse
2266 if Error_Posted
(Par
) then
2269 elsif Base_Type
(T1
) = Base_Type
(Par
)
2270 or else (Is_Private_Type
(T1
)
2271 and then Present
(Full_View
(T1
))
2272 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2276 elsif Is_Private_Type
(Par
)
2277 and then Present
(Full_View
(Par
))
2278 and then Full_View
(Par
) = Base_Type
(T1
)
2282 elsif Etype
(Par
) /= Par
then
2291 ---------------------------
2292 -- Is_Invisible_Operator --
2293 ---------------------------
2295 function Is_Invisible_Operator
2300 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2303 if Nkind
(N
) not in N_Op
then
2306 elsif not Comes_From_Source
(N
) then
2309 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2312 elsif Nkind
(N
) in N_Binary_Op
2313 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2319 and then not In_Open_Scopes
(Scope
(T
))
2320 and then not Is_Potentially_Use_Visible
(T
)
2321 and then not In_Use
(T
)
2322 and then not In_Use
(Scope
(T
))
2324 (Nkind
(Orig_Node
) /= N_Function_Call
2325 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2326 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2328 and then not In_Instance
;
2330 end Is_Invisible_Operator
;
2336 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2340 S
:= Ancestor_Subtype
(T1
);
2341 while Present
(S
) loop
2345 S
:= Ancestor_Subtype
(S
);
2356 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2357 Index
: Interp_Index
;
2361 Get_First_Interp
(Nam
, Index
, It
);
2362 while Present
(It
.Nam
) loop
2363 if Scope
(It
.Nam
) = Standard_Standard
2364 and then Scope
(It
.Typ
) /= Standard_Standard
2366 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2367 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2370 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2371 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2374 Get_Next_Interp
(Index
, It
);
2382 procedure New_Interps
(N
: Node_Id
) is
2386 All_Interp
.Increment_Last
;
2387 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
2389 Map_Ptr
:= Headers
(Hash
(N
));
2391 if Map_Ptr
= No_Entry
then
2393 -- Place new node at end of table
2395 Interp_Map
.Increment_Last
;
2396 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2399 -- Place node at end of chain, or locate its previous entry
2402 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2404 -- Node is already in the table, and is being rewritten.
2405 -- Start a new interp section, retain hash link.
2407 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2408 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2409 Set_Is_Overloaded
(N
, True);
2413 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2414 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2418 -- Chain the new node
2420 Interp_Map
.Increment_Last
;
2421 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2424 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2425 Set_Is_Overloaded
(N
, True);
2428 ---------------------------
2429 -- Operator_Matches_Spec --
2430 ---------------------------
2432 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2433 Op_Name
: constant Name_Id
:= Chars
(Op
);
2434 T
: constant Entity_Id
:= Etype
(New_S
);
2442 -- To verify that a predefined operator matches a given signature,
2443 -- do a case analysis of the operator classes. Function can have one
2444 -- or two formals and must have the proper result type.
2446 New_F
:= First_Formal
(New_S
);
2447 Old_F
:= First_Formal
(Op
);
2449 while Present
(New_F
) and then Present
(Old_F
) loop
2451 Next_Formal
(New_F
);
2452 Next_Formal
(Old_F
);
2455 -- Definite mismatch if different number of parameters
2457 if Present
(Old_F
) or else Present
(New_F
) then
2463 T1
:= Etype
(First_Formal
(New_S
));
2465 if Op_Name
= Name_Op_Subtract
2466 or else Op_Name
= Name_Op_Add
2467 or else Op_Name
= Name_Op_Abs
2469 return Base_Type
(T1
) = Base_Type
(T
)
2470 and then Is_Numeric_Type
(T
);
2472 elsif Op_Name
= Name_Op_Not
then
2473 return Base_Type
(T1
) = Base_Type
(T
)
2474 and then Valid_Boolean_Arg
(Base_Type
(T
));
2483 T1
:= Etype
(First_Formal
(New_S
));
2484 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2486 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2487 or else Op_Name
= Name_Op_Xor
2489 return Base_Type
(T1
) = Base_Type
(T2
)
2490 and then Base_Type
(T1
) = Base_Type
(T
)
2491 and then Valid_Boolean_Arg
(Base_Type
(T
));
2493 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2494 return Base_Type
(T1
) = Base_Type
(T2
)
2495 and then not Is_Limited_Type
(T1
)
2496 and then Is_Boolean_Type
(T
);
2498 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2499 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2501 return Base_Type
(T1
) = Base_Type
(T2
)
2502 and then Valid_Comparison_Arg
(T1
)
2503 and then Is_Boolean_Type
(T
);
2505 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2506 return Base_Type
(T1
) = Base_Type
(T2
)
2507 and then Base_Type
(T1
) = Base_Type
(T
)
2508 and then Is_Numeric_Type
(T
);
2510 -- for division and multiplication, a user-defined function does
2511 -- not match the predefined universal_fixed operation, except in
2514 elsif Op_Name
= Name_Op_Divide
then
2515 return (Base_Type
(T1
) = Base_Type
(T2
)
2516 and then Base_Type
(T1
) = Base_Type
(T
)
2517 and then Is_Numeric_Type
(T
)
2518 and then (not Is_Fixed_Point_Type
(T
)
2519 or else Ada_Version
= Ada_83
))
2521 -- Mixed_Mode operations on fixed-point types
2523 or else (Base_Type
(T1
) = Base_Type
(T
)
2524 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2525 and then Is_Fixed_Point_Type
(T
))
2527 -- A user defined operator can also match (and hide) a mixed
2528 -- operation on universal literals.
2530 or else (Is_Integer_Type
(T2
)
2531 and then Is_Floating_Point_Type
(T1
)
2532 and then Base_Type
(T1
) = Base_Type
(T
));
2534 elsif Op_Name
= Name_Op_Multiply
then
2535 return (Base_Type
(T1
) = Base_Type
(T2
)
2536 and then Base_Type
(T1
) = Base_Type
(T
)
2537 and then Is_Numeric_Type
(T
)
2538 and then (not Is_Fixed_Point_Type
(T
)
2539 or else Ada_Version
= Ada_83
))
2541 -- Mixed_Mode operations on fixed-point types
2543 or else (Base_Type
(T1
) = Base_Type
(T
)
2544 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2545 and then Is_Fixed_Point_Type
(T
))
2547 or else (Base_Type
(T2
) = Base_Type
(T
)
2548 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2549 and then Is_Fixed_Point_Type
(T
))
2551 or else (Is_Integer_Type
(T2
)
2552 and then Is_Floating_Point_Type
(T1
)
2553 and then Base_Type
(T1
) = Base_Type
(T
))
2555 or else (Is_Integer_Type
(T1
)
2556 and then Is_Floating_Point_Type
(T2
)
2557 and then Base_Type
(T2
) = Base_Type
(T
));
2559 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2560 return Base_Type
(T1
) = Base_Type
(T2
)
2561 and then Base_Type
(T1
) = Base_Type
(T
)
2562 and then Is_Integer_Type
(T
);
2564 elsif Op_Name
= Name_Op_Expon
then
2565 return Base_Type
(T1
) = Base_Type
(T
)
2566 and then Is_Numeric_Type
(T
)
2567 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2569 elsif Op_Name
= Name_Op_Concat
then
2570 return Is_Array_Type
(T
)
2571 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2572 and then (Base_Type
(T1
) = Base_Type
(T
)
2574 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2575 and then (Base_Type
(T2
) = Base_Type
(T
)
2577 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2583 end Operator_Matches_Spec
;
2589 procedure Remove_Interp
(I
: in out Interp_Index
) is
2593 -- Find end of Interp list and copy downward to erase the discarded one
2596 while Present
(All_Interp
.Table
(II
).Typ
) loop
2600 for J
in I
+ 1 .. II
loop
2601 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2604 -- Back up interp. index to insure that iterator will pick up next
2605 -- available interpretation.
2614 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2616 O_N
: Node_Id
:= Old_N
;
2619 if Is_Overloaded
(Old_N
) then
2620 if Nkind
(Old_N
) = N_Selected_Component
2621 and then Is_Overloaded
(Selector_Name
(Old_N
))
2623 O_N
:= Selector_Name
(Old_N
);
2626 Map_Ptr
:= Headers
(Hash
(O_N
));
2628 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2629 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2630 pragma Assert
(Map_Ptr
/= No_Entry
);
2633 New_Interps
(New_N
);
2634 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2635 Interp_Map
.Table
(Map_Ptr
).Index
;
2643 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
2644 B1
: constant Entity_Id
:= Base_Type
(T1
);
2645 B2
: constant Entity_Id
:= Base_Type
(T2
);
2647 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2648 -- Check whether T is the equivalent type of a remote access type.
2649 -- If distribution is enabled, T is a legal context for Null.
2651 ----------------------
2652 -- Is_Remote_Access --
2653 ----------------------
2655 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2657 return Is_Record_Type
(T
)
2658 and then (Is_Remote_Call_Interface
(T
)
2659 or else Is_Remote_Types
(T
))
2660 and then Present
(Corresponding_Remote_Type
(T
))
2661 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2662 end Is_Remote_Access
;
2664 -- Start of processing for Specific_Type
2667 if T1
= Any_Type
or else T2
= Any_Type
then
2675 or else (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2676 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2677 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2678 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2683 or else (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2684 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2685 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2686 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2690 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2693 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2696 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2699 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
2702 elsif T1
= Any_Access
2703 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
2707 elsif T2
= Any_Access
2708 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
2712 elsif T2
= Any_Composite
2713 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
2717 elsif T1
= Any_Composite
2718 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
2722 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
2725 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
2728 -- ----------------------------------------------------------
2729 -- Special cases for equality operators (all other predefined
2730 -- operators can never apply to tagged types)
2731 -- ----------------------------------------------------------
2733 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
2736 elsif Is_Class_Wide_Type
(T1
)
2737 and then Is_Class_Wide_Type
(T2
)
2738 and then Is_Interface
(Etype
(T2
))
2742 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
2743 -- class-wide interface T2
2745 elsif Is_Class_Wide_Type
(T2
)
2746 and then Is_Interface
(Etype
(T2
))
2747 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
2748 Iface
=> Etype
(T2
))
2752 elsif Is_Class_Wide_Type
(T1
)
2753 and then Is_Ancestor
(Root_Type
(T1
), T2
)
2757 elsif Is_Class_Wide_Type
(T2
)
2758 and then Is_Ancestor
(Root_Type
(T2
), T1
)
2762 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
2764 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
2765 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
2766 and then Is_Access_Type
(T2
)
2770 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
2772 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
2773 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
2774 and then Is_Access_Type
(T1
)
2778 elsif (Ekind
(T1
) = E_Allocator_Type
2779 or else Ekind
(T1
) = E_Access_Attribute_Type
2780 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
2781 and then Is_Access_Type
(T2
)
2785 elsif (Ekind
(T2
) = E_Allocator_Type
2786 or else Ekind
(T2
) = E_Access_Attribute_Type
2787 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
2788 and then Is_Access_Type
(T1
)
2792 -- If none of the above cases applies, types are not compatible
2799 -----------------------
2800 -- Valid_Boolean_Arg --
2801 -----------------------
2803 -- In addition to booleans and arrays of booleans, we must include
2804 -- aggregates as valid boolean arguments, because in the first pass of
2805 -- resolution their components are not examined. If it turns out not to be
2806 -- an aggregate of booleans, this will be diagnosed in Resolve.
2807 -- Any_Composite must be checked for prior to the array type checks because
2808 -- Any_Composite does not have any associated indexes.
2810 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
2812 return Is_Boolean_Type
(T
)
2813 or else T
= Any_Composite
2814 or else (Is_Array_Type
(T
)
2815 and then T
/= Any_String
2816 and then Number_Dimensions
(T
) = 1
2817 and then Is_Boolean_Type
(Component_Type
(T
))
2818 and then (not Is_Private_Composite
(T
)
2819 or else In_Instance
)
2820 and then (not Is_Limited_Composite
(T
)
2821 or else In_Instance
))
2822 or else Is_Modular_Integer_Type
(T
)
2823 or else T
= Universal_Integer
;
2824 end Valid_Boolean_Arg
;
2826 --------------------------
2827 -- Valid_Comparison_Arg --
2828 --------------------------
2830 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
2833 if T
= Any_Composite
then
2835 elsif Is_Discrete_Type
(T
)
2836 or else Is_Real_Type
(T
)
2839 elsif Is_Array_Type
(T
)
2840 and then Number_Dimensions
(T
) = 1
2841 and then Is_Discrete_Type
(Component_Type
(T
))
2842 and then (not Is_Private_Composite
(T
)
2843 or else In_Instance
)
2844 and then (not Is_Limited_Composite
(T
)
2845 or else In_Instance
)
2848 elsif Is_String_Type
(T
) then
2853 end Valid_Comparison_Arg
;
2855 ----------------------
2856 -- Write_Interp_Ref --
2857 ----------------------
2859 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
2861 Write_Str
(" Node: ");
2862 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
2863 Write_Str
(" Index: ");
2864 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
2865 Write_Str
(" Next: ");
2866 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
2868 end Write_Interp_Ref
;
2870 ---------------------
2871 -- Write_Overloads --
2872 ---------------------
2874 procedure Write_Overloads
(N
: Node_Id
) is
2880 if not Is_Overloaded
(N
) then
2881 Write_Str
("Non-overloaded entity ");
2883 Write_Entity_Info
(Entity
(N
), " ");
2886 Get_First_Interp
(N
, I
, It
);
2887 Write_Str
("Overloaded entity ");
2889 Write_Str
(" Name Type");
2891 Write_Str
("===============================");
2895 while Present
(Nam
) loop
2896 Write_Int
(Int
(Nam
));
2898 Write_Name
(Chars
(Nam
));
2900 Write_Int
(Int
(It
.Typ
));
2902 Write_Name
(Chars
(It
.Typ
));
2904 Get_Next_Interp
(I
, It
);
2908 end Write_Overloads
;