1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree; use Atree;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
34 with Output; use Output;
36 with Sem_Ch6; use Sem_Ch6;
37 with Sem_Ch8; use Sem_Ch8;
38 with Sem_Util; use Sem_Util;
39 with Stand; use Stand;
40 with Sinfo; use Sinfo;
41 with Snames; use Snames;
42 with Uintp; use Uintp;
44 package body Sem_Type is
46 -------------------------------------
47 -- Handling of Overload Resolution --
48 -------------------------------------
50 -- Overload resolution uses two passes over the syntax tree of a complete
51 -- context. In the first, bottom-up pass, the types of actuals in calls
52 -- are used to resolve possibly overloaded subprogram and operator names.
53 -- In the second top-down pass, the type of the context (for example the
54 -- condition in a while statement) is used to resolve a possibly ambiguous
55 -- call, and the unique subprogram name in turn imposes a specific context
56 -- on each of its actuals.
58 -- Most expressions are in fact unambiguous, and the bottom-up pass is
59 -- sufficient to resolve most everything. To simplify the common case,
60 -- names and expressions carry a flag Is_Overloaded to indicate whether
61 -- they have more than one interpretation. If the flag is off, then each
62 -- name has already a unique meaning and type, and the bottom-up pass is
63 -- sufficient (and much simpler).
65 --------------------------
66 -- Operator Overloading --
67 --------------------------
69 -- The visibility of operators is handled differently from that of
70 -- other entities. We do not introduce explicit versions of primitive
71 -- operators for each type definition. As a result, there is only one
72 -- entity corresponding to predefined addition on all numeric types, etc.
73 -- The back-end resolves predefined operators according to their type.
74 -- The visibility of primitive operations then reduces to the visibility
75 -- of the resulting type: (a + b) is a legal interpretation of some
76 -- primitive operator + if the type of the result (which must also be
77 -- the type of a and b) is directly visible (i.e. either immediately
78 -- visible or use-visible.)
80 -- User-defined operators are treated like other functions, but the
81 -- visibility of these user-defined operations must be special-cased
82 -- to determine whether they hide or are hidden by predefined operators.
83 -- The form P."+" (x, y) requires additional handling.
85 -- Concatenation is treated more conventionally: for every one-dimensional
86 -- array type we introduce a explicit concatenation operator. This is
87 -- necessary to handle the case of (element & element => array) which
88 -- cannot be handled conveniently if there is no explicit instance of
89 -- resulting type of the operation.
91 -----------------------
92 -- Local Subprograms --
93 -----------------------
95 procedure All_Overloads;
96 pragma Warnings (Off, All_Overloads);
97 -- Debugging procedure: list full contents of Overloads table.
99 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
100 -- Yields universal_Integer or Universal_Real if this is a candidate.
102 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
103 -- If T1 and T2 are compatible, return the one that is not
104 -- universal or is not a "class" type (any_character, etc).
110 procedure Add_One_Interp
114 Opnd_Type : Entity_Id := Empty)
116 Vis_Type : Entity_Id;
118 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
119 -- Add one interpretation to node. Node is already known to be
120 -- overloaded. Add new interpretation if not hidden by previous
121 -- one, and remove previous one if hidden by new one.
123 function Is_Universal_Operation (Op : Entity_Id) return Boolean;
124 -- True if the entity is a predefined operator and the operands have
125 -- a universal Interpretation.
131 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
132 Index : Interp_Index;
136 Get_First_Interp (N, Index, It);
138 while Present (It.Nam) loop
140 -- A user-defined subprogram hides another declared at an outer
141 -- level, or one that is use-visible. So return if previous
142 -- definition hides new one (which is either in an outer
143 -- scope, or use-visible). Note that for functions use-visible
144 -- is the same as potentially use-visible. If new one hides
145 -- previous one, replace entry in table of interpretations.
146 -- If this is a universal operation, retain the operator in case
147 -- preference rule applies.
149 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
150 and then Ekind (Name) = Ekind (It.Nam))
151 or else (Ekind (Name) = E_Operator
152 and then Ekind (It.Nam) = E_Function))
154 and then Is_Immediately_Visible (It.Nam)
155 and then Type_Conformant (Name, It.Nam)
156 and then Base_Type (It.Typ) = Base_Type (T)
158 if Is_Universal_Operation (Name) then
161 -- If node is an operator symbol, we have no actuals with
162 -- which to check hiding, and this is done in full in the
163 -- caller (Analyze_Subprogram_Renaming) so we include the
164 -- predefined operator in any case.
166 elsif Nkind (N) = N_Operator_Symbol
167 or else (Nkind (N) = N_Expanded_Name
169 Nkind (Selector_Name (N)) = N_Operator_Symbol)
173 elsif not In_Open_Scopes (Scope (Name))
174 or else Scope_Depth (Scope (Name))
175 <= Scope_Depth (Scope (It.Nam))
177 -- If ambiguity within instance, and entity is not an
178 -- implicit operation, save for later disambiguation.
180 if Scope (Name) = Scope (It.Nam)
181 and then not Is_Inherited_Operation (Name)
190 All_Interp.Table (Index).Nam := Name;
194 -- Avoid making duplicate entries in overloads
197 and then Base_Type (It.Typ) = Base_Type (T)
201 -- Otherwise keep going
204 Get_Next_Interp (Index, It);
209 -- On exit, enter new interpretation. The context, or a preference
210 -- rule, will resolve the ambiguity on the second pass.
212 All_Interp.Table (All_Interp.Last) := (Name, Typ);
213 All_Interp.Increment_Last;
214 All_Interp.Table (All_Interp.Last) := No_Interp;
218 ----------------------------
219 -- Is_Universal_Operation --
220 ----------------------------
222 function Is_Universal_Operation (Op : Entity_Id) return Boolean is
226 if Ekind (Op) /= E_Operator then
229 elsif Nkind (N) in N_Binary_Op then
230 return Present (Universal_Interpretation (Left_Opnd (N)))
231 and then Present (Universal_Interpretation (Right_Opnd (N)));
233 elsif Nkind (N) in N_Unary_Op then
234 return Present (Universal_Interpretation (Right_Opnd (N)));
236 elsif Nkind (N) = N_Function_Call then
237 Arg := First_Actual (N);
239 while Present (Arg) loop
241 if No (Universal_Interpretation (Arg)) then
253 end Is_Universal_Operation;
255 -- Start of processing for Add_One_Interp
258 -- If the interpretation is a predefined operator, verify that the
259 -- result type is visible, or that the entity has already been
260 -- resolved (case of an instantiation node that refers to a predefined
261 -- operation, or an internally generated operator node, or an operator
262 -- given as an expanded name). If the operator is a comparison or
263 -- equality, it is the type of the operand that matters to determine
264 -- whether the operator is visible. In an instance, the check is not
265 -- performed, given that the operator was visible in the generic.
267 if Ekind (E) = E_Operator then
269 if Present (Opnd_Type) then
270 Vis_Type := Opnd_Type;
272 Vis_Type := Base_Type (T);
275 if In_Open_Scopes (Scope (Vis_Type))
276 or else Is_Potentially_Use_Visible (Vis_Type)
277 or else In_Use (Vis_Type)
278 or else (In_Use (Scope (Vis_Type))
279 and then not Is_Hidden (Vis_Type))
280 or else Nkind (N) = N_Expanded_Name
281 or else (Nkind (N) in N_Op and then E = Entity (N))
286 -- If the node is given in functional notation and the prefix
287 -- is an expanded name, then the operator is visible if the
288 -- prefix is the scope of the result type as well. If the
289 -- operator is (implicitly) defined in an extension of system,
290 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
292 elsif Nkind (N) = N_Function_Call
293 and then Nkind (Name (N)) = N_Expanded_Name
294 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
295 or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
296 or else Scope (Vis_Type) = System_Aux_Id)
300 -- Save type for subsequent error message, in case no other
301 -- interpretation is found.
304 Candidate_Type := Vis_Type;
308 -- In an instance, an abstract non-dispatching operation cannot
309 -- be a candidate interpretation, because it could not have been
310 -- one in the generic (it may be a spurious overloading in the
314 and then Is_Abstract (E)
315 and then not Is_Dispatching_Operation (E)
320 -- If this is the first interpretation of N, N has type Any_Type.
321 -- In that case place the new type on the node. If one interpretation
322 -- already exists, indicate that the node is overloaded, and store
323 -- both the previous and the new interpretation in All_Interp. If
324 -- this is a later interpretation, just add it to the set.
326 if Etype (N) = Any_Type then
331 -- Record both the operator or subprogram name, and its type.
333 if Nkind (N) in N_Op or else Is_Entity_Name (N) then
340 -- Either there is no current interpretation in the table for any
341 -- node or the interpretation that is present is for a different
342 -- node. In both cases add a new interpretation to the table.
344 elsif Interp_Map.Last < 0
345 or else Interp_Map.Table (Interp_Map.Last).Node /= N
349 if (Nkind (N) in N_Op or else Is_Entity_Name (N))
350 and then Present (Entity (N))
352 Add_Entry (Entity (N), Etype (N));
354 elsif (Nkind (N) = N_Function_Call
355 or else Nkind (N) = N_Procedure_Call_Statement)
356 and then (Nkind (Name (N)) = N_Operator_Symbol
357 or else Is_Entity_Name (Name (N)))
359 Add_Entry (Entity (Name (N)), Etype (N));
362 -- Overloaded prefix in indexed or selected component,
363 -- or call whose name is an expression or another call.
365 Add_Entry (Etype (N), Etype (N));
379 procedure All_Overloads is
381 for J in All_Interp.First .. All_Interp.Last loop
383 if Present (All_Interp.Table (J).Nam) then
384 Write_Entity_Info (All_Interp.Table (J). Nam, " ");
386 Write_Str ("No Interp");
389 Write_Str ("=================");
394 ---------------------
395 -- Collect_Interps --
396 ---------------------
398 procedure Collect_Interps (N : Node_Id) is
399 Ent : constant Entity_Id := Entity (N);
401 First_Interp : Interp_Index;
406 -- Unconditionally add the entity that was initially matched
408 First_Interp := All_Interp.Last;
409 Add_One_Interp (N, Ent, Etype (N));
411 -- For expanded name, pick up all additional entities from the
412 -- same scope, since these are obviously also visible. Note that
413 -- these are not necessarily contiguous on the homonym chain.
415 if Nkind (N) = N_Expanded_Name then
417 while Present (H) loop
418 if Scope (H) = Scope (Entity (N)) then
419 Add_One_Interp (N, H, Etype (H));
425 -- Case of direct name
428 -- First, search the homonym chain for directly visible entities
430 H := Current_Entity (Ent);
431 while Present (H) loop
432 exit when (not Is_Overloadable (H))
433 and then Is_Immediately_Visible (H);
435 if Is_Immediately_Visible (H)
438 -- Only add interpretation if not hidden by an inner
439 -- immediately visible one.
441 for J in First_Interp .. All_Interp.Last - 1 loop
443 -- Current homograph is not hidden. Add to overloads.
445 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
448 -- Homograph is hidden, unless it is a predefined operator.
450 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
452 -- A homograph in the same scope can occur within an
453 -- instantiation, the resulting ambiguity has to be
456 if Scope (H) = Scope (Ent)
458 and then not Is_Inherited_Operation (H)
460 All_Interp.Table (All_Interp.Last) := (H, Etype (H));
461 All_Interp.Increment_Last;
462 All_Interp.Table (All_Interp.Last) := No_Interp;
465 elsif Scope (H) /= Standard_Standard then
471 -- On exit, we know that current homograph is not hidden.
473 Add_One_Interp (N, H, Etype (H));
476 Write_Str ("Add overloaded Interpretation ");
486 -- Scan list of homographs for use-visible entities only.
488 H := Current_Entity (Ent);
490 while Present (H) loop
491 if Is_Potentially_Use_Visible (H)
493 and then Is_Overloadable (H)
495 for J in First_Interp .. All_Interp.Last - 1 loop
497 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
500 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
501 goto Next_Use_Homograph;
505 Add_One_Interp (N, H, Etype (H));
508 <<Next_Use_Homograph>>
513 if All_Interp.Last = First_Interp + 1 then
515 -- The original interpretation is in fact not overloaded.
517 Set_Is_Overloaded (N, False);
525 function Covers (T1, T2 : Entity_Id) return Boolean is
527 -- If either operand missing, then this is an error, but ignore
528 -- it (and pretend we have a cover) if errors already detected,
529 -- since this may simply mean we have malformed trees.
531 if No (T1) or else No (T2) then
532 if Total_Errors_Detected /= 0 then
539 -- Simplest case: same types are compatible, and types that have the
540 -- same base type and are not generic actuals are compatible. Generic
541 -- actuals belong to their class but are not compatible with other
542 -- types of their class, and in particular with other generic actuals.
543 -- They are however compatible with their own subtypes, and itypes
544 -- with the same base are compatible as well. Similary, constrained
545 -- subtypes obtained from expressions of an unconstrained nominal type
546 -- are compatible with the base type (may lead to spurious ambiguities
547 -- in obscure cases ???)
549 -- Generic actuals require special treatment to avoid spurious ambi-
550 -- guities in an instance, when two formal types are instantiated with
551 -- the same actual, so that different subprograms end up with the same
552 -- signature in the instance.
557 elsif Base_Type (T1) = Base_Type (T2) then
558 if not Is_Generic_Actual_Type (T1) then
561 return (not Is_Generic_Actual_Type (T2)
562 or else Is_Itype (T1)
563 or else Is_Itype (T2)
564 or else Is_Constr_Subt_For_U_Nominal (T1)
565 or else Is_Constr_Subt_For_U_Nominal (T2)
566 or else Scope (T1) /= Scope (T2));
569 -- Literals are compatible with types in a given "class"
571 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
572 or else (T2 = Universal_Real and then Is_Real_Type (T1))
573 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
574 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
575 or else (T2 = Any_String and then Is_String_Type (T1))
576 or else (T2 = Any_Character and then Is_Character_Type (T1))
577 or else (T2 = Any_Access and then Is_Access_Type (T1))
581 -- The context may be class wide.
583 elsif Is_Class_Wide_Type (T1)
584 and then Is_Ancestor (Root_Type (T1), T2)
588 elsif Is_Class_Wide_Type (T1)
589 and then Is_Class_Wide_Type (T2)
590 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
594 -- In a dispatching call the actual may be class-wide
596 elsif Is_Class_Wide_Type (T2)
597 and then Base_Type (Root_Type (T2)) = Base_Type (T1)
601 -- Some contexts require a class of types rather than a specific type
603 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
604 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
605 or else (T1 = Any_Real and then Is_Real_Type (T2))
606 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
607 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
611 -- An aggregate is compatible with an array or record type
613 elsif T2 = Any_Composite
614 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
618 -- If the expected type is an anonymous access, the designated
619 -- type must cover that of the expression.
621 elsif Ekind (T1) = E_Anonymous_Access_Type
622 and then Is_Access_Type (T2)
623 and then Covers (Designated_Type (T1), Designated_Type (T2))
627 -- An Access_To_Subprogram is compatible with itself, or with an
628 -- anonymous type created for an attribute reference Access.
630 elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type
632 Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type)
633 and then Is_Access_Type (T2)
634 and then (not Comes_From_Source (T1)
635 or else not Comes_From_Source (T2))
636 and then (Is_Overloadable (Designated_Type (T2))
638 Ekind (Designated_Type (T2)) = E_Subprogram_Type)
640 Type_Conformant (Designated_Type (T1), Designated_Type (T2))
642 Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
646 elsif Is_Record_Type (T1)
647 and then (Is_Remote_Call_Interface (T1)
648 or else Is_Remote_Types (T1))
649 and then Present (Corresponding_Remote_Type (T1))
651 return Covers (Corresponding_Remote_Type (T1), T2);
653 elsif Ekind (T2) = E_Access_Attribute_Type
654 and then (Ekind (Base_Type (T1)) = E_General_Access_Type
655 or else Ekind (Base_Type (T1)) = E_Access_Type)
656 and then Covers (Designated_Type (T1), Designated_Type (T2))
658 -- If the target type is a RACW type while the source is an access
659 -- attribute type, we are building a RACW that may be exported.
661 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then
662 Set_Has_RACW (Current_Sem_Unit);
667 elsif Ekind (T2) = E_Allocator_Type
668 and then Is_Access_Type (T1)
669 and then Covers (Designated_Type (T1), Designated_Type (T2))
673 -- A boolean operation on integer literals is compatible with a
676 elsif T2 = Any_Modular
677 and then Is_Modular_Integer_Type (T1)
681 -- The actual type may be the result of a previous error
683 elsif Base_Type (T2) = Any_Type then
686 -- A packed array type covers its corresponding non-packed type.
687 -- This is not legitimate Ada, but allows the omission of a number
688 -- of otherwise useless unchecked conversions, and since this can
689 -- only arise in (known correct) expanded code, no harm is done
691 elsif Is_Array_Type (T2)
692 and then Is_Packed (T2)
693 and then T1 = Packed_Array_Type (T2)
697 -- Similarly an array type covers its corresponding packed array type
699 elsif Is_Array_Type (T1)
700 and then Is_Packed (T1)
701 and then T2 = Packed_Array_Type (T1)
705 -- In an instance the proper view may not always be correct for
706 -- private types, but private and full view are compatible. This
707 -- removes spurious errors from nested instantiations that involve,
708 -- among other things, types derived from privated types.
711 and then Is_Private_Type (T1)
712 and then ((Present (Full_View (T1))
713 and then Covers (Full_View (T1), T2))
714 or else Base_Type (T1) = T2
715 or else Base_Type (T2) = T1)
719 -- In the expansion of inlined bodies, types are compatible if they
720 -- are structurally equivalent.
722 elsif In_Inlined_Body
723 and then (Underlying_Type (T1) = Underlying_Type (T2)
724 or else (Is_Access_Type (T1)
725 and then Is_Access_Type (T2)
727 Designated_Type (T1) = Designated_Type (T2))
728 or else (T1 = Any_Access
729 and then Is_Access_Type (Underlying_Type (T2))))
733 -- Otherwise it doesn't cover!
744 function Disambiguate
746 I1, I2 : Interp_Index;
753 Nam1, Nam2 : Entity_Id;
754 Predef_Subp : Entity_Id;
755 User_Subp : Entity_Id;
757 function Matches (Actual, Formal : Node_Id) return Boolean;
758 -- Look for exact type match in an instance, to remove spurious
759 -- ambiguities when two formal types have the same actual.
761 function Standard_Operator return Boolean;
763 function Remove_Conversions return Interp;
764 -- Last chance for pathological cases involving comparisons on
765 -- literals, and user overloadings of the same operator. Such
766 -- pathologies have been removed from the ACVC, but still appear in
767 -- two DEC tests, with the following notable quote from Ben Brosgol:
769 -- [Note: I disclaim all credit/responsibility/blame for coming up with
770 -- this example; Robert Dewar brought it to our attention, since it
771 -- is apparently found in the ACVC 1.5. I did not attempt to find
772 -- the reason in the Reference Manual that makes the example legal,
773 -- since I was too nauseated by it to want to pursue it further.]
775 -- Accordingly, this is not a fully recursive solution, but it handles
776 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
777 -- pathology in the other direction with calls whose multiple overloaded
778 -- actuals make them truly unresolvable.
784 function Matches (Actual, Formal : Node_Id) return Boolean is
785 T1 : constant Entity_Id := Etype (Actual);
786 T2 : constant Entity_Id := Etype (Formal);
791 (Is_Numeric_Type (T2)
793 (T1 = Universal_Real or else T1 = Universal_Integer));
796 ------------------------
797 -- Remove_Conversions --
798 ------------------------
800 function Remove_Conversions return Interp is
810 Get_First_Interp (N, I, It);
812 while Present (It.Typ) loop
814 if not Is_Overloadable (It.Nam) then
818 F1 := First_Formal (It.Nam);
824 if Nkind (N) = N_Function_Call
825 or else Nkind (N) = N_Procedure_Call_Statement
827 Act1 := First_Actual (N);
829 if Present (Act1) then
830 Act2 := Next_Actual (Act1);
835 elsif Nkind (N) in N_Unary_Op then
836 Act1 := Right_Opnd (N);
839 elsif Nkind (N) in N_Binary_Op then
840 Act1 := Left_Opnd (N);
841 Act2 := Right_Opnd (N);
847 if Nkind (Act1) in N_Op
848 and then Is_Overloaded (Act1)
849 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
850 or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
851 and then Has_Compatible_Type (Act1, Standard_Boolean)
852 and then Etype (F1) = Standard_Boolean
855 if It1 /= No_Interp then
859 and then Nkind (Act2) in N_Op
860 and then Is_Overloaded (Act2)
861 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
863 Nkind (Right_Opnd (Act1)) = N_Real_Literal)
864 and then Has_Compatible_Type (Act2, Standard_Boolean)
866 -- The preference rule on the first actual is not
867 -- sufficient to disambiguate.
878 Get_Next_Interp (I, It);
881 if Serious_Errors_Detected > 0 then
883 -- After some error, a formal may have Any_Type and yield
884 -- a spurious match. To avoid cascaded errors if possible,
885 -- check for such a formal in either candidate.
891 Formal := First_Formal (Nam1);
892 while Present (Formal) loop
893 if Etype (Formal) = Any_Type then
894 return Disambiguate.It2;
897 Next_Formal (Formal);
900 Formal := First_Formal (Nam2);
901 while Present (Formal) loop
902 if Etype (Formal) = Any_Type then
903 return Disambiguate.It1;
906 Next_Formal (Formal);
912 end Remove_Conversions;
914 -----------------------
915 -- Standard_Operator --
916 -----------------------
918 function Standard_Operator return Boolean is
922 if Nkind (N) in N_Op then
925 elsif Nkind (N) = N_Function_Call then
928 if Nkind (Nam) /= N_Expanded_Name then
931 return Entity (Prefix (Nam)) = Standard_Standard;
936 end Standard_Operator;
938 -- Start of processing for Disambiguate
941 -- Recover the two legal interpretations.
943 Get_First_Interp (N, I, It);
946 Get_Next_Interp (I, It);
953 Get_Next_Interp (I, It);
959 -- If the context is universal, the predefined operator is preferred.
960 -- This includes bounds in numeric type declarations, and expressions
961 -- in type conversions. If no interpretation yields a universal type,
962 -- then we must check whether the user-defined entity hides the prede-
965 if Chars (Nam1) in Any_Operator_Name
966 and then Standard_Operator
968 if Typ = Universal_Integer
969 or else Typ = Universal_Real
970 or else Typ = Any_Integer
971 or else Typ = Any_Discrete
972 or else Typ = Any_Real
973 or else Typ = Any_Type
975 -- Find an interpretation that yields the universal type, or else
976 -- a predefined operator that yields a predefined numeric type.
979 Candidate : Interp := No_Interp;
981 Get_First_Interp (N, I, It);
983 while Present (It.Typ) loop
984 if (Covers (Typ, It.Typ)
985 or else Typ = Any_Type)
987 (It.Typ = Universal_Integer
988 or else It.Typ = Universal_Real)
992 elsif Covers (Typ, It.Typ)
993 and then Scope (It.Typ) = Standard_Standard
994 and then Scope (It.Nam) = Standard_Standard
995 and then Is_Numeric_Type (It.Typ)
1000 Get_Next_Interp (I, It);
1003 if Candidate /= No_Interp then
1008 elsif Chars (Nam1) /= Name_Op_Not
1009 and then (Typ = Standard_Boolean
1010 or else Typ = Any_Boolean)
1012 -- Equality or comparison operation. Choose predefined operator
1013 -- if arguments are universal. The node may be an operator, a
1014 -- name, or a function call, so unpack arguments accordingly.
1017 Arg1, Arg2 : Node_Id;
1020 if Nkind (N) in N_Op then
1021 Arg1 := Left_Opnd (N);
1022 Arg2 := Right_Opnd (N);
1024 elsif Is_Entity_Name (N)
1025 or else Nkind (N) = N_Operator_Symbol
1027 Arg1 := First_Entity (Entity (N));
1028 Arg2 := Next_Entity (Arg1);
1031 Arg1 := First_Actual (N);
1032 Arg2 := Next_Actual (Arg1);
1036 and then Present (Universal_Interpretation (Arg1))
1037 and then Universal_Interpretation (Arg2) =
1038 Universal_Interpretation (Arg1)
1040 Get_First_Interp (N, I, It);
1042 while Scope (It.Nam) /= Standard_Standard loop
1043 Get_Next_Interp (I, It);
1052 -- If no universal interpretation, check whether user-defined operator
1053 -- hides predefined one, as well as other special cases. If the node
1054 -- is a range, then one or both bounds are ambiguous. Each will have
1055 -- to be disambiguated w.r.t. the context type. The type of the range
1056 -- itself is imposed by the context, so we can return either legal
1059 if Ekind (Nam1) = E_Operator then
1060 Predef_Subp := Nam1;
1063 elsif Ekind (Nam2) = E_Operator then
1064 Predef_Subp := Nam2;
1067 elsif Nkind (N) = N_Range then
1070 -- If two user defined-subprograms are visible, it is a true ambiguity,
1071 -- unless one of them is an entry and the context is a conditional or
1072 -- timed entry call, or unless we are within an instance and this is
1073 -- results from two formals types with the same actual.
1076 if Nkind (N) = N_Procedure_Call_Statement
1077 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1078 and then N = Entry_Call_Statement (Parent (N))
1080 if Ekind (Nam2) = E_Entry then
1082 elsif Ekind (Nam1) = E_Entry then
1088 -- If the ambiguity occurs within an instance, it is due to several
1089 -- formal types with the same actual. Look for an exact match
1090 -- between the types of the formals of the overloadable entities,
1091 -- and the actuals in the call, to recover the unambiguous match
1092 -- in the original generic.
1094 elsif In_Instance then
1095 if (Nkind (N) = N_Function_Call
1096 or else Nkind (N) = N_Procedure_Call_Statement)
1103 Actual := First_Actual (N);
1104 Formal := First_Formal (Nam1);
1105 while Present (Actual) loop
1106 if Etype (Actual) /= Etype (Formal) then
1110 Next_Actual (Actual);
1111 Next_Formal (Formal);
1117 elsif Nkind (N) in N_Binary_Op then
1119 if Matches (Left_Opnd (N), First_Formal (Nam1))
1121 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1128 elsif Nkind (N) in N_Unary_Op then
1130 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1137 return Remove_Conversions;
1140 return Remove_Conversions;
1144 -- an implicit concatenation operator on a string type cannot be
1145 -- disambiguated from the predefined concatenation. This can only
1146 -- happen with concatenation of string literals.
1148 if Chars (User_Subp) = Name_Op_Concat
1149 and then Ekind (User_Subp) = E_Operator
1150 and then Is_String_Type (Etype (First_Formal (User_Subp)))
1154 -- If the user-defined operator is in an open scope, or in the scope
1155 -- of the resulting type, or given by an expanded name that names its
1156 -- scope, it hides the predefined operator for the type. Exponentiation
1157 -- has to be special-cased because the implicit operator does not have
1158 -- a symmetric signature, and may not be hidden by the explicit one.
1160 elsif (Nkind (N) = N_Function_Call
1161 and then Nkind (Name (N)) = N_Expanded_Name
1162 and then (Chars (Predef_Subp) /= Name_Op_Expon
1163 or else Hides_Op (User_Subp, Predef_Subp))
1164 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1165 or else Hides_Op (User_Subp, Predef_Subp)
1167 if It1.Nam = User_Subp then
1173 -- Otherwise, the predefined operator has precedence, or if the
1174 -- user-defined operation is directly visible we have a true ambiguity.
1175 -- If this is a fixed-point multiplication and division in Ada83 mode,
1176 -- exclude the universal_fixed operator, which often causes ambiguities
1180 if (In_Open_Scopes (Scope (User_Subp))
1181 or else Is_Potentially_Use_Visible (User_Subp))
1182 and then not In_Instance
1184 if Is_Fixed_Point_Type (Typ)
1185 and then (Chars (Nam1) = Name_Op_Multiply
1186 or else Chars (Nam1) = Name_Op_Divide)
1189 if It2.Nam = Predef_Subp then
1199 elsif It1.Nam = Predef_Subp then
1209 ---------------------
1210 -- End_Interp_List --
1211 ---------------------
1213 procedure End_Interp_List is
1215 All_Interp.Table (All_Interp.Last) := No_Interp;
1216 All_Interp.Increment_Last;
1217 end End_Interp_List;
1219 -------------------------
1220 -- Entity_Matches_Spec --
1221 -------------------------
1223 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1225 -- Simple case: same entity kinds, type conformance is required.
1226 -- A parameterless function can also rename a literal.
1228 if Ekind (Old_S) = Ekind (New_S)
1229 or else (Ekind (New_S) = E_Function
1230 and then Ekind (Old_S) = E_Enumeration_Literal)
1232 return Type_Conformant (New_S, Old_S);
1234 elsif Ekind (New_S) = E_Function
1235 and then Ekind (Old_S) = E_Operator
1237 return Operator_Matches_Spec (Old_S, New_S);
1239 elsif Ekind (New_S) = E_Procedure
1240 and then Is_Entry (Old_S)
1242 return Type_Conformant (New_S, Old_S);
1247 end Entity_Matches_Spec;
1249 ----------------------
1250 -- Find_Unique_Type --
1251 ----------------------
1253 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1256 T : Entity_Id := Etype (L);
1257 TR : Entity_Id := Any_Type;
1260 if Is_Overloaded (R) then
1261 Get_First_Interp (R, I, It);
1263 while Present (It.Typ) loop
1264 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1266 -- If several interpretations are possible and L is universal,
1267 -- apply preference rule.
1269 if TR /= Any_Type then
1271 if (T = Universal_Integer or else T = Universal_Real)
1282 Get_Next_Interp (I, It);
1287 -- In the non-overloaded case, the Etype of R is already set
1294 -- If one of the operands is Universal_Fixed, the type of the
1295 -- other operand provides the context.
1297 if Etype (R) = Universal_Fixed then
1300 elsif T = Universal_Fixed then
1304 return Specific_Type (T, Etype (R));
1307 end Find_Unique_Type;
1309 ----------------------
1310 -- Get_First_Interp --
1311 ----------------------
1313 procedure Get_First_Interp
1315 I : out Interp_Index;
1318 Int_Ind : Interp_Index;
1322 -- If a selected component is overloaded because the selector has
1323 -- multiple interpretations, the node is a call to a protected
1324 -- operation or an indirect call. Retrieve the interpretation from
1325 -- the selector name. The selected component may be overloaded as well
1326 -- if the prefix is overloaded. That case is unchanged.
1328 if Nkind (N) = N_Selected_Component
1329 and then Is_Overloaded (Selector_Name (N))
1331 O_N := Selector_Name (N);
1336 for Index in 0 .. Interp_Map.Last loop
1337 if Interp_Map.Table (Index).Node = O_N then
1338 Int_Ind := Interp_Map.Table (Index).Index;
1339 It := All_Interp.Table (Int_Ind);
1345 -- Procedure should never be called if the node has no interpretations
1347 raise Program_Error;
1348 end Get_First_Interp;
1350 ----------------------
1351 -- Get_Next_Interp --
1352 ----------------------
1354 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
1357 It := All_Interp.Table (I);
1358 end Get_Next_Interp;
1360 -------------------------
1361 -- Has_Compatible_Type --
1362 -------------------------
1364 function Has_Compatible_Type
1377 if Nkind (N) = N_Subtype_Indication
1378 or else not Is_Overloaded (N)
1380 return Covers (Typ, Etype (N))
1381 or else (not Is_Tagged_Type (Typ)
1382 and then Ekind (Typ) /= E_Anonymous_Access_Type
1383 and then Covers (Etype (N), Typ));
1386 Get_First_Interp (N, I, It);
1388 while Present (It.Typ) loop
1389 if Covers (Typ, It.Typ)
1390 or else (not Is_Tagged_Type (Typ)
1391 and then Ekind (Typ) /= E_Anonymous_Access_Type
1392 and then Covers (It.Typ, Typ))
1397 Get_Next_Interp (I, It);
1402 end Has_Compatible_Type;
1408 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
1409 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
1412 return Operator_Matches_Spec (Op, F)
1413 and then (In_Open_Scopes (Scope (F))
1414 or else Scope (F) = Scope (Btyp)
1415 or else (not In_Open_Scopes (Scope (Btyp))
1416 and then not In_Use (Btyp)
1417 and then not In_Use (Scope (Btyp))));
1420 ------------------------
1421 -- Init_Interp_Tables --
1422 ------------------------
1424 procedure Init_Interp_Tables is
1428 end Init_Interp_Tables;
1430 ---------------------
1431 -- Intersect_Types --
1432 ---------------------
1434 function Intersect_Types (L, R : Node_Id) return Entity_Id is
1435 Index : Interp_Index;
1439 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
1440 -- Find interpretation of right arg that has type compatible with T
1442 --------------------------
1443 -- Check_Right_Argument --
1444 --------------------------
1446 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
1447 Index : Interp_Index;
1452 if not Is_Overloaded (R) then
1453 return Specific_Type (T, Etype (R));
1456 Get_First_Interp (R, Index, It);
1459 T2 := Specific_Type (T, It.Typ);
1461 if T2 /= Any_Type then
1465 Get_Next_Interp (Index, It);
1466 exit when No (It.Typ);
1471 end Check_Right_Argument;
1473 -- Start processing for Intersect_Types
1476 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
1480 if not Is_Overloaded (L) then
1481 Typ := Check_Right_Argument (Etype (L));
1485 Get_First_Interp (L, Index, It);
1487 while Present (It.Typ) loop
1488 Typ := Check_Right_Argument (It.Typ);
1489 exit when Typ /= Any_Type;
1490 Get_Next_Interp (Index, It);
1495 -- If Typ is Any_Type, it means no compatible pair of types was found
1497 if Typ = Any_Type then
1499 if Nkind (Parent (L)) in N_Op then
1500 Error_Msg_N ("incompatible types for operator", Parent (L));
1502 elsif Nkind (Parent (L)) = N_Range then
1503 Error_Msg_N ("incompatible types given in constraint", Parent (L));
1506 Error_Msg_N ("incompatible types", Parent (L));
1511 end Intersect_Types;
1517 function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
1521 if Base_Type (T1) = Base_Type (T2) then
1524 elsif Is_Private_Type (T1)
1525 and then Present (Full_View (T1))
1526 and then Base_Type (T2) = Base_Type (Full_View (T1))
1534 if Base_Type (T1) = Base_Type (Par)
1535 or else (Is_Private_Type (T1)
1536 and then Present (Full_View (T1))
1537 and then Base_Type (Par) = Base_Type (Full_View (T1)))
1541 elsif Is_Private_Type (Par)
1542 and then Present (Full_View (Par))
1543 and then Full_View (Par) = Base_Type (T1)
1547 elsif Etype (Par) /= Par then
1560 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
1564 S := Ancestor_Subtype (T1);
1565 while Present (S) loop
1569 S := Ancestor_Subtype (S);
1580 procedure New_Interps (N : Node_Id) is
1582 Interp_Map.Increment_Last;
1583 All_Interp.Increment_Last;
1584 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
1585 All_Interp.Table (All_Interp.Last) := No_Interp;
1586 Set_Is_Overloaded (N, True);
1589 ---------------------------
1590 -- Operator_Matches_Spec --
1591 ---------------------------
1593 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
1594 Op_Name : constant Name_Id := Chars (Op);
1595 T : constant Entity_Id := Etype (New_S);
1603 -- To verify that a predefined operator matches a given signature,
1604 -- do a case analysis of the operator classes. Function can have one
1605 -- or two formals and must have the proper result type.
1607 New_F := First_Formal (New_S);
1608 Old_F := First_Formal (Op);
1611 while Present (New_F) and then Present (Old_F) loop
1613 Next_Formal (New_F);
1614 Next_Formal (Old_F);
1617 -- Definite mismatch if different number of parameters
1619 if Present (Old_F) or else Present (New_F) then
1625 T1 := Etype (First_Formal (New_S));
1627 if Op_Name = Name_Op_Subtract
1628 or else Op_Name = Name_Op_Add
1629 or else Op_Name = Name_Op_Abs
1631 return Base_Type (T1) = Base_Type (T)
1632 and then Is_Numeric_Type (T);
1634 elsif Op_Name = Name_Op_Not then
1635 return Base_Type (T1) = Base_Type (T)
1636 and then Valid_Boolean_Arg (Base_Type (T));
1645 T1 := Etype (First_Formal (New_S));
1646 T2 := Etype (Next_Formal (First_Formal (New_S)));
1648 if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
1649 or else Op_Name = Name_Op_Xor
1651 return Base_Type (T1) = Base_Type (T2)
1652 and then Base_Type (T1) = Base_Type (T)
1653 and then Valid_Boolean_Arg (Base_Type (T));
1655 elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
1656 return Base_Type (T1) = Base_Type (T2)
1657 and then not Is_Limited_Type (T1)
1658 and then Is_Boolean_Type (T);
1660 elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
1661 or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
1663 return Base_Type (T1) = Base_Type (T2)
1664 and then Valid_Comparison_Arg (T1)
1665 and then Is_Boolean_Type (T);
1667 elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
1668 return Base_Type (T1) = Base_Type (T2)
1669 and then Base_Type (T1) = Base_Type (T)
1670 and then Is_Numeric_Type (T);
1672 -- for division and multiplication, a user-defined function does
1673 -- not match the predefined universal_fixed operation, except in
1676 elsif Op_Name = Name_Op_Divide then
1677 return (Base_Type (T1) = Base_Type (T2)
1678 and then Base_Type (T1) = Base_Type (T)
1679 and then Is_Numeric_Type (T)
1680 and then (not Is_Fixed_Point_Type (T)
1683 -- Mixed_Mode operations on fixed-point types.
1685 or else (Base_Type (T1) = Base_Type (T)
1686 and then Base_Type (T2) = Base_Type (Standard_Integer)
1687 and then Is_Fixed_Point_Type (T))
1689 -- A user defined operator can also match (and hide) a mixed
1690 -- operation on universal literals.
1692 or else (Is_Integer_Type (T2)
1693 and then Is_Floating_Point_Type (T1)
1694 and then Base_Type (T1) = Base_Type (T));
1696 elsif Op_Name = Name_Op_Multiply then
1697 return (Base_Type (T1) = Base_Type (T2)
1698 and then Base_Type (T1) = Base_Type (T)
1699 and then Is_Numeric_Type (T)
1700 and then (not Is_Fixed_Point_Type (T)
1703 -- Mixed_Mode operations on fixed-point types.
1705 or else (Base_Type (T1) = Base_Type (T)
1706 and then Base_Type (T2) = Base_Type (Standard_Integer)
1707 and then Is_Fixed_Point_Type (T))
1709 or else (Base_Type (T2) = Base_Type (T)
1710 and then Base_Type (T1) = Base_Type (Standard_Integer)
1711 and then Is_Fixed_Point_Type (T))
1713 or else (Is_Integer_Type (T2)
1714 and then Is_Floating_Point_Type (T1)
1715 and then Base_Type (T1) = Base_Type (T))
1717 or else (Is_Integer_Type (T1)
1718 and then Is_Floating_Point_Type (T2)
1719 and then Base_Type (T2) = Base_Type (T));
1721 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
1722 return Base_Type (T1) = Base_Type (T2)
1723 and then Base_Type (T1) = Base_Type (T)
1724 and then Is_Integer_Type (T);
1726 elsif Op_Name = Name_Op_Expon then
1727 return Base_Type (T1) = Base_Type (T)
1728 and then Is_Numeric_Type (T)
1729 and then Base_Type (T2) = Base_Type (Standard_Integer);
1731 elsif Op_Name = Name_Op_Concat then
1732 return Is_Array_Type (T)
1733 and then (Base_Type (T) = Base_Type (Etype (Op)))
1734 and then (Base_Type (T1) = Base_Type (T)
1736 Base_Type (T1) = Base_Type (Component_Type (T)))
1737 and then (Base_Type (T2) = Base_Type (T)
1739 Base_Type (T2) = Base_Type (Component_Type (T)));
1745 end Operator_Matches_Spec;
1751 procedure Remove_Interp (I : in out Interp_Index) is
1755 -- Find end of Interp list and copy downward to erase the discarded one
1759 while Present (All_Interp.Table (II).Typ) loop
1763 for J in I + 1 .. II loop
1764 All_Interp.Table (J - 1) := All_Interp.Table (J);
1767 -- Back up interp. index to insure that iterator will pick up next
1768 -- available interpretation.
1777 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
1779 if Is_Overloaded (Old_N) then
1780 for Index in 0 .. Interp_Map.Last loop
1781 if Interp_Map.Table (Index).Node = Old_N then
1782 Interp_Map.Table (Index).Node := New_N;
1793 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
1794 B1 : constant Entity_Id := Base_Type (T1);
1795 B2 : constant Entity_Id := Base_Type (T2);
1797 function Is_Remote_Access (T : Entity_Id) return Boolean;
1798 -- Check whether T is the equivalent type of a remote access type.
1799 -- If distribution is enabled, T is a legal context for Null.
1801 ----------------------
1802 -- Is_Remote_Access --
1803 ----------------------
1805 function Is_Remote_Access (T : Entity_Id) return Boolean is
1807 return Is_Record_Type (T)
1808 and then (Is_Remote_Call_Interface (T)
1809 or else Is_Remote_Types (T))
1810 and then Present (Corresponding_Remote_Type (T))
1811 and then Is_Access_Type (Corresponding_Remote_Type (T));
1812 end Is_Remote_Access;
1814 -- Start of processing for Specific_Type
1817 if (T1 = Any_Type or else T2 = Any_Type) then
1824 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
1825 or else (T1 = Universal_Real and then Is_Real_Type (T2))
1826 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
1830 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
1831 or else (T2 = Universal_Real and then Is_Real_Type (T1))
1832 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
1836 elsif (T2 = Any_String and then Is_String_Type (T1)) then
1839 elsif (T1 = Any_String and then Is_String_Type (T2)) then
1842 elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
1845 elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
1848 elsif (T1 = Any_Access
1849 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
1853 elsif (T2 = Any_Access
1854 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
1858 elsif (T2 = Any_Composite
1859 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
1863 elsif (T1 = Any_Composite
1864 and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
1868 elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
1871 elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
1874 -- Special cases for equality operators (all other predefined
1875 -- operators can never apply to tagged types)
1877 elsif Is_Class_Wide_Type (T1)
1878 and then Is_Ancestor (Root_Type (T1), T2)
1882 elsif Is_Class_Wide_Type (T2)
1883 and then Is_Ancestor (Root_Type (T2), T1)
1887 elsif (Ekind (B1) = E_Access_Subprogram_Type
1889 Ekind (B1) = E_Access_Protected_Subprogram_Type)
1890 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
1891 and then Is_Access_Type (T2)
1895 elsif (Ekind (B2) = E_Access_Subprogram_Type
1897 Ekind (B2) = E_Access_Protected_Subprogram_Type)
1898 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
1899 and then Is_Access_Type (T1)
1903 elsif (Ekind (T1) = E_Allocator_Type
1904 or else Ekind (T1) = E_Access_Attribute_Type
1905 or else Ekind (T1) = E_Anonymous_Access_Type)
1906 and then Is_Access_Type (T2)
1910 elsif (Ekind (T2) = E_Allocator_Type
1911 or else Ekind (T2) = E_Access_Attribute_Type
1912 or else Ekind (T2) = E_Anonymous_Access_Type)
1913 and then Is_Access_Type (T1)
1917 -- If none of the above cases applies, types are not compatible.
1924 ------------------------------
1925 -- Universal_Interpretation --
1926 ------------------------------
1928 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
1929 Index : Interp_Index;
1933 -- The argument may be a formal parameter of an operator or subprogram
1934 -- with multiple interpretations, or else an expression for an actual.
1936 if Nkind (Opnd) = N_Defining_Identifier
1937 or else not Is_Overloaded (Opnd)
1939 if Etype (Opnd) = Universal_Integer
1940 or else Etype (Opnd) = Universal_Real
1942 return Etype (Opnd);
1948 Get_First_Interp (Opnd, Index, It);
1950 while Present (It.Typ) loop
1952 if It.Typ = Universal_Integer
1953 or else It.Typ = Universal_Real
1958 Get_Next_Interp (Index, It);
1963 end Universal_Interpretation;
1965 -----------------------
1966 -- Valid_Boolean_Arg --
1967 -----------------------
1969 -- In addition to booleans and arrays of booleans, we must include
1970 -- aggregates as valid boolean arguments, because in the first pass
1971 -- of resolution their components are not examined. If it turns out not
1972 -- to be an aggregate of booleans, this will be diagnosed in Resolve.
1973 -- Any_Composite must be checked for prior to the array type checks
1974 -- because Any_Composite does not have any associated indexes.
1976 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
1978 return Is_Boolean_Type (T)
1979 or else T = Any_Composite
1980 or else (Is_Array_Type (T)
1981 and then T /= Any_String
1982 and then Number_Dimensions (T) = 1
1983 and then Is_Boolean_Type (Component_Type (T))
1984 and then (not Is_Private_Composite (T)
1985 or else In_Instance)
1986 and then (not Is_Limited_Composite (T)
1987 or else In_Instance))
1988 or else Is_Modular_Integer_Type (T)
1989 or else T = Universal_Integer;
1990 end Valid_Boolean_Arg;
1992 --------------------------
1993 -- Valid_Comparison_Arg --
1994 --------------------------
1996 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
1998 return Is_Discrete_Type (T)
1999 or else Is_Real_Type (T)
2000 or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
2001 and then Is_Discrete_Type (Component_Type (T))
2002 and then (not Is_Private_Composite (T)
2003 or else In_Instance)
2004 and then (not Is_Limited_Composite (T)
2005 or else In_Instance))
2006 or else Is_String_Type (T);
2007 end Valid_Comparison_Arg;
2009 ---------------------
2010 -- Write_Overloads --
2011 ---------------------
2013 procedure Write_Overloads (N : Node_Id) is
2019 if not Is_Overloaded (N) then
2020 Write_Str ("Non-overloaded entity ");
2022 Write_Entity_Info (Entity (N), " ");
2025 Get_First_Interp (N, I, It);
2026 Write_Str ("Overloaded entity ");
2030 while Present (Nam) loop
2031 Write_Entity_Info (Nam, " ");
2032 Write_Str ("=================");
2034 Get_Next_Interp (I, It);
2038 end Write_Overloads;