1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Nlists; use Nlists;
33 with Errout; use Errout;
35 with Namet; use Namet;
37 with Output; use Output;
39 with Sem_Aux; use Sem_Aux;
40 with Sem_Ch6; use Sem_Ch6;
41 with Sem_Ch8; use Sem_Ch8;
42 with Sem_Ch12; use Sem_Ch12;
43 with Sem_Disp; use Sem_Disp;
44 with Sem_Dist; use Sem_Dist;
45 with Sem_Util; use Sem_Util;
46 with Stand; use Stand;
47 with Sinfo; use Sinfo;
48 with Snames; use Snames;
50 with Treepr; use Treepr;
51 with Uintp; use Uintp;
53 package body Sem_Type is
59 -- The following data structures establish a mapping between nodes and
60 -- their interpretations. An overloaded node has an entry in Interp_Map,
61 -- which in turn contains a pointer into the All_Interp array. The
62 -- interpretations of a given node are contiguous in All_Interp. Each set
63 -- of interpretations is terminated with the marker No_Interp. In order to
64 -- speed up the retrieval of the interpretations of an overloaded node, the
65 -- Interp_Map table is accessed by means of a simple hashing scheme, and
66 -- the entries in Interp_Map are chained. The heads of clash lists are
67 -- stored in array Headers.
69 -- Headers Interp_Map All_Interp
71 -- _ +-----+ +--------+
72 -- |_| |_____| --->|interp1 |
73 -- |_|---------->|node | | |interp2 |
74 -- |_| |index|---------| |nointerp|
79 -- This scheme does not currently reclaim interpretations. In principle,
80 -- after a unit is compiled, all overloadings have been resolved, and the
81 -- candidate interpretations should be deleted. This should be easier
82 -- now than with the previous scheme???
84 package All_Interp is new Table.Table (
85 Table_Component_Type => Interp,
86 Table_Index_Type => Interp_Index,
88 Table_Initial => Alloc.All_Interp_Initial,
89 Table_Increment => Alloc.All_Interp_Increment,
90 Table_Name => "All_Interp");
92 type Interp_Ref is record
98 Header_Size : constant Int := 2 ** 12;
99 No_Entry : constant Int := -1;
100 Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
102 package Interp_Map is new Table.Table (
103 Table_Component_Type => Interp_Ref,
104 Table_Index_Type => Int,
105 Table_Low_Bound => 0,
106 Table_Initial => Alloc.Interp_Map_Initial,
107 Table_Increment => Alloc.Interp_Map_Increment,
108 Table_Name => "Interp_Map");
110 function Hash (N : Node_Id) return Int;
111 -- A trivial hashing function for nodes, used to insert an overloaded
112 -- node into the Interp_Map table.
114 -------------------------------------
115 -- Handling of Overload Resolution --
116 -------------------------------------
118 -- Overload resolution uses two passes over the syntax tree of a complete
119 -- context. In the first, bottom-up pass, the types of actuals in calls
120 -- are used to resolve possibly overloaded subprogram and operator names.
121 -- In the second top-down pass, the type of the context (for example the
122 -- condition in a while statement) is used to resolve a possibly ambiguous
123 -- call, and the unique subprogram name in turn imposes a specific context
124 -- on each of its actuals.
126 -- Most expressions are in fact unambiguous, and the bottom-up pass is
127 -- sufficient to resolve most everything. To simplify the common case,
128 -- names and expressions carry a flag Is_Overloaded to indicate whether
129 -- they have more than one interpretation. If the flag is off, then each
130 -- name has already a unique meaning and type, and the bottom-up pass is
131 -- sufficient (and much simpler).
133 --------------------------
134 -- Operator Overloading --
135 --------------------------
137 -- The visibility of operators is handled differently from that of other
138 -- entities. We do not introduce explicit versions of primitive operators
139 -- for each type definition. As a result, there is only one entity
140 -- corresponding to predefined addition on all numeric types, etc. The
141 -- back end resolves predefined operators according to their type. The
142 -- visibility of primitive operations then reduces to the visibility of the
143 -- resulting type: (a + b) is a legal interpretation of some primitive
144 -- operator + if the type of the result (which must also be the type of a
145 -- and b) is directly visible (either immediately visible or use-visible).
147 -- User-defined operators are treated like other functions, but the
148 -- visibility of these user-defined operations must be special-cased
149 -- to determine whether they hide or are hidden by predefined operators.
150 -- The form P."+" (x, y) requires additional handling.
152 -- Concatenation is treated more conventionally: for every one-dimensional
153 -- array type we introduce a explicit concatenation operator. This is
154 -- necessary to handle the case of (element & element => array) which
155 -- cannot be handled conveniently if there is no explicit instance of
156 -- resulting type of the operation.
158 -----------------------
159 -- Local Subprograms --
160 -----------------------
162 procedure All_Overloads;
163 pragma Warnings (Off, All_Overloads);
164 -- Debugging procedure: list full contents of Overloads table
166 function Binary_Op_Interp_Has_Abstract_Op
168 E : Entity_Id) return Entity_Id;
169 -- Given the node and entity of a binary operator, determine whether the
170 -- actuals of E contain an abstract interpretation with regards to the
171 -- types of their corresponding formals. Return the abstract operation or
174 function Function_Interp_Has_Abstract_Op
176 E : Entity_Id) return Entity_Id;
177 -- Given the node and entity of a function call, determine whether the
178 -- actuals of E contain an abstract interpretation with regards to the
179 -- types of their corresponding formals. Return the abstract operation or
182 function Has_Abstract_Op
184 Typ : Entity_Id) return Entity_Id;
185 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
186 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
187 -- abstract interpretation which yields type Typ.
189 procedure New_Interps (N : Node_Id);
190 -- Initialize collection of interpretations for the given node, which is
191 -- either an overloaded entity, or an operation whose arguments have
192 -- multiple interpretations. Interpretations can be added to only one
195 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
196 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
197 -- or is not a "class" type (any_character, etc).
203 procedure Add_One_Interp
207 Opnd_Type : Entity_Id := Empty)
209 Vis_Type : Entity_Id;
211 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
212 -- Add one interpretation to an overloaded node. Add a new entry if
213 -- not hidden by previous one, and remove previous one if hidden by
216 function Is_Universal_Operation (Op : Entity_Id) return Boolean;
217 -- True if the entity is a predefined operator and the operands have
218 -- a universal Interpretation.
224 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
225 Abstr_Op : Entity_Id := Empty;
229 -- Start of processing for Add_Entry
232 -- Find out whether the new entry references interpretations that
233 -- are abstract or disabled by abstract operators.
235 if Ada_Version >= Ada_2005 then
236 if Nkind (N) in N_Binary_Op then
237 Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
238 elsif Nkind (N) = N_Function_Call then
239 Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
243 Get_First_Interp (N, I, It);
244 while Present (It.Nam) loop
246 -- A user-defined subprogram hides another declared at an outer
247 -- level, or one that is use-visible. So return if previous
248 -- definition hides new one (which is either in an outer
249 -- scope, or use-visible). Note that for functions use-visible
250 -- is the same as potentially use-visible. If new one hides
251 -- previous one, replace entry in table of interpretations.
252 -- If this is a universal operation, retain the operator in case
253 -- preference rule applies.
255 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
256 and then Ekind (Name) = Ekind (It.Nam))
257 or else (Ekind (Name) = E_Operator
258 and then Ekind (It.Nam) = E_Function))
259 and then Is_Immediately_Visible (It.Nam)
260 and then Type_Conformant (Name, It.Nam)
261 and then Base_Type (It.Typ) = Base_Type (T)
263 if Is_Universal_Operation (Name) then
266 -- If node is an operator symbol, we have no actuals with
267 -- which to check hiding, and this is done in full in the
268 -- caller (Analyze_Subprogram_Renaming) so we include the
269 -- predefined operator in any case.
271 elsif Nkind (N) = N_Operator_Symbol
273 (Nkind (N) = N_Expanded_Name
274 and then Nkind (Selector_Name (N)) = N_Operator_Symbol)
278 elsif not In_Open_Scopes (Scope (Name))
279 or else Scope_Depth (Scope (Name)) <=
280 Scope_Depth (Scope (It.Nam))
282 -- If ambiguity within instance, and entity is not an
283 -- implicit operation, save for later disambiguation.
285 if Scope (Name) = Scope (It.Nam)
286 and then not Is_Inherited_Operation (Name)
295 All_Interp.Table (I).Nam := Name;
299 -- Avoid making duplicate entries in overloads
302 and then Base_Type (It.Typ) = Base_Type (T)
306 -- Otherwise keep going
309 Get_Next_Interp (I, It);
313 All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
314 All_Interp.Append (No_Interp);
317 ----------------------------
318 -- Is_Universal_Operation --
319 ----------------------------
321 function Is_Universal_Operation (Op : Entity_Id) return Boolean is
325 if Ekind (Op) /= E_Operator then
328 elsif Nkind (N) in N_Binary_Op then
329 if Present (Universal_Interpretation (Left_Opnd (N)))
330 and then Present (Universal_Interpretation (Right_Opnd (N)))
333 elsif Nkind (N) in N_Op_Eq | N_Op_Ne
335 (Is_Anonymous_Access_Type (Etype (Left_Opnd (N)))
336 or else Is_Anonymous_Access_Type (Etype (Right_Opnd (N))))
343 elsif Nkind (N) in N_Unary_Op then
344 return Present (Universal_Interpretation (Right_Opnd (N)));
346 elsif Nkind (N) = N_Function_Call then
347 Arg := First_Actual (N);
348 while Present (Arg) loop
349 if No (Universal_Interpretation (Arg)) then
361 end Is_Universal_Operation;
363 -- Start of processing for Add_One_Interp
366 -- If the interpretation is a predefined operator, verify that the
367 -- result type is visible, or that the entity has already been
368 -- resolved (case of an instantiation node that refers to a predefined
369 -- operation, or an internally generated operator node, or an operator
370 -- given as an expanded name). If the operator is a comparison or
371 -- equality, it is the type of the operand that matters to determine
372 -- whether the operator is visible. In an instance, the check is not
373 -- performed, given that the operator was visible in the generic.
375 if Ekind (E) = E_Operator then
376 if Present (Opnd_Type) then
377 Vis_Type := Opnd_Type;
379 Vis_Type := Base_Type (T);
382 if In_Open_Scopes (Scope (Vis_Type))
383 or else Is_Potentially_Use_Visible (Vis_Type)
384 or else In_Use (Vis_Type)
385 or else (In_Use (Scope (Vis_Type))
386 and then not Is_Hidden (Vis_Type))
387 or else Nkind (N) = N_Expanded_Name
388 or else (Nkind (N) in N_Op and then E = Entity (N))
389 or else (In_Instance or else In_Inlined_Body)
390 or else Is_Anonymous_Access_Type (Vis_Type)
394 -- If the node is given in functional notation and the prefix
395 -- is an expanded name, then the operator is visible if the
396 -- prefix is the scope of the result type as well. If the
397 -- operator is (implicitly) defined in an extension of system,
398 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
400 elsif Nkind (N) = N_Function_Call
401 and then Nkind (Name (N)) = N_Expanded_Name
402 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
403 or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
404 or else Scope (Vis_Type) = System_Aux_Id)
408 -- Save type for subsequent error message, in case no other
409 -- interpretation is found.
412 Candidate_Type := Vis_Type;
416 -- In an instance, an abstract non-dispatching operation cannot be a
417 -- candidate interpretation, because it could not have been one in the
418 -- generic (it may be a spurious overloading in the instance).
421 and then Is_Overloadable (E)
422 and then Is_Abstract_Subprogram (E)
423 and then not Is_Dispatching_Operation (E)
427 -- An inherited interface operation that is implemented by some derived
428 -- type does not participate in overload resolution, only the
429 -- implementation operation does.
432 and then Is_Subprogram (E)
433 and then Present (Interface_Alias (E))
435 -- Ada 2005 (AI-251): If this primitive operation corresponds with
436 -- an immediate ancestor interface there is no need to add it to the
437 -- list of interpretations. The corresponding aliased primitive is
438 -- also in this list of primitive operations and will be used instead
439 -- because otherwise we have a dummy ambiguity between the two
440 -- subprograms which are in fact the same.
443 (Find_Dispatching_Type (Interface_Alias (E)),
444 Find_Dispatching_Type (E))
446 Add_One_Interp (N, Interface_Alias (E), T);
451 -- Calling stubs for an RACW operation never participate in resolution,
452 -- they are executed only through dispatching calls.
454 elsif Is_RACW_Stub_Type_Operation (E) then
458 -- If this is the first interpretation of N, N has type Any_Type.
459 -- In that case place the new type on the node. If one interpretation
460 -- already exists, indicate that the node is overloaded, and store
461 -- both the previous and the new interpretation in All_Interp. If
462 -- this is a later interpretation, just add it to the set.
464 if Etype (N) = Any_Type then
469 -- Record both the operator or subprogram name, and its type
471 if Nkind (N) in N_Op or else Is_Entity_Name (N) then
478 -- Either there is no current interpretation in the table for any
479 -- node or the interpretation that is present is for a different
480 -- node. In both cases add a new interpretation to the table.
482 elsif Interp_Map.Last < 0
484 (Interp_Map.Table (Interp_Map.Last).Node /= N
485 and then not Is_Overloaded (N))
489 if (Nkind (N) in N_Op or else Is_Entity_Name (N))
490 and then Present (Entity (N))
492 Add_Entry (Entity (N), Etype (N));
494 elsif Nkind (N) in N_Subprogram_Call
495 and then Is_Entity_Name (Name (N))
497 Add_Entry (Entity (Name (N)), Etype (N));
499 -- If this is an indirect call there will be no name associated
500 -- with the previous entry. To make diagnostics clearer, save
501 -- Subprogram_Type of first interpretation, so that the error will
502 -- point to the anonymous access to subprogram, not to the result
503 -- type of the call itself.
505 elsif (Nkind (N)) = N_Function_Call
506 and then Nkind (Name (N)) = N_Explicit_Dereference
507 and then Is_Overloaded (Name (N))
513 pragma Warnings (Off, Itn);
516 Get_First_Interp (Name (N), Itn, It);
517 Add_Entry (It.Nam, Etype (N));
521 -- Overloaded prefix in indexed or selected component, or call
522 -- whose name is an expression or another call.
524 Add_Entry (Etype (N), Etype (N));
538 procedure All_Overloads is
540 for J in All_Interp.First .. All_Interp.Last loop
542 if Present (All_Interp.Table (J).Nam) then
543 Write_Entity_Info (All_Interp.Table (J). Nam, " ");
545 Write_Str ("No Interp");
549 Write_Str ("=================");
554 --------------------------------------
555 -- Binary_Op_Interp_Has_Abstract_Op --
556 --------------------------------------
558 function Binary_Op_Interp_Has_Abstract_Op
560 E : Entity_Id) return Entity_Id
562 Abstr_Op : Entity_Id;
563 E_Left : constant Node_Id := First_Formal (E);
564 E_Right : constant Node_Id := Next_Formal (E_Left);
567 Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
568 if Present (Abstr_Op) then
572 return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
573 end Binary_Op_Interp_Has_Abstract_Op;
575 ---------------------
576 -- Collect_Interps --
577 ---------------------
579 procedure Collect_Interps (N : Node_Id) is
580 Ent : constant Entity_Id := Entity (N);
582 First_Interp : Interp_Index;
584 function Within_Instance (E : Entity_Id) return Boolean;
585 -- Within an instance there can be spurious ambiguities between a local
586 -- entity and one declared outside of the instance. This can only happen
587 -- for subprograms, because otherwise the local entity hides the outer
588 -- one. For an overloadable entity, this predicate determines whether it
589 -- is a candidate within the instance, or must be ignored.
591 ---------------------
592 -- Within_Instance --
593 ---------------------
595 function Within_Instance (E : Entity_Id) return Boolean is
600 if not In_Instance then
604 Inst := Current_Scope;
605 while Present (Inst) and then not Is_Generic_Instance (Inst) loop
606 Inst := Scope (Inst);
610 while Present (Scop) and then Scop /= Standard_Standard loop
615 Scop := Scope (Scop);
621 -- Start of processing for Collect_Interps
626 -- Unconditionally add the entity that was initially matched
628 First_Interp := All_Interp.Last;
629 Add_One_Interp (N, Ent, Etype (N));
631 -- For expanded name, pick up all additional entities from the
632 -- same scope, since these are obviously also visible. Note that
633 -- these are not necessarily contiguous on the homonym chain.
635 if Nkind (N) = N_Expanded_Name then
637 while Present (H) loop
638 if Scope (H) = Scope (Entity (N)) then
639 Add_One_Interp (N, H, Etype (H));
645 -- Case of direct name
648 -- First, search the homonym chain for directly visible entities
650 H := Current_Entity (Ent);
651 while Present (H) loop
653 not Is_Overloadable (H)
654 and then Is_Immediately_Visible (H);
656 if Is_Immediately_Visible (H) and then H /= Ent then
658 -- Only add interpretation if not hidden by an inner
659 -- immediately visible one.
661 for J in First_Interp .. All_Interp.Last - 1 loop
663 -- Current homograph is not hidden. Add to overloads
665 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
668 -- Homograph is hidden, unless it is a predefined operator
670 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
672 -- A homograph in the same scope can occur within an
673 -- instantiation, the resulting ambiguity has to be
674 -- resolved later. The homographs may both be local
675 -- functions or actuals, or may be declared at different
676 -- levels within the instance. The renaming of an actual
677 -- within the instance must not be included.
679 if Within_Instance (H)
680 and then H /= Renamed_Entity (Ent)
681 and then not Is_Inherited_Operation (H)
683 All_Interp.Table (All_Interp.Last) :=
684 (H, Etype (H), Empty);
685 All_Interp.Append (No_Interp);
688 elsif Scope (H) /= Standard_Standard then
694 -- On exit, we know that current homograph is not hidden
696 Add_One_Interp (N, H, Etype (H));
699 Write_Str ("Add overloaded interpretation ");
709 -- Scan list of homographs for use-visible entities only
711 H := Current_Entity (Ent);
713 while Present (H) loop
714 if Is_Potentially_Use_Visible (H)
716 and then Is_Overloadable (H)
718 for J in First_Interp .. All_Interp.Last - 1 loop
720 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
723 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
724 goto Next_Use_Homograph;
728 Add_One_Interp (N, H, Etype (H));
731 <<Next_Use_Homograph>>
736 if All_Interp.Last = First_Interp + 1 then
738 -- The final interpretation is in fact not overloaded. Note that the
739 -- unique legal interpretation may or may not be the original one,
740 -- so we need to update N's entity and etype now, because once N
741 -- is marked as not overloaded it is also expected to carry the
742 -- proper interpretation.
744 Set_Is_Overloaded (N, False);
745 Set_Entity (N, All_Interp.Table (First_Interp).Nam);
746 Set_Etype (N, All_Interp.Table (First_Interp).Typ);
754 function Covers (T1, T2 : Entity_Id) return Boolean is
758 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
759 -- In an instance the proper view may not always be correct for
760 -- private types, but private and full view are compatible. This
761 -- removes spurious errors from nested instantiations that involve,
762 -- among other things, types derived from private types.
764 function Real_Actual (T : Entity_Id) return Entity_Id;
765 -- If an actual in an inner instance is the formal of an enclosing
766 -- generic, the actual in the enclosing instance is the one that can
767 -- create an accidental ambiguity, and the check on compatibily of
768 -- generic actual types must use this enclosing actual.
770 ----------------------
771 -- Full_View_Covers --
772 ----------------------
774 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
776 if Present (Full_View (Typ1))
777 and then Covers (Full_View (Typ1), Typ2)
781 elsif Present (Underlying_Full_View (Typ1))
782 and then Covers (Underlying_Full_View (Typ1), Typ2)
789 end Full_View_Covers;
795 function Real_Actual (T : Entity_Id) return Entity_Id is
796 Par : constant Node_Id := Parent (T);
800 -- Retrieve parent subtype from subtype declaration for actual
802 if Nkind (Par) = N_Subtype_Declaration
803 and then not Comes_From_Source (Par)
804 and then Is_Entity_Name (Subtype_Indication (Par))
806 RA := Entity (Subtype_Indication (Par));
808 if Is_Generic_Actual_Type (RA) then
813 -- Otherwise actual is not the actual of an enclosing instance
818 -- Start of processing for Covers
821 -- If either operand is missing, then this is an error, but ignore it
822 -- and pretend we have a cover if errors already detected since this may
823 -- simply mean we have malformed trees or a semantic error upstream.
825 if No (T1) or else No (T2) then
826 if Total_Errors_Detected /= 0 then
833 -- Trivial case: same types are always compatible
839 -- First check for Standard_Void_Type, which is special. Subsequent
840 -- processing in this routine assumes T1 and T2 are bona fide types;
841 -- Standard_Void_Type is a special entity that has some, but not all,
842 -- properties of types.
844 if T1 = Standard_Void_Type or else T2 = Standard_Void_Type then
848 BT1 := Base_Type (T1);
849 BT2 := Base_Type (T2);
851 -- Handle underlying view of records with unknown discriminants
852 -- using the original entity that motivated the construction of
853 -- this underlying record view (see Build_Derived_Private_Type).
855 if Is_Underlying_Record_View (BT1) then
856 BT1 := Underlying_Record_View (BT1);
859 if Is_Underlying_Record_View (BT2) then
860 BT2 := Underlying_Record_View (BT2);
863 -- Simplest case: types that have the same base type and are not generic
864 -- actuals are compatible. Generic actuals belong to their class but are
865 -- not compatible with other types of their class, and in particular
866 -- with other generic actuals. They are however compatible with their
867 -- own subtypes, and itypes with the same base are compatible as well.
868 -- Similarly, constrained subtypes obtained from expressions of an
869 -- unconstrained nominal type are compatible with the base type (may
870 -- lead to spurious ambiguities in obscure cases ???)
872 -- Generic actuals require special treatment to avoid spurious ambi-
873 -- guities in an instance, when two formal types are instantiated with
874 -- the same actual, so that different subprograms end up with the same
875 -- signature in the instance. If a generic actual is the actual of an
876 -- enclosing instance, it is that actual that we must compare: generic
877 -- actuals are only incompatible if they appear in the same instance.
883 if not Is_Generic_Actual_Type (T1)
885 not Is_Generic_Actual_Type (T2)
889 -- Both T1 and T2 are generic actual types
893 RT1 : constant Entity_Id := Real_Actual (T1);
894 RT2 : constant Entity_Id := Real_Actual (T2);
897 or else Is_Itype (T1)
898 or else Is_Itype (T2)
899 or else Is_Constr_Subt_For_U_Nominal (T1)
900 or else Is_Constr_Subt_For_U_Nominal (T2)
901 or else Scope (RT1) /= Scope (RT2);
905 -- Literals are compatible with types in a given "class"
907 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
908 or else (T2 = Universal_Real and then Is_Real_Type (T1))
909 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
910 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
911 or else (T2 = Any_Character and then Is_Character_Type (T1))
912 or else (T2 = Any_String and then Is_String_Type (T1))
913 or else (T2 = Any_Access and then Is_Access_Type (T1))
917 -- The context may be class wide, and a class-wide type is compatible
918 -- with any member of the class.
920 elsif Is_Class_Wide_Type (T1)
921 and then Is_Ancestor (Root_Type (T1), T2)
925 elsif Is_Class_Wide_Type (T1)
926 and then Is_Class_Wide_Type (T2)
927 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
931 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a
932 -- task_type or protected_type that implements the interface.
934 elsif Ada_Version >= Ada_2005
935 and then Is_Concurrent_Type (T2)
936 and then Is_Class_Wide_Type (T1)
937 and then Is_Interface (Etype (T1))
938 and then Interface_Present_In_Ancestor
939 (Typ => BT2, Iface => Etype (T1))
943 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
944 -- object T2 implementing T1.
946 elsif Ada_Version >= Ada_2005
947 and then Is_Tagged_Type (T2)
948 and then Is_Class_Wide_Type (T1)
949 and then Is_Interface (Etype (T1))
951 if Interface_Present_In_Ancestor (Typ => T2,
962 if Is_Concurrent_Type (BT2) then
963 E := Corresponding_Record_Type (BT2);
968 -- Ada 2005 (AI-251): A class-wide abstract interface type T1
969 -- covers an object T2 that implements a direct derivation of T1.
970 -- Note: test for presence of E is defense against previous error.
973 Check_Error_Detected;
975 -- Here we have a corresponding record type
977 elsif Present (Interfaces (E)) then
978 Elmt := First_Elmt (Interfaces (E));
979 while Present (Elmt) loop
980 if Is_Ancestor (Etype (T1), Node (Elmt)) then
988 -- We should also check the case in which T1 is an ancestor of
989 -- some implemented interface???
994 -- In a dispatching call, the formal is of some specific type, and the
995 -- actual is of the corresponding class-wide type, including a subtype
996 -- of the class-wide type.
998 elsif Is_Class_Wide_Type (T2)
1000 (Class_Wide_Type (T1) = Class_Wide_Type (T2)
1001 or else Base_Type (Root_Type (T2)) = BT1)
1005 -- Some contexts require a class of types rather than a specific type.
1006 -- For example, conditions require any boolean type, fixed point
1007 -- attributes require some real type, etc. The built-in types Any_XXX
1008 -- represent these classes.
1010 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
1011 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
1012 or else (T1 = Any_Real and then Is_Real_Type (T2))
1013 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
1014 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
1018 -- An aggregate is compatible with an array or record type
1020 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
1023 -- In Ada_2020, an aggregate is compatible with the type that
1024 -- as the ccorrespoding aspect.
1026 elsif Ada_Version >= Ada_2020
1027 and then T2 = Any_Composite
1028 and then Present (Find_Aspect (T1, Aspect_Aggregate))
1032 -- If the expected type is an anonymous access, the designated type must
1033 -- cover that of the expression. Use the base type for this check: even
1034 -- though access subtypes are rare in sources, they are generated for
1035 -- actuals in instantiations.
1037 elsif Ekind (BT1) = E_Anonymous_Access_Type
1038 and then Is_Access_Type (T2)
1039 and then Covers (Designated_Type (T1), Designated_Type (T2))
1043 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
1044 -- of a named general access type. An implicit conversion will be
1045 -- applied. For the resolution, the designated types must match if
1046 -- untagged; further, if the designated type is tagged, the designated
1047 -- type of the anonymous access type shall be covered by the designated
1048 -- type of the named access type.
1050 elsif Ada_Version >= Ada_2012
1051 and then Ekind (BT1) = E_General_Access_Type
1052 and then Ekind (BT2) = E_Anonymous_Access_Type
1053 and then Covers (Designated_Type (T1), Designated_Type (T2))
1054 and then (Is_Class_Wide_Type (Designated_Type (T1)) >=
1055 Is_Class_Wide_Type (Designated_Type (T2)))
1059 -- An Access_To_Subprogram is compatible with itself, or with an
1060 -- anonymous type created for an attribute reference Access.
1062 elsif Ekind (BT1) in E_Access_Subprogram_Type
1063 | E_Access_Protected_Subprogram_Type
1064 and then Is_Access_Type (T2)
1065 and then (not Comes_From_Source (T1)
1066 or else not Comes_From_Source (T2))
1067 and then (Is_Overloadable (Designated_Type (T2))
1068 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1069 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1070 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1074 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1075 -- with itself, or with an anonymous type created for an attribute
1076 -- reference Access.
1078 elsif Ekind (BT1) in E_Anonymous_Access_Subprogram_Type
1079 | E_Anonymous_Access_Protected_Subprogram_Type
1080 and then Is_Access_Type (T2)
1081 and then (not Comes_From_Source (T1)
1082 or else not Comes_From_Source (T2))
1083 and then (Is_Overloadable (Designated_Type (T2))
1084 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1085 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1086 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1090 -- The context can be a remote access type, and the expression the
1091 -- corresponding source type declared in a categorized package, or
1094 elsif Is_Record_Type (T1)
1095 and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1))
1096 and then Present (Corresponding_Remote_Type (T1))
1098 return Covers (Corresponding_Remote_Type (T1), T2);
1102 elsif Is_Record_Type (T2)
1103 and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2))
1104 and then Present (Corresponding_Remote_Type (T2))
1106 return Covers (Corresponding_Remote_Type (T2), T1);
1108 -- Synchronized types are represented at run time by their corresponding
1109 -- record type. During expansion one is replaced with the other, but
1110 -- they are compatible views of the same type.
1112 elsif Is_Record_Type (T1)
1113 and then Is_Concurrent_Type (T2)
1114 and then Present (Corresponding_Record_Type (T2))
1116 return Covers (T1, Corresponding_Record_Type (T2));
1118 elsif Is_Concurrent_Type (T1)
1119 and then Present (Corresponding_Record_Type (T1))
1120 and then Is_Record_Type (T2)
1122 return Covers (Corresponding_Record_Type (T1), T2);
1124 -- During analysis, an attribute reference 'Access has a special type
1125 -- kind: Access_Attribute_Type, to be replaced eventually with the type
1126 -- imposed by context.
1128 elsif Ekind (T2) = E_Access_Attribute_Type
1129 and then Ekind (BT1) in E_General_Access_Type | E_Access_Type
1130 and then Covers (Designated_Type (T1), Designated_Type (T2))
1132 -- If the target type is a RACW type while the source is an access
1133 -- attribute type, we are building a RACW that may be exported.
1135 if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1136 Set_Has_RACW (Current_Sem_Unit);
1141 -- Ditto for allocators, which eventually resolve to the context type
1143 elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then
1144 return Covers (Designated_Type (T1), Designated_Type (T2))
1146 (From_Limited_With (Designated_Type (T1))
1147 and then Covers (Designated_Type (T2), Designated_Type (T1)));
1149 -- A boolean operation on integer literals is compatible with modular
1152 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
1155 -- The actual type may be the result of a previous error
1157 elsif BT2 = Any_Type then
1160 -- A Raise_Expressions is legal in any expression context
1162 elsif BT2 = Raise_Type then
1165 -- A packed array type covers its corresponding non-packed type. This is
1166 -- not legitimate Ada, but allows the omission of a number of otherwise
1167 -- useless unchecked conversions, and since this can only arise in
1168 -- (known correct) expanded code, no harm is done.
1170 elsif Is_Packed_Array (T2)
1171 and then T1 = Packed_Array_Impl_Type (T2)
1175 -- Similarly an array type covers its corresponding packed array type
1177 elsif Is_Packed_Array (T1)
1178 and then T2 = Packed_Array_Impl_Type (T1)
1182 -- In instances, or with types exported from instantiations, check
1183 -- whether a partial and a full view match. Verify that types are
1184 -- legal, to prevent cascaded errors.
1186 elsif Is_Private_Type (T1)
1187 and then (In_Instance
1188 or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2)))
1189 and then Full_View_Covers (T1, T2)
1193 elsif Is_Private_Type (T2)
1194 and then (In_Instance
1195 or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1)))
1196 and then Full_View_Covers (T2, T1)
1200 -- In the expansion of inlined bodies, types are compatible if they
1201 -- are structurally equivalent.
1203 elsif In_Inlined_Body
1204 and then (Underlying_Type (T1) = Underlying_Type (T2)
1206 (Is_Access_Type (T1)
1207 and then Is_Access_Type (T2)
1208 and then Designated_Type (T1) = Designated_Type (T2))
1211 and then Is_Access_Type (Underlying_Type (T2)))
1214 and then Is_Composite_Type (Underlying_Type (T1))))
1218 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity
1219 -- obtained through a limited_with compatible with its real entity.
1221 elsif From_Limited_With (T1) then
1223 -- If the expected type is the nonlimited view of a type, the
1224 -- expression may have the limited view. If that one in turn is
1225 -- incomplete, get full view if available.
1227 return Has_Non_Limited_View (T1)
1228 and then Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1230 elsif From_Limited_With (T2) then
1232 -- If units in the context have Limited_With clauses on each other,
1233 -- either type might have a limited view. Checks performed elsewhere
1234 -- verify that the context type is the nonlimited view.
1236 return Has_Non_Limited_View (T2)
1237 and then Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1239 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1241 elsif Ekind (T1) = E_Incomplete_Subtype then
1242 return Covers (Full_View (Etype (T1)), T2);
1244 elsif Ekind (T2) = E_Incomplete_Subtype then
1245 return Covers (T1, Full_View (Etype (T2)));
1247 -- Ada 2005 (AI-423): Coverage of formal anonymous access types
1248 -- and actual anonymous access types in the context of generic
1249 -- instantiations. We have the following situation:
1252 -- type Formal is private;
1253 -- Formal_Obj : access Formal; -- T1
1257 -- type Actual is ...
1258 -- Actual_Obj : access Actual; -- T2
1259 -- package Instance is new G (Formal => Actual,
1260 -- Formal_Obj => Actual_Obj);
1262 elsif Ada_Version >= Ada_2005
1263 and then Is_Anonymous_Access_Type (T1)
1264 and then Is_Anonymous_Access_Type (T2)
1265 and then Is_Generic_Type (Directly_Designated_Type (T1))
1266 and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1267 Directly_Designated_Type (T2)
1271 -- Otherwise, types are not compatible
1282 function Disambiguate
1284 I1, I2 : Interp_Index;
1285 Typ : Entity_Id) return Interp
1290 Nam1, Nam2 : Entity_Id;
1291 Predef_Subp : Entity_Id;
1292 User_Subp : Entity_Id;
1294 function Inherited_From_Actual (S : Entity_Id) return Boolean;
1295 -- Determine whether one of the candidates is an operation inherited by
1296 -- a type that is derived from an actual in an instantiation.
1298 function In_Same_Declaration_List
1300 Op_Decl : Entity_Id) return Boolean;
1301 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
1302 -- access types is declared on the partial view of a designated type, so
1303 -- that the type declaration and equality are not in the same list of
1304 -- declarations. This AI gives a preference rule for the user-defined
1305 -- operation. Same rule applies for arithmetic operations on private
1306 -- types completed with fixed-point types: the predefined operation is
1307 -- hidden; this is already handled properly in GNAT.
1309 function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1310 -- Determine whether a subprogram is an actual in an enclosing instance.
1311 -- An overloading between such a subprogram and one declared outside the
1312 -- instance is resolved in favor of the first, because it resolved in
1313 -- the generic. Within the instance the actual is represented by a
1314 -- constructed subprogram renaming.
1316 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
1317 -- Determine whether function Func_Id is an exact match for binary or
1318 -- unary operator Op.
1320 function Operand_Type return Entity_Id;
1321 -- Determine type of operand for an equality operation, to apply Ada
1322 -- 2005 rules to equality on anonymous access types.
1324 function Standard_Operator return Boolean;
1325 -- Check whether subprogram is predefined operator declared in Standard.
1326 -- It may given by an operator name, or by an expanded name whose prefix
1329 function Remove_Conversions return Interp;
1330 -- Last chance for pathological cases involving comparisons on literals,
1331 -- and user overloadings of the same operator. Such pathologies have
1332 -- been removed from the ACVC, but still appear in two DEC tests, with
1333 -- the following notable quote from Ben Brosgol:
1335 -- [Note: I disclaim all credit/responsibility/blame for coming up with
1336 -- this example; Robert Dewar brought it to our attention, since it is
1337 -- apparently found in the ACVC 1.5. I did not attempt to find the
1338 -- reason in the Reference Manual that makes the example legal, since I
1339 -- was too nauseated by it to want to pursue it further.]
1341 -- Accordingly, this is not a fully recursive solution, but it handles
1342 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1343 -- pathology in the other direction with calls whose multiple overloaded
1344 -- actuals make them truly unresolvable.
1346 -- The new rules concerning abstract operations create additional need
1347 -- for special handling of expressions with universal operands, see
1348 -- comments to Has_Abstract_Interpretation below.
1350 function Is_User_Defined_Anonymous_Access_Equality
1351 (User_Subp, Predef_Subp : Entity_Id) return Boolean;
1352 -- Check for Ada 2005, AI-020: If the context involves an anonymous
1353 -- access operand, recognize a user-defined equality (User_Subp) with
1354 -- the proper signature, declared in the same declarative list as the
1355 -- type and not hiding a predefined equality Predef_Subp.
1357 ---------------------------
1358 -- Inherited_From_Actual --
1359 ---------------------------
1361 function Inherited_From_Actual (S : Entity_Id) return Boolean is
1362 Par : constant Node_Id := Parent (S);
1364 if Nkind (Par) /= N_Full_Type_Declaration
1365 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1369 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1371 Is_Generic_Actual_Type (
1372 Entity (Subtype_Indication (Type_Definition (Par))));
1374 end Inherited_From_Actual;
1376 ------------------------------
1377 -- In_Same_Declaration_List --
1378 ------------------------------
1380 function In_Same_Declaration_List
1382 Op_Decl : Entity_Id) return Boolean
1384 Scop : constant Entity_Id := Scope (Typ);
1387 return In_Same_List (Parent (Typ), Op_Decl)
1389 (Is_Package_Or_Generic_Package (Scop)
1390 and then List_Containing (Op_Decl) =
1391 Visible_Declarations (Parent (Scop))
1392 and then List_Containing (Parent (Typ)) =
1393 Private_Declarations (Parent (Scop)));
1394 end In_Same_Declaration_List;
1396 --------------------------
1397 -- Is_Actual_Subprogram --
1398 --------------------------
1400 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1402 return In_Open_Scopes (Scope (S))
1403 and then Nkind (Unit_Declaration_Node (S)) =
1404 N_Subprogram_Renaming_Declaration
1406 -- Why the Comes_From_Source test here???
1408 and then not Comes_From_Source (Unit_Declaration_Node (S))
1411 (Is_Generic_Instance (Scope (S))
1412 or else Is_Wrapper_Package (Scope (S)));
1413 end Is_Actual_Subprogram;
1419 function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
1420 function Matching_Types
1421 (Opnd_Typ : Entity_Id;
1422 Formal_Typ : Entity_Id) return Boolean;
1423 -- Determine whether operand type Opnd_Typ and formal parameter type
1424 -- Formal_Typ are either the same or compatible.
1426 --------------------
1427 -- Matching_Types --
1428 --------------------
1430 function Matching_Types
1431 (Opnd_Typ : Entity_Id;
1432 Formal_Typ : Entity_Id) return Boolean
1437 if Opnd_Typ = Formal_Typ then
1440 -- Any integer type matches universal integer
1442 elsif Opnd_Typ = Universal_Integer
1443 and then Is_Integer_Type (Formal_Typ)
1447 -- Any floating point type matches universal real
1449 elsif Opnd_Typ = Universal_Real
1450 and then Is_Floating_Point_Type (Formal_Typ)
1454 -- The type of the formal parameter maps a generic actual type to
1455 -- a generic formal type. If the operand type is the type being
1456 -- mapped in an instance, then this is a match.
1458 elsif Is_Generic_Actual_Type (Formal_Typ)
1459 and then Etype (Formal_Typ) = Opnd_Typ
1463 -- ??? There are possibly other cases to consider
1472 F1 : constant Entity_Id := First_Formal (Func_Id);
1473 F1_Typ : constant Entity_Id := Etype (F1);
1474 F2 : constant Entity_Id := Next_Formal (F1);
1475 F2_Typ : constant Entity_Id := Etype (F2);
1476 Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op));
1477 Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
1479 -- Start of processing for Matches
1482 if Lop_Typ = F1_Typ then
1483 return Matching_Types (Rop_Typ, F2_Typ);
1485 elsif Rop_Typ = F2_Typ then
1486 return Matching_Types (Lop_Typ, F1_Typ);
1488 -- Otherwise this is not a good match because each operand-formal
1489 -- pair is compatible only on base-type basis, which is not specific
1501 function Operand_Type return Entity_Id is
1505 if Nkind (N) = N_Function_Call then
1506 Opnd := First_Actual (N);
1508 Opnd := Left_Opnd (N);
1511 return Etype (Opnd);
1514 ------------------------
1515 -- Remove_Conversions --
1516 ------------------------
1518 function Remove_Conversions return Interp is
1526 function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1527 -- If an operation has universal operands the universal operation
1528 -- is present among its interpretations. If there is an abstract
1529 -- interpretation for the operator, with a numeric result, this
1530 -- interpretation was already removed in sem_ch4, but the universal
1531 -- one is still visible. We must rescan the list of operators and
1532 -- remove the universal interpretation to resolve the ambiguity.
1534 ---------------------------------
1535 -- Has_Abstract_Interpretation --
1536 ---------------------------------
1538 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1542 if Nkind (N) not in N_Op
1543 or else Ada_Version < Ada_2005
1544 or else not Is_Overloaded (N)
1545 or else No (Universal_Interpretation (N))
1550 E := Get_Name_Entity_Id (Chars (N));
1551 while Present (E) loop
1552 if Is_Overloadable (E)
1553 and then Is_Abstract_Subprogram (E)
1554 and then Is_Numeric_Type (Etype (E))
1562 -- Finally, if an operand of the binary operator is itself
1563 -- an operator, recurse to see whether its own abstract
1564 -- interpretation is responsible for the spurious ambiguity.
1566 if Nkind (N) in N_Binary_Op then
1567 return Has_Abstract_Interpretation (Left_Opnd (N))
1568 or else Has_Abstract_Interpretation (Right_Opnd (N));
1570 elsif Nkind (N) in N_Unary_Op then
1571 return Has_Abstract_Interpretation (Right_Opnd (N));
1577 end Has_Abstract_Interpretation;
1579 -- Start of processing for Remove_Conversions
1584 Get_First_Interp (N, I, It);
1585 while Present (It.Typ) loop
1586 if not Is_Overloadable (It.Nam) then
1590 F1 := First_Formal (It.Nam);
1596 if Nkind (N) in N_Subprogram_Call then
1597 Act1 := First_Actual (N);
1599 if Present (Act1) then
1600 Act2 := Next_Actual (Act1);
1605 elsif Nkind (N) in N_Unary_Op then
1606 Act1 := Right_Opnd (N);
1609 elsif Nkind (N) in N_Binary_Op then
1610 Act1 := Left_Opnd (N);
1611 Act2 := Right_Opnd (N);
1613 -- Use the type of the second formal, so as to include
1614 -- exponentiation, where the exponent may be ambiguous and
1615 -- the result non-universal.
1623 if Nkind (Act1) in N_Op
1624 and then Is_Overloaded (Act1)
1626 (Nkind (Act1) in N_Unary_Op
1627 or else Nkind (Left_Opnd (Act1)) in
1628 N_Integer_Literal | N_Real_Literal)
1629 and then Nkind (Right_Opnd (Act1)) in
1630 N_Integer_Literal | N_Real_Literal
1631 and then Has_Compatible_Type (Act1, Standard_Boolean)
1632 and then Etype (F1) = Standard_Boolean
1634 -- If the two candidates are the original ones, the
1635 -- ambiguity is real. Otherwise keep the original, further
1636 -- calls to Disambiguate will take care of others in the
1637 -- list of candidates.
1639 if It1 /= No_Interp then
1640 if It = Disambiguate.It1
1641 or else It = Disambiguate.It2
1643 if It1 = Disambiguate.It1
1644 or else It1 = Disambiguate.It2
1652 elsif Present (Act2)
1653 and then Nkind (Act2) in N_Op
1654 and then Is_Overloaded (Act2)
1655 and then Nkind (Right_Opnd (Act2)) in
1656 N_Integer_Literal | N_Real_Literal
1657 and then Has_Compatible_Type (Act2, Standard_Boolean)
1659 -- The preference rule on the first actual is not
1660 -- sufficient to disambiguate.
1668 elsif Is_Numeric_Type (Etype (F1))
1669 and then Has_Abstract_Interpretation (Act1)
1671 -- Current interpretation is not the right one because it
1672 -- expects a numeric operand. Examine all the other ones.
1679 Get_First_Interp (N, I, It);
1680 while Present (It.Typ) loop
1682 not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1685 or else not Has_Abstract_Interpretation (Act2)
1688 (Etype (Next_Formal (First_Formal (It.Nam))))
1694 Get_Next_Interp (I, It);
1703 Get_Next_Interp (I, It);
1706 -- After some error, a formal may have Any_Type and yield a spurious
1707 -- match. To avoid cascaded errors if possible, check for such a
1708 -- formal in either candidate.
1710 if Serious_Errors_Detected > 0 then
1715 Formal := First_Formal (Nam1);
1716 while Present (Formal) loop
1717 if Etype (Formal) = Any_Type then
1718 return Disambiguate.It2;
1721 Next_Formal (Formal);
1724 Formal := First_Formal (Nam2);
1725 while Present (Formal) loop
1726 if Etype (Formal) = Any_Type then
1727 return Disambiguate.It1;
1730 Next_Formal (Formal);
1736 end Remove_Conversions;
1738 -----------------------
1739 -- Standard_Operator --
1740 -----------------------
1742 function Standard_Operator return Boolean is
1746 if Nkind (N) in N_Op then
1749 elsif Nkind (N) = N_Function_Call then
1752 if Nkind (Nam) /= N_Expanded_Name then
1755 return Entity (Prefix (Nam)) = Standard_Standard;
1760 end Standard_Operator;
1762 -----------------------------------------------
1763 -- Is_User_Defined_Anonymous_Access_Equality --
1764 -----------------------------------------------
1766 function Is_User_Defined_Anonymous_Access_Equality
1767 (User_Subp, Predef_Subp : Entity_Id) return Boolean is
1769 return Present (User_Subp)
1771 -- Check for Ada 2005 and use of anonymous access
1773 and then Ada_Version >= Ada_2005
1774 and then Etype (User_Subp) = Standard_Boolean
1775 and then Is_Anonymous_Access_Type (Operand_Type)
1777 -- This check is only relevant if User_Subp is visible and not in
1780 and then (In_Open_Scopes (Scope (User_Subp))
1781 or else Is_Potentially_Use_Visible (User_Subp))
1782 and then not In_Instance
1783 and then not Hides_Op (User_Subp, Predef_Subp)
1785 -- Is User_Subp declared in the same declarative list as the type?
1788 In_Same_Declaration_List
1789 (Designated_Type (Operand_Type),
1790 Unit_Declaration_Node (User_Subp));
1791 end Is_User_Defined_Anonymous_Access_Equality;
1793 -- Start of processing for Disambiguate
1796 -- Recover the two legal interpretations
1798 Get_First_Interp (N, I, It);
1800 Get_Next_Interp (I, It);
1807 Get_Next_Interp (I, It);
1813 -- Check whether one of the entities is an Ada 2005/2012 and we are
1814 -- operating in an earlier mode, in which case we discard the Ada
1815 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
1817 if Ada_Version < Ada_2005 then
1818 if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
1820 elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
1825 -- Check whether one of the entities is an Ada 2012 entity and we are
1826 -- operating in Ada 2005 mode, in which case we discard the Ada 2012
1827 -- entity, so that we get proper Ada 2005 overload resolution.
1829 if Ada_Version = Ada_2005 then
1830 if Is_Ada_2012_Only (Nam1) then
1832 elsif Is_Ada_2012_Only (Nam2) then
1837 -- If the context is universal, the predefined operator is preferred.
1838 -- This includes bounds in numeric type declarations, and expressions
1839 -- in type conversions. If no interpretation yields a universal type,
1840 -- then we must check whether the user-defined entity hides the prede-
1843 if Chars (Nam1) in Any_Operator_Name and then Standard_Operator then
1844 if Typ = Universal_Integer
1845 or else Typ = Universal_Real
1846 or else Typ = Any_Integer
1847 or else Typ = Any_Discrete
1848 or else Typ = Any_Real
1849 or else Typ = Any_Type
1851 -- Find an interpretation that yields the universal type, or else
1852 -- a predefined operator that yields a predefined numeric type.
1855 Candidate : Interp := No_Interp;
1858 Get_First_Interp (N, I, It);
1859 while Present (It.Typ) loop
1860 if (It.Typ = Universal_Integer
1861 or else It.Typ = Universal_Real)
1862 and then (Typ = Any_Type or else Covers (Typ, It.Typ))
1866 elsif Is_Numeric_Type (It.Typ)
1867 and then Scope (It.Typ) = Standard_Standard
1868 and then Scope (It.Nam) = Standard_Standard
1869 and then Covers (Typ, It.Typ)
1874 Get_Next_Interp (I, It);
1877 if Candidate /= No_Interp then
1882 elsif Chars (Nam1) /= Name_Op_Not
1883 and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1885 -- Equality or comparison operation. Choose predefined operator if
1886 -- arguments are universal. The node may be an operator, name, or
1887 -- a function call, so unpack arguments accordingly.
1890 Arg1, Arg2 : Node_Id;
1893 if Nkind (N) in N_Op then
1894 Arg1 := Left_Opnd (N);
1895 Arg2 := Right_Opnd (N);
1897 elsif Is_Entity_Name (N) then
1898 Arg1 := First_Entity (Entity (N));
1899 Arg2 := Next_Entity (Arg1);
1902 Arg1 := First_Actual (N);
1903 Arg2 := Next_Actual (Arg1);
1906 if Present (Arg2) then
1907 if Ekind (Nam1) = E_Operator then
1908 Predef_Subp := Nam1;
1910 elsif Ekind (Nam2) = E_Operator then
1911 Predef_Subp := Nam2;
1914 Predef_Subp := Empty;
1918 -- Take into account universal interpretation as well as
1919 -- universal_access equality, as long as AI05-0020 does not
1922 if (Present (Universal_Interpretation (Arg1))
1923 and then Universal_Interpretation (Arg2) =
1924 Universal_Interpretation (Arg1))
1926 (Nkind (N) in N_Op_Eq | N_Op_Ne
1927 and then (Is_Anonymous_Access_Type (Etype (Arg1))
1929 Is_Anonymous_Access_Type (Etype (Arg2)))
1931 Is_User_Defined_Anonymous_Access_Equality
1932 (User_Subp, Predef_Subp))
1934 Get_First_Interp (N, I, It);
1935 while Scope (It.Nam) /= Standard_Standard loop
1936 Get_Next_Interp (I, It);
1946 -- If no universal interpretation, check whether user-defined operator
1947 -- hides predefined one, as well as other special cases. If the node
1948 -- is a range, then one or both bounds are ambiguous. Each will have
1949 -- to be disambiguated w.r.t. the context type. The type of the range
1950 -- itself is imposed by the context, so we can return either legal
1953 if Ekind (Nam1) = E_Operator then
1954 Predef_Subp := Nam1;
1957 elsif Ekind (Nam2) = E_Operator then
1958 Predef_Subp := Nam2;
1961 elsif Nkind (N) = N_Range then
1964 -- Implement AI05-105: A renaming declaration with an access
1965 -- definition must resolve to an anonymous access type. This
1966 -- is a resolution rule and can be used to disambiguate.
1968 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1969 and then Present (Access_Definition (Parent (N)))
1971 if Is_Anonymous_Access_Type (It1.Typ) then
1972 if Ekind (It2.Typ) = Ekind (It1.Typ) then
1982 elsif Is_Anonymous_Access_Type (It2.Typ) then
1985 -- No legal interpretation
1991 -- Two access attribute types may have been created for an expression
1992 -- with an implicit dereference, which is automatically overloaded.
1993 -- If both access attribute types designate the same object type,
1994 -- disambiguation if any will take place elsewhere, so keep any one of
1995 -- the interpretations.
1997 elsif Ekind (It1.Typ) = E_Access_Attribute_Type
1998 and then Ekind (It2.Typ) = E_Access_Attribute_Type
1999 and then Designated_Type (It1.Typ) = Designated_Type (It2.Typ)
2003 -- If two user defined-subprograms are visible, it is a true ambiguity,
2004 -- unless one of them is an entry and the context is a conditional or
2005 -- timed entry call, or unless we are within an instance and this is
2006 -- results from two formals types with the same actual.
2009 if Nkind (N) = N_Procedure_Call_Statement
2010 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
2011 and then N = Entry_Call_Statement (Parent (N))
2013 if Ekind (Nam2) = E_Entry then
2015 elsif Ekind (Nam1) = E_Entry then
2021 -- If the ambiguity occurs within an instance, it is due to several
2022 -- formal types with the same actual. Look for an exact match between
2023 -- the types of the formals of the overloadable entities, and the
2024 -- actuals in the call, to recover the unambiguous match in the
2025 -- original generic.
2027 -- The ambiguity can also be due to an overloading between a formal
2028 -- subprogram and a subprogram declared outside the generic. If the
2029 -- node is overloaded, it did not resolve to the global entity in
2030 -- the generic, and we choose the formal subprogram.
2032 -- Finally, the ambiguity can be between an explicit subprogram and
2033 -- one inherited (with different defaults) from an actual. In this
2034 -- case the resolution was to the explicit declaration in the
2035 -- generic, and remains so in the instance.
2037 -- The same sort of disambiguation needed for calls is also required
2038 -- for the name given in a subprogram renaming, and that case is
2039 -- handled here as well. We test Comes_From_Source to exclude this
2040 -- treatment for implicit renamings created for formal subprograms.
2042 elsif In_Instance and then not In_Generic_Actual (N) then
2043 if Nkind (N) in N_Subprogram_Call
2045 (Nkind (N) in N_Has_Entity
2047 Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
2048 and then Comes_From_Source (Parent (N)))
2053 Renam : Entity_Id := Empty;
2054 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
2055 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
2058 if Is_Act1 and then not Is_Act2 then
2061 elsif Is_Act2 and then not Is_Act1 then
2064 elsif Inherited_From_Actual (Nam1)
2065 and then Comes_From_Source (Nam2)
2069 elsif Inherited_From_Actual (Nam2)
2070 and then Comes_From_Source (Nam1)
2075 -- In the case of a renamed subprogram, pick up the entity
2076 -- of the renaming declaration so we can traverse its
2077 -- formal parameters.
2079 if Nkind (N) in N_Has_Entity then
2080 Renam := Defining_Unit_Name (Specification (Parent (N)));
2083 if Present (Renam) then
2084 Actual := First_Formal (Renam);
2086 Actual := First_Actual (N);
2089 Formal := First_Formal (Nam1);
2090 while Present (Actual) loop
2091 if Etype (Actual) /= Etype (Formal) then
2095 if Present (Renam) then
2096 Next_Formal (Actual);
2098 Next_Actual (Actual);
2101 Next_Formal (Formal);
2107 elsif Nkind (N) in N_Binary_Op then
2108 if Matches (N, Nam1) then
2114 elsif Nkind (N) in N_Unary_Op then
2115 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
2122 return Remove_Conversions;
2125 return Remove_Conversions;
2129 -- An implicit concatenation operator on a string type cannot be
2130 -- disambiguated from the predefined concatenation. This can only
2131 -- happen with concatenation of string literals.
2133 if Chars (User_Subp) = Name_Op_Concat
2134 and then Ekind (User_Subp) = E_Operator
2135 and then Is_String_Type (Etype (First_Formal (User_Subp)))
2139 -- If the user-defined operator is in an open scope, or in the scope
2140 -- of the resulting type, or given by an expanded name that names its
2141 -- scope, it hides the predefined operator for the type. Exponentiation
2142 -- has to be special-cased because the implicit operator does not have
2143 -- a symmetric signature, and may not be hidden by the explicit one.
2145 elsif (Nkind (N) = N_Function_Call
2146 and then Nkind (Name (N)) = N_Expanded_Name
2147 and then (Chars (Predef_Subp) /= Name_Op_Expon
2148 or else Hides_Op (User_Subp, Predef_Subp))
2149 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
2150 or else Hides_Op (User_Subp, Predef_Subp)
2152 if It1.Nam = User_Subp then
2158 -- Otherwise, the predefined operator has precedence, or if the user-
2159 -- defined operation is directly visible we have a true ambiguity.
2161 -- If this is a fixed-point multiplication and division in Ada 83 mode,
2162 -- exclude the universal_fixed operator, which often causes ambiguities
2165 -- Ditto in Ada 2012, where an ambiguity may arise for an operation
2166 -- on a partial view that is completed with a fixed point type. See
2167 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
2168 -- user-defined type and subprogram, so that a client of the package
2169 -- has the same resolution as the body of the package.
2172 if (In_Open_Scopes (Scope (User_Subp))
2173 or else Is_Potentially_Use_Visible (User_Subp))
2174 and then not In_Instance
2176 if Is_Fixed_Point_Type (Typ)
2177 and then Chars (Nam1) in Name_Op_Multiply | Name_Op_Divide
2179 (Ada_Version = Ada_83
2180 or else (Ada_Version >= Ada_2012
2181 and then In_Same_Declaration_List
2182 (First_Subtype (Typ),
2183 Unit_Declaration_Node (User_Subp))))
2185 if It2.Nam = Predef_Subp then
2191 -- Check for AI05-020
2193 elsif Chars (Nam1) in Name_Op_Eq | Name_Op_Ne
2194 and then Is_User_Defined_Anonymous_Access_Equality
2195 (User_Subp, Predef_Subp)
2197 if It2.Nam = Predef_Subp then
2203 -- An immediately visible operator hides a use-visible user-
2204 -- defined operation. This disambiguation cannot take place
2205 -- earlier because the visibility of the predefined operator
2206 -- can only be established when operand types are known.
2208 elsif Ekind (User_Subp) = E_Function
2209 and then Ekind (Predef_Subp) = E_Operator
2210 and then Nkind (N) in N_Op
2211 and then not Is_Overloaded (Right_Opnd (N))
2213 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N))))
2214 and then Is_Potentially_Use_Visible (User_Subp)
2216 if It2.Nam = Predef_Subp then
2226 elsif It1.Nam = Predef_Subp then
2235 ---------------------
2236 -- End_Interp_List --
2237 ---------------------
2239 procedure End_Interp_List is
2241 All_Interp.Table (All_Interp.Last) := No_Interp;
2242 All_Interp.Increment_Last;
2243 end End_Interp_List;
2245 -------------------------
2246 -- Entity_Matches_Spec --
2247 -------------------------
2249 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
2251 -- Simple case: same entity kinds, type conformance is required. A
2252 -- parameterless function can also rename a literal.
2254 if Ekind (Old_S) = Ekind (New_S)
2255 or else (Ekind (New_S) = E_Function
2256 and then Ekind (Old_S) = E_Enumeration_Literal)
2258 return Type_Conformant (New_S, Old_S);
2260 elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
2261 return Operator_Matches_Spec (Old_S, New_S);
2263 elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then
2264 return Type_Conformant (New_S, Old_S);
2269 end Entity_Matches_Spec;
2271 ----------------------
2272 -- Find_Unique_Type --
2273 ----------------------
2275 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
2276 T : constant Entity_Id := Etype (L);
2279 TR : Entity_Id := Any_Type;
2282 if Is_Overloaded (R) then
2283 Get_First_Interp (R, I, It);
2284 while Present (It.Typ) loop
2285 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
2287 -- If several interpretations are possible and L is universal,
2288 -- apply preference rule.
2290 if TR /= Any_Type then
2291 if (T = Universal_Integer or else T = Universal_Real)
2302 Get_Next_Interp (I, It);
2307 -- In the non-overloaded case, the Etype of R is already set correctly
2313 -- If one of the operands is Universal_Fixed, the type of the other
2314 -- operand provides the context.
2316 if Etype (R) = Universal_Fixed then
2319 elsif T = Universal_Fixed then
2322 -- If one operand is a raise_expression, use type of other operand
2324 elsif Nkind (L) = N_Raise_Expression then
2328 return Specific_Type (T, Etype (R));
2330 end Find_Unique_Type;
2332 -------------------------------------
2333 -- Function_Interp_Has_Abstract_Op --
2334 -------------------------------------
2336 function Function_Interp_Has_Abstract_Op
2338 E : Entity_Id) return Entity_Id
2340 Abstr_Op : Entity_Id;
2343 Form_Parm : Node_Id;
2346 -- Why is check on E needed below ???
2347 -- In any case this para needs comments ???
2349 if Is_Overloaded (N) and then Is_Overloadable (E) then
2350 Act_Parm := First_Actual (N);
2351 Form_Parm := First_Formal (E);
2352 while Present (Act_Parm) and then Present (Form_Parm) loop
2355 if Nkind (Act) = N_Parameter_Association then
2356 Act := Explicit_Actual_Parameter (Act);
2359 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2361 if Present (Abstr_Op) then
2365 Next_Actual (Act_Parm);
2366 Next_Formal (Form_Parm);
2371 end Function_Interp_Has_Abstract_Op;
2373 ----------------------
2374 -- Get_First_Interp --
2375 ----------------------
2377 procedure Get_First_Interp
2379 I : out Interp_Index;
2382 Int_Ind : Interp_Index;
2387 -- If a selected component is overloaded because the selector has
2388 -- multiple interpretations, the node is a call to a protected
2389 -- operation or an indirect call. Retrieve the interpretation from
2390 -- the selector name. The selected component may be overloaded as well
2391 -- if the prefix is overloaded. That case is unchanged.
2393 if Nkind (N) = N_Selected_Component
2394 and then Is_Overloaded (Selector_Name (N))
2396 O_N := Selector_Name (N);
2401 Map_Ptr := Headers (Hash (O_N));
2402 while Map_Ptr /= No_Entry loop
2403 if Interp_Map.Table (Map_Ptr).Node = O_N then
2404 Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2405 It := All_Interp.Table (Int_Ind);
2409 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2413 -- Procedure should never be called if the node has no interpretations
2415 raise Program_Error;
2416 end Get_First_Interp;
2418 ---------------------
2419 -- Get_Next_Interp --
2420 ---------------------
2422 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2425 It := All_Interp.Table (I);
2426 end Get_Next_Interp;
2428 -------------------------
2429 -- Has_Compatible_Type --
2430 -------------------------
2432 function Has_Compatible_Type
2434 Typ : Entity_Id) return Boolean
2444 if Nkind (N) = N_Subtype_Indication
2445 or else not Is_Overloaded (N)
2448 Covers (Typ, Etype (N))
2450 -- Ada 2005 (AI-345): The context may be a synchronized interface.
2451 -- If the type is already frozen use the corresponding_record
2452 -- to check whether it is a proper descendant.
2455 (Is_Record_Type (Typ)
2456 and then Is_Concurrent_Type (Etype (N))
2457 and then Present (Corresponding_Record_Type (Etype (N)))
2458 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2461 (Is_Concurrent_Type (Typ)
2462 and then Is_Record_Type (Etype (N))
2463 and then Present (Corresponding_Record_Type (Typ))
2464 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2467 (not Is_Tagged_Type (Typ)
2468 and then Ekind (Typ) /= E_Anonymous_Access_Type
2469 and then Covers (Etype (N), Typ))
2472 (Nkind (N) = N_Integer_Literal
2473 and then Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
2476 (Nkind (N) = N_Real_Literal
2477 and then Present (Find_Aspect (Typ, Aspect_Real_Literal)))
2480 (Nkind (N) = N_String_Literal
2481 and then Present (Find_Aspect (Typ, Aspect_String_Literal)));
2486 Get_First_Interp (N, I, It);
2487 while Present (It.Typ) loop
2488 if (Covers (Typ, It.Typ)
2490 (Scope (It.Nam) /= Standard_Standard
2491 or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2493 -- Ada 2005 (AI-345)
2496 (Is_Concurrent_Type (It.Typ)
2497 and then Present (Corresponding_Record_Type
2499 and then Covers (Typ, Corresponding_Record_Type
2502 or else (not Is_Tagged_Type (Typ)
2503 and then Ekind (Typ) /= E_Anonymous_Access_Type
2504 and then Covers (It.Typ, Typ))
2509 Get_Next_Interp (I, It);
2514 end Has_Compatible_Type;
2516 ---------------------
2517 -- Has_Abstract_Op --
2518 ---------------------
2520 function Has_Abstract_Op
2522 Typ : Entity_Id) return Entity_Id
2528 if Is_Overloaded (N) then
2529 Get_First_Interp (N, I, It);
2530 while Present (It.Nam) loop
2531 if Present (It.Abstract_Op)
2532 and then Etype (It.Abstract_Op) = Typ
2534 return It.Abstract_Op;
2537 Get_Next_Interp (I, It);
2542 end Has_Abstract_Op;
2548 function Hash (N : Node_Id) return Int is
2550 -- Nodes have a size that is power of two, so to select significant
2551 -- bits only we remove the low-order bits.
2553 return ((Int (N) / 2 ** 5) mod Header_Size);
2560 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2561 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2563 return Operator_Matches_Spec (Op, F)
2564 and then (In_Open_Scopes (Scope (F))
2565 or else Scope (F) = Scope (Btyp)
2566 or else (not In_Open_Scopes (Scope (Btyp))
2567 and then not In_Use (Btyp)
2568 and then not In_Use (Scope (Btyp))));
2571 ------------------------
2572 -- Init_Interp_Tables --
2573 ------------------------
2575 procedure Init_Interp_Tables is
2579 Headers := (others => No_Entry);
2580 end Init_Interp_Tables;
2582 -----------------------------------
2583 -- Interface_Present_In_Ancestor --
2584 -----------------------------------
2586 function Interface_Present_In_Ancestor
2588 Iface : Entity_Id) return Boolean
2590 Target_Typ : Entity_Id;
2591 Iface_Typ : Entity_Id;
2593 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2594 -- Returns True if Typ or some ancestor of Typ implements Iface
2596 -------------------------------
2597 -- Iface_Present_In_Ancestor --
2598 -------------------------------
2600 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2606 if Typ = Iface_Typ then
2610 -- Handle private types
2612 if Present (Full_View (Typ))
2613 and then not Is_Concurrent_Type (Full_View (Typ))
2615 E := Full_View (Typ);
2621 if Present (Interfaces (E))
2622 and then not Is_Empty_Elmt_List (Interfaces (E))
2624 Elmt := First_Elmt (Interfaces (E));
2625 while Present (Elmt) loop
2628 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2636 exit when Etype (E) = E
2638 -- Handle private types
2640 or else (Present (Full_View (Etype (E)))
2641 and then Full_View (Etype (E)) = E);
2643 -- Check if the current type is a direct derivation of the
2646 if Etype (E) = Iface_Typ then
2650 -- Climb to the immediate ancestor handling private types
2652 if Present (Full_View (Etype (E))) then
2653 E := Full_View (Etype (E));
2660 end Iface_Present_In_Ancestor;
2662 -- Start of processing for Interface_Present_In_Ancestor
2665 -- Iface might be a class-wide subtype, so we have to apply Base_Type
2667 if Is_Class_Wide_Type (Iface) then
2668 Iface_Typ := Etype (Base_Type (Iface));
2675 Iface_Typ := Base_Type (Iface_Typ);
2677 if Is_Access_Type (Typ) then
2678 Target_Typ := Etype (Directly_Designated_Type (Typ));
2683 if Is_Concurrent_Record_Type (Target_Typ) then
2684 Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2687 Target_Typ := Base_Type (Target_Typ);
2689 -- In case of concurrent types we can't use the Corresponding Record_Typ
2690 -- to look for the interface because it is built by the expander (and
2691 -- hence it is not always available). For this reason we traverse the
2692 -- list of interfaces (available in the parent of the concurrent type)
2694 if Is_Concurrent_Type (Target_Typ) then
2695 if Present (Interface_List (Parent (Target_Typ))) then
2700 AI := First (Interface_List (Parent (Target_Typ)));
2702 -- The progenitor itself may be a subtype of an interface type.
2704 while Present (AI) loop
2705 if Etype (AI) = Iface_Typ
2706 or else Base_Type (Etype (AI)) = Iface_Typ
2710 elsif Present (Interfaces (Etype (AI)))
2711 and then Iface_Present_In_Ancestor (Etype (AI))
2724 if Is_Class_Wide_Type (Target_Typ) then
2725 Target_Typ := Etype (Target_Typ);
2728 if Ekind (Target_Typ) = E_Incomplete_Type then
2730 -- We must have either a full view or a nonlimited view of the type
2731 -- to locate the list of ancestors.
2733 if Present (Full_View (Target_Typ)) then
2734 Target_Typ := Full_View (Target_Typ);
2736 -- In a spec expression or in an expression function, the use of
2737 -- an incomplete type is legal; legality of the conversion will be
2738 -- checked at freeze point of related entity.
2740 if In_Spec_Expression then
2744 pragma Assert (Present (Non_Limited_View (Target_Typ)));
2745 Target_Typ := Non_Limited_View (Target_Typ);
2749 -- Protect the front end against previously detected errors
2751 if Ekind (Target_Typ) = E_Incomplete_Type then
2756 return Iface_Present_In_Ancestor (Target_Typ);
2757 end Interface_Present_In_Ancestor;
2759 ---------------------
2760 -- Intersect_Types --
2761 ---------------------
2763 function Intersect_Types (L, R : Node_Id) return Entity_Id is
2764 Index : Interp_Index;
2768 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2769 -- Find interpretation of right arg that has type compatible with T
2771 --------------------------
2772 -- Check_Right_Argument --
2773 --------------------------
2775 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2776 Index : Interp_Index;
2781 if not Is_Overloaded (R) then
2782 return Specific_Type (T, Etype (R));
2785 Get_First_Interp (R, Index, It);
2787 T2 := Specific_Type (T, It.Typ);
2789 if T2 /= Any_Type then
2793 Get_Next_Interp (Index, It);
2794 exit when No (It.Typ);
2799 end Check_Right_Argument;
2801 -- Start of processing for Intersect_Types
2804 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2808 if not Is_Overloaded (L) then
2809 Typ := Check_Right_Argument (Etype (L));
2813 Get_First_Interp (L, Index, It);
2814 while Present (It.Typ) loop
2815 Typ := Check_Right_Argument (It.Typ);
2816 exit when Typ /= Any_Type;
2817 Get_Next_Interp (Index, It);
2822 -- If Typ is Any_Type, it means no compatible pair of types was found
2824 if Typ = Any_Type then
2825 if Nkind (Parent (L)) in N_Op then
2826 Error_Msg_N ("incompatible types for operator", Parent (L));
2828 elsif Nkind (Parent (L)) = N_Range then
2829 Error_Msg_N ("incompatible types given in constraint", Parent (L));
2831 -- Ada 2005 (AI-251): Complete the error notification
2833 elsif Is_Class_Wide_Type (Etype (R))
2834 and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2836 Error_Msg_NE ("(Ada 2005) does not implement interface }",
2837 L, Etype (Class_Wide_Type (Etype (R))));
2839 -- Specialize message if one operand is a limited view, a priori
2840 -- unrelated to all other types.
2842 elsif From_Limited_With (Etype (R)) then
2843 Error_Msg_NE ("limited view of& not compatible with context",
2846 elsif From_Limited_With (Etype (L)) then
2847 Error_Msg_NE ("limited view of& not compatible with context",
2850 Error_Msg_N ("incompatible types", Parent (L));
2855 end Intersect_Types;
2857 -----------------------
2858 -- In_Generic_Actual --
2859 -----------------------
2861 function In_Generic_Actual (Exp : Node_Id) return Boolean is
2862 Par : constant Node_Id := Parent (Exp);
2868 elsif Nkind (Par) in N_Declaration then
2870 Nkind (Par) = N_Object_Declaration
2871 and then Present (Corresponding_Generic_Association (Par));
2873 elsif Nkind (Par) = N_Object_Renaming_Declaration then
2874 return Present (Corresponding_Generic_Association (Par));
2876 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2880 return In_Generic_Actual (Par);
2882 end In_Generic_Actual;
2888 function Is_Ancestor
2891 Use_Full_View : Boolean := False) return Boolean
2898 BT1 := Base_Type (T1);
2899 BT2 := Base_Type (T2);
2901 -- Handle underlying view of records with unknown discriminants using
2902 -- the original entity that motivated the construction of this
2903 -- underlying record view (see Build_Derived_Private_Type).
2905 if Is_Underlying_Record_View (BT1) then
2906 BT1 := Underlying_Record_View (BT1);
2909 if Is_Underlying_Record_View (BT2) then
2910 BT2 := Underlying_Record_View (BT2);
2916 -- The predicate must look past privacy
2918 elsif Is_Private_Type (T1)
2919 and then Present (Full_View (T1))
2920 and then BT2 = Base_Type (Full_View (T1))
2924 elsif Is_Private_Type (T2)
2925 and then Present (Full_View (T2))
2926 and then BT1 = Base_Type (Full_View (T2))
2931 -- Obtain the parent of the base type of T2 (use the full view if
2935 and then Is_Private_Type (BT2)
2936 and then Present (Full_View (BT2))
2938 -- No climbing needed if its full view is the root type
2940 if Full_View (BT2) = Root_Type (Full_View (BT2)) then
2944 Par := Etype (Full_View (BT2));
2951 -- If there was a error on the type declaration, do not recurse
2953 if Error_Posted (Par) then
2956 elsif BT1 = Base_Type (Par)
2957 or else (Is_Private_Type (T1)
2958 and then Present (Full_View (T1))
2959 and then Base_Type (Par) = Base_Type (Full_View (T1)))
2963 elsif Is_Private_Type (Par)
2964 and then Present (Full_View (Par))
2965 and then Full_View (Par) = BT1
2971 elsif Par = Root_Type (Par) then
2974 -- Continue climbing
2977 -- Use the full-view of private types (if allowed). Guard
2978 -- against infinite loops when full view has same type as
2979 -- parent, as can happen with interface extensions.
2982 and then Is_Private_Type (Par)
2983 and then Present (Full_View (Par))
2984 and then Par /= Etype (Full_View (Par))
2986 Par := Etype (Full_View (Par));
2995 ---------------------------
2996 -- Is_Invisible_Operator --
2997 ---------------------------
2999 function Is_Invisible_Operator
3001 T : Entity_Id) return Boolean
3003 Orig_Node : constant Node_Id := Original_Node (N);
3006 if Nkind (N) not in N_Op then
3009 elsif not Comes_From_Source (N) then
3012 elsif No (Universal_Interpretation (Right_Opnd (N))) then
3015 elsif Nkind (N) in N_Binary_Op
3016 and then No (Universal_Interpretation (Left_Opnd (N)))
3021 return Is_Numeric_Type (T)
3022 and then not In_Open_Scopes (Scope (T))
3023 and then not Is_Potentially_Use_Visible (T)
3024 and then not In_Use (T)
3025 and then not In_Use (Scope (T))
3027 (Nkind (Orig_Node) /= N_Function_Call
3028 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
3029 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
3030 and then not In_Instance;
3032 end Is_Invisible_Operator;
3034 --------------------
3036 --------------------
3038 function Is_Progenitor
3040 Typ : Entity_Id) return Boolean
3043 return Implements_Interface (Typ, Iface, Exclude_Parents => True);
3050 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
3054 S := Ancestor_Subtype (T1);
3055 while Present (S) loop
3059 S := Ancestor_Subtype (S);
3070 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
3071 Index : Interp_Index;
3075 Get_First_Interp (Nam, Index, It);
3076 while Present (It.Nam) loop
3077 if Scope (It.Nam) = Standard_Standard
3078 and then Scope (It.Typ) /= Standard_Standard
3080 Error_Msg_Sloc := Sloc (Parent (It.Typ));
3081 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
3084 Error_Msg_Sloc := Sloc (It.Nam);
3085 Error_Msg_NE ("\\& declared#!", Err, It.Nam);
3088 Get_Next_Interp (Index, It);
3096 procedure New_Interps (N : Node_Id) is
3100 All_Interp.Append (No_Interp);
3102 Map_Ptr := Headers (Hash (N));
3104 if Map_Ptr = No_Entry then
3106 -- Place new node at end of table
3108 Interp_Map.Increment_Last;
3109 Headers (Hash (N)) := Interp_Map.Last;
3112 -- Place node at end of chain, or locate its previous entry
3115 if Interp_Map.Table (Map_Ptr).Node = N then
3117 -- Node is already in the table, and is being rewritten.
3118 -- Start a new interp section, retain hash link.
3120 Interp_Map.Table (Map_Ptr).Node := N;
3121 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
3122 Set_Is_Overloaded (N, True);
3126 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
3127 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3131 -- Chain the new node
3133 Interp_Map.Increment_Last;
3134 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
3137 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
3138 Set_Is_Overloaded (N, True);
3141 ---------------------------
3142 -- Operator_Matches_Spec --
3143 ---------------------------
3145 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
3146 New_First_F : constant Entity_Id := First_Formal (New_S);
3147 Op_Name : constant Name_Id := Chars (Op);
3148 T : constant Entity_Id := Etype (New_S);
3156 -- To verify that a predefined operator matches a given signature, do a
3157 -- case analysis of the operator classes. Function can have one or two
3158 -- formals and must have the proper result type.
3160 New_F := New_First_F;
3161 Old_F := First_Formal (Op);
3163 while Present (New_F) and then Present (Old_F) loop
3165 Next_Formal (New_F);
3166 Next_Formal (Old_F);
3169 -- Definite mismatch if different number of parameters
3171 if Present (Old_F) or else Present (New_F) then
3177 T1 := Etype (New_First_F);
3179 if Op_Name in Name_Op_Subtract | Name_Op_Add | Name_Op_Abs then
3180 return Base_Type (T1) = Base_Type (T)
3181 and then Is_Numeric_Type (T);
3183 elsif Op_Name = Name_Op_Not then
3184 return Base_Type (T1) = Base_Type (T)
3185 and then Valid_Boolean_Arg (Base_Type (T));
3194 T1 := Etype (New_First_F);
3195 T2 := Etype (Next_Formal (New_First_F));
3197 if Op_Name in Name_Op_And | Name_Op_Or | Name_Op_Xor then
3198 return Base_Type (T1) = Base_Type (T2)
3199 and then Base_Type (T1) = Base_Type (T)
3200 and then Valid_Boolean_Arg (Base_Type (T));
3202 elsif Op_Name in Name_Op_Eq | Name_Op_Ne then
3203 return Base_Type (T1) = Base_Type (T2)
3204 and then not Is_Limited_Type (T1)
3205 and then Is_Boolean_Type (T);
3207 elsif Op_Name in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
3209 return Base_Type (T1) = Base_Type (T2)
3210 and then Valid_Comparison_Arg (T1)
3211 and then Is_Boolean_Type (T);
3213 elsif Op_Name in Name_Op_Add | Name_Op_Subtract then
3214 return Base_Type (T1) = Base_Type (T2)
3215 and then Base_Type (T1) = Base_Type (T)
3216 and then Is_Numeric_Type (T);
3218 -- For division and multiplication, a user-defined function does not
3219 -- match the predefined universal_fixed operation, except in Ada 83.
3221 elsif Op_Name = Name_Op_Divide then
3222 return (Base_Type (T1) = Base_Type (T2)
3223 and then Base_Type (T1) = Base_Type (T)
3224 and then Is_Numeric_Type (T)
3225 and then (not Is_Fixed_Point_Type (T)
3226 or else Ada_Version = Ada_83))
3228 -- Mixed_Mode operations on fixed-point types
3230 or else (Base_Type (T1) = Base_Type (T)
3231 and then Base_Type (T2) = Base_Type (Standard_Integer)
3232 and then Is_Fixed_Point_Type (T))
3234 -- A user defined operator can also match (and hide) a mixed
3235 -- operation on universal literals.
3237 or else (Is_Integer_Type (T2)
3238 and then Is_Floating_Point_Type (T1)
3239 and then Base_Type (T1) = Base_Type (T));
3241 elsif Op_Name = Name_Op_Multiply then
3242 return (Base_Type (T1) = Base_Type (T2)
3243 and then Base_Type (T1) = Base_Type (T)
3244 and then Is_Numeric_Type (T)
3245 and then (not Is_Fixed_Point_Type (T)
3246 or else Ada_Version = Ada_83))
3248 -- Mixed_Mode operations on fixed-point types
3250 or else (Base_Type (T1) = Base_Type (T)
3251 and then Base_Type (T2) = Base_Type (Standard_Integer)
3252 and then Is_Fixed_Point_Type (T))
3254 or else (Base_Type (T2) = Base_Type (T)
3255 and then Base_Type (T1) = Base_Type (Standard_Integer)
3256 and then Is_Fixed_Point_Type (T))
3258 or else (Is_Integer_Type (T2)
3259 and then Is_Floating_Point_Type (T1)
3260 and then Base_Type (T1) = Base_Type (T))
3262 or else (Is_Integer_Type (T1)
3263 and then Is_Floating_Point_Type (T2)
3264 and then Base_Type (T2) = Base_Type (T));
3266 elsif Op_Name in Name_Op_Mod | Name_Op_Rem then
3267 return Base_Type (T1) = Base_Type (T2)
3268 and then Base_Type (T1) = Base_Type (T)
3269 and then Is_Integer_Type (T);
3271 elsif Op_Name = Name_Op_Expon then
3272 return Base_Type (T1) = Base_Type (T)
3273 and then Is_Numeric_Type (T)
3274 and then Base_Type (T2) = Base_Type (Standard_Integer);
3276 elsif Op_Name = Name_Op_Concat then
3277 return Is_Array_Type (T)
3278 and then (Base_Type (T) = Base_Type (Etype (Op)))
3279 and then (Base_Type (T1) = Base_Type (T)
3281 Base_Type (T1) = Base_Type (Component_Type (T)))
3282 and then (Base_Type (T2) = Base_Type (T)
3284 Base_Type (T2) = Base_Type (Component_Type (T)));
3290 end Operator_Matches_Spec;
3296 procedure Remove_Interp (I : in out Interp_Index) is
3300 -- Find end of interp list and copy downward to erase the discarded one
3303 while Present (All_Interp.Table (II).Typ) loop
3307 for J in I + 1 .. II loop
3308 All_Interp.Table (J - 1) := All_Interp.Table (J);
3311 -- Back up interp index to insure that iterator will pick up next
3312 -- available interpretation.
3321 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
3323 O_N : Node_Id := Old_N;
3326 if Is_Overloaded (Old_N) then
3327 Set_Is_Overloaded (New_N);
3329 if Nkind (Old_N) = N_Selected_Component
3330 and then Is_Overloaded (Selector_Name (Old_N))
3332 O_N := Selector_Name (Old_N);
3335 Map_Ptr := Headers (Hash (O_N));
3337 while Interp_Map.Table (Map_Ptr).Node /= O_N loop
3338 Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3339 pragma Assert (Map_Ptr /= No_Entry);
3342 New_Interps (New_N);
3343 Interp_Map.Table (Interp_Map.Last).Index :=
3344 Interp_Map.Table (Map_Ptr).Index;
3352 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
3353 T1 : constant Entity_Id := Available_View (Typ_1);
3354 T2 : constant Entity_Id := Available_View (Typ_2);
3355 B1 : constant Entity_Id := Base_Type (T1);
3356 B2 : constant Entity_Id := Base_Type (T2);
3358 function Is_Remote_Access (T : Entity_Id) return Boolean;
3359 -- Check whether T is the equivalent type of a remote access type.
3360 -- If distribution is enabled, T is a legal context for Null.
3362 ----------------------
3363 -- Is_Remote_Access --
3364 ----------------------
3366 function Is_Remote_Access (T : Entity_Id) return Boolean is
3368 return Is_Record_Type (T)
3369 and then (Is_Remote_Call_Interface (T)
3370 or else Is_Remote_Types (T))
3371 and then Present (Corresponding_Remote_Type (T))
3372 and then Is_Access_Type (Corresponding_Remote_Type (T));
3373 end Is_Remote_Access;
3375 -- Start of processing for Specific_Type
3378 if T1 = Any_Type or else T2 = Any_Type then
3385 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
3386 or else (T1 = Universal_Real and then Is_Real_Type (T2))
3387 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
3388 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
3392 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
3393 or else (T2 = Universal_Real and then Is_Real_Type (T1))
3394 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
3395 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
3399 elsif T2 = Any_String and then Is_String_Type (T1) then
3402 elsif T1 = Any_String and then Is_String_Type (T2) then
3405 elsif T2 = Any_Character and then Is_Character_Type (T1) then
3408 elsif T1 = Any_Character and then Is_Character_Type (T2) then
3411 elsif T1 = Any_Access
3412 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3416 elsif T2 = Any_Access
3417 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3421 -- In an instance, the specific type may have a private view. Use full
3422 -- view to check legality.
3424 elsif T2 = Any_Access
3425 and then Is_Private_Type (T1)
3426 and then Present (Full_View (T1))
3427 and then Is_Access_Type (Full_View (T1))
3428 and then In_Instance
3432 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
3435 elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then
3438 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3441 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3444 -- ----------------------------------------------------------
3445 -- Special cases for equality operators (all other predefined
3446 -- operators can never apply to tagged types)
3447 -- ----------------------------------------------------------
3449 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3452 elsif Is_Class_Wide_Type (T1)
3453 and then Is_Class_Wide_Type (T2)
3454 and then Is_Interface (Etype (T2))
3458 -- Ada 2005 (AI-251): T1 is a concrete type that implements the
3459 -- class-wide interface T2
3461 elsif Is_Class_Wide_Type (T2)
3462 and then Is_Interface (Etype (T2))
3463 and then Interface_Present_In_Ancestor (Typ => T1,
3464 Iface => Etype (T2))
3468 elsif Is_Class_Wide_Type (T1)
3469 and then Is_Ancestor (Root_Type (T1), T2)
3473 elsif Is_Class_Wide_Type (T2)
3474 and then Is_Ancestor (Root_Type (T2), T1)
3478 elsif Is_Access_Type (T1)
3479 and then Is_Access_Type (T2)
3480 and then Is_Class_Wide_Type (Designated_Type (T1))
3481 and then not Is_Class_Wide_Type (Designated_Type (T2))
3483 Is_Ancestor (Root_Type (Designated_Type (T1)), Designated_Type (T2))
3487 elsif Is_Access_Type (T1)
3488 and then Is_Access_Type (T2)
3489 and then Is_Class_Wide_Type (Designated_Type (T2))
3490 and then not Is_Class_Wide_Type (Designated_Type (T1))
3492 Is_Ancestor (Root_Type (Designated_Type (T2)), Designated_Type (T1))
3496 elsif Ekind (B1) in E_Access_Subprogram_Type
3497 | E_Access_Protected_Subprogram_Type
3498 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3499 and then Is_Access_Type (T2)
3503 elsif Ekind (B2) in E_Access_Subprogram_Type
3504 | E_Access_Protected_Subprogram_Type
3505 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3506 and then Is_Access_Type (T1)
3510 elsif Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type
3511 and then Is_Access_Type (T2)
3515 elsif Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type
3516 and then Is_Access_Type (T1)
3520 -- Ada 2005 (AI-230): Support the following operators:
3522 -- function "=" (L, R : universal_access) return Boolean;
3523 -- function "/=" (L, R : universal_access) return Boolean;
3525 -- Pool-specific access types (E_Access_Type) are not covered by these
3526 -- operators because of the legality rule of 4.5.2(9.2): "The operands
3527 -- of the equality operators for universal_access shall be convertible
3528 -- to one another (see 4.6)". For example, considering the type decla-
3529 -- ration "type P is access Integer" and an anonymous access to Integer,
3530 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
3531 -- is no rule in 4.6 that allows "access Integer" to be converted to P.
3532 -- Note that this does not preclude one operand to be a pool-specific
3533 -- access type, as a previous version of this code enforced.
3535 elsif Ada_Version >= Ada_2005 then
3536 if Is_Anonymous_Access_Type (T1)
3537 and then Is_Access_Type (T2)
3541 elsif Is_Anonymous_Access_Type (T2)
3542 and then Is_Access_Type (T1)
3548 -- If none of the above cases applies, types are not compatible
3553 ---------------------
3554 -- Set_Abstract_Op --
3555 ---------------------
3557 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3559 All_Interp.Table (I).Abstract_Op := V;
3560 end Set_Abstract_Op;
3562 -----------------------
3563 -- Valid_Boolean_Arg --
3564 -----------------------
3566 -- In addition to booleans and arrays of booleans, we must include
3567 -- aggregates as valid boolean arguments, because in the first pass of
3568 -- resolution their components are not examined. If it turns out not to be
3569 -- an aggregate of booleans, this will be diagnosed in Resolve.
3570 -- Any_Composite must be checked for prior to the array type checks because
3571 -- Any_Composite does not have any associated indexes.
3573 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3575 if Is_Boolean_Type (T)
3576 or else Is_Modular_Integer_Type (T)
3577 or else T = Universal_Integer
3578 or else T = Any_Composite
3582 elsif Is_Array_Type (T)
3583 and then T /= Any_String
3584 and then Number_Dimensions (T) = 1
3585 and then Is_Boolean_Type (Component_Type (T))
3587 ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T))
3589 or else Available_Full_View_Of_Component (T))
3596 end Valid_Boolean_Arg;
3598 --------------------------
3599 -- Valid_Comparison_Arg --
3600 --------------------------
3602 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3605 if T = Any_Composite then
3608 elsif Is_Discrete_Type (T)
3609 or else Is_Real_Type (T)
3613 elsif Is_Array_Type (T)
3614 and then Number_Dimensions (T) = 1
3615 and then Is_Discrete_Type (Component_Type (T))
3616 and then (not Is_Private_Composite (T) or else In_Instance)
3617 and then (not Is_Limited_Composite (T) or else In_Instance)
3621 elsif Is_Array_Type (T)
3622 and then Number_Dimensions (T) = 1
3623 and then Is_Discrete_Type (Component_Type (T))
3624 and then Available_Full_View_Of_Component (T)
3628 elsif Is_String_Type (T) then
3633 end Valid_Comparison_Arg;
3639 procedure Write_Interp (It : Interp) is
3641 Write_Str ("Nam: ");
3642 Print_Tree_Node (It.Nam);
3643 Write_Str ("Typ: ");
3644 Print_Tree_Node (It.Typ);
3645 Write_Str ("Abstract_Op: ");
3646 Print_Tree_Node (It.Abstract_Op);
3649 ----------------------
3650 -- Write_Interp_Ref --
3651 ----------------------
3653 procedure Write_Interp_Ref (Map_Ptr : Int) is
3655 Write_Str (" Node: ");
3656 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3657 Write_Str (" Index: ");
3658 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3659 Write_Str (" Next: ");
3660 Write_Int (Interp_Map.Table (Map_Ptr).Next);
3662 end Write_Interp_Ref;
3664 ---------------------
3665 -- Write_Overloads --
3666 ---------------------
3668 procedure Write_Overloads (N : Node_Id) is
3674 Write_Str ("Overloads: ");
3675 Print_Node_Briefly (N);
3677 if not Is_Overloaded (N) then
3678 if Is_Entity_Name (N) then
3679 Write_Line ("Non-overloaded entity ");
3680 Write_Entity_Info (Entity (N), " ");
3683 elsif Nkind (N) not in N_Has_Entity then
3684 Get_First_Interp (N, I, It);
3685 while Present (It.Nam) loop
3686 Write_Int (Int (It.Typ));
3688 Write_Name (Chars (It.Typ));
3690 Get_Next_Interp (I, It);
3694 Get_First_Interp (N, I, It);
3695 Write_Line ("Overloaded entity ");
3696 Write_Line (" Name Type Abstract Op");
3697 Write_Line ("===============================================");
3700 while Present (Nam) loop
3701 Write_Int (Int (Nam));
3703 Write_Name (Chars (Nam));
3705 Write_Int (Int (It.Typ));
3707 Write_Name (Chars (It.Typ));
3709 if Present (It.Abstract_Op) then
3711 Write_Int (Int (It.Abstract_Op));
3713 Write_Name (Chars (It.Abstract_Op));
3717 Get_Next_Interp (I, It);
3721 end Write_Overloads;