1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Nlists
; use Nlists
;
32 with Errout
; use Errout
;
34 with Namet
; use Namet
;
36 with Output
; use Output
;
38 with Sem_Ch6
; use Sem_Ch6
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Ch12
; use Sem_Ch12
;
41 with Sem_Disp
; use Sem_Disp
;
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 function Binary_Op_Interp_Has_Abstract_Op
165 E
: Entity_Id
) return Entity_Id
;
166 -- Given the node and entity of a binary operator, determine whether the
167 -- actuals of E contain an abstract interpretation with regards to the
168 -- types of their corresponding formals. Return the abstract operation or
171 function Function_Interp_Has_Abstract_Op
173 E
: Entity_Id
) return Entity_Id
;
174 -- Given the node and entity of a function call, determine whether the
175 -- actuals of E contain an abstract interpretation with regards to the
176 -- types of their corresponding formals. Return the abstract operation or
179 function Has_Abstract_Op
181 Typ
: Entity_Id
) return Entity_Id
;
182 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
183 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
184 -- abstract interpretation which yields type Typ.
186 procedure New_Interps
(N
: Node_Id
);
187 -- Initialize collection of interpretations for the given node, which is
188 -- either an overloaded entity, or an operation whose arguments have
189 -- multiple interpretations. Interpretations can be added to only one
192 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
;
193 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
194 -- or is not a "class" type (any_character, etc).
200 procedure Add_One_Interp
204 Opnd_Type
: Entity_Id
:= Empty
)
206 Vis_Type
: Entity_Id
;
208 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
209 -- Add one interpretation to an overloaded node. Add a new entry if
210 -- not hidden by previous one, and remove previous one if hidden by
213 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
214 -- True if the entity is a predefined operator and the operands have
215 -- a universal Interpretation.
221 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
222 Abstr_Op
: Entity_Id
:= Empty
;
226 -- Start of processing for Add_Entry
229 -- Find out whether the new entry references interpretations that
230 -- are abstract or disabled by abstract operators.
232 if Ada_Version
>= Ada_05
then
233 if Nkind
(N
) in N_Binary_Op
then
234 Abstr_Op
:= Binary_Op_Interp_Has_Abstract_Op
(N
, Name
);
235 elsif Nkind
(N
) = N_Function_Call
then
236 Abstr_Op
:= Function_Interp_Has_Abstract_Op
(N
, Name
);
240 Get_First_Interp
(N
, I
, It
);
241 while Present
(It
.Nam
) loop
243 -- A user-defined subprogram hides another declared at an outer
244 -- level, or one that is use-visible. So return if previous
245 -- definition hides new one (which is either in an outer
246 -- scope, or use-visible). Note that for functions use-visible
247 -- is the same as potentially use-visible. If new one hides
248 -- previous one, replace entry in table of interpretations.
249 -- If this is a universal operation, retain the operator in case
250 -- preference rule applies.
252 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
253 and then Ekind
(Name
) = Ekind
(It
.Nam
))
254 or else (Ekind
(Name
) = E_Operator
255 and then Ekind
(It
.Nam
) = E_Function
))
257 and then Is_Immediately_Visible
(It
.Nam
)
258 and then Type_Conformant
(Name
, It
.Nam
)
259 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
261 if Is_Universal_Operation
(Name
) then
264 -- If node is an operator symbol, we have no actuals with
265 -- which to check hiding, and this is done in full in the
266 -- caller (Analyze_Subprogram_Renaming) so we include the
267 -- predefined operator in any case.
269 elsif Nkind
(N
) = N_Operator_Symbol
270 or else (Nkind
(N
) = N_Expanded_Name
272 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
276 elsif not In_Open_Scopes
(Scope
(Name
))
277 or else Scope_Depth
(Scope
(Name
)) <=
278 Scope_Depth
(Scope
(It
.Nam
))
280 -- If ambiguity within instance, and entity is not an
281 -- implicit operation, save for later disambiguation.
283 if Scope
(Name
) = Scope
(It
.Nam
)
284 and then not Is_Inherited_Operation
(Name
)
293 All_Interp
.Table
(I
).Nam
:= Name
;
297 -- Avoid making duplicate entries in overloads
300 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
304 -- Otherwise keep going
307 Get_Next_Interp
(I
, It
);
312 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
, Abstr_Op
);
313 All_Interp
.Increment_Last
;
314 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
325 if Ekind
(Op
) /= E_Operator
then
328 elsif Nkind
(N
) in N_Binary_Op
then
329 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
330 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
332 elsif Nkind
(N
) in N_Unary_Op
then
333 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
335 elsif Nkind
(N
) = N_Function_Call
then
336 Arg
:= First_Actual
(N
);
337 while Present
(Arg
) loop
338 if No
(Universal_Interpretation
(Arg
)) then
350 end Is_Universal_Operation
;
352 -- Start of processing for Add_One_Interp
355 -- If the interpretation is a predefined operator, verify that the
356 -- result type is visible, or that the entity has already been
357 -- resolved (case of an instantiation node that refers to a predefined
358 -- operation, or an internally generated operator node, or an operator
359 -- given as an expanded name). If the operator is a comparison or
360 -- equality, it is the type of the operand that matters to determine
361 -- whether the operator is visible. In an instance, the check is not
362 -- performed, given that the operator was visible in the generic.
364 if Ekind
(E
) = E_Operator
then
366 if Present
(Opnd_Type
) then
367 Vis_Type
:= Opnd_Type
;
369 Vis_Type
:= Base_Type
(T
);
372 if In_Open_Scopes
(Scope
(Vis_Type
))
373 or else Is_Potentially_Use_Visible
(Vis_Type
)
374 or else In_Use
(Vis_Type
)
375 or else (In_Use
(Scope
(Vis_Type
))
376 and then not Is_Hidden
(Vis_Type
))
377 or else Nkind
(N
) = N_Expanded_Name
378 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
380 or else Ekind
(Vis_Type
) = E_Anonymous_Access_Type
384 -- If the node is given in functional notation and the prefix
385 -- is an expanded name, then the operator is visible if the
386 -- prefix is the scope of the result type as well. If the
387 -- operator is (implicitly) defined in an extension of system,
388 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
390 elsif Nkind
(N
) = N_Function_Call
391 and then Nkind
(Name
(N
)) = N_Expanded_Name
392 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
393 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
394 or else Scope
(Vis_Type
) = System_Aux_Id
)
398 -- Save type for subsequent error message, in case no other
399 -- interpretation is found.
402 Candidate_Type
:= Vis_Type
;
406 -- In an instance, an abstract non-dispatching operation cannot
407 -- be a candidate interpretation, because it could not have been
408 -- one in the generic (it may be a spurious overloading in the
412 and then Is_Overloadable
(E
)
413 and then Is_Abstract_Subprogram
(E
)
414 and then not Is_Dispatching_Operation
(E
)
418 -- An inherited interface operation that is implemented by some
419 -- derived type does not participate in overload resolution, only
420 -- the implementation operation does.
423 and then Is_Subprogram
(E
)
424 and then Present
(Abstract_Interface_Alias
(E
))
426 -- Ada 2005 (AI-251): If this primitive operation corresponds with
427 -- an inmediate ancestor interface there is no need to add it to the
428 -- list of interpretations; the corresponding aliased primitive is
429 -- also in this list of primitive operations and will be used instead
430 -- because otherwise we have a dummy between the two subprograms that
431 -- are in fact the same.
434 (Find_Dispatching_Type
(Abstract_Interface_Alias
(E
)),
435 Find_Dispatching_Type
(E
))
437 Add_One_Interp
(N
, Abstract_Interface_Alias
(E
), T
);
443 -- If this is the first interpretation of N, N has type Any_Type.
444 -- In that case place the new type on the node. If one interpretation
445 -- already exists, indicate that the node is overloaded, and store
446 -- both the previous and the new interpretation in All_Interp. If
447 -- this is a later interpretation, just add it to the set.
449 if Etype
(N
) = Any_Type
then
454 -- Record both the operator or subprogram name, and its type
456 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
463 -- Either there is no current interpretation in the table for any
464 -- node or the interpretation that is present is for a different
465 -- node. In both cases add a new interpretation to the table.
467 elsif Interp_Map
.Last
< 0
469 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
470 and then not Is_Overloaded
(N
))
474 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
475 and then Present
(Entity
(N
))
477 Add_Entry
(Entity
(N
), Etype
(N
));
479 elsif (Nkind
(N
) = N_Function_Call
480 or else Nkind
(N
) = N_Procedure_Call_Statement
)
481 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
482 or else Is_Entity_Name
(Name
(N
)))
484 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
486 -- If this is an indirect call there will be no name associated
487 -- with the previous entry. To make diagnostics clearer, save
488 -- Subprogram_Type of first interpretation, so that the error will
489 -- point to the anonymous access to subprogram, not to the result
490 -- type of the call itself.
492 elsif (Nkind
(N
)) = N_Function_Call
493 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
494 and then Is_Overloaded
(Name
(N
))
500 pragma Warnings
(Off
, Itn
);
503 Get_First_Interp
(Name
(N
), Itn
, It
);
504 Add_Entry
(It
.Nam
, Etype
(N
));
508 -- Overloaded prefix in indexed or selected component,
509 -- or call whose name is an expression or another call.
511 Add_Entry
(Etype
(N
), Etype
(N
));
525 procedure All_Overloads
is
527 for J
in All_Interp
.First
.. All_Interp
.Last
loop
529 if Present
(All_Interp
.Table
(J
).Nam
) then
530 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
532 Write_Str
("No Interp");
535 Write_Str
("=================");
540 --------------------------------------
541 -- Binary_Op_Interp_Has_Abstract_Op --
542 --------------------------------------
544 function Binary_Op_Interp_Has_Abstract_Op
546 E
: Entity_Id
) return Entity_Id
548 Abstr_Op
: Entity_Id
;
549 E_Left
: constant Node_Id
:= First_Formal
(E
);
550 E_Right
: constant Node_Id
:= Next_Formal
(E_Left
);
553 Abstr_Op
:= Has_Abstract_Op
(Left_Opnd
(N
), Etype
(E_Left
));
554 if Present
(Abstr_Op
) then
558 return Has_Abstract_Op
(Right_Opnd
(N
), Etype
(E_Right
));
559 end Binary_Op_Interp_Has_Abstract_Op
;
561 ---------------------
562 -- Collect_Interps --
563 ---------------------
565 procedure Collect_Interps
(N
: Node_Id
) is
566 Ent
: constant Entity_Id
:= Entity
(N
);
568 First_Interp
: Interp_Index
;
573 -- Unconditionally add the entity that was initially matched
575 First_Interp
:= All_Interp
.Last
;
576 Add_One_Interp
(N
, Ent
, Etype
(N
));
578 -- For expanded name, pick up all additional entities from the
579 -- same scope, since these are obviously also visible. Note that
580 -- these are not necessarily contiguous on the homonym chain.
582 if Nkind
(N
) = N_Expanded_Name
then
584 while Present
(H
) loop
585 if Scope
(H
) = Scope
(Entity
(N
)) then
586 Add_One_Interp
(N
, H
, Etype
(H
));
592 -- Case of direct name
595 -- First, search the homonym chain for directly visible entities
597 H
:= Current_Entity
(Ent
);
598 while Present
(H
) loop
599 exit when (not Is_Overloadable
(H
))
600 and then Is_Immediately_Visible
(H
);
602 if Is_Immediately_Visible
(H
)
605 -- Only add interpretation if not hidden by an inner
606 -- immediately visible one.
608 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
610 -- Current homograph is not hidden. Add to overloads
612 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
615 -- Homograph is hidden, unless it is a predefined operator
617 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
619 -- A homograph in the same scope can occur within an
620 -- instantiation, the resulting ambiguity has to be
623 if Scope
(H
) = Scope
(Ent
)
625 and then not Is_Inherited_Operation
(H
)
627 All_Interp
.Table
(All_Interp
.Last
) :=
628 (H
, Etype
(H
), Empty
);
629 All_Interp
.Increment_Last
;
630 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
633 elsif Scope
(H
) /= Standard_Standard
then
639 -- On exit, we know that current homograph is not hidden
641 Add_One_Interp
(N
, H
, Etype
(H
));
644 Write_Str
("Add overloaded Interpretation ");
654 -- Scan list of homographs for use-visible entities only
656 H
:= Current_Entity
(Ent
);
658 while Present
(H
) loop
659 if Is_Potentially_Use_Visible
(H
)
661 and then Is_Overloadable
(H
)
663 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
665 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
668 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
669 goto Next_Use_Homograph
;
673 Add_One_Interp
(N
, H
, Etype
(H
));
676 <<Next_Use_Homograph
>>
681 if All_Interp
.Last
= First_Interp
+ 1 then
683 -- The original interpretation is in fact not overloaded
685 Set_Is_Overloaded
(N
, False);
693 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
698 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
699 -- In an instance the proper view may not always be correct for
700 -- private types, but private and full view are compatible. This
701 -- removes spurious errors from nested instantiations that involve,
702 -- among other things, types derived from private types.
704 ----------------------
705 -- Full_View_Covers --
706 ----------------------
708 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
711 Is_Private_Type
(Typ1
)
713 ((Present
(Full_View
(Typ1
))
714 and then Covers
(Full_View
(Typ1
), Typ2
))
715 or else Base_Type
(Typ1
) = Typ2
716 or else Base_Type
(Typ2
) = Typ1
);
717 end Full_View_Covers
;
719 -- Start of processing for Covers
722 -- If either operand missing, then this is an error, but ignore it (and
723 -- pretend we have a cover) if errors already detected, since this may
724 -- simply mean we have malformed trees.
726 if No
(T1
) or else No
(T2
) then
727 if Total_Errors_Detected
/= 0 then
734 BT1
:= Base_Type
(T1
);
735 BT2
:= Base_Type
(T2
);
738 -- Simplest case: same types are compatible, and types that have the
739 -- same base type and are not generic actuals are compatible. Generic
740 -- actuals belong to their class but are not compatible with other
741 -- types of their class, and in particular with other generic actuals.
742 -- They are however compatible with their own subtypes, and itypes
743 -- with the same base are compatible as well. Similarly, constrained
744 -- subtypes obtained from expressions of an unconstrained nominal type
745 -- are compatible with the base type (may lead to spurious ambiguities
746 -- in obscure cases ???)
748 -- Generic actuals require special treatment to avoid spurious ambi-
749 -- guities in an instance, when two formal types are instantiated with
750 -- the same actual, so that different subprograms end up with the same
751 -- signature in the instance.
760 if not Is_Generic_Actual_Type
(T1
) then
763 return (not Is_Generic_Actual_Type
(T2
)
764 or else Is_Itype
(T1
)
765 or else Is_Itype
(T2
)
766 or else Is_Constr_Subt_For_U_Nominal
(T1
)
767 or else Is_Constr_Subt_For_U_Nominal
(T2
)
768 or else Scope
(T1
) /= Scope
(T2
));
771 -- Literals are compatible with types in a given "class"
773 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
774 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
775 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
776 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
777 or else (T2
= Any_String
and then Is_String_Type
(T1
))
778 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
779 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
783 -- The context may be class wide
785 elsif Is_Class_Wide_Type
(T1
)
786 and then Is_Ancestor
(Root_Type
(T1
), T2
)
790 elsif Is_Class_Wide_Type
(T1
)
791 and then Is_Class_Wide_Type
(T2
)
792 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
796 -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
797 -- task_type or protected_type implementing T1
799 elsif Ada_Version
>= Ada_05
800 and then Is_Class_Wide_Type
(T1
)
801 and then Is_Interface
(Etype
(T1
))
802 and then Is_Concurrent_Type
(T2
)
803 and then Interface_Present_In_Ancestor
804 (Typ
=> Base_Type
(T2
),
809 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
810 -- object T2 implementing T1
812 elsif Ada_Version
>= Ada_05
813 and then Is_Class_Wide_Type
(T1
)
814 and then Is_Interface
(Etype
(T1
))
815 and then Is_Tagged_Type
(T2
)
817 if Interface_Present_In_Ancestor
(Typ
=> T2
,
828 if Is_Concurrent_Type
(BT2
) then
829 E
:= Corresponding_Record_Type
(BT2
);
834 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
835 -- covers an object T2 that implements a direct derivation of T1.
836 -- Note: test for presence of E is defense against previous error.
839 and then Present
(Abstract_Interfaces
(E
))
841 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
842 while Present
(Elmt
) loop
843 if Is_Ancestor
(Etype
(T1
), Node
(Elmt
)) then
851 -- We should also check the case in which T1 is an ancestor of
852 -- some implemented interface???
857 -- In a dispatching call the actual may be class-wide
859 elsif Is_Class_Wide_Type
(T2
)
860 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
864 -- Some contexts require a class of types rather than a specific type
866 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
867 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
868 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
869 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
870 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
874 -- An aggregate is compatible with an array or record type
876 elsif T2
= Any_Composite
877 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
881 -- If the expected type is an anonymous access, the designated type must
882 -- cover that of the expression. Use the base type for this check: even
883 -- though access subtypes are rare in sources, they are generated for
884 -- actuals in instantiations.
886 elsif Ekind
(BT1
) = E_Anonymous_Access_Type
887 and then Is_Access_Type
(T2
)
888 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
892 -- An Access_To_Subprogram is compatible with itself, or with an
893 -- anonymous type created for an attribute reference Access.
895 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
897 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
898 and then Is_Access_Type
(T2
)
899 and then (not Comes_From_Source
(T1
)
900 or else not Comes_From_Source
(T2
))
901 and then (Is_Overloadable
(Designated_Type
(T2
))
903 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
905 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
907 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
911 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
912 -- with itself, or with an anonymous type created for an attribute
915 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
918 = E_Anonymous_Access_Protected_Subprogram_Type
)
919 and then Is_Access_Type
(T2
)
920 and then (not Comes_From_Source
(T1
)
921 or else not Comes_From_Source
(T2
))
922 and then (Is_Overloadable
(Designated_Type
(T2
))
924 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
926 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
928 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
932 -- The context can be a remote access type, and the expression the
933 -- corresponding source type declared in a categorized package, or
936 elsif Is_Record_Type
(T1
)
937 and then (Is_Remote_Call_Interface
(T1
)
938 or else Is_Remote_Types
(T1
))
939 and then Present
(Corresponding_Remote_Type
(T1
))
941 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
943 elsif Is_Record_Type
(T2
)
944 and then (Is_Remote_Call_Interface
(T2
)
945 or else Is_Remote_Types
(T2
))
946 and then Present
(Corresponding_Remote_Type
(T2
))
948 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
950 elsif Ekind
(T2
) = E_Access_Attribute_Type
951 and then (Ekind
(BT1
) = E_General_Access_Type
952 or else Ekind
(BT1
) = E_Access_Type
)
953 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
955 -- If the target type is a RACW type while the source is an access
956 -- attribute type, we are building a RACW that may be exported.
958 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
959 Set_Has_RACW
(Current_Sem_Unit
);
964 elsif Ekind
(T2
) = E_Allocator_Type
965 and then Is_Access_Type
(T1
)
967 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
969 (From_With_Type
(Designated_Type
(T1
))
970 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
972 -- A boolean operation on integer literals is compatible with modular
975 elsif T2
= Any_Modular
976 and then Is_Modular_Integer_Type
(T1
)
980 -- The actual type may be the result of a previous error
982 elsif Base_Type
(T2
) = Any_Type
then
985 -- A packed array type covers its corresponding non-packed type. This is
986 -- not legitimate Ada, but allows the omission of a number of otherwise
987 -- useless unchecked conversions, and since this can only arise in
988 -- (known correct) expanded code, no harm is done
990 elsif Is_Array_Type
(T2
)
991 and then Is_Packed
(T2
)
992 and then T1
= Packed_Array_Type
(T2
)
996 -- Similarly an array type covers its corresponding packed array type
998 elsif Is_Array_Type
(T1
)
999 and then Is_Packed
(T1
)
1000 and then T2
= Packed_Array_Type
(T1
)
1004 -- In instances, or with types exported from instantiations, check
1005 -- whether a partial and a full view match. Verify that types are
1006 -- legal, to prevent cascaded errors.
1010 (Full_View_Covers
(T1
, T2
)
1011 or else Full_View_Covers
(T2
, T1
))
1016 and then Is_Generic_Actual_Type
(T2
)
1017 and then Full_View_Covers
(T1
, T2
)
1022 and then Is_Generic_Actual_Type
(T1
)
1023 and then Full_View_Covers
(T2
, T1
)
1027 -- In the expansion of inlined bodies, types are compatible if they
1028 -- are structurally equivalent.
1030 elsif In_Inlined_Body
1031 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
1032 or else (Is_Access_Type
(T1
)
1033 and then Is_Access_Type
(T2
)
1035 Designated_Type
(T1
) = Designated_Type
(T2
))
1036 or else (T1
= Any_Access
1037 and then Is_Access_Type
(Underlying_Type
(T2
)))
1038 or else (T2
= Any_Composite
1040 Is_Composite_Type
(Underlying_Type
(T1
))))
1044 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1045 -- compatible with its real entity.
1047 elsif From_With_Type
(T1
) then
1049 -- If the expected type is the non-limited view of a type, the
1050 -- expression may have the limited view. If that one in turn is
1051 -- incomplete, get full view if available.
1053 if Is_Incomplete_Type
(T1
) then
1054 return Covers
(Get_Full_View
(Non_Limited_View
(T1
)), T2
);
1056 elsif Ekind
(T1
) = E_Class_Wide_Type
then
1058 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
1063 elsif From_With_Type
(T2
) then
1065 -- If units in the context have Limited_With clauses on each other,
1066 -- either type might have a limited view. Checks performed elsewhere
1067 -- verify that the context type is the non-limited view.
1069 if Is_Incomplete_Type
(T2
) then
1070 return Covers
(T1
, Get_Full_View
(Non_Limited_View
(T2
)));
1072 elsif Ekind
(T2
) = E_Class_Wide_Type
then
1074 Present
(Non_Limited_View
(Etype
(T2
)))
1076 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
1081 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1083 elsif Ekind
(T1
) = E_Incomplete_Subtype
then
1084 return Covers
(Full_View
(Etype
(T1
)), T2
);
1086 elsif Ekind
(T2
) = E_Incomplete_Subtype
then
1087 return Covers
(T1
, Full_View
(Etype
(T2
)));
1089 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1090 -- and actual anonymous access types in the context of generic
1091 -- instantiation. We have the following situation:
1094 -- type Formal is private;
1095 -- Formal_Obj : access Formal; -- T1
1099 -- type Actual is ...
1100 -- Actual_Obj : access Actual; -- T2
1101 -- package Instance is new G (Formal => Actual,
1102 -- Formal_Obj => Actual_Obj);
1104 elsif Ada_Version
>= Ada_05
1105 and then Ekind
(T1
) = E_Anonymous_Access_Type
1106 and then Ekind
(T2
) = E_Anonymous_Access_Type
1107 and then Is_Generic_Type
(Directly_Designated_Type
(T1
))
1108 and then Get_Instance_Of
(Directly_Designated_Type
(T1
)) =
1109 Directly_Designated_Type
(T2
)
1113 -- Otherwise it doesn't cover!
1124 function Disambiguate
1126 I1
, I2
: Interp_Index
;
1133 Nam1
, Nam2
: Entity_Id
;
1134 Predef_Subp
: Entity_Id
;
1135 User_Subp
: Entity_Id
;
1137 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
1138 -- Determine whether one of the candidates is an operation inherited by
1139 -- a type that is derived from an actual in an instantiation.
1141 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean;
1142 -- Determine whether the expression is part of a generic actual. At
1143 -- the time the actual is resolved the scope is already that of the
1144 -- instance, but conceptually the resolution of the actual takes place
1145 -- in the enclosing context, and no special disambiguation rules should
1148 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
1149 -- Determine whether a subprogram is an actual in an enclosing instance.
1150 -- An overloading between such a subprogram and one declared outside the
1151 -- instance is resolved in favor of the first, because it resolved in
1154 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
1155 -- Look for exact type match in an instance, to remove spurious
1156 -- ambiguities when two formal types have the same actual.
1158 function Standard_Operator
return Boolean;
1159 -- Check whether subprogram is predefined operator declared in Standard.
1160 -- It may given by an operator name, or by an expanded name whose prefix
1163 function Remove_Conversions
return Interp
;
1164 -- Last chance for pathological cases involving comparisons on literals,
1165 -- and user overloadings of the same operator. Such pathologies have
1166 -- been removed from the ACVC, but still appear in two DEC tests, with
1167 -- the following notable quote from Ben Brosgol:
1169 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1170 -- this example; Robert Dewar brought it to our attention, since it is
1171 -- apparently found in the ACVC 1.5. I did not attempt to find the
1172 -- reason in the Reference Manual that makes the example legal, since I
1173 -- was too nauseated by it to want to pursue it further.]
1175 -- Accordingly, this is not a fully recursive solution, but it handles
1176 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1177 -- pathology in the other direction with calls whose multiple overloaded
1178 -- actuals make them truly unresolvable.
1180 -- The new rules concerning abstract operations create additional need
1181 -- for special handling of expressions with universal operands, see
1182 -- comments to Has_Abstract_Interpretation below.
1184 ------------------------
1185 -- In_Generic_Actual --
1186 ------------------------
1188 function In_Generic_Actual
(Exp
: Node_Id
) return Boolean is
1189 Par
: constant Node_Id
:= Parent
(Exp
);
1195 elsif Nkind
(Par
) in N_Declaration
then
1196 if Nkind
(Par
) = N_Object_Declaration
1197 or else Nkind
(Par
) = N_Object_Renaming_Declaration
1199 return Present
(Corresponding_Generic_Association
(Par
));
1204 elsif Nkind
(Par
) in N_Statement_Other_Than_Procedure_Call
then
1208 return In_Generic_Actual
(Parent
(Par
));
1210 end In_Generic_Actual
;
1212 ---------------------------
1213 -- Inherited_From_Actual --
1214 ---------------------------
1216 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1217 Par
: constant Node_Id
:= Parent
(S
);
1219 if Nkind
(Par
) /= N_Full_Type_Declaration
1220 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1224 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1226 Is_Generic_Actual_Type
(
1227 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1229 end Inherited_From_Actual
;
1231 --------------------------
1232 -- Is_Actual_Subprogram --
1233 --------------------------
1235 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1237 return In_Open_Scopes
(Scope
(S
))
1239 (Is_Generic_Instance
(Scope
(S
))
1240 or else Is_Wrapper_Package
(Scope
(S
)));
1241 end Is_Actual_Subprogram
;
1247 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1248 T1
: constant Entity_Id
:= Etype
(Actual
);
1249 T2
: constant Entity_Id
:= Etype
(Formal
);
1253 (Is_Numeric_Type
(T2
)
1255 (T1
= Universal_Real
or else T1
= Universal_Integer
));
1258 ------------------------
1259 -- Remove_Conversions --
1260 ------------------------
1262 function Remove_Conversions
return Interp
is
1270 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean;
1271 -- If an operation has universal operands the universal operation
1272 -- is present among its interpretations. If there is an abstract
1273 -- interpretation for the operator, with a numeric result, this
1274 -- interpretation was already removed in sem_ch4, but the universal
1275 -- one is still visible. We must rescan the list of operators and
1276 -- remove the universal interpretation to resolve the ambiguity.
1278 ---------------------------------
1279 -- Has_Abstract_Interpretation --
1280 ---------------------------------
1282 function Has_Abstract_Interpretation
(N
: Node_Id
) return Boolean is
1286 if Nkind
(N
) not in N_Op
1287 or else Ada_Version
< Ada_05
1288 or else not Is_Overloaded
(N
)
1289 or else No
(Universal_Interpretation
(N
))
1294 E
:= Get_Name_Entity_Id
(Chars
(N
));
1295 while Present
(E
) loop
1296 if Is_Overloadable
(E
)
1297 and then Is_Abstract_Subprogram
(E
)
1298 and then Is_Numeric_Type
(Etype
(E
))
1306 -- Finally, if an operand of the binary operator is itself
1307 -- an operator, recurse to see whether its own abstract
1308 -- interpretation is responsible for the spurious ambiguity.
1310 if Nkind
(N
) in N_Binary_Op
then
1311 return Has_Abstract_Interpretation
(Left_Opnd
(N
))
1312 or else Has_Abstract_Interpretation
(Right_Opnd
(N
));
1314 elsif Nkind
(N
) in N_Unary_Op
then
1315 return Has_Abstract_Interpretation
(Right_Opnd
(N
));
1321 end Has_Abstract_Interpretation
;
1323 -- Start of processing for Remove_Conversions
1328 Get_First_Interp
(N
, I
, It
);
1329 while Present
(It
.Typ
) loop
1330 if not Is_Overloadable
(It
.Nam
) then
1334 F1
:= First_Formal
(It
.Nam
);
1340 if Nkind
(N
) = N_Function_Call
1341 or else Nkind
(N
) = N_Procedure_Call_Statement
1343 Act1
:= First_Actual
(N
);
1345 if Present
(Act1
) then
1346 Act2
:= Next_Actual
(Act1
);
1351 elsif Nkind
(N
) in N_Unary_Op
then
1352 Act1
:= Right_Opnd
(N
);
1355 elsif Nkind
(N
) in N_Binary_Op
then
1356 Act1
:= Left_Opnd
(N
);
1357 Act2
:= Right_Opnd
(N
);
1359 -- Use type of second formal, so as to include
1360 -- exponentiation, where the exponent may be
1361 -- ambiguous and the result non-universal.
1369 if Nkind
(Act1
) in N_Op
1370 and then Is_Overloaded
(Act1
)
1371 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1372 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1373 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1374 and then Etype
(F1
) = Standard_Boolean
1376 -- If the two candidates are the original ones, the
1377 -- ambiguity is real. Otherwise keep the original, further
1378 -- calls to Disambiguate will take care of others in the
1379 -- list of candidates.
1381 if It1
/= No_Interp
then
1382 if It
= Disambiguate
.It1
1383 or else It
= Disambiguate
.It2
1385 if It1
= Disambiguate
.It1
1386 or else It1
= Disambiguate
.It2
1394 elsif Present
(Act2
)
1395 and then Nkind
(Act2
) in N_Op
1396 and then Is_Overloaded
(Act2
)
1397 and then (Nkind
(Right_Opnd
(Act2
)) = N_Integer_Literal
1399 Nkind
(Right_Opnd
(Act2
)) = N_Real_Literal
)
1400 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1402 -- The preference rule on the first actual is not
1403 -- sufficient to disambiguate.
1411 elsif Is_Numeric_Type
(Etype
(F1
))
1413 (Has_Abstract_Interpretation
(Act1
)
1414 or else Has_Abstract_Interpretation
(Act2
))
1416 if It
= Disambiguate
.It1
then
1417 return Disambiguate
.It2
;
1418 elsif It
= Disambiguate
.It2
then
1419 return Disambiguate
.It1
;
1425 Get_Next_Interp
(I
, It
);
1428 -- After some error, a formal may have Any_Type and yield a spurious
1429 -- match. To avoid cascaded errors if possible, check for such a
1430 -- formal in either candidate.
1432 if Serious_Errors_Detected
> 0 then
1437 Formal
:= First_Formal
(Nam1
);
1438 while Present
(Formal
) loop
1439 if Etype
(Formal
) = Any_Type
then
1440 return Disambiguate
.It2
;
1443 Next_Formal
(Formal
);
1446 Formal
:= First_Formal
(Nam2
);
1447 while Present
(Formal
) loop
1448 if Etype
(Formal
) = Any_Type
then
1449 return Disambiguate
.It1
;
1452 Next_Formal
(Formal
);
1458 end Remove_Conversions
;
1460 -----------------------
1461 -- Standard_Operator --
1462 -----------------------
1464 function Standard_Operator
return Boolean is
1468 if Nkind
(N
) in N_Op
then
1471 elsif Nkind
(N
) = N_Function_Call
then
1474 if Nkind
(Nam
) /= N_Expanded_Name
then
1477 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1482 end Standard_Operator
;
1484 -- Start of processing for Disambiguate
1487 -- Recover the two legal interpretations
1489 Get_First_Interp
(N
, I
, It
);
1491 Get_Next_Interp
(I
, It
);
1497 Get_Next_Interp
(I
, It
);
1503 if Ada_Version
< Ada_05
then
1505 -- Check whether one of the entities is an Ada 2005 entity and we are
1506 -- operating in an earlier mode, in which case we discard the Ada
1507 -- 2005 entity, so that we get proper Ada 95 overload resolution.
1509 if Is_Ada_2005_Only
(Nam1
) then
1511 elsif Is_Ada_2005_Only
(Nam2
) then
1516 -- Check for overloaded CIL convention stuff because the CIL libraries
1517 -- do sick things like Console.WriteLine where it matches
1518 -- two different overloads, so just pick the first ???
1520 if Convention
(Nam1
) = Convention_CIL
1521 and then Convention
(Nam2
) = Convention_CIL
1522 and then Ekind
(Nam1
) = Ekind
(Nam2
)
1523 and then (Ekind
(Nam1
) = E_Procedure
1524 or else Ekind
(Nam1
) = E_Function
)
1529 -- If the context is universal, the predefined operator is preferred.
1530 -- This includes bounds in numeric type declarations, and expressions
1531 -- in type conversions. If no interpretation yields a universal type,
1532 -- then we must check whether the user-defined entity hides the prede-
1535 if Chars
(Nam1
) in Any_Operator_Name
1536 and then Standard_Operator
1538 if Typ
= Universal_Integer
1539 or else Typ
= Universal_Real
1540 or else Typ
= Any_Integer
1541 or else Typ
= Any_Discrete
1542 or else Typ
= Any_Real
1543 or else Typ
= Any_Type
1545 -- Find an interpretation that yields the universal type, or else
1546 -- a predefined operator that yields a predefined numeric type.
1549 Candidate
: Interp
:= No_Interp
;
1552 Get_First_Interp
(N
, I
, It
);
1553 while Present
(It
.Typ
) loop
1554 if (Covers
(Typ
, It
.Typ
)
1555 or else Typ
= Any_Type
)
1557 (It
.Typ
= Universal_Integer
1558 or else It
.Typ
= Universal_Real
)
1562 elsif Covers
(Typ
, It
.Typ
)
1563 and then Scope
(It
.Typ
) = Standard_Standard
1564 and then Scope
(It
.Nam
) = Standard_Standard
1565 and then Is_Numeric_Type
(It
.Typ
)
1570 Get_Next_Interp
(I
, It
);
1573 if Candidate
/= No_Interp
then
1578 elsif Chars
(Nam1
) /= Name_Op_Not
1579 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1581 -- Equality or comparison operation. Choose predefined operator if
1582 -- arguments are universal. The node may be an operator, name, or
1583 -- a function call, so unpack arguments accordingly.
1586 Arg1
, Arg2
: Node_Id
;
1589 if Nkind
(N
) in N_Op
then
1590 Arg1
:= Left_Opnd
(N
);
1591 Arg2
:= Right_Opnd
(N
);
1593 elsif Is_Entity_Name
(N
)
1594 or else Nkind
(N
) = N_Operator_Symbol
1596 Arg1
:= First_Entity
(Entity
(N
));
1597 Arg2
:= Next_Entity
(Arg1
);
1600 Arg1
:= First_Actual
(N
);
1601 Arg2
:= Next_Actual
(Arg1
);
1605 and then Present
(Universal_Interpretation
(Arg1
))
1606 and then Universal_Interpretation
(Arg2
) =
1607 Universal_Interpretation
(Arg1
)
1609 Get_First_Interp
(N
, I
, It
);
1610 while Scope
(It
.Nam
) /= Standard_Standard
loop
1611 Get_Next_Interp
(I
, It
);
1620 -- If no universal interpretation, check whether user-defined operator
1621 -- hides predefined one, as well as other special cases. If the node
1622 -- is a range, then one or both bounds are ambiguous. Each will have
1623 -- to be disambiguated w.r.t. the context type. The type of the range
1624 -- itself is imposed by the context, so we can return either legal
1627 if Ekind
(Nam1
) = E_Operator
then
1628 Predef_Subp
:= Nam1
;
1631 elsif Ekind
(Nam2
) = E_Operator
then
1632 Predef_Subp
:= Nam2
;
1635 elsif Nkind
(N
) = N_Range
then
1638 -- If two user defined-subprograms are visible, it is a true ambiguity,
1639 -- unless one of them is an entry and the context is a conditional or
1640 -- timed entry call, or unless we are within an instance and this is
1641 -- results from two formals types with the same actual.
1644 if Nkind
(N
) = N_Procedure_Call_Statement
1645 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1646 and then N
= Entry_Call_Statement
(Parent
(N
))
1648 if Ekind
(Nam2
) = E_Entry
then
1650 elsif Ekind
(Nam1
) = E_Entry
then
1656 -- If the ambiguity occurs within an instance, it is due to several
1657 -- formal types with the same actual. Look for an exact match between
1658 -- the types of the formals of the overloadable entities, and the
1659 -- actuals in the call, to recover the unambiguous match in the
1660 -- original generic.
1662 -- The ambiguity can also be due to an overloading between a formal
1663 -- subprogram and a subprogram declared outside the generic. If the
1664 -- node is overloaded, it did not resolve to the global entity in
1665 -- the generic, and we choose the formal subprogram.
1667 -- Finally, the ambiguity can be between an explicit subprogram and
1668 -- one inherited (with different defaults) from an actual. In this
1669 -- case the resolution was to the explicit declaration in the
1670 -- generic, and remains so in the instance.
1673 and then not In_Generic_Actual
(N
)
1675 if Nkind
(N
) = N_Function_Call
1676 or else Nkind
(N
) = N_Procedure_Call_Statement
1681 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1682 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1685 if Is_Act1
and then not Is_Act2
then
1688 elsif Is_Act2
and then not Is_Act1
then
1691 elsif Inherited_From_Actual
(Nam1
)
1692 and then Comes_From_Source
(Nam2
)
1696 elsif Inherited_From_Actual
(Nam2
)
1697 and then Comes_From_Source
(Nam1
)
1702 Actual
:= First_Actual
(N
);
1703 Formal
:= First_Formal
(Nam1
);
1704 while Present
(Actual
) loop
1705 if Etype
(Actual
) /= Etype
(Formal
) then
1709 Next_Actual
(Actual
);
1710 Next_Formal
(Formal
);
1716 elsif Nkind
(N
) in N_Binary_Op
then
1717 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1719 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1726 elsif Nkind
(N
) in N_Unary_Op
then
1727 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1734 return Remove_Conversions
;
1737 return Remove_Conversions
;
1741 -- An implicit concatenation operator on a string type cannot be
1742 -- disambiguated from the predefined concatenation. This can only
1743 -- happen with concatenation of string literals.
1745 if Chars
(User_Subp
) = Name_Op_Concat
1746 and then Ekind
(User_Subp
) = E_Operator
1747 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1751 -- If the user-defined operator is in an open scope, or in the scope
1752 -- of the resulting type, or given by an expanded name that names its
1753 -- scope, it hides the predefined operator for the type. Exponentiation
1754 -- has to be special-cased because the implicit operator does not have
1755 -- a symmetric signature, and may not be hidden by the explicit one.
1757 elsif (Nkind
(N
) = N_Function_Call
1758 and then Nkind
(Name
(N
)) = N_Expanded_Name
1759 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1760 or else Hides_Op
(User_Subp
, Predef_Subp
))
1761 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1762 or else Hides_Op
(User_Subp
, Predef_Subp
)
1764 if It1
.Nam
= User_Subp
then
1770 -- Otherwise, the predefined operator has precedence, or if the user-
1771 -- defined operation is directly visible we have a true ambiguity. If
1772 -- this is a fixed-point multiplication and division in Ada83 mode,
1773 -- exclude the universal_fixed operator, which often causes ambiguities
1777 if (In_Open_Scopes
(Scope
(User_Subp
))
1778 or else Is_Potentially_Use_Visible
(User_Subp
))
1779 and then not In_Instance
1781 if Is_Fixed_Point_Type
(Typ
)
1782 and then (Chars
(Nam1
) = Name_Op_Multiply
1783 or else Chars
(Nam1
) = Name_Op_Divide
)
1784 and then Ada_Version
= Ada_83
1786 if It2
.Nam
= Predef_Subp
then
1792 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access
1793 -- states that the operator defined in Standard is not available
1794 -- if there is a user-defined equality with the proper signature,
1795 -- declared in the same declarative list as the type. The node
1796 -- may be an operator or a function call.
1798 elsif (Chars
(Nam1
) = Name_Op_Eq
1800 Chars
(Nam1
) = Name_Op_Ne
)
1801 and then Ada_Version
>= Ada_05
1802 and then Etype
(User_Subp
) = Standard_Boolean
1807 if Nkind
(N
) = N_Function_Call
then
1808 Opnd
:= First_Actual
(N
);
1810 Opnd
:= Left_Opnd
(N
);
1813 if Ekind
(Etype
(Opnd
)) = E_Anonymous_Access_Type
1815 List_Containing
(Parent
(Designated_Type
(Etype
(Opnd
))))
1816 = List_Containing
(Unit_Declaration_Node
(User_Subp
))
1818 if It2
.Nam
= Predef_Subp
then
1824 return Remove_Conversions
;
1832 elsif It1
.Nam
= Predef_Subp
then
1841 ---------------------
1842 -- End_Interp_List --
1843 ---------------------
1845 procedure End_Interp_List
is
1847 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1848 All_Interp
.Increment_Last
;
1849 end End_Interp_List
;
1851 -------------------------
1852 -- Entity_Matches_Spec --
1853 -------------------------
1855 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1857 -- Simple case: same entity kinds, type conformance is required. A
1858 -- parameterless function can also rename a literal.
1860 if Ekind
(Old_S
) = Ekind
(New_S
)
1861 or else (Ekind
(New_S
) = E_Function
1862 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1864 return Type_Conformant
(New_S
, Old_S
);
1866 elsif Ekind
(New_S
) = E_Function
1867 and then Ekind
(Old_S
) = E_Operator
1869 return Operator_Matches_Spec
(Old_S
, New_S
);
1871 elsif Ekind
(New_S
) = E_Procedure
1872 and then Is_Entry
(Old_S
)
1874 return Type_Conformant
(New_S
, Old_S
);
1879 end Entity_Matches_Spec
;
1881 ----------------------
1882 -- Find_Unique_Type --
1883 ----------------------
1885 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1886 T
: constant Entity_Id
:= Etype
(L
);
1889 TR
: Entity_Id
:= Any_Type
;
1892 if Is_Overloaded
(R
) then
1893 Get_First_Interp
(R
, I
, It
);
1894 while Present
(It
.Typ
) loop
1895 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1897 -- If several interpretations are possible and L is universal,
1898 -- apply preference rule.
1900 if TR
/= Any_Type
then
1902 if (T
= Universal_Integer
or else T
= Universal_Real
)
1913 Get_Next_Interp
(I
, It
);
1918 -- In the non-overloaded case, the Etype of R is already set correctly
1924 -- If one of the operands is Universal_Fixed, the type of the other
1925 -- operand provides the context.
1927 if Etype
(R
) = Universal_Fixed
then
1930 elsif T
= Universal_Fixed
then
1933 -- Ada 2005 (AI-230): Support the following operators:
1935 -- function "=" (L, R : universal_access) return Boolean;
1936 -- function "/=" (L, R : universal_access) return Boolean;
1938 -- Pool specific access types (E_Access_Type) are not covered by these
1939 -- operators because of the legality rule of 4.5.2(9.2): "The operands
1940 -- of the equality operators for universal_access shall be convertible
1941 -- to one another (see 4.6)". For example, considering the type decla-
1942 -- ration "type P is access Integer" and an anonymous access to Integer,
1943 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
1944 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
1946 elsif Ada_Version
>= Ada_05
1948 (Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
1950 Ekind
(Etype
(L
)) = E_Anonymous_Access_Subprogram_Type
)
1951 and then Is_Access_Type
(Etype
(R
))
1952 and then Ekind
(Etype
(R
)) /= E_Access_Type
1956 elsif Ada_Version
>= Ada_05
1958 (Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
1959 or else Ekind
(Etype
(R
)) = E_Anonymous_Access_Subprogram_Type
)
1960 and then Is_Access_Type
(Etype
(L
))
1961 and then Ekind
(Etype
(L
)) /= E_Access_Type
1966 return Specific_Type
(T
, Etype
(R
));
1968 end Find_Unique_Type
;
1970 -------------------------------------
1971 -- Function_Interp_Has_Abstract_Op --
1972 -------------------------------------
1974 function Function_Interp_Has_Abstract_Op
1976 E
: Entity_Id
) return Entity_Id
1978 Abstr_Op
: Entity_Id
;
1981 Form_Parm
: Node_Id
;
1984 if Is_Overloaded
(N
) then
1985 Act_Parm
:= First_Actual
(N
);
1986 Form_Parm
:= First_Formal
(E
);
1987 while Present
(Act_Parm
)
1988 and then Present
(Form_Parm
)
1992 if Nkind
(Act
) = N_Parameter_Association
then
1993 Act
:= Explicit_Actual_Parameter
(Act
);
1996 Abstr_Op
:= Has_Abstract_Op
(Act
, Etype
(Form_Parm
));
1998 if Present
(Abstr_Op
) then
2002 Next_Actual
(Act_Parm
);
2003 Next_Formal
(Form_Parm
);
2008 end Function_Interp_Has_Abstract_Op
;
2010 ----------------------
2011 -- Get_First_Interp --
2012 ----------------------
2014 procedure Get_First_Interp
2016 I
: out Interp_Index
;
2019 Int_Ind
: Interp_Index
;
2024 -- If a selected component is overloaded because the selector has
2025 -- multiple interpretations, the node is a call to a protected
2026 -- operation or an indirect call. Retrieve the interpretation from
2027 -- the selector name. The selected component may be overloaded as well
2028 -- if the prefix is overloaded. That case is unchanged.
2030 if Nkind
(N
) = N_Selected_Component
2031 and then Is_Overloaded
(Selector_Name
(N
))
2033 O_N
:= Selector_Name
(N
);
2038 Map_Ptr
:= Headers
(Hash
(O_N
));
2039 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
2040 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
2041 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
2042 It
:= All_Interp
.Table
(Int_Ind
);
2046 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2050 -- Procedure should never be called if the node has no interpretations
2052 raise Program_Error
;
2053 end Get_First_Interp
;
2055 ---------------------
2056 -- Get_Next_Interp --
2057 ---------------------
2059 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
2062 It
:= All_Interp
.Table
(I
);
2063 end Get_Next_Interp
;
2065 -------------------------
2066 -- Has_Compatible_Type --
2067 -------------------------
2069 function Has_Compatible_Type
2082 if Nkind
(N
) = N_Subtype_Indication
2083 or else not Is_Overloaded
(N
)
2086 Covers
(Typ
, Etype
(N
))
2088 -- Ada 2005 (AI-345) The context may be a synchronized interface.
2089 -- If the type is already frozen use the corresponding_record
2090 -- to check whether it is a proper descendant.
2093 (Is_Concurrent_Type
(Etype
(N
))
2094 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
2095 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
2098 (not Is_Tagged_Type
(Typ
)
2099 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2100 and then Covers
(Etype
(N
), Typ
));
2103 Get_First_Interp
(N
, I
, It
);
2104 while Present
(It
.Typ
) loop
2105 if (Covers
(Typ
, It
.Typ
)
2107 (Scope
(It
.Nam
) /= Standard_Standard
2108 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
2110 -- Ada 2005 (AI-345)
2113 (Is_Concurrent_Type
(It
.Typ
)
2114 and then Present
(Corresponding_Record_Type
2116 and then Covers
(Typ
, Corresponding_Record_Type
2119 or else (not Is_Tagged_Type
(Typ
)
2120 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
2121 and then Covers
(It
.Typ
, Typ
))
2126 Get_Next_Interp
(I
, It
);
2131 end Has_Compatible_Type
;
2133 ---------------------
2134 -- Has_Abstract_Op --
2135 ---------------------
2137 function Has_Abstract_Op
2139 Typ
: Entity_Id
) return Entity_Id
2145 if Is_Overloaded
(N
) then
2146 Get_First_Interp
(N
, I
, It
);
2147 while Present
(It
.Nam
) loop
2148 if Present
(It
.Abstract_Op
)
2149 and then Etype
(It
.Abstract_Op
) = Typ
2151 return It
.Abstract_Op
;
2154 Get_Next_Interp
(I
, It
);
2159 end Has_Abstract_Op
;
2165 function Hash
(N
: Node_Id
) return Int
is
2167 -- Nodes have a size that is power of two, so to select significant
2168 -- bits only we remove the low-order bits.
2170 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
2177 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
2178 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
2180 return Operator_Matches_Spec
(Op
, F
)
2181 and then (In_Open_Scopes
(Scope
(F
))
2182 or else Scope
(F
) = Scope
(Btyp
)
2183 or else (not In_Open_Scopes
(Scope
(Btyp
))
2184 and then not In_Use
(Btyp
)
2185 and then not In_Use
(Scope
(Btyp
))));
2188 ------------------------
2189 -- Init_Interp_Tables --
2190 ------------------------
2192 procedure Init_Interp_Tables
is
2196 Headers
:= (others => No_Entry
);
2197 end Init_Interp_Tables
;
2199 -----------------------------------
2200 -- Interface_Present_In_Ancestor --
2201 -----------------------------------
2203 function Interface_Present_In_Ancestor
2205 Iface
: Entity_Id
) return Boolean
2207 Target_Typ
: Entity_Id
;
2208 Iface_Typ
: Entity_Id
;
2210 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
2211 -- Returns True if Typ or some ancestor of Typ implements Iface
2213 -------------------------------
2214 -- Iface_Present_In_Ancestor --
2215 -------------------------------
2217 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
2223 if Typ
= Iface_Typ
then
2227 -- Handle private types
2229 if Present
(Full_View
(Typ
))
2230 and then not Is_Concurrent_Type
(Full_View
(Typ
))
2232 E
:= Full_View
(Typ
);
2238 if Present
(Abstract_Interfaces
(E
))
2239 and then Present
(Abstract_Interfaces
(E
))
2240 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
))
2242 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
2243 while Present
(Elmt
) loop
2246 if AI
= Iface_Typ
or else Is_Ancestor
(Iface_Typ
, AI
) then
2254 exit when Etype
(E
) = E
2256 -- Handle private types
2258 or else (Present
(Full_View
(Etype
(E
)))
2259 and then Full_View
(Etype
(E
)) = E
);
2261 -- Check if the current type is a direct derivation of the
2264 if Etype
(E
) = Iface_Typ
then
2268 -- Climb to the immediate ancestor handling private types
2270 if Present
(Full_View
(Etype
(E
))) then
2271 E
:= Full_View
(Etype
(E
));
2278 end Iface_Present_In_Ancestor
;
2280 -- Start of processing for Interface_Present_In_Ancestor
2283 if Is_Class_Wide_Type
(Iface
) then
2284 Iface_Typ
:= Etype
(Iface
);
2291 Iface_Typ
:= Base_Type
(Iface_Typ
);
2293 if Is_Access_Type
(Typ
) then
2294 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
2299 if Is_Concurrent_Record_Type
(Target_Typ
) then
2300 Target_Typ
:= Corresponding_Concurrent_Type
(Target_Typ
);
2303 Target_Typ
:= Base_Type
(Target_Typ
);
2305 -- In case of concurrent types we can't use the Corresponding Record_Typ
2306 -- to look for the interface because it is built by the expander (and
2307 -- hence it is not always available). For this reason we traverse the
2308 -- list of interfaces (available in the parent of the concurrent type)
2310 if Is_Concurrent_Type
(Target_Typ
) then
2311 if Present
(Interface_List
(Parent
(Target_Typ
))) then
2316 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
2317 while Present
(AI
) loop
2318 if Etype
(AI
) = Iface_Typ
then
2321 elsif Present
(Abstract_Interfaces
(Etype
(AI
)))
2322 and then Iface_Present_In_Ancestor
(Etype
(AI
))
2335 if Is_Class_Wide_Type
(Target_Typ
) then
2336 Target_Typ
:= Etype
(Target_Typ
);
2339 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2340 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
2341 Target_Typ
:= Non_Limited_View
(Target_Typ
);
2343 -- Protect the frontend against previously detected errors
2345 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
2350 return Iface_Present_In_Ancestor
(Target_Typ
);
2351 end Interface_Present_In_Ancestor
;
2353 ---------------------
2354 -- Intersect_Types --
2355 ---------------------
2357 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
2358 Index
: Interp_Index
;
2362 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
2363 -- Find interpretation of right arg that has type compatible with T
2365 --------------------------
2366 -- Check_Right_Argument --
2367 --------------------------
2369 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
2370 Index
: Interp_Index
;
2375 if not Is_Overloaded
(R
) then
2376 return Specific_Type
(T
, Etype
(R
));
2379 Get_First_Interp
(R
, Index
, It
);
2381 T2
:= Specific_Type
(T
, It
.Typ
);
2383 if T2
/= Any_Type
then
2387 Get_Next_Interp
(Index
, It
);
2388 exit when No
(It
.Typ
);
2393 end Check_Right_Argument
;
2395 -- Start processing for Intersect_Types
2398 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
2402 if not Is_Overloaded
(L
) then
2403 Typ
:= Check_Right_Argument
(Etype
(L
));
2407 Get_First_Interp
(L
, Index
, It
);
2408 while Present
(It
.Typ
) loop
2409 Typ
:= Check_Right_Argument
(It
.Typ
);
2410 exit when Typ
/= Any_Type
;
2411 Get_Next_Interp
(Index
, It
);
2416 -- If Typ is Any_Type, it means no compatible pair of types was found
2418 if Typ
= Any_Type
then
2419 if Nkind
(Parent
(L
)) in N_Op
then
2420 Error_Msg_N
("incompatible types for operator", Parent
(L
));
2422 elsif Nkind
(Parent
(L
)) = N_Range
then
2423 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
2425 -- Ada 2005 (AI-251): Complete the error notification
2427 elsif Is_Class_Wide_Type
(Etype
(R
))
2428 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
2430 Error_Msg_NE
("(Ada 2005) does not implement interface }",
2431 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
2434 Error_Msg_N
("incompatible types", Parent
(L
));
2439 end Intersect_Types
;
2445 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
2449 if Base_Type
(T1
) = Base_Type
(T2
) then
2452 elsif Is_Private_Type
(T1
)
2453 and then Present
(Full_View
(T1
))
2454 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
2462 -- If there was a error on the type declaration, do not recurse
2464 if Error_Posted
(Par
) then
2467 elsif Base_Type
(T1
) = Base_Type
(Par
)
2468 or else (Is_Private_Type
(T1
)
2469 and then Present
(Full_View
(T1
))
2470 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2474 elsif Is_Private_Type
(Par
)
2475 and then Present
(Full_View
(Par
))
2476 and then Full_View
(Par
) = Base_Type
(T1
)
2480 elsif Etype
(Par
) /= Par
then
2489 ---------------------------
2490 -- Is_Invisible_Operator --
2491 ---------------------------
2493 function Is_Invisible_Operator
2498 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2501 if Nkind
(N
) not in N_Op
then
2504 elsif not Comes_From_Source
(N
) then
2507 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2510 elsif Nkind
(N
) in N_Binary_Op
2511 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2516 return Is_Numeric_Type
(T
)
2517 and then not In_Open_Scopes
(Scope
(T
))
2518 and then not Is_Potentially_Use_Visible
(T
)
2519 and then not In_Use
(T
)
2520 and then not In_Use
(Scope
(T
))
2522 (Nkind
(Orig_Node
) /= N_Function_Call
2523 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2524 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2525 and then not In_Instance
;
2527 end Is_Invisible_Operator
;
2533 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2537 S
:= Ancestor_Subtype
(T1
);
2538 while Present
(S
) loop
2542 S
:= Ancestor_Subtype
(S
);
2553 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2554 Index
: Interp_Index
;
2558 Get_First_Interp
(Nam
, Index
, It
);
2559 while Present
(It
.Nam
) loop
2560 if Scope
(It
.Nam
) = Standard_Standard
2561 and then Scope
(It
.Typ
) /= Standard_Standard
2563 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2564 Error_Msg_NE
("\\& (inherited) declared#!", Err
, It
.Nam
);
2567 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2568 Error_Msg_NE
("\\& declared#!", Err
, It
.Nam
);
2571 Get_Next_Interp
(Index
, It
);
2579 procedure New_Interps
(N
: Node_Id
) is
2583 All_Interp
.Increment_Last
;
2584 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
2586 Map_Ptr
:= Headers
(Hash
(N
));
2588 if Map_Ptr
= No_Entry
then
2590 -- Place new node at end of table
2592 Interp_Map
.Increment_Last
;
2593 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2596 -- Place node at end of chain, or locate its previous entry
2599 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2601 -- Node is already in the table, and is being rewritten.
2602 -- Start a new interp section, retain hash link.
2604 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2605 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2606 Set_Is_Overloaded
(N
, True);
2610 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2611 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2615 -- Chain the new node
2617 Interp_Map
.Increment_Last
;
2618 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2621 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2622 Set_Is_Overloaded
(N
, True);
2625 ---------------------------
2626 -- Operator_Matches_Spec --
2627 ---------------------------
2629 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2630 Op_Name
: constant Name_Id
:= Chars
(Op
);
2631 T
: constant Entity_Id
:= Etype
(New_S
);
2639 -- To verify that a predefined operator matches a given signature,
2640 -- do a case analysis of the operator classes. Function can have one
2641 -- or two formals and must have the proper result type.
2643 New_F
:= First_Formal
(New_S
);
2644 Old_F
:= First_Formal
(Op
);
2646 while Present
(New_F
) and then Present
(Old_F
) loop
2648 Next_Formal
(New_F
);
2649 Next_Formal
(Old_F
);
2652 -- Definite mismatch if different number of parameters
2654 if Present
(Old_F
) or else Present
(New_F
) then
2660 T1
:= Etype
(First_Formal
(New_S
));
2662 if Op_Name
= Name_Op_Subtract
2663 or else Op_Name
= Name_Op_Add
2664 or else Op_Name
= Name_Op_Abs
2666 return Base_Type
(T1
) = Base_Type
(T
)
2667 and then Is_Numeric_Type
(T
);
2669 elsif Op_Name
= Name_Op_Not
then
2670 return Base_Type
(T1
) = Base_Type
(T
)
2671 and then Valid_Boolean_Arg
(Base_Type
(T
));
2680 T1
:= Etype
(First_Formal
(New_S
));
2681 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2683 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2684 or else Op_Name
= Name_Op_Xor
2686 return Base_Type
(T1
) = Base_Type
(T2
)
2687 and then Base_Type
(T1
) = Base_Type
(T
)
2688 and then Valid_Boolean_Arg
(Base_Type
(T
));
2690 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2691 return Base_Type
(T1
) = Base_Type
(T2
)
2692 and then not Is_Limited_Type
(T1
)
2693 and then Is_Boolean_Type
(T
);
2695 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2696 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2698 return Base_Type
(T1
) = Base_Type
(T2
)
2699 and then Valid_Comparison_Arg
(T1
)
2700 and then Is_Boolean_Type
(T
);
2702 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2703 return Base_Type
(T1
) = Base_Type
(T2
)
2704 and then Base_Type
(T1
) = Base_Type
(T
)
2705 and then Is_Numeric_Type
(T
);
2707 -- for division and multiplication, a user-defined function does
2708 -- not match the predefined universal_fixed operation, except in
2711 elsif Op_Name
= Name_Op_Divide
then
2712 return (Base_Type
(T1
) = Base_Type
(T2
)
2713 and then Base_Type
(T1
) = Base_Type
(T
)
2714 and then Is_Numeric_Type
(T
)
2715 and then (not Is_Fixed_Point_Type
(T
)
2716 or else Ada_Version
= Ada_83
))
2718 -- Mixed_Mode operations on fixed-point types
2720 or else (Base_Type
(T1
) = Base_Type
(T
)
2721 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2722 and then Is_Fixed_Point_Type
(T
))
2724 -- A user defined operator can also match (and hide) a mixed
2725 -- operation on universal literals.
2727 or else (Is_Integer_Type
(T2
)
2728 and then Is_Floating_Point_Type
(T1
)
2729 and then Base_Type
(T1
) = Base_Type
(T
));
2731 elsif Op_Name
= Name_Op_Multiply
then
2732 return (Base_Type
(T1
) = Base_Type
(T2
)
2733 and then Base_Type
(T1
) = Base_Type
(T
)
2734 and then Is_Numeric_Type
(T
)
2735 and then (not Is_Fixed_Point_Type
(T
)
2736 or else Ada_Version
= Ada_83
))
2738 -- Mixed_Mode operations on fixed-point types
2740 or else (Base_Type
(T1
) = Base_Type
(T
)
2741 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2742 and then Is_Fixed_Point_Type
(T
))
2744 or else (Base_Type
(T2
) = Base_Type
(T
)
2745 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2746 and then Is_Fixed_Point_Type
(T
))
2748 or else (Is_Integer_Type
(T2
)
2749 and then Is_Floating_Point_Type
(T1
)
2750 and then Base_Type
(T1
) = Base_Type
(T
))
2752 or else (Is_Integer_Type
(T1
)
2753 and then Is_Floating_Point_Type
(T2
)
2754 and then Base_Type
(T2
) = Base_Type
(T
));
2756 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2757 return Base_Type
(T1
) = Base_Type
(T2
)
2758 and then Base_Type
(T1
) = Base_Type
(T
)
2759 and then Is_Integer_Type
(T
);
2761 elsif Op_Name
= Name_Op_Expon
then
2762 return Base_Type
(T1
) = Base_Type
(T
)
2763 and then Is_Numeric_Type
(T
)
2764 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2766 elsif Op_Name
= Name_Op_Concat
then
2767 return Is_Array_Type
(T
)
2768 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2769 and then (Base_Type
(T1
) = Base_Type
(T
)
2771 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2772 and then (Base_Type
(T2
) = Base_Type
(T
)
2774 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2780 end Operator_Matches_Spec
;
2786 procedure Remove_Interp
(I
: in out Interp_Index
) is
2790 -- Find end of Interp list and copy downward to erase the discarded one
2793 while Present
(All_Interp
.Table
(II
).Typ
) loop
2797 for J
in I
+ 1 .. II
loop
2798 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2801 -- Back up interp. index to insure that iterator will pick up next
2802 -- available interpretation.
2811 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2813 O_N
: Node_Id
:= Old_N
;
2816 if Is_Overloaded
(Old_N
) then
2817 if Nkind
(Old_N
) = N_Selected_Component
2818 and then Is_Overloaded
(Selector_Name
(Old_N
))
2820 O_N
:= Selector_Name
(Old_N
);
2823 Map_Ptr
:= Headers
(Hash
(O_N
));
2825 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2826 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2827 pragma Assert
(Map_Ptr
/= No_Entry
);
2830 New_Interps
(New_N
);
2831 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2832 Interp_Map
.Table
(Map_Ptr
).Index
;
2840 function Specific_Type
(Typ_1
, Typ_2
: Entity_Id
) return Entity_Id
is
2841 T1
: constant Entity_Id
:= Available_View
(Typ_1
);
2842 T2
: constant Entity_Id
:= Available_View
(Typ_2
);
2843 B1
: constant Entity_Id
:= Base_Type
(T1
);
2844 B2
: constant Entity_Id
:= Base_Type
(T2
);
2846 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2847 -- Check whether T is the equivalent type of a remote access type.
2848 -- If distribution is enabled, T is a legal context for Null.
2850 ----------------------
2851 -- Is_Remote_Access --
2852 ----------------------
2854 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2856 return Is_Record_Type
(T
)
2857 and then (Is_Remote_Call_Interface
(T
)
2858 or else Is_Remote_Types
(T
))
2859 and then Present
(Corresponding_Remote_Type
(T
))
2860 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2861 end Is_Remote_Access
;
2863 -- Start of processing for Specific_Type
2866 if T1
= Any_Type
or else T2
= Any_Type
then
2873 elsif (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2874 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2875 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2876 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2880 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2881 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2882 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2883 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2887 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2890 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2893 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2896 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
2899 elsif T1
= Any_Access
2900 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
2904 elsif T2
= Any_Access
2905 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
2909 elsif T2
= Any_Composite
2910 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
2914 elsif T1
= Any_Composite
2915 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
2919 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
2922 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
2925 -- ----------------------------------------------------------
2926 -- Special cases for equality operators (all other predefined
2927 -- operators can never apply to tagged types)
2928 -- ----------------------------------------------------------
2930 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
2933 elsif Is_Class_Wide_Type
(T1
)
2934 and then Is_Class_Wide_Type
(T2
)
2935 and then Is_Interface
(Etype
(T2
))
2939 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
2940 -- class-wide interface T2
2942 elsif Is_Class_Wide_Type
(T2
)
2943 and then Is_Interface
(Etype
(T2
))
2944 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
2945 Iface
=> Etype
(T2
))
2949 elsif Is_Class_Wide_Type
(T1
)
2950 and then Is_Ancestor
(Root_Type
(T1
), T2
)
2954 elsif Is_Class_Wide_Type
(T2
)
2955 and then Is_Ancestor
(Root_Type
(T2
), T1
)
2959 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
2961 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
2962 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
2963 and then Is_Access_Type
(T2
)
2967 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
2969 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
2970 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
2971 and then Is_Access_Type
(T1
)
2975 elsif (Ekind
(T1
) = E_Allocator_Type
2976 or else Ekind
(T1
) = E_Access_Attribute_Type
2977 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
2978 and then Is_Access_Type
(T2
)
2982 elsif (Ekind
(T2
) = E_Allocator_Type
2983 or else Ekind
(T2
) = E_Access_Attribute_Type
2984 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
2985 and then Is_Access_Type
(T1
)
2989 -- If none of the above cases applies, types are not compatible
2996 ---------------------
2997 -- Set_Abstract_Op --
2998 ---------------------
3000 procedure Set_Abstract_Op
(I
: Interp_Index
; V
: Entity_Id
) is
3002 All_Interp
.Table
(I
).Abstract_Op
:= V
;
3003 end Set_Abstract_Op
;
3005 -----------------------
3006 -- Valid_Boolean_Arg --
3007 -----------------------
3009 -- In addition to booleans and arrays of booleans, we must include
3010 -- aggregates as valid boolean arguments, because in the first pass of
3011 -- resolution their components are not examined. If it turns out not to be
3012 -- an aggregate of booleans, this will be diagnosed in Resolve.
3013 -- Any_Composite must be checked for prior to the array type checks because
3014 -- Any_Composite does not have any associated indexes.
3016 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
3018 return Is_Boolean_Type
(T
)
3019 or else T
= Any_Composite
3020 or else (Is_Array_Type
(T
)
3021 and then T
/= Any_String
3022 and then Number_Dimensions
(T
) = 1
3023 and then Is_Boolean_Type
(Component_Type
(T
))
3024 and then (not Is_Private_Composite
(T
)
3025 or else In_Instance
)
3026 and then (not Is_Limited_Composite
(T
)
3027 or else In_Instance
))
3028 or else Is_Modular_Integer_Type
(T
)
3029 or else T
= Universal_Integer
;
3030 end Valid_Boolean_Arg
;
3032 --------------------------
3033 -- Valid_Comparison_Arg --
3034 --------------------------
3036 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
3039 if T
= Any_Composite
then
3041 elsif Is_Discrete_Type
(T
)
3042 or else Is_Real_Type
(T
)
3045 elsif Is_Array_Type
(T
)
3046 and then Number_Dimensions
(T
) = 1
3047 and then Is_Discrete_Type
(Component_Type
(T
))
3048 and then (not Is_Private_Composite
(T
)
3049 or else In_Instance
)
3050 and then (not Is_Limited_Composite
(T
)
3051 or else In_Instance
)
3054 elsif Is_String_Type
(T
) then
3059 end Valid_Comparison_Arg
;
3061 ----------------------
3062 -- Write_Interp_Ref --
3063 ----------------------
3065 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
3067 Write_Str
(" Node: ");
3068 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
3069 Write_Str
(" Index: ");
3070 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
3071 Write_Str
(" Next: ");
3072 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
3074 end Write_Interp_Ref
;
3076 ---------------------
3077 -- Write_Overloads --
3078 ---------------------
3080 procedure Write_Overloads
(N
: Node_Id
) is
3086 if not Is_Overloaded
(N
) then
3087 Write_Str
("Non-overloaded entity ");
3089 Write_Entity_Info
(Entity
(N
), " ");
3092 Get_First_Interp
(N
, I
, It
);
3093 Write_Str
("Overloaded entity ");
3095 Write_Str
(" Name Type Abstract Op");
3097 Write_Str
("===============================================");
3101 while Present
(Nam
) loop
3102 Write_Int
(Int
(Nam
));
3104 Write_Name
(Chars
(Nam
));
3106 Write_Int
(Int
(It
.Typ
));
3108 Write_Name
(Chars
(It
.Typ
));
3110 if Present
(It
.Abstract_Op
) then
3112 Write_Int
(Int
(It
.Abstract_Op
));
3114 Write_Name
(Chars
(It
.Abstract_Op
));
3118 Get_Next_Interp
(I
, It
);
3122 end Write_Overloads
;