1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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
;
36 with Output
; use Output
;
38 with Sem_Ch6
; use Sem_Ch6
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Util
; use Sem_Util
;
41 with Stand
; use Stand
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
45 with Uintp
; use Uintp
;
47 package body Sem_Type
is
53 -- The following data structures establish a mapping between nodes and
54 -- their interpretations. An overloaded node has an entry in Interp_Map,
55 -- which in turn contains a pointer into the All_Interp array. The
56 -- interpretations of a given node are contiguous in All_Interp. Each
57 -- set of interpretations is terminated with the marker No_Interp.
58 -- In order to speed up the retrieval of the interpretations of an
59 -- overloaded node, the Interp_Map table is accessed by means of a simple
60 -- hashing scheme, and the entries in Interp_Map are chained. The heads
61 -- of clash lists are stored in array Headers.
63 -- Headers Interp_Map All_Interp
65 -- _ +-----+ +--------+
66 -- |_| |_____| --->|interp1 |
67 -- |_|---------->|node | | |interp2 |
68 -- |_| |index|---------| |nointerp|
73 -- This scheme does not currently reclaim interpretations. In principle,
74 -- after a unit is compiled, all overloadings have been resolved, and the
75 -- candidate interpretations should be deleted. This should be easier
76 -- now than with the previous scheme???
78 package All_Interp
is new Table
.Table
(
79 Table_Component_Type
=> Interp
,
80 Table_Index_Type
=> Int
,
82 Table_Initial
=> Alloc
.All_Interp_Initial
,
83 Table_Increment
=> Alloc
.All_Interp_Increment
,
84 Table_Name
=> "All_Interp");
86 type Interp_Ref
is record
92 Header_Size
: constant Int
:= 2 ** 12;
93 No_Entry
: constant Int
:= -1;
94 Headers
: array (0 .. Header_Size
) of Int
:= (others => No_Entry
);
96 package Interp_Map
is new Table
.Table
(
97 Table_Component_Type
=> Interp_Ref
,
98 Table_Index_Type
=> Int
,
100 Table_Initial
=> Alloc
.Interp_Map_Initial
,
101 Table_Increment
=> Alloc
.Interp_Map_Increment
,
102 Table_Name
=> "Interp_Map");
104 function Hash
(N
: Node_Id
) return Int
;
105 -- A trivial hashing function for nodes, used to insert an overloaded
106 -- node into the Interp_Map table.
108 -------------------------------------
109 -- Handling of Overload Resolution --
110 -------------------------------------
112 -- Overload resolution uses two passes over the syntax tree of a complete
113 -- context. In the first, bottom-up pass, the types of actuals in calls
114 -- are used to resolve possibly overloaded subprogram and operator names.
115 -- In the second top-down pass, the type of the context (for example the
116 -- condition in a while statement) is used to resolve a possibly ambiguous
117 -- call, and the unique subprogram name in turn imposes a specific context
118 -- on each of its actuals.
120 -- Most expressions are in fact unambiguous, and the bottom-up pass is
121 -- sufficient to resolve most everything. To simplify the common case,
122 -- names and expressions carry a flag Is_Overloaded to indicate whether
123 -- they have more than one interpretation. If the flag is off, then each
124 -- name has already a unique meaning and type, and the bottom-up pass is
125 -- sufficient (and much simpler).
127 --------------------------
128 -- Operator Overloading --
129 --------------------------
131 -- The visibility of operators is handled differently from that of
132 -- other entities. We do not introduce explicit versions of primitive
133 -- operators for each type definition. As a result, there is only one
134 -- entity corresponding to predefined addition on all numeric types, etc.
135 -- The back-end resolves predefined operators according to their type.
136 -- The visibility of primitive operations then reduces to the visibility
137 -- of the resulting type: (a + b) is a legal interpretation of some
138 -- primitive operator + if the type of the result (which must also be
139 -- the type of a and b) is directly visible (i.e. either immediately
140 -- visible or use-visible.)
142 -- User-defined operators are treated like other functions, but the
143 -- visibility of these user-defined operations must be special-cased
144 -- to determine whether they hide or are hidden by predefined operators.
145 -- The form P."+" (x, y) requires additional handling.
147 -- Concatenation is treated more conventionally: for every one-dimensional
148 -- array type we introduce a explicit concatenation operator. This is
149 -- necessary to handle the case of (element & element => array) which
150 -- cannot be handled conveniently if there is no explicit instance of
151 -- resulting type of the operation.
153 -----------------------
154 -- Local Subprograms --
155 -----------------------
157 procedure All_Overloads
;
158 pragma Warnings
(Off
, All_Overloads
);
159 -- Debugging procedure: list full contents of Overloads table
161 procedure New_Interps
(N
: Node_Id
);
162 -- Initialize collection of interpretations for the given node, which is
163 -- either an overloaded entity, or an operation whose arguments have
164 -- multiple interpretations. Interpretations can be added to only one
167 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
168 -- If T1 and T2 are compatible, return the one that is not
169 -- universal or is not a "class" type (any_character, etc).
175 procedure Add_One_Interp
179 Opnd_Type
: Entity_Id
:= Empty
)
181 Vis_Type
: Entity_Id
;
183 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
);
184 -- Add one interpretation to node. Node is already known to be
185 -- overloaded. Add new interpretation if not hidden by previous
186 -- one, and remove previous one if hidden by new one.
188 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean;
189 -- True if the entity is a predefined operator and the operands have
190 -- a universal Interpretation.
196 procedure Add_Entry
(Name
: Entity_Id
; Typ
: Entity_Id
) is
197 Index
: Interp_Index
;
201 Get_First_Interp
(N
, Index
, It
);
202 while Present
(It
.Nam
) loop
204 -- A user-defined subprogram hides another declared at an outer
205 -- level, or one that is use-visible. So return if previous
206 -- definition hides new one (which is either in an outer
207 -- scope, or use-visible). Note that for functions use-visible
208 -- is the same as potentially use-visible. If new one hides
209 -- previous one, replace entry in table of interpretations.
210 -- If this is a universal operation, retain the operator in case
211 -- preference rule applies.
213 if (((Ekind
(Name
) = E_Function
or else Ekind
(Name
) = E_Procedure
)
214 and then Ekind
(Name
) = Ekind
(It
.Nam
))
215 or else (Ekind
(Name
) = E_Operator
216 and then Ekind
(It
.Nam
) = E_Function
))
218 and then Is_Immediately_Visible
(It
.Nam
)
219 and then Type_Conformant
(Name
, It
.Nam
)
220 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
222 if Is_Universal_Operation
(Name
) then
225 -- If node is an operator symbol, we have no actuals with
226 -- which to check hiding, and this is done in full in the
227 -- caller (Analyze_Subprogram_Renaming) so we include the
228 -- predefined operator in any case.
230 elsif Nkind
(N
) = N_Operator_Symbol
231 or else (Nkind
(N
) = N_Expanded_Name
233 Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
)
237 elsif not In_Open_Scopes
(Scope
(Name
))
238 or else Scope_Depth
(Scope
(Name
)) <=
239 Scope_Depth
(Scope
(It
.Nam
))
241 -- If ambiguity within instance, and entity is not an
242 -- implicit operation, save for later disambiguation.
244 if Scope
(Name
) = Scope
(It
.Nam
)
245 and then not Is_Inherited_Operation
(Name
)
254 All_Interp
.Table
(Index
).Nam
:= Name
;
258 -- Avoid making duplicate entries in overloads
261 and then Base_Type
(It
.Typ
) = Base_Type
(T
)
265 -- Otherwise keep going
268 Get_Next_Interp
(Index
, It
);
273 -- On exit, enter new interpretation. The context, or a preference
274 -- rule, will resolve the ambiguity on the second pass.
276 All_Interp
.Table
(All_Interp
.Last
) := (Name
, Typ
);
277 All_Interp
.Increment_Last
;
278 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
281 ----------------------------
282 -- Is_Universal_Operation --
283 ----------------------------
285 function Is_Universal_Operation
(Op
: Entity_Id
) return Boolean is
289 if Ekind
(Op
) /= E_Operator
then
292 elsif Nkind
(N
) in N_Binary_Op
then
293 return Present
(Universal_Interpretation
(Left_Opnd
(N
)))
294 and then Present
(Universal_Interpretation
(Right_Opnd
(N
)));
296 elsif Nkind
(N
) in N_Unary_Op
then
297 return Present
(Universal_Interpretation
(Right_Opnd
(N
)));
299 elsif Nkind
(N
) = N_Function_Call
then
300 Arg
:= First_Actual
(N
);
301 while Present
(Arg
) loop
302 if No
(Universal_Interpretation
(Arg
)) then
314 end Is_Universal_Operation
;
316 -- Start of processing for Add_One_Interp
319 -- If the interpretation is a predefined operator, verify that the
320 -- result type is visible, or that the entity has already been
321 -- resolved (case of an instantiation node that refers to a predefined
322 -- operation, or an internally generated operator node, or an operator
323 -- given as an expanded name). If the operator is a comparison or
324 -- equality, it is the type of the operand that matters to determine
325 -- whether the operator is visible. In an instance, the check is not
326 -- performed, given that the operator was visible in the generic.
328 if Ekind
(E
) = E_Operator
then
330 if Present
(Opnd_Type
) then
331 Vis_Type
:= Opnd_Type
;
333 Vis_Type
:= Base_Type
(T
);
336 if In_Open_Scopes
(Scope
(Vis_Type
))
337 or else Is_Potentially_Use_Visible
(Vis_Type
)
338 or else In_Use
(Vis_Type
)
339 or else (In_Use
(Scope
(Vis_Type
))
340 and then not Is_Hidden
(Vis_Type
))
341 or else Nkind
(N
) = N_Expanded_Name
342 or else (Nkind
(N
) in N_Op
and then E
= Entity
(N
))
347 -- If the node is given in functional notation and the prefix
348 -- is an expanded name, then the operator is visible if the
349 -- prefix is the scope of the result type as well. If the
350 -- operator is (implicitly) defined in an extension of system,
351 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
353 elsif Nkind
(N
) = N_Function_Call
354 and then Nkind
(Name
(N
)) = N_Expanded_Name
355 and then (Entity
(Prefix
(Name
(N
))) = Scope
(Base_Type
(T
))
356 or else Entity
(Prefix
(Name
(N
))) = Scope
(Vis_Type
)
357 or else Scope
(Vis_Type
) = System_Aux_Id
)
361 -- Save type for subsequent error message, in case no other
362 -- interpretation is found.
365 Candidate_Type
:= Vis_Type
;
369 -- In an instance, an abstract non-dispatching operation cannot
370 -- be a candidate interpretation, because it could not have been
371 -- one in the generic (it may be a spurious overloading in the
375 and then Is_Abstract
(E
)
376 and then not Is_Dispatching_Operation
(E
)
380 -- An inherited interface operation that is implemented by some
381 -- derived type does not participate in overload resolution, only
382 -- the implementation operation does.
385 and then Is_Subprogram
(E
)
386 and then Present
(Abstract_Interface_Alias
(E
))
388 Add_One_Interp
(N
, Abstract_Interface_Alias
(E
), T
);
392 -- If this is the first interpretation of N, N has type Any_Type.
393 -- In that case place the new type on the node. If one interpretation
394 -- already exists, indicate that the node is overloaded, and store
395 -- both the previous and the new interpretation in All_Interp. If
396 -- this is a later interpretation, just add it to the set.
398 if Etype
(N
) = Any_Type
then
403 -- Record both the operator or subprogram name, and its type
405 if Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
) then
412 -- Either there is no current interpretation in the table for any
413 -- node or the interpretation that is present is for a different
414 -- node. In both cases add a new interpretation to the table.
416 elsif Interp_Map
.Last
< 0
418 (Interp_Map
.Table
(Interp_Map
.Last
).Node
/= N
419 and then not Is_Overloaded
(N
))
423 if (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
424 and then Present
(Entity
(N
))
426 Add_Entry
(Entity
(N
), Etype
(N
));
428 elsif (Nkind
(N
) = N_Function_Call
429 or else Nkind
(N
) = N_Procedure_Call_Statement
)
430 and then (Nkind
(Name
(N
)) = N_Operator_Symbol
431 or else Is_Entity_Name
(Name
(N
)))
433 Add_Entry
(Entity
(Name
(N
)), Etype
(N
));
436 -- Overloaded prefix in indexed or selected component,
437 -- or call whose name is an expression or another call.
439 Add_Entry
(Etype
(N
), Etype
(N
));
453 procedure All_Overloads
is
455 for J
in All_Interp
.First
.. All_Interp
.Last
loop
457 if Present
(All_Interp
.Table
(J
).Nam
) then
458 Write_Entity_Info
(All_Interp
.Table
(J
). Nam
, " ");
460 Write_Str
("No Interp");
463 Write_Str
("=================");
468 ---------------------
469 -- Collect_Interps --
470 ---------------------
472 procedure Collect_Interps
(N
: Node_Id
) is
473 Ent
: constant Entity_Id
:= Entity
(N
);
475 First_Interp
: Interp_Index
;
480 -- Unconditionally add the entity that was initially matched
482 First_Interp
:= All_Interp
.Last
;
483 Add_One_Interp
(N
, Ent
, Etype
(N
));
485 -- For expanded name, pick up all additional entities from the
486 -- same scope, since these are obviously also visible. Note that
487 -- these are not necessarily contiguous on the homonym chain.
489 if Nkind
(N
) = N_Expanded_Name
then
491 while Present
(H
) loop
492 if Scope
(H
) = Scope
(Entity
(N
)) then
493 Add_One_Interp
(N
, H
, Etype
(H
));
499 -- Case of direct name
502 -- First, search the homonym chain for directly visible entities
504 H
:= Current_Entity
(Ent
);
505 while Present
(H
) loop
506 exit when (not Is_Overloadable
(H
))
507 and then Is_Immediately_Visible
(H
);
509 if Is_Immediately_Visible
(H
)
512 -- Only add interpretation if not hidden by an inner
513 -- immediately visible one.
515 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
517 -- Current homograph is not hidden. Add to overloads
519 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
522 -- Homograph is hidden, unless it is a predefined operator
524 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
526 -- A homograph in the same scope can occur within an
527 -- instantiation, the resulting ambiguity has to be
530 if Scope
(H
) = Scope
(Ent
)
532 and then not Is_Inherited_Operation
(H
)
534 All_Interp
.Table
(All_Interp
.Last
) := (H
, Etype
(H
));
535 All_Interp
.Increment_Last
;
536 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
539 elsif Scope
(H
) /= Standard_Standard
then
545 -- On exit, we know that current homograph is not hidden
547 Add_One_Interp
(N
, H
, Etype
(H
));
550 Write_Str
("Add overloaded Interpretation ");
560 -- Scan list of homographs for use-visible entities only
562 H
:= Current_Entity
(Ent
);
564 while Present
(H
) loop
565 if Is_Potentially_Use_Visible
(H
)
567 and then Is_Overloadable
(H
)
569 for J
in First_Interp
.. All_Interp
.Last
- 1 loop
571 if not Is_Immediately_Visible
(All_Interp
.Table
(J
).Nam
) then
574 elsif Type_Conformant
(H
, All_Interp
.Table
(J
).Nam
) then
575 goto Next_Use_Homograph
;
579 Add_One_Interp
(N
, H
, Etype
(H
));
582 <<Next_Use_Homograph
>>
587 if All_Interp
.Last
= First_Interp
+ 1 then
589 -- The original interpretation is in fact not overloaded
591 Set_Is_Overloaded
(N
, False);
599 function Covers
(T1
, T2
: Entity_Id
) return Boolean is
604 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean;
605 -- In an instance the proper view may not always be correct for
606 -- private types, but private and full view are compatible. This
607 -- removes spurious errors from nested instantiations that involve,
608 -- among other things, types derived from private types.
610 ----------------------
611 -- Full_View_Covers --
612 ----------------------
614 function Full_View_Covers
(Typ1
, Typ2
: Entity_Id
) return Boolean is
617 Is_Private_Type
(Typ1
)
619 ((Present
(Full_View
(Typ1
))
620 and then Covers
(Full_View
(Typ1
), Typ2
))
621 or else Base_Type
(Typ1
) = Typ2
622 or else Base_Type
(Typ2
) = Typ1
);
623 end Full_View_Covers
;
625 -- Start of processing for Covers
628 -- If either operand missing, then this is an error, but ignore it (and
629 -- pretend we have a cover) if errors already detected, since this may
630 -- simply mean we have malformed trees.
632 if No
(T1
) or else No
(T2
) then
633 if Total_Errors_Detected
/= 0 then
640 BT1
:= Base_Type
(T1
);
641 BT2
:= Base_Type
(T2
);
644 -- Simplest case: same types are compatible, and types that have the
645 -- same base type and are not generic actuals are compatible. Generic
646 -- actuals belong to their class but are not compatible with other
647 -- types of their class, and in particular with other generic actuals.
648 -- They are however compatible with their own subtypes, and itypes
649 -- with the same base are compatible as well. Similarly, constrained
650 -- subtypes obtained from expressions of an unconstrained nominal type
651 -- are compatible with the base type (may lead to spurious ambiguities
652 -- in obscure cases ???)
654 -- Generic actuals require special treatment to avoid spurious ambi-
655 -- guities in an instance, when two formal types are instantiated with
656 -- the same actual, so that different subprograms end up with the same
657 -- signature in the instance.
666 if not Is_Generic_Actual_Type
(T1
) then
669 return (not Is_Generic_Actual_Type
(T2
)
670 or else Is_Itype
(T1
)
671 or else Is_Itype
(T2
)
672 or else Is_Constr_Subt_For_U_Nominal
(T1
)
673 or else Is_Constr_Subt_For_U_Nominal
(T2
)
674 or else Scope
(T1
) /= Scope
(T2
));
677 -- Literals are compatible with types in a given "class"
679 elsif (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
680 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
681 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
682 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
683 or else (T2
= Any_String
and then Is_String_Type
(T1
))
684 or else (T2
= Any_Character
and then Is_Character_Type
(T1
))
685 or else (T2
= Any_Access
and then Is_Access_Type
(T1
))
689 -- The context may be class wide
691 elsif Is_Class_Wide_Type
(T1
)
692 and then Is_Ancestor
(Root_Type
(T1
), T2
)
696 elsif Is_Class_Wide_Type
(T1
)
697 and then Is_Class_Wide_Type
(T2
)
698 and then Base_Type
(Etype
(T1
)) = Base_Type
(Etype
(T2
))
702 -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
703 -- task_type or protected_type implementing T1
705 elsif Ada_Version
>= Ada_05
706 and then Is_Class_Wide_Type
(T1
)
707 and then Is_Interface
(Etype
(T1
))
708 and then Is_Concurrent_Type
(T2
)
709 and then Interface_Present_In_Ancestor
710 (Typ
=> Base_Type
(T2
),
715 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
716 -- object T2 implementing T1
718 elsif Ada_Version
>= Ada_05
719 and then Is_Class_Wide_Type
(T1
)
720 and then Is_Interface
(Etype
(T1
))
721 and then Is_Tagged_Type
(T2
)
723 if Interface_Present_In_Ancestor
(Typ
=> T2
,
728 elsif Present
(Abstract_Interfaces
(T2
)) then
730 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
731 -- covers an object T2 that implements a direct derivation of T1.
734 E
: Elmt_Id
:= First_Elmt
(Abstract_Interfaces
(T2
));
736 while Present
(E
) loop
737 if Is_Ancestor
(Etype
(T1
), Node
(E
)) then
745 -- We should also check the case in which T1 is an ancestor of
746 -- some implemented interface???
754 -- In a dispatching call the actual may be class-wide
756 elsif Is_Class_Wide_Type
(T2
)
757 and then Base_Type
(Root_Type
(T2
)) = Base_Type
(T1
)
761 -- Some contexts require a class of types rather than a specific type
763 elsif (T1
= Any_Integer
and then Is_Integer_Type
(T2
))
764 or else (T1
= Any_Boolean
and then Is_Boolean_Type
(T2
))
765 or else (T1
= Any_Real
and then Is_Real_Type
(T2
))
766 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
767 or else (T1
= Any_Discrete
and then Is_Discrete_Type
(T2
))
771 -- An aggregate is compatible with an array or record type
773 elsif T2
= Any_Composite
774 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
778 -- If the expected type is an anonymous access, the designated type must
779 -- cover that of the expression.
781 elsif Ekind
(T1
) = E_Anonymous_Access_Type
782 and then Is_Access_Type
(T2
)
783 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
787 -- An Access_To_Subprogram is compatible with itself, or with an
788 -- anonymous type created for an attribute reference Access.
790 elsif (Ekind
(BT1
) = E_Access_Subprogram_Type
792 Ekind
(BT1
) = E_Access_Protected_Subprogram_Type
)
793 and then Is_Access_Type
(T2
)
794 and then (not Comes_From_Source
(T1
)
795 or else not Comes_From_Source
(T2
))
796 and then (Is_Overloadable
(Designated_Type
(T2
))
798 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
800 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
802 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
806 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
807 -- with itself, or with an anonymous type created for an attribute
810 elsif (Ekind
(BT1
) = E_Anonymous_Access_Subprogram_Type
813 = E_Anonymous_Access_Protected_Subprogram_Type
)
814 and then Is_Access_Type
(T2
)
815 and then (not Comes_From_Source
(T1
)
816 or else not Comes_From_Source
(T2
))
817 and then (Is_Overloadable
(Designated_Type
(T2
))
819 Ekind
(Designated_Type
(T2
)) = E_Subprogram_Type
)
821 Type_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
823 Mode_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
827 -- The context can be a remote access type, and the expression the
828 -- corresponding source type declared in a categorized package, or
831 elsif Is_Record_Type
(T1
)
832 and then (Is_Remote_Call_Interface
(T1
)
833 or else Is_Remote_Types
(T1
))
834 and then Present
(Corresponding_Remote_Type
(T1
))
836 return Covers
(Corresponding_Remote_Type
(T1
), T2
);
838 elsif Is_Record_Type
(T2
)
839 and then (Is_Remote_Call_Interface
(T2
)
840 or else Is_Remote_Types
(T2
))
841 and then Present
(Corresponding_Remote_Type
(T2
))
843 return Covers
(Corresponding_Remote_Type
(T2
), T1
);
845 elsif Ekind
(T2
) = E_Access_Attribute_Type
846 and then (Ekind
(BT1
) = E_General_Access_Type
847 or else Ekind
(BT1
) = E_Access_Type
)
848 and then Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
850 -- If the target type is a RACW type while the source is an access
851 -- attribute type, we are building a RACW that may be exported.
853 if Is_Remote_Access_To_Class_Wide_Type
(BT1
) then
854 Set_Has_RACW
(Current_Sem_Unit
);
859 elsif Ekind
(T2
) = E_Allocator_Type
860 and then Is_Access_Type
(T1
)
862 return Covers
(Designated_Type
(T1
), Designated_Type
(T2
))
864 (From_With_Type
(Designated_Type
(T1
))
865 and then Covers
(Designated_Type
(T2
), Designated_Type
(T1
)));
867 -- A boolean operation on integer literals is compatible with modular
870 elsif T2
= Any_Modular
871 and then Is_Modular_Integer_Type
(T1
)
875 -- The actual type may be the result of a previous error
877 elsif Base_Type
(T2
) = Any_Type
then
880 -- A packed array type covers its corresponding non-packed type. This is
881 -- not legitimate Ada, but allows the omission of a number of otherwise
882 -- useless unchecked conversions, and since this can only arise in
883 -- (known correct) expanded code, no harm is done
885 elsif Is_Array_Type
(T2
)
886 and then Is_Packed
(T2
)
887 and then T1
= Packed_Array_Type
(T2
)
891 -- Similarly an array type covers its corresponding packed array type
893 elsif Is_Array_Type
(T1
)
894 and then Is_Packed
(T1
)
895 and then T2
= Packed_Array_Type
(T1
)
901 (Full_View_Covers
(T1
, T2
)
902 or else Full_View_Covers
(T2
, T1
))
906 -- In the expansion of inlined bodies, types are compatible if they
907 -- are structurally equivalent.
909 elsif In_Inlined_Body
910 and then (Underlying_Type
(T1
) = Underlying_Type
(T2
)
911 or else (Is_Access_Type
(T1
)
912 and then Is_Access_Type
(T2
)
914 Designated_Type
(T1
) = Designated_Type
(T2
))
915 or else (T1
= Any_Access
916 and then Is_Access_Type
(Underlying_Type
(T2
))))
920 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
921 -- compatible with its real entity.
923 elsif From_With_Type
(T1
) then
925 -- If the expected type is the non-limited view of a type, the
926 -- expression may have the limited view.
928 if Ekind
(T1
) = E_Incomplete_Type
then
929 return Covers
(Non_Limited_View
(T1
), T2
);
931 elsif Ekind
(T1
) = E_Class_Wide_Type
then
933 Covers
(Class_Wide_Type
(Non_Limited_View
(Etype
(T1
))), T2
);
938 elsif From_With_Type
(T2
) then
940 -- If units in the context have Limited_With clauses on each other,
941 -- either type might have a limited view. Checks performed elsewhere
942 -- verify that the context type is the non-limited view.
944 if Ekind
(T2
) = E_Incomplete_Type
then
945 return Covers
(T1
, Non_Limited_View
(T2
));
947 elsif Ekind
(T2
) = E_Class_Wide_Type
then
949 Covers
(T1
, Class_Wide_Type
(Non_Limited_View
(Etype
(T2
))));
954 -- Otherwise it doesn't cover!
965 function Disambiguate
967 I1
, I2
: Interp_Index
;
974 Nam1
, Nam2
: Entity_Id
;
975 Predef_Subp
: Entity_Id
;
976 User_Subp
: Entity_Id
;
978 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean;
979 -- Determine whether one of the candidates is an operation inherited by
980 -- a type that is derived from an actual in an instantiation.
982 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean;
983 -- Determine whether a subprogram is an actual in an enclosing instance.
984 -- An overloading between such a subprogram and one declared outside the
985 -- instance is resolved in favor of the first, because it resolved in
988 function Matches
(Actual
, Formal
: Node_Id
) return Boolean;
989 -- Look for exact type match in an instance, to remove spurious
990 -- ambiguities when two formal types have the same actual.
992 function Standard_Operator
return Boolean;
993 -- Comment required ???
995 function Remove_Conversions
return Interp
;
996 -- Last chance for pathological cases involving comparisons on literals,
997 -- and user overloadings of the same operator. Such pathologies have
998 -- been removed from the ACVC, but still appear in two DEC tests, with
999 -- the following notable quote from Ben Brosgol:
1001 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1002 -- this example; Robert Dewar brought it to our attention, since it is
1003 -- apparently found in the ACVC 1.5. I did not attempt to find the
1004 -- reason in the Reference Manual that makes the example legal, since I
1005 -- was too nauseated by it to want to pursue it further.]
1007 -- Accordingly, this is not a fully recursive solution, but it handles
1008 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1009 -- pathology in the other direction with calls whose multiple overloaded
1010 -- actuals make them truly unresolvable.
1012 ---------------------------
1013 -- Inherited_From_Actual --
1014 ---------------------------
1016 function Inherited_From_Actual
(S
: Entity_Id
) return Boolean is
1017 Par
: constant Node_Id
:= Parent
(S
);
1019 if Nkind
(Par
) /= N_Full_Type_Declaration
1020 or else Nkind
(Type_Definition
(Par
)) /= N_Derived_Type_Definition
1024 return Is_Entity_Name
(Subtype_Indication
(Type_Definition
(Par
)))
1026 Is_Generic_Actual_Type
(
1027 Entity
(Subtype_Indication
(Type_Definition
(Par
))));
1029 end Inherited_From_Actual
;
1031 --------------------------
1032 -- Is_Actual_Subprogram --
1033 --------------------------
1035 function Is_Actual_Subprogram
(S
: Entity_Id
) return Boolean is
1037 return In_Open_Scopes
(Scope
(S
))
1039 (Is_Generic_Instance
(Scope
(S
))
1040 or else Is_Wrapper_Package
(Scope
(S
)));
1041 end Is_Actual_Subprogram
;
1047 function Matches
(Actual
, Formal
: Node_Id
) return Boolean is
1048 T1
: constant Entity_Id
:= Etype
(Actual
);
1049 T2
: constant Entity_Id
:= Etype
(Formal
);
1053 (Is_Numeric_Type
(T2
)
1055 (T1
= Universal_Real
or else T1
= Universal_Integer
));
1058 ------------------------
1059 -- Remove_Conversions --
1060 ------------------------
1062 function Remove_Conversions
return Interp
is
1073 Get_First_Interp
(N
, I
, It
);
1074 while Present
(It
.Typ
) loop
1076 if not Is_Overloadable
(It
.Nam
) then
1080 F1
:= First_Formal
(It
.Nam
);
1086 if Nkind
(N
) = N_Function_Call
1087 or else Nkind
(N
) = N_Procedure_Call_Statement
1089 Act1
:= First_Actual
(N
);
1091 if Present
(Act1
) then
1092 Act2
:= Next_Actual
(Act1
);
1097 elsif Nkind
(N
) in N_Unary_Op
then
1098 Act1
:= Right_Opnd
(N
);
1101 elsif Nkind
(N
) in N_Binary_Op
then
1102 Act1
:= Left_Opnd
(N
);
1103 Act2
:= Right_Opnd
(N
);
1109 if Nkind
(Act1
) in N_Op
1110 and then Is_Overloaded
(Act1
)
1111 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1112 or else Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1113 and then Has_Compatible_Type
(Act1
, Standard_Boolean
)
1114 and then Etype
(F1
) = Standard_Boolean
1116 -- If the two candidates are the original ones, the
1117 -- ambiguity is real. Otherwise keep the original, further
1118 -- calls to Disambiguate will take care of others in the
1119 -- list of candidates.
1121 if It1
/= No_Interp
then
1122 if It
= Disambiguate
.It1
1123 or else It
= Disambiguate
.It2
1125 if It1
= Disambiguate
.It1
1126 or else It1
= Disambiguate
.It2
1134 elsif Present
(Act2
)
1135 and then Nkind
(Act2
) in N_Op
1136 and then Is_Overloaded
(Act2
)
1137 and then (Nkind
(Right_Opnd
(Act1
)) = N_Integer_Literal
1139 Nkind
(Right_Opnd
(Act1
)) = N_Real_Literal
)
1140 and then Has_Compatible_Type
(Act2
, Standard_Boolean
)
1142 -- The preference rule on the first actual is not
1143 -- sufficient to disambiguate.
1154 Get_Next_Interp
(I
, It
);
1157 -- After some error, a formal may have Any_Type and yield a spurious
1158 -- match. To avoid cascaded errors if possible, check for such a
1159 -- formal in either candidate.
1161 if Serious_Errors_Detected
> 0 then
1166 Formal
:= First_Formal
(Nam1
);
1167 while Present
(Formal
) loop
1168 if Etype
(Formal
) = Any_Type
then
1169 return Disambiguate
.It2
;
1172 Next_Formal
(Formal
);
1175 Formal
:= First_Formal
(Nam2
);
1176 while Present
(Formal
) loop
1177 if Etype
(Formal
) = Any_Type
then
1178 return Disambiguate
.It1
;
1181 Next_Formal
(Formal
);
1187 end Remove_Conversions
;
1189 -----------------------
1190 -- Standard_Operator --
1191 -----------------------
1193 function Standard_Operator
return Boolean is
1197 if Nkind
(N
) in N_Op
then
1200 elsif Nkind
(N
) = N_Function_Call
then
1203 if Nkind
(Nam
) /= N_Expanded_Name
then
1206 return Entity
(Prefix
(Nam
)) = Standard_Standard
;
1211 end Standard_Operator
;
1213 -- Start of processing for Disambiguate
1216 -- Recover the two legal interpretations
1218 Get_First_Interp
(N
, I
, It
);
1220 Get_Next_Interp
(I
, It
);
1226 Get_Next_Interp
(I
, It
);
1232 -- If the context is universal, the predefined operator is preferred.
1233 -- This includes bounds in numeric type declarations, and expressions
1234 -- in type conversions. If no interpretation yields a universal type,
1235 -- then we must check whether the user-defined entity hides the prede-
1238 if Chars
(Nam1
) in Any_Operator_Name
1239 and then Standard_Operator
1241 if Typ
= Universal_Integer
1242 or else Typ
= Universal_Real
1243 or else Typ
= Any_Integer
1244 or else Typ
= Any_Discrete
1245 or else Typ
= Any_Real
1246 or else Typ
= Any_Type
1248 -- Find an interpretation that yields the universal type, or else
1249 -- a predefined operator that yields a predefined numeric type.
1252 Candidate
: Interp
:= No_Interp
;
1255 Get_First_Interp
(N
, I
, It
);
1256 while Present
(It
.Typ
) loop
1257 if (Covers
(Typ
, It
.Typ
)
1258 or else Typ
= Any_Type
)
1260 (It
.Typ
= Universal_Integer
1261 or else It
.Typ
= Universal_Real
)
1265 elsif Covers
(Typ
, It
.Typ
)
1266 and then Scope
(It
.Typ
) = Standard_Standard
1267 and then Scope
(It
.Nam
) = Standard_Standard
1268 and then Is_Numeric_Type
(It
.Typ
)
1273 Get_Next_Interp
(I
, It
);
1276 if Candidate
/= No_Interp
then
1281 elsif Chars
(Nam1
) /= Name_Op_Not
1282 and then (Typ
= Standard_Boolean
or else Typ
= Any_Boolean
)
1284 -- Equality or comparison operation. Choose predefined operator if
1285 -- arguments are universal. The node may be an operator, name, or
1286 -- a function call, so unpack arguments accordingly.
1289 Arg1
, Arg2
: Node_Id
;
1292 if Nkind
(N
) in N_Op
then
1293 Arg1
:= Left_Opnd
(N
);
1294 Arg2
:= Right_Opnd
(N
);
1296 elsif Is_Entity_Name
(N
)
1297 or else Nkind
(N
) = N_Operator_Symbol
1299 Arg1
:= First_Entity
(Entity
(N
));
1300 Arg2
:= Next_Entity
(Arg1
);
1303 Arg1
:= First_Actual
(N
);
1304 Arg2
:= Next_Actual
(Arg1
);
1308 and then Present
(Universal_Interpretation
(Arg1
))
1309 and then Universal_Interpretation
(Arg2
) =
1310 Universal_Interpretation
(Arg1
)
1312 Get_First_Interp
(N
, I
, It
);
1313 while Scope
(It
.Nam
) /= Standard_Standard
loop
1314 Get_Next_Interp
(I
, It
);
1323 -- If no universal interpretation, check whether user-defined operator
1324 -- hides predefined one, as well as other special cases. If the node
1325 -- is a range, then one or both bounds are ambiguous. Each will have
1326 -- to be disambiguated w.r.t. the context type. The type of the range
1327 -- itself is imposed by the context, so we can return either legal
1330 if Ekind
(Nam1
) = E_Operator
then
1331 Predef_Subp
:= Nam1
;
1334 elsif Ekind
(Nam2
) = E_Operator
then
1335 Predef_Subp
:= Nam2
;
1338 elsif Nkind
(N
) = N_Range
then
1341 -- If two user defined-subprograms are visible, it is a true ambiguity,
1342 -- unless one of them is an entry and the context is a conditional or
1343 -- timed entry call, or unless we are within an instance and this is
1344 -- results from two formals types with the same actual.
1347 if Nkind
(N
) = N_Procedure_Call_Statement
1348 and then Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
1349 and then N
= Entry_Call_Statement
(Parent
(N
))
1351 if Ekind
(Nam2
) = E_Entry
then
1353 elsif Ekind
(Nam1
) = E_Entry
then
1359 -- If the ambiguity occurs within an instance, it is due to several
1360 -- formal types with the same actual. Look for an exact match between
1361 -- the types of the formals of the overloadable entities, and the
1362 -- actuals in the call, to recover the unambiguous match in the
1363 -- original generic.
1365 -- The ambiguity can also be due to an overloading between a formal
1366 -- subprogram and a subprogram declared outside the generic. If the
1367 -- node is overloaded, it did not resolve to the global entity in
1368 -- the generic, and we choose the formal subprogram.
1370 -- Finally, the ambiguity can be between an explicit subprogram and
1371 -- one inherited (with different defaults) from an actual. In this
1372 -- case the resolution was to the explicit declaration in the
1373 -- generic, and remains so in the instance.
1375 elsif In_Instance
then
1376 if Nkind
(N
) = N_Function_Call
1377 or else Nkind
(N
) = N_Procedure_Call_Statement
1382 Is_Act1
: constant Boolean := Is_Actual_Subprogram
(Nam1
);
1383 Is_Act2
: constant Boolean := Is_Actual_Subprogram
(Nam2
);
1386 if Is_Act1
and then not Is_Act2
then
1389 elsif Is_Act2
and then not Is_Act1
then
1392 elsif Inherited_From_Actual
(Nam1
)
1393 and then Comes_From_Source
(Nam2
)
1397 elsif Inherited_From_Actual
(Nam2
)
1398 and then Comes_From_Source
(Nam1
)
1403 Actual
:= First_Actual
(N
);
1404 Formal
:= First_Formal
(Nam1
);
1405 while Present
(Actual
) loop
1406 if Etype
(Actual
) /= Etype
(Formal
) then
1410 Next_Actual
(Actual
);
1411 Next_Formal
(Formal
);
1417 elsif Nkind
(N
) in N_Binary_Op
then
1418 if Matches
(Left_Opnd
(N
), First_Formal
(Nam1
))
1420 Matches
(Right_Opnd
(N
), Next_Formal
(First_Formal
(Nam1
)))
1427 elsif Nkind
(N
) in N_Unary_Op
then
1428 if Etype
(Right_Opnd
(N
)) = Etype
(First_Formal
(Nam1
)) then
1435 return Remove_Conversions
;
1438 return Remove_Conversions
;
1442 -- an implicit concatenation operator on a string type cannot be
1443 -- disambiguated from the predefined concatenation. This can only
1444 -- happen with concatenation of string literals.
1446 if Chars
(User_Subp
) = Name_Op_Concat
1447 and then Ekind
(User_Subp
) = E_Operator
1448 and then Is_String_Type
(Etype
(First_Formal
(User_Subp
)))
1452 -- If the user-defined operator is in an open scope, or in the scope
1453 -- of the resulting type, or given by an expanded name that names its
1454 -- scope, it hides the predefined operator for the type. Exponentiation
1455 -- has to be special-cased because the implicit operator does not have
1456 -- a symmetric signature, and may not be hidden by the explicit one.
1458 elsif (Nkind
(N
) = N_Function_Call
1459 and then Nkind
(Name
(N
)) = N_Expanded_Name
1460 and then (Chars
(Predef_Subp
) /= Name_Op_Expon
1461 or else Hides_Op
(User_Subp
, Predef_Subp
))
1462 and then Scope
(User_Subp
) = Entity
(Prefix
(Name
(N
))))
1463 or else Hides_Op
(User_Subp
, Predef_Subp
)
1465 if It1
.Nam
= User_Subp
then
1471 -- Otherwise, the predefined operator has precedence, or if the user-
1472 -- defined operation is directly visible we have a true ambiguity. If
1473 -- this is a fixed-point multiplication and division in Ada83 mode,
1474 -- exclude the universal_fixed operator, which often causes ambiguities
1478 if (In_Open_Scopes
(Scope
(User_Subp
))
1479 or else Is_Potentially_Use_Visible
(User_Subp
))
1480 and then not In_Instance
1482 if Is_Fixed_Point_Type
(Typ
)
1483 and then (Chars
(Nam1
) = Name_Op_Multiply
1484 or else Chars
(Nam1
) = Name_Op_Divide
)
1485 and then Ada_Version
= Ada_83
1487 if It2
.Nam
= Predef_Subp
then
1496 elsif It1
.Nam
= Predef_Subp
then
1505 ---------------------
1506 -- End_Interp_List --
1507 ---------------------
1509 procedure End_Interp_List
is
1511 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
1512 All_Interp
.Increment_Last
;
1513 end End_Interp_List
;
1515 -------------------------
1516 -- Entity_Matches_Spec --
1517 -------------------------
1519 function Entity_Matches_Spec
(Old_S
, New_S
: Entity_Id
) return Boolean is
1521 -- Simple case: same entity kinds, type conformance is required. A
1522 -- parameterless function can also rename a literal.
1524 if Ekind
(Old_S
) = Ekind
(New_S
)
1525 or else (Ekind
(New_S
) = E_Function
1526 and then Ekind
(Old_S
) = E_Enumeration_Literal
)
1528 return Type_Conformant
(New_S
, Old_S
);
1530 elsif Ekind
(New_S
) = E_Function
1531 and then Ekind
(Old_S
) = E_Operator
1533 return Operator_Matches_Spec
(Old_S
, New_S
);
1535 elsif Ekind
(New_S
) = E_Procedure
1536 and then Is_Entry
(Old_S
)
1538 return Type_Conformant
(New_S
, Old_S
);
1543 end Entity_Matches_Spec
;
1545 ----------------------
1546 -- Find_Unique_Type --
1547 ----------------------
1549 function Find_Unique_Type
(L
: Node_Id
; R
: Node_Id
) return Entity_Id
is
1550 T
: constant Entity_Id
:= Etype
(L
);
1553 TR
: Entity_Id
:= Any_Type
;
1556 if Is_Overloaded
(R
) then
1557 Get_First_Interp
(R
, I
, It
);
1558 while Present
(It
.Typ
) loop
1559 if Covers
(T
, It
.Typ
) or else Covers
(It
.Typ
, T
) then
1561 -- If several interpretations are possible and L is universal,
1562 -- apply preference rule.
1564 if TR
/= Any_Type
then
1566 if (T
= Universal_Integer
or else T
= Universal_Real
)
1577 Get_Next_Interp
(I
, It
);
1582 -- In the non-overloaded case, the Etype of R is already set correctly
1588 -- If one of the operands is Universal_Fixed, the type of the other
1589 -- operand provides the context.
1591 if Etype
(R
) = Universal_Fixed
then
1594 elsif T
= Universal_Fixed
then
1597 -- Ada 2005 (AI-230): Support the following operators:
1599 -- function "=" (L, R : universal_access) return Boolean;
1600 -- function "/=" (L, R : universal_access) return Boolean;
1602 elsif Ada_Version
>= Ada_05
1603 and then Ekind
(Etype
(L
)) = E_Anonymous_Access_Type
1604 and then Is_Access_Type
(Etype
(R
))
1608 elsif Ada_Version
>= Ada_05
1609 and then Ekind
(Etype
(R
)) = E_Anonymous_Access_Type
1610 and then Is_Access_Type
(Etype
(L
))
1615 return Specific_Type
(T
, Etype
(R
));
1618 end Find_Unique_Type
;
1620 ----------------------
1621 -- Get_First_Interp --
1622 ----------------------
1624 procedure Get_First_Interp
1626 I
: out Interp_Index
;
1630 Int_Ind
: Interp_Index
;
1634 -- If a selected component is overloaded because the selector has
1635 -- multiple interpretations, the node is a call to a protected
1636 -- operation or an indirect call. Retrieve the interpretation from
1637 -- the selector name. The selected component may be overloaded as well
1638 -- if the prefix is overloaded. That case is unchanged.
1640 if Nkind
(N
) = N_Selected_Component
1641 and then Is_Overloaded
(Selector_Name
(N
))
1643 O_N
:= Selector_Name
(N
);
1648 Map_Ptr
:= Headers
(Hash
(O_N
));
1649 while Present
(Interp_Map
.Table
(Map_Ptr
).Node
) loop
1650 if Interp_Map
.Table
(Map_Ptr
).Node
= O_N
then
1651 Int_Ind
:= Interp_Map
.Table
(Map_Ptr
).Index
;
1652 It
:= All_Interp
.Table
(Int_Ind
);
1656 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
1660 -- Procedure should never be called if the node has no interpretations
1662 raise Program_Error
;
1663 end Get_First_Interp
;
1665 ---------------------
1666 -- Get_Next_Interp --
1667 ---------------------
1669 procedure Get_Next_Interp
(I
: in out Interp_Index
; It
: out Interp
) is
1672 It
:= All_Interp
.Table
(I
);
1673 end Get_Next_Interp
;
1675 -------------------------
1676 -- Has_Compatible_Type --
1677 -------------------------
1679 function Has_Compatible_Type
1692 if Nkind
(N
) = N_Subtype_Indication
1693 or else not Is_Overloaded
(N
)
1696 Covers
(Typ
, Etype
(N
))
1698 -- Ada 2005 (AI-345) The context may be a synchronized interface.
1699 -- If the type is already frozen use the corresponding_record
1700 -- to check whether it is a proper descendant.
1703 (Is_Concurrent_Type
(Etype
(N
))
1704 and then Present
(Corresponding_Record_Type
(Etype
(N
)))
1705 and then Covers
(Typ
, Corresponding_Record_Type
(Etype
(N
))))
1708 (not Is_Tagged_Type
(Typ
)
1709 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1710 and then Covers
(Etype
(N
), Typ
));
1713 Get_First_Interp
(N
, I
, It
);
1714 while Present
(It
.Typ
) loop
1715 if (Covers
(Typ
, It
.Typ
)
1717 (Scope
(It
.Nam
) /= Standard_Standard
1718 or else not Is_Invisible_Operator
(N
, Base_Type
(Typ
))))
1720 -- Ada 2005 (AI-345)
1723 (Is_Concurrent_Type
(It
.Typ
)
1724 and then Present
(Corresponding_Record_Type
1726 and then Covers
(Typ
, Corresponding_Record_Type
1729 or else (not Is_Tagged_Type
(Typ
)
1730 and then Ekind
(Typ
) /= E_Anonymous_Access_Type
1731 and then Covers
(It
.Typ
, Typ
))
1736 Get_Next_Interp
(I
, It
);
1741 end Has_Compatible_Type
;
1747 function Hash
(N
: Node_Id
) return Int
is
1749 -- Nodes have a size that is power of two, so to select significant
1750 -- bits only we remove the low-order bits.
1752 return ((Int
(N
) / 2 ** 5) mod Header_Size
);
1759 function Hides_Op
(F
: Entity_Id
; Op
: Entity_Id
) return Boolean is
1760 Btyp
: constant Entity_Id
:= Base_Type
(Etype
(First_Formal
(F
)));
1762 return Operator_Matches_Spec
(Op
, F
)
1763 and then (In_Open_Scopes
(Scope
(F
))
1764 or else Scope
(F
) = Scope
(Btyp
)
1765 or else (not In_Open_Scopes
(Scope
(Btyp
))
1766 and then not In_Use
(Btyp
)
1767 and then not In_Use
(Scope
(Btyp
))));
1770 ------------------------
1771 -- Init_Interp_Tables --
1772 ------------------------
1774 procedure Init_Interp_Tables
is
1778 Headers
:= (others => No_Entry
);
1779 end Init_Interp_Tables
;
1781 -----------------------------------
1782 -- Interface_Present_In_Ancestor --
1783 -----------------------------------
1785 function Interface_Present_In_Ancestor
1787 Iface
: Entity_Id
) return Boolean
1789 Target_Typ
: Entity_Id
;
1791 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean;
1792 -- Returns True if Typ or some ancestor of Typ implements Iface
1794 function Iface_Present_In_Ancestor
(Typ
: Entity_Id
) return Boolean is
1806 if Present
(Abstract_Interfaces
(E
))
1807 and then Present
(Abstract_Interfaces
(E
))
1808 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
))
1810 Elmt
:= First_Elmt
(Abstract_Interfaces
(E
));
1811 while Present
(Elmt
) loop
1814 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
1822 exit when Etype
(E
) = E
;
1824 -- Check if the current type is a direct derivation of the
1827 if Etype
(E
) = Iface
then
1831 -- Climb to the immediate ancestor
1837 end Iface_Present_In_Ancestor
;
1840 if Is_Access_Type
(Typ
) then
1841 Target_Typ
:= Etype
(Directly_Designated_Type
(Typ
));
1846 -- In case of concurrent types we can't use the Corresponding Record_Typ
1847 -- to look for the interface because it is built by the expander (and
1848 -- hence it is not always available). For this reason we traverse the
1849 -- list of interfaces (available in the parent of the concurrent type)
1851 if Is_Concurrent_Type
(Target_Typ
) then
1852 if Present
(Interface_List
(Parent
(Target_Typ
))) then
1856 AI
:= First
(Interface_List
(Parent
(Target_Typ
)));
1857 while Present
(AI
) loop
1858 if Etype
(AI
) = Iface
then
1861 elsif Present
(Abstract_Interfaces
(Etype
(AI
)))
1862 and then Iface_Present_In_Ancestor
(Etype
(AI
))
1875 if Is_Class_Wide_Type
(Target_Typ
) then
1876 Target_Typ
:= Etype
(Target_Typ
);
1879 if Ekind
(Target_Typ
) = E_Incomplete_Type
then
1880 pragma Assert
(Present
(Non_Limited_View
(Target_Typ
)));
1881 Target_Typ
:= Non_Limited_View
(Target_Typ
);
1884 return Iface_Present_In_Ancestor
(Target_Typ
);
1885 end Interface_Present_In_Ancestor
;
1887 ---------------------
1888 -- Intersect_Types --
1889 ---------------------
1891 function Intersect_Types
(L
, R
: Node_Id
) return Entity_Id
is
1892 Index
: Interp_Index
;
1896 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
;
1897 -- Find interpretation of right arg that has type compatible with T
1899 --------------------------
1900 -- Check_Right_Argument --
1901 --------------------------
1903 function Check_Right_Argument
(T
: Entity_Id
) return Entity_Id
is
1904 Index
: Interp_Index
;
1909 if not Is_Overloaded
(R
) then
1910 return Specific_Type
(T
, Etype
(R
));
1913 Get_First_Interp
(R
, Index
, It
);
1915 T2
:= Specific_Type
(T
, It
.Typ
);
1917 if T2
/= Any_Type
then
1921 Get_Next_Interp
(Index
, It
);
1922 exit when No
(It
.Typ
);
1927 end Check_Right_Argument
;
1929 -- Start processing for Intersect_Types
1932 if Etype
(L
) = Any_Type
or else Etype
(R
) = Any_Type
then
1936 if not Is_Overloaded
(L
) then
1937 Typ
:= Check_Right_Argument
(Etype
(L
));
1941 Get_First_Interp
(L
, Index
, It
);
1942 while Present
(It
.Typ
) loop
1943 Typ
:= Check_Right_Argument
(It
.Typ
);
1944 exit when Typ
/= Any_Type
;
1945 Get_Next_Interp
(Index
, It
);
1950 -- If Typ is Any_Type, it means no compatible pair of types was found
1952 if Typ
= Any_Type
then
1953 if Nkind
(Parent
(L
)) in N_Op
then
1954 Error_Msg_N
("incompatible types for operator", Parent
(L
));
1956 elsif Nkind
(Parent
(L
)) = N_Range
then
1957 Error_Msg_N
("incompatible types given in constraint", Parent
(L
));
1959 -- Ada 2005 (AI-251): Complete the error notification
1961 elsif Is_Class_Wide_Type
(Etype
(R
))
1962 and then Is_Interface
(Etype
(Class_Wide_Type
(Etype
(R
))))
1964 Error_Msg_NE
("(Ada 2005) does not implement interface }",
1965 L
, Etype
(Class_Wide_Type
(Etype
(R
))));
1968 Error_Msg_N
("incompatible types", Parent
(L
));
1973 end Intersect_Types
;
1979 function Is_Ancestor
(T1
, T2
: Entity_Id
) return Boolean is
1983 if Base_Type
(T1
) = Base_Type
(T2
) then
1986 elsif Is_Private_Type
(T1
)
1987 and then Present
(Full_View
(T1
))
1988 and then Base_Type
(T2
) = Base_Type
(Full_View
(T1
))
1996 -- If there was a error on the type declaration, do not recurse
1998 if Error_Posted
(Par
) then
2001 elsif Base_Type
(T1
) = Base_Type
(Par
)
2002 or else (Is_Private_Type
(T1
)
2003 and then Present
(Full_View
(T1
))
2004 and then Base_Type
(Par
) = Base_Type
(Full_View
(T1
)))
2008 elsif Is_Private_Type
(Par
)
2009 and then Present
(Full_View
(Par
))
2010 and then Full_View
(Par
) = Base_Type
(T1
)
2014 elsif Etype
(Par
) /= Par
then
2023 ---------------------------
2024 -- Is_Invisible_Operator --
2025 ---------------------------
2027 function Is_Invisible_Operator
2032 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2035 if Nkind
(N
) not in N_Op
then
2038 elsif not Comes_From_Source
(N
) then
2041 elsif No
(Universal_Interpretation
(Right_Opnd
(N
))) then
2044 elsif Nkind
(N
) in N_Binary_Op
2045 and then No
(Universal_Interpretation
(Left_Opnd
(N
)))
2051 and then not In_Open_Scopes
(Scope
(T
))
2052 and then not Is_Potentially_Use_Visible
(T
)
2053 and then not In_Use
(T
)
2054 and then not In_Use
(Scope
(T
))
2056 (Nkind
(Orig_Node
) /= N_Function_Call
2057 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
2058 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
2060 and then not In_Instance
;
2062 end Is_Invisible_Operator
;
2068 function Is_Subtype_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
2072 S
:= Ancestor_Subtype
(T1
);
2073 while Present
(S
) loop
2077 S
:= Ancestor_Subtype
(S
);
2088 procedure List_Interps
(Nam
: Node_Id
; Err
: Node_Id
) is
2089 Index
: Interp_Index
;
2093 Get_First_Interp
(Nam
, Index
, It
);
2094 while Present
(It
.Nam
) loop
2095 if Scope
(It
.Nam
) = Standard_Standard
2096 and then Scope
(It
.Typ
) /= Standard_Standard
2098 Error_Msg_Sloc
:= Sloc
(Parent
(It
.Typ
));
2099 Error_Msg_NE
(" & (inherited) declared#!", Err
, It
.Nam
);
2102 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
2103 Error_Msg_NE
(" & declared#!", Err
, It
.Nam
);
2106 Get_Next_Interp
(Index
, It
);
2114 procedure New_Interps
(N
: Node_Id
) is
2118 All_Interp
.Increment_Last
;
2119 All_Interp
.Table
(All_Interp
.Last
) := No_Interp
;
2121 Map_Ptr
:= Headers
(Hash
(N
));
2123 if Map_Ptr
= No_Entry
then
2125 -- Place new node at end of table
2127 Interp_Map
.Increment_Last
;
2128 Headers
(Hash
(N
)) := Interp_Map
.Last
;
2131 -- Place node at end of chain, or locate its previous entry
2134 if Interp_Map
.Table
(Map_Ptr
).Node
= N
then
2136 -- Node is already in the table, and is being rewritten.
2137 -- Start a new interp section, retain hash link.
2139 Interp_Map
.Table
(Map_Ptr
).Node
:= N
;
2140 Interp_Map
.Table
(Map_Ptr
).Index
:= All_Interp
.Last
;
2141 Set_Is_Overloaded
(N
, True);
2145 exit when Interp_Map
.Table
(Map_Ptr
).Next
= No_Entry
;
2146 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2150 -- Chain the new node
2152 Interp_Map
.Increment_Last
;
2153 Interp_Map
.Table
(Map_Ptr
).Next
:= Interp_Map
.Last
;
2156 Interp_Map
.Table
(Interp_Map
.Last
) := (N
, All_Interp
.Last
, No_Entry
);
2157 Set_Is_Overloaded
(N
, True);
2160 ---------------------------
2161 -- Operator_Matches_Spec --
2162 ---------------------------
2164 function Operator_Matches_Spec
(Op
, New_S
: Entity_Id
) return Boolean is
2165 Op_Name
: constant Name_Id
:= Chars
(Op
);
2166 T
: constant Entity_Id
:= Etype
(New_S
);
2174 -- To verify that a predefined operator matches a given signature,
2175 -- do a case analysis of the operator classes. Function can have one
2176 -- or two formals and must have the proper result type.
2178 New_F
:= First_Formal
(New_S
);
2179 Old_F
:= First_Formal
(Op
);
2181 while Present
(New_F
) and then Present
(Old_F
) loop
2183 Next_Formal
(New_F
);
2184 Next_Formal
(Old_F
);
2187 -- Definite mismatch if different number of parameters
2189 if Present
(Old_F
) or else Present
(New_F
) then
2195 T1
:= Etype
(First_Formal
(New_S
));
2197 if Op_Name
= Name_Op_Subtract
2198 or else Op_Name
= Name_Op_Add
2199 or else Op_Name
= Name_Op_Abs
2201 return Base_Type
(T1
) = Base_Type
(T
)
2202 and then Is_Numeric_Type
(T
);
2204 elsif Op_Name
= Name_Op_Not
then
2205 return Base_Type
(T1
) = Base_Type
(T
)
2206 and then Valid_Boolean_Arg
(Base_Type
(T
));
2215 T1
:= Etype
(First_Formal
(New_S
));
2216 T2
:= Etype
(Next_Formal
(First_Formal
(New_S
)));
2218 if Op_Name
= Name_Op_And
or else Op_Name
= Name_Op_Or
2219 or else Op_Name
= Name_Op_Xor
2221 return Base_Type
(T1
) = Base_Type
(T2
)
2222 and then Base_Type
(T1
) = Base_Type
(T
)
2223 and then Valid_Boolean_Arg
(Base_Type
(T
));
2225 elsif Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
2226 return Base_Type
(T1
) = Base_Type
(T2
)
2227 and then not Is_Limited_Type
(T1
)
2228 and then Is_Boolean_Type
(T
);
2230 elsif Op_Name
= Name_Op_Lt
or else Op_Name
= Name_Op_Le
2231 or else Op_Name
= Name_Op_Gt
or else Op_Name
= Name_Op_Ge
2233 return Base_Type
(T1
) = Base_Type
(T2
)
2234 and then Valid_Comparison_Arg
(T1
)
2235 and then Is_Boolean_Type
(T
);
2237 elsif Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
2238 return Base_Type
(T1
) = Base_Type
(T2
)
2239 and then Base_Type
(T1
) = Base_Type
(T
)
2240 and then Is_Numeric_Type
(T
);
2242 -- for division and multiplication, a user-defined function does
2243 -- not match the predefined universal_fixed operation, except in
2246 elsif Op_Name
= Name_Op_Divide
then
2247 return (Base_Type
(T1
) = Base_Type
(T2
)
2248 and then Base_Type
(T1
) = Base_Type
(T
)
2249 and then Is_Numeric_Type
(T
)
2250 and then (not Is_Fixed_Point_Type
(T
)
2251 or else Ada_Version
= Ada_83
))
2253 -- Mixed_Mode operations on fixed-point types
2255 or else (Base_Type
(T1
) = Base_Type
(T
)
2256 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2257 and then Is_Fixed_Point_Type
(T
))
2259 -- A user defined operator can also match (and hide) a mixed
2260 -- operation on universal literals.
2262 or else (Is_Integer_Type
(T2
)
2263 and then Is_Floating_Point_Type
(T1
)
2264 and then Base_Type
(T1
) = Base_Type
(T
));
2266 elsif Op_Name
= Name_Op_Multiply
then
2267 return (Base_Type
(T1
) = Base_Type
(T2
)
2268 and then Base_Type
(T1
) = Base_Type
(T
)
2269 and then Is_Numeric_Type
(T
)
2270 and then (not Is_Fixed_Point_Type
(T
)
2271 or else Ada_Version
= Ada_83
))
2273 -- Mixed_Mode operations on fixed-point types
2275 or else (Base_Type
(T1
) = Base_Type
(T
)
2276 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
2277 and then Is_Fixed_Point_Type
(T
))
2279 or else (Base_Type
(T2
) = Base_Type
(T
)
2280 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
2281 and then Is_Fixed_Point_Type
(T
))
2283 or else (Is_Integer_Type
(T2
)
2284 and then Is_Floating_Point_Type
(T1
)
2285 and then Base_Type
(T1
) = Base_Type
(T
))
2287 or else (Is_Integer_Type
(T1
)
2288 and then Is_Floating_Point_Type
(T2
)
2289 and then Base_Type
(T2
) = Base_Type
(T
));
2291 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
2292 return Base_Type
(T1
) = Base_Type
(T2
)
2293 and then Base_Type
(T1
) = Base_Type
(T
)
2294 and then Is_Integer_Type
(T
);
2296 elsif Op_Name
= Name_Op_Expon
then
2297 return Base_Type
(T1
) = Base_Type
(T
)
2298 and then Is_Numeric_Type
(T
)
2299 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
);
2301 elsif Op_Name
= Name_Op_Concat
then
2302 return Is_Array_Type
(T
)
2303 and then (Base_Type
(T
) = Base_Type
(Etype
(Op
)))
2304 and then (Base_Type
(T1
) = Base_Type
(T
)
2306 Base_Type
(T1
) = Base_Type
(Component_Type
(T
)))
2307 and then (Base_Type
(T2
) = Base_Type
(T
)
2309 Base_Type
(T2
) = Base_Type
(Component_Type
(T
)));
2315 end Operator_Matches_Spec
;
2321 procedure Remove_Interp
(I
: in out Interp_Index
) is
2325 -- Find end of Interp list and copy downward to erase the discarded one
2328 while Present
(All_Interp
.Table
(II
).Typ
) loop
2332 for J
in I
+ 1 .. II
loop
2333 All_Interp
.Table
(J
- 1) := All_Interp
.Table
(J
);
2336 -- Back up interp. index to insure that iterator will pick up next
2337 -- available interpretation.
2346 procedure Save_Interps
(Old_N
: Node_Id
; New_N
: Node_Id
) is
2348 O_N
: Node_Id
:= Old_N
;
2351 if Is_Overloaded
(Old_N
) then
2352 if Nkind
(Old_N
) = N_Selected_Component
2353 and then Is_Overloaded
(Selector_Name
(Old_N
))
2355 O_N
:= Selector_Name
(Old_N
);
2358 Map_Ptr
:= Headers
(Hash
(O_N
));
2360 while Interp_Map
.Table
(Map_Ptr
).Node
/= O_N
loop
2361 Map_Ptr
:= Interp_Map
.Table
(Map_Ptr
).Next
;
2362 pragma Assert
(Map_Ptr
/= No_Entry
);
2365 New_Interps
(New_N
);
2366 Interp_Map
.Table
(Interp_Map
.Last
).Index
:=
2367 Interp_Map
.Table
(Map_Ptr
).Index
;
2375 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
2376 B1
: constant Entity_Id
:= Base_Type
(T1
);
2377 B2
: constant Entity_Id
:= Base_Type
(T2
);
2379 function Is_Remote_Access
(T
: Entity_Id
) return Boolean;
2380 -- Check whether T is the equivalent type of a remote access type.
2381 -- If distribution is enabled, T is a legal context for Null.
2383 ----------------------
2384 -- Is_Remote_Access --
2385 ----------------------
2387 function Is_Remote_Access
(T
: Entity_Id
) return Boolean is
2389 return Is_Record_Type
(T
)
2390 and then (Is_Remote_Call_Interface
(T
)
2391 or else Is_Remote_Types
(T
))
2392 and then Present
(Corresponding_Remote_Type
(T
))
2393 and then Is_Access_Type
(Corresponding_Remote_Type
(T
));
2394 end Is_Remote_Access
;
2396 -- Start of processing for Specific_Type
2399 if T1
= Any_Type
or else T2
= Any_Type
then
2407 or else (T1
= Universal_Integer
and then Is_Integer_Type
(T2
))
2408 or else (T1
= Universal_Real
and then Is_Real_Type
(T2
))
2409 or else (T1
= Universal_Fixed
and then Is_Fixed_Point_Type
(T2
))
2410 or else (T1
= Any_Fixed
and then Is_Fixed_Point_Type
(T2
))
2415 or else (T2
= Universal_Integer
and then Is_Integer_Type
(T1
))
2416 or else (T2
= Universal_Real
and then Is_Real_Type
(T1
))
2417 or else (T2
= Universal_Fixed
and then Is_Fixed_Point_Type
(T1
))
2418 or else (T2
= Any_Fixed
and then Is_Fixed_Point_Type
(T1
))
2422 elsif T2
= Any_String
and then Is_String_Type
(T1
) then
2425 elsif T1
= Any_String
and then Is_String_Type
(T2
) then
2428 elsif T2
= Any_Character
and then Is_Character_Type
(T1
) then
2431 elsif T1
= Any_Character
and then Is_Character_Type
(T2
) then
2434 elsif T1
= Any_Access
2435 and then (Is_Access_Type
(T2
) or else Is_Remote_Access
(T2
))
2439 elsif T2
= Any_Access
2440 and then (Is_Access_Type
(T1
) or else Is_Remote_Access
(T1
))
2444 elsif T2
= Any_Composite
2445 and then Ekind
(T1
) in E_Array_Type
.. E_Record_Subtype
2449 elsif T1
= Any_Composite
2450 and then Ekind
(T2
) in E_Array_Type
.. E_Record_Subtype
2454 elsif T1
= Any_Modular
and then Is_Modular_Integer_Type
(T2
) then
2457 elsif T2
= Any_Modular
and then Is_Modular_Integer_Type
(T1
) then
2460 -- ----------------------------------------------------------
2461 -- Special cases for equality operators (all other predefined
2462 -- operators can never apply to tagged types)
2463 -- ----------------------------------------------------------
2465 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
2468 elsif Is_Class_Wide_Type
(T1
)
2469 and then Is_Class_Wide_Type
(T2
)
2470 and then Is_Interface
(Etype
(T2
))
2474 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
2475 -- class-wide interface T2
2477 elsif Is_Class_Wide_Type
(T2
)
2478 and then Is_Interface
(Etype
(T2
))
2479 and then Interface_Present_In_Ancestor
(Typ
=> T1
,
2480 Iface
=> Etype
(T2
))
2484 elsif Is_Class_Wide_Type
(T1
)
2485 and then Is_Ancestor
(Root_Type
(T1
), T2
)
2489 elsif Is_Class_Wide_Type
(T2
)
2490 and then Is_Ancestor
(Root_Type
(T2
), T1
)
2494 elsif (Ekind
(B1
) = E_Access_Subprogram_Type
2496 Ekind
(B1
) = E_Access_Protected_Subprogram_Type
)
2497 and then Ekind
(Designated_Type
(B1
)) /= E_Subprogram_Type
2498 and then Is_Access_Type
(T2
)
2502 elsif (Ekind
(B2
) = E_Access_Subprogram_Type
2504 Ekind
(B2
) = E_Access_Protected_Subprogram_Type
)
2505 and then Ekind
(Designated_Type
(B2
)) /= E_Subprogram_Type
2506 and then Is_Access_Type
(T1
)
2510 elsif (Ekind
(T1
) = E_Allocator_Type
2511 or else Ekind
(T1
) = E_Access_Attribute_Type
2512 or else Ekind
(T1
) = E_Anonymous_Access_Type
)
2513 and then Is_Access_Type
(T2
)
2517 elsif (Ekind
(T2
) = E_Allocator_Type
2518 or else Ekind
(T2
) = E_Access_Attribute_Type
2519 or else Ekind
(T2
) = E_Anonymous_Access_Type
)
2520 and then Is_Access_Type
(T1
)
2524 -- If none of the above cases applies, types are not compatible
2531 -----------------------
2532 -- Valid_Boolean_Arg --
2533 -----------------------
2535 -- In addition to booleans and arrays of booleans, we must include
2536 -- aggregates as valid boolean arguments, because in the first pass of
2537 -- resolution their components are not examined. If it turns out not to be
2538 -- an aggregate of booleans, this will be diagnosed in Resolve.
2539 -- Any_Composite must be checked for prior to the array type checks because
2540 -- Any_Composite does not have any associated indexes.
2542 function Valid_Boolean_Arg
(T
: Entity_Id
) return Boolean is
2544 return Is_Boolean_Type
(T
)
2545 or else T
= Any_Composite
2546 or else (Is_Array_Type
(T
)
2547 and then T
/= Any_String
2548 and then Number_Dimensions
(T
) = 1
2549 and then Is_Boolean_Type
(Component_Type
(T
))
2550 and then (not Is_Private_Composite
(T
)
2551 or else In_Instance
)
2552 and then (not Is_Limited_Composite
(T
)
2553 or else In_Instance
))
2554 or else Is_Modular_Integer_Type
(T
)
2555 or else T
= Universal_Integer
;
2556 end Valid_Boolean_Arg
;
2558 --------------------------
2559 -- Valid_Comparison_Arg --
2560 --------------------------
2562 function Valid_Comparison_Arg
(T
: Entity_Id
) return Boolean is
2565 if T
= Any_Composite
then
2567 elsif Is_Discrete_Type
(T
)
2568 or else Is_Real_Type
(T
)
2571 elsif Is_Array_Type
(T
)
2572 and then Number_Dimensions
(T
) = 1
2573 and then Is_Discrete_Type
(Component_Type
(T
))
2574 and then (not Is_Private_Composite
(T
)
2575 or else In_Instance
)
2576 and then (not Is_Limited_Composite
(T
)
2577 or else In_Instance
)
2580 elsif Is_String_Type
(T
) then
2585 end Valid_Comparison_Arg
;
2587 ---------------------
2588 -- Write_Overloads --
2589 ---------------------
2591 procedure Write_Overloads
(N
: Node_Id
) is
2597 if not Is_Overloaded
(N
) then
2598 Write_Str
("Non-overloaded entity ");
2600 Write_Entity_Info
(Entity
(N
), " ");
2603 Get_First_Interp
(N
, I
, It
);
2604 Write_Str
("Overloaded entity ");
2608 while Present
(Nam
) loop
2609 Write_Entity_Info
(Nam
, " ");
2610 Write_Str
("=================");
2612 Get_Next_Interp
(I
, It
);
2616 end Write_Overloads
;
2618 ----------------------
2619 -- Write_Interp_Ref --
2620 ----------------------
2622 procedure Write_Interp_Ref
(Map_Ptr
: Int
) is
2624 Write_Str
(" Node: ");
2625 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Node
));
2626 Write_Str
(" Index: ");
2627 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Index
));
2628 Write_Str
(" Next: ");
2629 Write_Int
(Int
(Interp_Map
.Table
(Map_Ptr
).Next
));
2631 end Write_Interp_Ref
;