gcc/ada/sem_type.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ T Y P E                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  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.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Alloc;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Nlists;   use Nlists;
  32 with Errout;   use Errout;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  35 with Opt;      use Opt;
  36 with Output;   use Output;
  37 with Sem;      use Sem;
  38 with Sem_Aux;  use Sem_Aux;
  39 with Sem_Ch6;  use Sem_Ch6;
  40 with Sem_Ch8;  use Sem_Ch8;
  41 with Sem_Ch12; use Sem_Ch12;
  42 with Sem_Disp; use Sem_Disp;
  43 with Sem_Dist; use Sem_Dist;
  44 with Sem_Util; use Sem_Util;
  45 with Stand;    use Stand;
  46 with Sinfo;    use Sinfo;
  47 with Snames;   use Snames;
  48 with Table;
  49 with Uintp;    use Uintp;
  50
  51 package body Sem_Type is
  52
  53    ---------------------
  54    -- Data Structures --
  55    ---------------------
  56
  57    --  The following data structures establish a mapping between nodes and
  58    --  their interpretations. An overloaded node has an entry in Interp_Map,
  59    --  which in turn contains a pointer into the All_Interp array. The
  60    --  interpretations of a given node are contiguous in All_Interp. Each set
  61    --  of interpretations is terminated with the marker No_Interp. In order to
  62    --  speed up the retrieval of the interpretations of an overloaded node, the
  63    --  Interp_Map table is accessed by means of a simple hashing scheme, and
  64    --  the entries in Interp_Map are chained. The heads of clash lists are
  65    --  stored in array Headers.
  66
  67    --              Headers        Interp_Map          All_Interp
  68
  69    --                 _            +-----+             +--------+
  70    --                |_|           |_____|         --->|interp1 |
  71    --                |_|---------->|node |         |   |interp2 |
  72    --                |_|           |index|---------|   |nointerp|
  73    --                |_|           |next |             |        |
  74    --                              |-----|             |        |
  75    --                              +-----+             +--------+
  76
  77    --  This scheme does not currently reclaim interpretations. In principle,
  78    --  after a unit is compiled, all overloadings have been resolved, and the
  79    --  candidate interpretations should be deleted. This should be easier
  80    --  now than with the previous scheme???
  81
  82    package All_Interp is new Table.Table (
  83      Table_Component_Type => Interp,
  84      Table_Index_Type     => Int,
  85      Table_Low_Bound      => 0,
  86      Table_Initial        => Alloc.All_Interp_Initial,
  87      Table_Increment      => Alloc.All_Interp_Increment,
  88      Table_Name           => "All_Interp");
  89
  90    type Interp_Ref is record
  91       Node  : Node_Id;
  92       Index : Interp_Index;
  93       Next  : Int;
  94    end record;
  95
  96    Header_Size : constant Int := 2 ** 12;
  97    No_Entry    : constant Int := -1;
  98    Headers     : array (0 .. Header_Size) of Int := (others => No_Entry);
  99
 100    package Interp_Map is new Table.Table (
 101      Table_Component_Type => Interp_Ref,
 102      Table_Index_Type     => Int,
 103      Table_Low_Bound      => 0,
 104      Table_Initial        => Alloc.Interp_Map_Initial,
 105      Table_Increment      => Alloc.Interp_Map_Increment,
 106      Table_Name           => "Interp_Map");
 107
 108    function Hash (N : Node_Id) return Int;
 109    --  A trivial hashing function for nodes, used to insert an overloaded
 110    --  node into the Interp_Map table.
 111
 112    -------------------------------------
 113    -- Handling of Overload Resolution --
 114    -------------------------------------
 115
 116    --  Overload resolution uses two passes over the syntax tree of a complete
 117    --  context. In the first, bottom-up pass, the types of actuals in calls
 118    --  are used to resolve possibly overloaded subprogram and operator names.
 119    --  In the second top-down pass, the type of the context (for example the
 120    --  condition in a while statement) is used to resolve a possibly ambiguous
 121    --  call, and the unique subprogram name in turn imposes a specific context
 122    --  on each of its actuals.
 123
 124    --  Most expressions are in fact unambiguous, and the bottom-up pass is
 125    --  sufficient  to resolve most everything. To simplify the common case,
 126    --  names and expressions carry a flag Is_Overloaded to indicate whether
 127    --  they have more than one interpretation. If the flag is off, then each
 128    --  name has already a unique meaning and type, and the bottom-up pass is
 129    --  sufficient (and much simpler).
 130
 131    --------------------------
 132    -- Operator Overloading --
 133    --------------------------
 134
 135    --  The visibility of operators is handled differently from that of other
 136    --  entities. We do not introduce explicit versions of primitive operators
 137    --  for each type definition. As a result, there is only one entity
 138    --  corresponding to predefined addition on all numeric types, etc. The
 139    --  back-end resolves predefined operators according to their type. The
 140    --  visibility of primitive operations then reduces to the visibility of the
 141    --  resulting type: (a + b) is a legal interpretation of some primitive
 142    --  operator + if the type of the result (which must also be the type of a
 143    --  and b) is directly visible (either immediately visible or use-visible).
 144
 145    --  User-defined operators are treated like other functions, but the
 146    --  visibility of these user-defined operations must be special-cased
 147    --  to determine whether they hide or are hidden by predefined operators.
 148    --  The form P."+" (x, y) requires additional handling.
 149
 150    --  Concatenation is treated more conventionally: for every one-dimensional
 151    --  array type we introduce a explicit concatenation operator. This is
 152    --  necessary to handle the case of (element & element => array) which
 153    --  cannot be handled conveniently if there is no explicit instance of
 154    --  resulting type of the operation.
 155
 156    -----------------------
 157    -- Local Subprograms --
 158    -----------------------
 159
 160    procedure All_Overloads;
 161    pragma Warnings (Off, All_Overloads);
 162    --  Debugging procedure: list full contents of Overloads table
 163
 164    function Binary_Op_Interp_Has_Abstract_Op
 165      (N : Node_Id;
 166       E : Entity_Id) return Entity_Id;
 167    --  Given the node and entity of a binary operator, determine whether the
 168    --  actuals of E contain an abstract interpretation with regards to the
 169    --  types of their corresponding formals. Return the abstract operation or
 170    --  Empty.
 171
 172    function Function_Interp_Has_Abstract_Op
 173      (N : Node_Id;
 174       E : Entity_Id) return Entity_Id;
 175    --  Given the node and entity of a function call, determine whether the
 176    --  actuals of E contain an abstract interpretation with regards to the
 177    --  types of their corresponding formals. Return the abstract operation or
 178    --  Empty.
 179
 180    function Has_Abstract_Op
 181      (N   : Node_Id;
 182       Typ : Entity_Id) return Entity_Id;
 183    --  Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
 184    --  Interp_Has_Abstract_Op. Determine whether an overloaded node has an
 185    --  abstract interpretation which yields type Typ.
 186
 187    procedure New_Interps (N : Node_Id);
 188    --  Initialize collection of interpretations for the given node, which is
 189    --  either an overloaded entity, or an operation whose arguments have
 190    --  multiple interpretations. Interpretations can be added to only one
 191    --  node at a time.
 192
 193    function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
 194    --  If Typ_1 and Typ_2 are compatible, return the one that is not universal
 195    --  or is not a "class" type (any_character, etc).
 196
 197    --------------------
 198    -- Add_One_Interp --
 199    --------------------
 200
 201    procedure Add_One_Interp
 202      (N         : Node_Id;
 203       E         : Entity_Id;
 204       T         : Entity_Id;
 205       Opnd_Type : Entity_Id := Empty)
 206    is
 207       Vis_Type : Entity_Id;
 208
 209       procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
 210       --  Add one interpretation to an overloaded node. Add a new entry if
 211       --  not hidden by previous one, and remove previous one if hidden by
 212       --  new one.
 213
 214       function Is_Universal_Operation (Op : Entity_Id) return Boolean;
 215       --  True if the entity is a predefined operator and the operands have
 216       --  a universal Interpretation.
 217
 218       ---------------
 219       -- Add_Entry --
 220       ---------------
 221
 222       procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
 223          Abstr_Op : Entity_Id := Empty;
 224          I        : Interp_Index;
 225          It       : Interp;
 226
 227       --  Start of processing for Add_Entry
 228
 229       begin
 230          --  Find out whether the new entry references interpretations that
 231          --  are abstract or disabled by abstract operators.
 232
 233          if Ada_Version >= Ada_2005 then
 234             if Nkind (N) in N_Binary_Op then
 235                Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
 236             elsif Nkind (N) = N_Function_Call then
 237                Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
 238             end if;
 239          end if;
 240
 241          Get_First_Interp (N, I, It);
 242          while Present (It.Nam) loop
 243
 244             --  A user-defined subprogram hides another declared at an outer
 245             --  level, or one that is use-visible. So return if previous
 246             --  definition hides new one (which is either in an outer
 247             --  scope, or use-visible). Note that for functions use-visible
 248             --  is the same as potentially use-visible. If new one hides
 249             --  previous one, replace entry in table of interpretations.
 250             --  If this is a universal operation, retain the operator in case
 251             --  preference rule applies.
 252
 253             if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
 254                  and then Ekind (Name) = Ekind (It.Nam))
 255                 or else (Ekind (Name) = E_Operator
 256               and then Ekind (It.Nam) = E_Function))
 257
 258               and then Is_Immediately_Visible (It.Nam)
 259               and then Type_Conformant (Name, It.Nam)
 260               and then Base_Type (It.Typ) = Base_Type (T)
 261             then
 262                if Is_Universal_Operation (Name) then
 263                   exit;
 264
 265                --  If node is an operator symbol, we have no actuals with
 266                --  which to check hiding, and this is done in full in the
 267                --  caller (Analyze_Subprogram_Renaming) so we include the
 268                --  predefined operator in any case.
 269
 270                elsif Nkind (N) = N_Operator_Symbol
 271                  or else (Nkind (N) = N_Expanded_Name
 272                             and then
 273                           Nkind (Selector_Name (N)) = N_Operator_Symbol)
 274                then
 275                   exit;
 276
 277                elsif not In_Open_Scopes (Scope (Name))
 278                  or else Scope_Depth (Scope (Name)) <=
 279                          Scope_Depth (Scope (It.Nam))
 280                then
 281                   --  If ambiguity within instance, and entity is not an
 282                   --  implicit operation, save for later disambiguation.
 283
 284                   if Scope (Name) = Scope (It.Nam)
 285                     and then not Is_Inherited_Operation (Name)
 286                     and then In_Instance
 287                   then
 288                      exit;
 289                   else
 290                      return;
 291                   end if;
 292
 293                else
 294                   All_Interp.Table (I).Nam := Name;
 295                   return;
 296                end if;
 297
 298             --  Avoid making duplicate entries in overloads
 299
 300             elsif Name = It.Nam
 301               and then Base_Type (It.Typ) = Base_Type (T)
 302             then
 303                return;
 304
 305             --  Otherwise keep going
 306
 307             else
 308                Get_Next_Interp (I, It);
 309             end if;
 310
 311          end loop;
 312
 313          All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
 314          All_Interp.Append (No_Interp);
 315       end Add_Entry;
 316
 317       ----------------------------
 318       -- Is_Universal_Operation --
 319       ----------------------------
 320
 321       function Is_Universal_Operation (Op : Entity_Id) return Boolean is
 322          Arg : Node_Id;
 323
 324       begin
 325          if Ekind (Op) /= E_Operator then
 326             return False;
 327
 328          elsif Nkind (N) in N_Binary_Op then
 329             return Present (Universal_Interpretation (Left_Opnd (N)))
 330               and then Present (Universal_Interpretation (Right_Opnd (N)));
 331
 332          elsif Nkind (N) in N_Unary_Op then
 333             return Present (Universal_Interpretation (Right_Opnd (N)));
 334
 335          elsif Nkind (N) = N_Function_Call then
 336             Arg := First_Actual (N);
 337             while Present (Arg) loop
 338                if No (Universal_Interpretation (Arg)) then
 339                   return False;
 340                end if;
 341
 342                Next_Actual (Arg);
 343             end loop;
 344
 345             return True;
 346
 347          else
 348             return False;
 349          end if;
 350       end Is_Universal_Operation;
 351
 352    --  Start of processing for Add_One_Interp
 353
 354    begin
 355       --  If the interpretation is a predefined operator, verify that the
 356       --  result type is visible, or that the entity has already been
 357       --  resolved (case of an instantiation node that refers to a predefined
 358       --  operation, or an internally generated operator node, or an operator
 359       --  given as an expanded name). If the operator is a comparison or
 360       --  equality, it is the type of the operand that matters to determine
 361       --  whether the operator is visible. In an instance, the check is not
 362       --  performed, given that the operator was visible in the generic.
 363
 364       if Ekind (E) = E_Operator then
 365          if Present (Opnd_Type) then
 366             Vis_Type := Opnd_Type;
 367          else
 368             Vis_Type := Base_Type (T);
 369          end if;
 370
 371          if In_Open_Scopes (Scope (Vis_Type))
 372            or else Is_Potentially_Use_Visible (Vis_Type)
 373            or else In_Use (Vis_Type)
 374            or else (In_Use (Scope (Vis_Type))
 375                       and then not Is_Hidden (Vis_Type))
 376            or else Nkind (N) = N_Expanded_Name
 377            or else (Nkind (N) in N_Op and then E = Entity (N))
 378            or else In_Instance
 379            or else Ekind (Vis_Type) = E_Anonymous_Access_Type
 380          then
 381             null;
 382
 383          --  If the node is given in functional notation and the prefix
 384          --  is an expanded name, then the operator is visible if the
 385          --  prefix is the scope of the result type as well. If the
 386          --  operator is (implicitly) defined in an extension of system,
 387          --  it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
 388
 389          elsif Nkind (N) = N_Function_Call
 390            and then Nkind (Name (N)) = N_Expanded_Name
 391            and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
 392                        or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
 393                        or else Scope (Vis_Type) = System_Aux_Id)
 394          then
 395             null;
 396
 397          --  Save type for subsequent error message, in case no other
 398          --  interpretation is found.
 399
 400          else
 401             Candidate_Type := Vis_Type;
 402             return;
 403          end if;
 404
 405       --  In an instance, an abstract non-dispatching operation cannot be a
 406       --  candidate interpretation, because it could not have been one in the
 407       --  generic (it may be a spurious overloading in the instance).
 408
 409       elsif In_Instance
 410         and then Is_Overloadable (E)
 411         and then Is_Abstract_Subprogram (E)
 412         and then not Is_Dispatching_Operation (E)
 413       then
 414          return;
 415
 416       --  An inherited interface operation that is implemented by some derived
 417       --  type does not participate in overload resolution, only the
 418       --  implementation operation does.
 419
 420       elsif Is_Hidden (E)
 421         and then Is_Subprogram (E)
 422         and then Present (Interface_Alias (E))
 423       then
 424          --  Ada 2005 (AI-251): If this primitive operation corresponds with
 425          --  an immediate ancestor interface there is no need to add it to the
 426          --  list of interpretations. The corresponding aliased primitive is
 427          --  also in this list of primitive operations and will be used instead
 428          --  because otherwise we have a dummy ambiguity between the two
 429          --  subprograms which are in fact the same.
 430
 431          if not Is_Ancestor
 432                   (Find_Dispatching_Type (Interface_Alias (E)),
 433                    Find_Dispatching_Type (E))
 434          then
 435             Add_One_Interp (N, Interface_Alias (E), T);
 436          end if;
 437
 438          return;
 439
 440       --  Calling stubs for an RACW operation never participate in resolution,
 441       --  they are executed only through dispatching calls.
 442
 443       elsif Is_RACW_Stub_Type_Operation (E) then
 444          return;
 445       end if;
 446
 447       --  If this is the first interpretation of N, N has type Any_Type.
 448       --  In that case place the new type on the node. If one interpretation
 449       --  already exists, indicate that the node is overloaded, and store
 450       --  both the previous and the new interpretation in All_Interp. If
 451       --  this is a later interpretation, just add it to the set.
 452
 453       if Etype (N) = Any_Type then
 454          if Is_Type (E) then
 455             Set_Etype (N, T);
 456
 457          else
 458             --  Record both the operator or subprogram name, and its type
 459
 460             if Nkind (N) in N_Op or else Is_Entity_Name (N) then
 461                Set_Entity (N, E);
 462             end if;
 463
 464             Set_Etype (N, T);
 465          end if;
 466
 467       --  Either there is no current interpretation in the table for any
 468       --  node or the interpretation that is present is for a different
 469       --  node. In both cases add a new interpretation to the table.
 470
 471       elsif Interp_Map.Last < 0
 472         or else
 473           (Interp_Map.Table (Interp_Map.Last).Node /= N
 474              and then not Is_Overloaded (N))
 475       then
 476          New_Interps (N);
 477
 478          if (Nkind (N) in N_Op or else Is_Entity_Name (N))
 479            and then Present (Entity (N))
 480          then
 481             Add_Entry (Entity (N), Etype (N));
 482
 483          elsif Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
 484            and then Is_Entity_Name (Name (N))
 485          then
 486             Add_Entry (Entity (Name (N)), Etype (N));
 487
 488          --  If this is an indirect call there will be no name associated
 489          --  with the previous entry. To make diagnostics clearer, save
 490          --  Subprogram_Type of first interpretation, so that the error will
 491          --  point to the anonymous access to subprogram, not to the result
 492          --  type of the call itself.
 493
 494          elsif (Nkind (N)) = N_Function_Call
 495            and then Nkind (Name (N)) = N_Explicit_Dereference
 496            and then Is_Overloaded (Name (N))
 497          then
 498             declare
 499                It : Interp;
 500
 501                Itn : Interp_Index;
 502                pragma Warnings (Off, Itn);
 503
 504             begin
 505                Get_First_Interp (Name (N), Itn, It);
 506                Add_Entry (It.Nam, Etype (N));
 507             end;
 508
 509          else
 510             --  Overloaded prefix in indexed or selected component, or call
 511             --  whose name is an expression or another call.
 512
 513             Add_Entry (Etype (N), Etype (N));
 514          end if;
 515
 516          Add_Entry (E, T);
 517
 518       else
 519          Add_Entry (E, T);
 520       end if;
 521    end Add_One_Interp;
 522
 523    -------------------
 524    -- All_Overloads --
 525    -------------------
 526
 527    procedure All_Overloads is
 528    begin
 529       for J in All_Interp.First .. All_Interp.Last loop
 530
 531          if Present (All_Interp.Table (J).Nam) then
 532             Write_Entity_Info (All_Interp.Table (J). Nam, " ");
 533          else
 534             Write_Str ("No Interp");
 535             Write_Eol;
 536          end if;
 537
 538          Write_Str ("=================");
 539          Write_Eol;
 540       end loop;
 541    end All_Overloads;
 542
 543    --------------------------------------
 544    -- Binary_Op_Interp_Has_Abstract_Op --
 545    --------------------------------------
 546
 547    function Binary_Op_Interp_Has_Abstract_Op
 548      (N : Node_Id;
 549       E : Entity_Id) return Entity_Id
 550    is
 551       Abstr_Op : Entity_Id;
 552       E_Left   : constant Node_Id := First_Formal (E);
 553       E_Right  : constant Node_Id := Next_Formal (E_Left);
 554
 555    begin
 556       Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
 557       if Present (Abstr_Op) then
 558          return Abstr_Op;
 559       end if;
 560
 561       return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
 562    end Binary_Op_Interp_Has_Abstract_Op;
 563
 564    ---------------------
 565    -- Collect_Interps --
 566    ---------------------
 567
 568    procedure Collect_Interps (N : Node_Id) is
 569       Ent          : constant Entity_Id := Entity (N);
 570       H            : Entity_Id;
 571       First_Interp : Interp_Index;
 572
 573       function Within_Instance (E : Entity_Id) return Boolean;
 574       --  Within an instance there can be spurious ambiguities between a local
 575       --  entity and one declared outside of the instance. This can only happen
 576       --  for subprograms, because otherwise the local entity hides the outer
 577       --  one. For an overloadable entity, this predicate determines whether it
 578       --  is a candidate within the instance, or must be ignored.
 579
 580       ---------------------
 581       -- Within_Instance --
 582       ---------------------
 583
 584       function Within_Instance (E : Entity_Id) return Boolean is
 585          Inst : Entity_Id;
 586          Scop : Entity_Id;
 587
 588       begin
 589          if not In_Instance then
 590             return False;
 591          end if;
 592
 593          Inst := Current_Scope;
 594          while Present (Inst) and then not Is_Generic_Instance (Inst) loop
 595             Inst := Scope (Inst);
 596          end loop;
 597
 598          Scop := Scope (E);
 599          while Present (Scop) and then Scop /= Standard_Standard loop
 600             if Scop = Inst then
 601                return True;
 602             end if;
 603             Scop := Scope (Scop);
 604          end loop;
 605
 606          return False;
 607       end Within_Instance;
 608
 609    --  Start of processing for Collect_Interps
 610
 611    begin
 612       New_Interps (N);
 613
 614       --  Unconditionally add the entity that was initially matched
 615
 616       First_Interp := All_Interp.Last;
 617       Add_One_Interp (N, Ent, Etype (N));
 618
 619       --  For expanded name, pick up all additional entities from the
 620       --  same scope, since these are obviously also visible. Note that
 621       --  these are not necessarily contiguous on the homonym chain.
 622
 623       if Nkind (N) = N_Expanded_Name then
 624          H := Homonym (Ent);
 625          while Present (H) loop
 626             if Scope (H) = Scope (Entity (N)) then
 627                Add_One_Interp (N, H, Etype (H));
 628             end if;
 629
 630             H := Homonym (H);
 631          end loop;
 632
 633       --  Case of direct name
 634
 635       else
 636          --  First, search the homonym chain for directly visible entities
 637
 638          H := Current_Entity (Ent);
 639          while Present (H) loop
 640             exit when (not Is_Overloadable (H))
 641               and then Is_Immediately_Visible (H);
 642
 643             if Is_Immediately_Visible (H)
 644               and then H /= Ent
 645             then
 646                --  Only add interpretation if not hidden by an inner
 647                --  immediately visible one.
 648
 649                for J in First_Interp .. All_Interp.Last - 1 loop
 650
 651                   --  Current homograph is not hidden. Add to overloads
 652
 653                   if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
 654                      exit;
 655
 656                   --  Homograph is hidden, unless it is a predefined operator
 657
 658                   elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
 659
 660                      --  A homograph in the same scope can occur within an
 661                      --  instantiation, the resulting ambiguity has to be
 662                      --  resolved later. The homographs may both be local
 663                      --  functions or actuals, or may be declared at different
 664                      --  levels within the instance. The renaming of an actual
 665                      --  within the instance must not be included.
 666
 667                      if Within_Instance (H)
 668                        and then H /= Renamed_Entity (Ent)
 669                        and then not Is_Inherited_Operation (H)
 670                      then
 671                         All_Interp.Table (All_Interp.Last) :=
 672                           (H, Etype (H), Empty);
 673                         All_Interp.Append (No_Interp);
 674                         goto Next_Homograph;
 675
 676                      elsif Scope (H) /= Standard_Standard then
 677                         goto Next_Homograph;
 678                      end if;
 679                   end if;
 680                end loop;
 681
 682                --  On exit, we know that current homograph is not hidden
 683
 684                Add_One_Interp (N, H, Etype (H));
 685
 686                if Debug_Flag_E then
 687                   Write_Str ("Add overloaded interpretation ");
 688                   Write_Int (Int (H));
 689                   Write_Eol;
 690                end if;
 691             end if;
 692
 693             <<Next_Homograph>>
 694                H := Homonym (H);
 695          end loop;
 696
 697          --  Scan list of homographs for use-visible entities only
 698
 699          H := Current_Entity (Ent);
 700
 701          while Present (H) loop
 702             if Is_Potentially_Use_Visible (H)
 703               and then H /= Ent
 704               and then Is_Overloadable (H)
 705             then
 706                for J in First_Interp .. All_Interp.Last - 1 loop
 707
 708                   if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
 709                      exit;
 710
 711                   elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
 712                      goto Next_Use_Homograph;
 713                   end if;
 714                end loop;
 715
 716                Add_One_Interp (N, H, Etype (H));
 717             end if;
 718
 719             <<Next_Use_Homograph>>
 720                H := Homonym (H);
 721          end loop;
 722       end if;
 723
 724       if All_Interp.Last = First_Interp + 1 then
 725
 726          --  The final interpretation is in fact not overloaded. Note that the
 727          --  unique legal interpretation may or may not be the original one,
 728          --  so we need to update N's entity and etype now, because once N
 729          --  is marked as not overloaded it is also expected to carry the
 730          --  proper interpretation.
 731
 732          Set_Is_Overloaded (N, False);
 733          Set_Entity (N, All_Interp.Table (First_Interp).Nam);
 734          Set_Etype  (N, All_Interp.Table (First_Interp).Typ);
 735       end if;
 736    end Collect_Interps;
 737
 738    ------------
 739    -- Covers --
 740    ------------
 741
 742    function Covers (T1, T2 : Entity_Id) return Boolean is
 743
 744       BT1 : Entity_Id;
 745       BT2 : Entity_Id;
 746
 747       function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
 748       --  In an instance the proper view may not always be correct for
 749       --  private types, but private and full view are compatible. This
 750       --  removes spurious errors from nested instantiations that involve,
 751       --  among other things, types derived from private types.
 752
 753       ----------------------
 754       -- Full_View_Covers --
 755       ----------------------
 756
 757       function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
 758       begin
 759          return
 760            Is_Private_Type (Typ1)
 761              and then
 762               ((Present (Full_View (Typ1))
 763                     and then Covers (Full_View (Typ1), Typ2))
 764                  or else Base_Type (Typ1) = Typ2
 765                  or else Base_Type (Typ2) = Typ1);
 766       end Full_View_Covers;
 767
 768    --  Start of processing for Covers
 769
 770    begin
 771       --  If either operand missing, then this is an error, but ignore it (and
 772       --  pretend we have a cover) if errors already detected, since this may
 773       --  simply mean we have malformed trees or a semantic error upstream.
 774
 775       if No (T1) or else No (T2) then
 776          if Total_Errors_Detected /= 0 then
 777             return True;
 778          else
 779             raise Program_Error;
 780          end if;
 781       end if;
 782
 783       --  Trivial case: same types are always compatible
 784
 785       if T1 = T2 then
 786          return True;
 787       end if;
 788
 789       --  First check for Standard_Void_Type, which is special. Subsequent
 790       --  processing in this routine assumes T1 and T2 are bona fide types;
 791       --  Standard_Void_Type is a special entity that has some, but not all,
 792       --  properties of types.
 793
 794       if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
 795          return False;
 796       end if;
 797
 798       BT1 := Base_Type (T1);
 799       BT2 := Base_Type (T2);
 800
 801       --  Handle underlying view of records with unknown discriminants
 802       --  using the original entity that motivated the construction of
 803       --  this underlying record view (see Build_Derived_Private_Type).
 804
 805       if Is_Underlying_Record_View (BT1) then
 806          BT1 := Underlying_Record_View (BT1);
 807       end if;
 808
 809       if Is_Underlying_Record_View (BT2) then
 810          BT2 := Underlying_Record_View (BT2);
 811       end if;
 812
 813       --  Simplest case: types that have the same base type and are not generic
 814       --  actuals are compatible. Generic actuals belong to their class but are
 815       --  not compatible with other types of their class, and in particular
 816       --  with other generic actuals. They are however compatible with their
 817       --  own subtypes, and itypes with the same base are compatible as well.
 818       --  Similarly, constrained subtypes obtained from expressions of an
 819       --  unconstrained nominal type are compatible with the base type (may
 820       --  lead to spurious ambiguities in obscure cases ???)
 821
 822       --  Generic actuals require special treatment to avoid spurious ambi-
 823       --  guities in an instance, when two formal types are instantiated with
 824       --  the same actual, so that different subprograms end up with the same
 825       --  signature in the instance.
 826
 827       if BT1 = BT2
 828         or else BT1 = T2
 829         or else BT2 = T1
 830       then
 831          if not Is_Generic_Actual_Type (T1) then
 832             return True;
 833          else
 834             return (not Is_Generic_Actual_Type (T2)
 835                      or else Is_Itype (T1)
 836                      or else Is_Itype (T2)
 837                      or else Is_Constr_Subt_For_U_Nominal (T1)
 838                      or else Is_Constr_Subt_For_U_Nominal (T2)
 839                      or else Scope (T1) /= Scope (T2));
 840          end if;
 841
 842       --  Literals are compatible with types in a given "class"
 843
 844       elsif     (T2 = Universal_Integer and then Is_Integer_Type (T1))
 845         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
 846         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
 847         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
 848         or else (T2 = Any_String        and then Is_String_Type (T1))
 849         or else (T2 = Any_Character     and then Is_Character_Type (T1))
 850         or else (T2 = Any_Access        and then Is_Access_Type (T1))
 851       then
 852          return True;
 853
 854       --  The context may be class wide, and a class-wide type is compatible
 855       --  with any member of the class.
 856
 857       elsif Is_Class_Wide_Type (T1)
 858         and then Is_Ancestor (Root_Type (T1), T2)
 859       then
 860          return True;
 861
 862       elsif Is_Class_Wide_Type (T1)
 863         and then Is_Class_Wide_Type (T2)
 864         and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
 865       then
 866          return True;
 867
 868       --  Ada 2005 (AI-345): A class-wide abstract interface type covers a
 869       --  task_type or protected_type that implements the interface.
 870
 871       elsif Ada_Version >= Ada_2005
 872         and then Is_Class_Wide_Type (T1)
 873         and then Is_Interface (Etype (T1))
 874         and then Is_Concurrent_Type (T2)
 875         and then Interface_Present_In_Ancestor
 876                    (Typ => BT2, Iface => Etype (T1))
 877       then
 878          return True;
 879
 880       --  Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
 881       --  object T2 implementing T1.
 882
 883       elsif Ada_Version >= Ada_2005
 884         and then Is_Class_Wide_Type (T1)
 885         and then Is_Interface (Etype (T1))
 886         and then Is_Tagged_Type (T2)
 887       then
 888          if Interface_Present_In_Ancestor (Typ   => T2,
 889                                            Iface => Etype (T1))
 890          then
 891             return True;
 892          end if;
 893
 894          declare
 895             E    : Entity_Id;
 896             Elmt : Elmt_Id;
 897
 898          begin
 899             if Is_Concurrent_Type (BT2) then
 900                E := Corresponding_Record_Type (BT2);
 901             else
 902                E := BT2;
 903             end if;
 904
 905             --  Ada 2005 (AI-251): A class-wide abstract interface type T1
 906             --  covers an object T2 that implements a direct derivation of T1.
 907             --  Note: test for presence of E is defense against previous error.
 908
 909             if Present (E)
 910               and then Present (Interfaces (E))
 911             then
 912                Elmt := First_Elmt (Interfaces (E));
 913                while Present (Elmt) loop
 914                   if Is_Ancestor (Etype (T1), Node (Elmt)) then
 915                      return True;
 916                   end if;
 917
 918                   Next_Elmt (Elmt);
 919                end loop;
 920             end if;
 921
 922             --  We should also check the case in which T1 is an ancestor of
 923             --  some implemented interface???
 924
 925             return False;
 926          end;
 927
 928       --  In a dispatching call, the formal is of some specific type, and the
 929       --  actual is of the corresponding class-wide type, including a subtype
 930       --  of the class-wide type.
 931
 932       elsif Is_Class_Wide_Type (T2)
 933         and then
 934           (Class_Wide_Type (T1) = Class_Wide_Type (T2)
 935              or else Base_Type (Root_Type (T2)) = BT1)
 936       then
 937          return True;
 938
 939       --  Some contexts require a class of types rather than a specific type.
 940       --  For example, conditions require any boolean type, fixed point
 941       --  attributes require some real type, etc. The built-in types Any_XXX
 942       --  represent these classes.
 943
 944       elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
 945         or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
 946         or else (T1 = Any_Real and then Is_Real_Type (T2))
 947         or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
 948         or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
 949       then
 950          return True;
 951
 952       --  An aggregate is compatible with an array or record type
 953
 954       elsif T2 = Any_Composite
 955         and then Is_Aggregate_Type (T1)
 956       then
 957          return True;
 958
 959       --  If the expected type is an anonymous access, the designated type must
 960       --  cover that of the expression. Use the base type for this check: even
 961       --  though access subtypes are rare in sources, they are generated for
 962       --  actuals in instantiations.
 963
 964       elsif Ekind (BT1) = E_Anonymous_Access_Type
 965         and then Is_Access_Type (T2)
 966         and then Covers (Designated_Type (T1), Designated_Type (T2))
 967       then
 968          return True;
 969
 970       --  Ada 2012 (AI05-0149): Allow an anonymous access type in the context
 971       --  of a named general access type. An implicit conversion will be
 972       --  applied. For the resolution, one designated type must cover the
 973       --  other.
 974
 975       elsif Ada_Version >= Ada_2012
 976         and then Ekind (BT1) = E_General_Access_Type
 977         and then Ekind (BT2) = E_Anonymous_Access_Type
 978         and then (Covers (Designated_Type (T1), Designated_Type (T2))
 979                    or else Covers (Designated_Type (T2), Designated_Type (T1)))
 980       then
 981          return True;
 982
 983       --  An Access_To_Subprogram is compatible with itself, or with an
 984       --  anonymous type created for an attribute reference Access.
 985
 986       elsif (Ekind (BT1) = E_Access_Subprogram_Type
 987                or else
 988              Ekind (BT1) = E_Access_Protected_Subprogram_Type)
 989         and then Is_Access_Type (T2)
 990         and then (not Comes_From_Source (T1)
 991                    or else not Comes_From_Source (T2))
 992         and then (Is_Overloadable (Designated_Type (T2))
 993                     or else
 994                   Ekind (Designated_Type (T2)) = E_Subprogram_Type)
 995         and then
 996           Type_Conformant (Designated_Type (T1), Designated_Type (T2))
 997         and then
 998           Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
 999       then
1000          return True;
1001
1002       --  Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
1003       --  with itself, or with an anonymous type created for an attribute
1004       --  reference Access.
1005
1006       elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type
1007                or else
1008              Ekind (BT1)
1009                       = E_Anonymous_Access_Protected_Subprogram_Type)
1010         and then Is_Access_Type (T2)
1011         and then (not Comes_From_Source (T1)
1012                    or else not Comes_From_Source (T2))
1013         and then (Is_Overloadable (Designated_Type (T2))
1014                     or else
1015                   Ekind (Designated_Type (T2)) = E_Subprogram_Type)
1016         and then
1017            Type_Conformant (Designated_Type (T1), Designated_Type (T2))
1018         and then
1019            Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
1020       then
1021          return True;
1022
1023       --  The context can be a remote access type, and the expression the
1024       --  corresponding source type declared in a categorized package, or
1025       --  vice versa.
1026
1027       elsif Is_Record_Type (T1)
1028         and then (Is_Remote_Call_Interface (T1)
1029                    or else Is_Remote_Types (T1))
1030         and then Present (Corresponding_Remote_Type (T1))
1031       then
1032          return Covers (Corresponding_Remote_Type (T1), T2);
1033
1034       --  and conversely.
1035
1036       elsif Is_Record_Type (T2)
1037         and then (Is_Remote_Call_Interface (T2)
1038                    or else Is_Remote_Types (T2))
1039         and then Present (Corresponding_Remote_Type (T2))
1040       then
1041          return Covers (Corresponding_Remote_Type (T2), T1);
1042
1043       --  Synchronized types are represented at run time by their corresponding
1044       --  record type. During expansion one is replaced with the other, but
1045       --  they are compatible views of the same type.
1046
1047       elsif Is_Record_Type (T1)
1048         and then Is_Concurrent_Type (T2)
1049         and then Present (Corresponding_Record_Type (T2))
1050       then
1051          return Covers (T1, Corresponding_Record_Type (T2));
1052
1053       elsif Is_Concurrent_Type (T1)
1054         and then Present (Corresponding_Record_Type (T1))
1055         and then Is_Record_Type (T2)
1056       then
1057          return Covers (Corresponding_Record_Type (T1), T2);
1058
1059       --  During analysis, an attribute reference 'Access has a special type
1060       --  kind: Access_Attribute_Type, to be replaced eventually with the type
1061       --  imposed by context.
1062
1063       elsif Ekind (T2) = E_Access_Attribute_Type
1064         and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
1065         and then Covers (Designated_Type (T1), Designated_Type (T2))
1066       then
1067          --  If the target type is a RACW type while the source is an access
1068          --  attribute type, we are building a RACW that may be exported.
1069
1070          if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1071             Set_Has_RACW (Current_Sem_Unit);
1072          end if;
1073
1074          return True;
1075
1076       --  Ditto for allocators, which eventually resolve to the context type
1077
1078       elsif Ekind (T2) = E_Allocator_Type
1079         and then Is_Access_Type (T1)
1080       then
1081          return Covers (Designated_Type (T1), Designated_Type (T2))
1082           or else
1083             (From_With_Type (Designated_Type (T1))
1084               and then Covers (Designated_Type (T2), Designated_Type (T1)));
1085
1086       --  A boolean operation on integer literals is compatible with modular
1087       --  context.
1088
1089       elsif T2 = Any_Modular
1090         and then Is_Modular_Integer_Type (T1)
1091       then
1092          return True;
1093
1094       --  The actual type may be the result of a previous error
1095
1096       elsif BT2 = Any_Type then
1097          return True;
1098
1099       --  A packed array type covers its corresponding non-packed type. This is
1100       --  not legitimate Ada, but allows the omission of a number of otherwise
1101       --  useless unchecked conversions, and since this can only arise in
1102       --  (known correct) expanded code, no harm is done.
1103
1104       elsif Is_Array_Type (T2)
1105         and then Is_Packed (T2)
1106         and then T1 = Packed_Array_Type (T2)
1107       then
1108          return True;
1109
1110       --  Similarly an array type covers its corresponding packed array type
1111
1112       elsif Is_Array_Type (T1)
1113         and then Is_Packed (T1)
1114         and then T2 = Packed_Array_Type (T1)
1115       then
1116          return True;
1117
1118       --  In instances, or with types exported from instantiations, check
1119       --  whether a partial and a full view match. Verify that types are
1120       --  legal, to prevent cascaded errors.
1121
1122       elsif In_Instance
1123         and then
1124           (Full_View_Covers (T1, T2)
1125             or else Full_View_Covers (T2, T1))
1126       then
1127          return True;
1128
1129       elsif Is_Type (T2)
1130         and then Is_Generic_Actual_Type (T2)
1131         and then Full_View_Covers (T1, T2)
1132       then
1133          return True;
1134
1135       elsif Is_Type (T1)
1136         and then Is_Generic_Actual_Type (T1)
1137         and then Full_View_Covers (T2, T1)
1138       then
1139          return True;
1140
1141       --  In the expansion of inlined bodies, types are compatible if they
1142       --  are structurally equivalent.
1143
1144       elsif In_Inlined_Body
1145         and then (Underlying_Type (T1) = Underlying_Type (T2)
1146                    or else (Is_Access_Type (T1)
1147                               and then Is_Access_Type (T2)
1148                               and then
1149                                 Designated_Type (T1) = Designated_Type (T2))
1150                    or else (T1 = Any_Access
1151                               and then Is_Access_Type (Underlying_Type (T2)))
1152                    or else (T2 = Any_Composite
1153                               and then
1154                                 Is_Composite_Type (Underlying_Type (T1))))
1155       then
1156          return True;
1157
1158       --  Ada 2005 (AI-50217): Additional branches to make the shadow entity
1159       --  obtained through a limited_with compatible with its real entity.
1160
1161       elsif From_With_Type (T1) then
1162
1163          --  If the expected type is the non-limited view of a type, the
1164          --  expression may have the limited view. If that one in turn is
1165          --  incomplete, get full view if available.
1166
1167          if Is_Incomplete_Type (T1) then
1168             return Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1169
1170          elsif Ekind (T1) = E_Class_Wide_Type then
1171             return
1172               Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
1173          else
1174             return False;
1175          end if;
1176
1177       elsif From_With_Type (T2) then
1178
1179          --  If units in the context have Limited_With clauses on each other,
1180          --  either type might have a limited view. Checks performed elsewhere
1181          --  verify that the context type is the nonlimited view.
1182
1183          if Is_Incomplete_Type (T2) then
1184             return Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1185
1186          elsif Ekind (T2) = E_Class_Wide_Type then
1187             return
1188               Present (Non_Limited_View (Etype (T2)))
1189                 and then
1190                   Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
1191          else
1192             return False;
1193          end if;
1194
1195       --  Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1196
1197       elsif Ekind (T1) = E_Incomplete_Subtype then
1198          return Covers (Full_View (Etype (T1)), T2);
1199
1200       elsif Ekind (T2) = E_Incomplete_Subtype then
1201          return Covers (T1, Full_View (Etype (T2)));
1202
1203       --  Ada 2005 (AI-423): Coverage of formal anonymous access types
1204       --  and actual anonymous access types in the context of generic
1205       --  instantiations. We have the following situation:
1206
1207       --     generic
1208       --        type Formal is private;
1209       --        Formal_Obj : access Formal;  --  T1
1210       --     package G is ...
1211
1212       --     package P is
1213       --        type Actual is ...
1214       --        Actual_Obj : access Actual;  --  T2
1215       --        package Instance is new G (Formal     => Actual,
1216       --                                   Formal_Obj => Actual_Obj);
1217
1218       elsif Ada_Version >= Ada_2005
1219         and then Ekind (T1) = E_Anonymous_Access_Type
1220         and then Ekind (T2) = E_Anonymous_Access_Type
1221         and then Is_Generic_Type (Directly_Designated_Type (T1))
1222         and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1223                    Directly_Designated_Type (T2)
1224       then
1225          return True;
1226
1227       --  Otherwise, types are not compatible!
1228
1229       else
1230          return False;
1231       end if;
1232    end Covers;
1233
1234    ------------------
1235    -- Disambiguate --
1236    ------------------
1237
1238    function Disambiguate
1239      (N      : Node_Id;
1240       I1, I2 : Interp_Index;
1241       Typ    : Entity_Id) return Interp
1242    is
1243       I           : Interp_Index;
1244       It          : Interp;
1245       It1, It2    : Interp;
1246       Nam1, Nam2  : Entity_Id;
1247       Predef_Subp : Entity_Id;
1248       User_Subp   : Entity_Id;
1249
1250       function Inherited_From_Actual (S : Entity_Id) return Boolean;
1251       --  Determine whether one of the candidates is an operation inherited by
1252       --  a type that is derived from an actual in an instantiation.
1253
1254       function In_Same_Declaration_List
1255         (Typ     : Entity_Id;
1256          Op_Decl : Entity_Id) return Boolean;
1257       --  AI05-0020: a spurious ambiguity may arise when equality on anonymous
1258       --  access types is declared on the partial view of a designated type, so
1259       --  that the type declaration and equality are not in the same list of
1260       --  declarations. This AI gives a preference rule for the user-defined
1261       --  operation. Same rule applies for arithmetic operations on private
1262       --  types completed with fixed-point types: the predefined operation is
1263       --  hidden;  this is already handled properly in GNAT.
1264
1265       function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1266       --  Determine whether a subprogram is an actual in an enclosing instance.
1267       --  An overloading between such a subprogram and one declared outside the
1268       --  instance is resolved in favor of the first, because it resolved in
1269       --  the generic.
1270
1271       function Matches (Actual, Formal : Node_Id) return Boolean;
1272       --  Look for exact type match in an instance, to remove spurious
1273       --  ambiguities when two formal types have the same actual.
1274
1275       function Operand_Type return Entity_Id;
1276       --  Determine type of operand for an equality operation, to apply
1277       --  Ada 2005 rules to equality on anonymous access types.
1278
1279       function Standard_Operator return Boolean;
1280       --  Check whether subprogram is predefined operator declared in Standard.
1281       --  It may given by an operator name, or by an expanded name whose prefix
1282       --  is Standard.
1283
1284       function Remove_Conversions return Interp;
1285       --  Last chance for pathological cases involving comparisons on literals,
1286       --  and user overloadings of the same operator. Such pathologies have
1287       --  been removed from the ACVC, but still appear in two DEC tests, with
1288       --  the following notable quote from Ben Brosgol:
1289       --
1290       --  [Note: I disclaim all credit/responsibility/blame for coming up with
1291       --  this example; Robert Dewar brought it to our attention, since it is
1292       --  apparently found in the ACVC 1.5. I did not attempt to find the
1293       --  reason in the Reference Manual that makes the example legal, since I
1294       --  was too nauseated by it to want to pursue it further.]
1295       --
1296       --  Accordingly, this is not a fully recursive solution, but it handles
1297       --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1298       --  pathology in the other direction with calls whose multiple overloaded
1299       --  actuals make them truly unresolvable.
1300
1301       --  The new rules concerning abstract operations create additional need
1302       --  for special handling of expressions with universal operands, see
1303       --  comments to Has_Abstract_Interpretation below.
1304
1305       ---------------------------
1306       -- Inherited_From_Actual --
1307       ---------------------------
1308
1309       function Inherited_From_Actual (S : Entity_Id) return Boolean is
1310          Par : constant Node_Id := Parent (S);
1311       begin
1312          if Nkind (Par) /= N_Full_Type_Declaration
1313            or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1314          then
1315             return False;
1316          else
1317             return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1318               and then
1319                Is_Generic_Actual_Type (
1320                  Entity (Subtype_Indication (Type_Definition (Par))));
1321          end if;
1322       end Inherited_From_Actual;
1323
1324       ------------------------------
1325       -- In_Same_Declaration_List --
1326       ------------------------------
1327
1328       function In_Same_Declaration_List
1329         (Typ     : Entity_Id;
1330          Op_Decl : Entity_Id) return Boolean
1331       is
1332          Scop : constant Entity_Id := Scope (Typ);
1333
1334       begin
1335          return In_Same_List (Parent (Typ), Op_Decl)
1336            or else
1337              (Ekind_In (Scop, E_Package, E_Generic_Package)
1338                 and then List_Containing (Op_Decl) =
1339                   Visible_Declarations (Parent (Scop))
1340                 and then List_Containing (Parent (Typ)) =
1341                   Private_Declarations (Parent (Scop)));
1342       end In_Same_Declaration_List;
1343
1344       --------------------------
1345       -- Is_Actual_Subprogram --
1346       --------------------------
1347
1348       function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1349       begin
1350          return In_Open_Scopes (Scope (S))
1351            and then
1352              (Is_Generic_Instance (Scope (S))
1353                or else Is_Wrapper_Package (Scope (S)));
1354       end Is_Actual_Subprogram;
1355
1356       -------------
1357       -- Matches --
1358       -------------
1359
1360       function Matches (Actual, Formal : Node_Id) return Boolean is
1361          T1 : constant Entity_Id := Etype (Actual);
1362          T2 : constant Entity_Id := Etype (Formal);
1363       begin
1364          return T1 = T2
1365            or else
1366              (Is_Numeric_Type (T2)
1367                and then (T1 = Universal_Real or else T1 = Universal_Integer));
1368       end Matches;
1369
1370       ------------------
1371       -- Operand_Type --
1372       ------------------
1373
1374       function Operand_Type return Entity_Id is
1375          Opnd : Node_Id;
1376
1377       begin
1378          if Nkind (N) = N_Function_Call then
1379             Opnd := First_Actual (N);
1380          else
1381             Opnd := Left_Opnd (N);
1382          end if;
1383
1384          return Etype (Opnd);
1385       end Operand_Type;
1386
1387       ------------------------
1388       -- Remove_Conversions --
1389       ------------------------
1390
1391       function Remove_Conversions return Interp is
1392          I    : Interp_Index;
1393          It   : Interp;
1394          It1  : Interp;
1395          F1   : Entity_Id;
1396          Act1 : Node_Id;
1397          Act2 : Node_Id;
1398
1399          function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1400          --  If an operation has universal operands the universal operation
1401          --  is present among its interpretations. If there is an abstract
1402          --  interpretation for the operator, with a numeric result, this
1403          --  interpretation was already removed in sem_ch4, but the universal
1404          --  one is still visible. We must rescan the list of operators and
1405          --  remove the universal interpretation to resolve the ambiguity.
1406
1407          ---------------------------------
1408          -- Has_Abstract_Interpretation --
1409          ---------------------------------
1410
1411          function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1412             E : Entity_Id;
1413
1414          begin
1415             if Nkind (N) not in N_Op
1416               or else Ada_Version < Ada_2005
1417               or else not Is_Overloaded (N)
1418               or else No (Universal_Interpretation (N))
1419             then
1420                return False;
1421
1422             else
1423                E := Get_Name_Entity_Id (Chars (N));
1424                while Present (E) loop
1425                   if Is_Overloadable (E)
1426                     and then Is_Abstract_Subprogram (E)
1427                     and then Is_Numeric_Type (Etype (E))
1428                   then
1429                      return True;
1430                   else
1431                      E := Homonym (E);
1432                   end if;
1433                end loop;
1434
1435                --  Finally, if an operand of the binary operator is itself
1436                --  an operator, recurse to see whether its own abstract
1437                --  interpretation is responsible for the spurious ambiguity.
1438
1439                if Nkind (N) in N_Binary_Op then
1440                   return Has_Abstract_Interpretation (Left_Opnd (N))
1441                     or else Has_Abstract_Interpretation (Right_Opnd (N));
1442
1443                elsif Nkind (N) in N_Unary_Op then
1444                   return Has_Abstract_Interpretation (Right_Opnd (N));
1445
1446                else
1447                   return False;
1448                end if;
1449             end if;
1450          end Has_Abstract_Interpretation;
1451
1452       --  Start of processing for Remove_Conversions
1453
1454       begin
1455          It1 := No_Interp;
1456
1457          Get_First_Interp (N, I, It);
1458          while Present (It.Typ) loop
1459             if not Is_Overloadable (It.Nam) then
1460                return No_Interp;
1461             end if;
1462
1463             F1 := First_Formal (It.Nam);
1464
1465             if No (F1) then
1466                return It1;
1467
1468             else
1469                if Nkind (N) = N_Function_Call
1470                  or else Nkind (N) = N_Procedure_Call_Statement
1471                then
1472                   Act1 := First_Actual (N);
1473
1474                   if Present (Act1) then
1475                      Act2 := Next_Actual (Act1);
1476                   else
1477                      Act2 := Empty;
1478                   end if;
1479
1480                elsif Nkind (N) in N_Unary_Op then
1481                   Act1 := Right_Opnd (N);
1482                   Act2 := Empty;
1483
1484                elsif Nkind (N) in N_Binary_Op then
1485                   Act1 := Left_Opnd (N);
1486                   Act2 := Right_Opnd (N);
1487
1488                   --  Use type of second formal, so as to include
1489                   --  exponentiation, where the exponent may be
1490                   --  ambiguous and the result non-universal.
1491
1492                   Next_Formal (F1);
1493
1494                else
1495                   return It1;
1496                end if;
1497
1498                if Nkind (Act1) in N_Op
1499                  and then Is_Overloaded (Act1)
1500                  and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1501                             or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1502                  and then Has_Compatible_Type (Act1, Standard_Boolean)
1503                  and then Etype (F1) = Standard_Boolean
1504                then
1505                   --  If the two candidates are the original ones, the
1506                   --  ambiguity is real. Otherwise keep the original, further
1507                   --  calls to Disambiguate will take care of others in the
1508                   --  list of candidates.
1509
1510                   if It1 /= No_Interp then
1511                      if It = Disambiguate.It1
1512                        or else It = Disambiguate.It2
1513                      then
1514                         if It1 = Disambiguate.It1
1515                           or else It1 = Disambiguate.It2
1516                         then
1517                            return No_Interp;
1518                         else
1519                            It1 := It;
1520                         end if;
1521                      end if;
1522
1523                   elsif Present (Act2)
1524                     and then Nkind (Act2) in N_Op
1525                     and then Is_Overloaded (Act2)
1526                     and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1527                                                           N_Real_Literal)
1528                     and then Has_Compatible_Type (Act2, Standard_Boolean)
1529                   then
1530                      --  The preference rule on the first actual is not
1531                      --  sufficient to disambiguate.
1532
1533                      goto Next_Interp;
1534
1535                   else
1536                      It1 := It;
1537                   end if;
1538
1539                elsif Is_Numeric_Type (Etype (F1))
1540                  and then Has_Abstract_Interpretation (Act1)
1541                then
1542                   --  Current interpretation is not the right one because it
1543                   --  expects a numeric operand. Examine all the other ones.
1544
1545                   declare
1546                      I  : Interp_Index;
1547                      It : Interp;
1548
1549                   begin
1550                      Get_First_Interp (N, I, It);
1551                      while Present (It.Typ) loop
1552                         if
1553                           not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1554                         then
1555                            if No (Act2)
1556                              or else not Has_Abstract_Interpretation (Act2)
1557                              or else not
1558                                Is_Numeric_Type
1559                                  (Etype (Next_Formal (First_Formal (It.Nam))))
1560                            then
1561                               return It;
1562                            end if;
1563                         end if;
1564
1565                         Get_Next_Interp (I, It);
1566                      end loop;
1567
1568                      return No_Interp;
1569                   end;
1570                end if;
1571             end if;
1572
1573             <<Next_Interp>>
1574                Get_Next_Interp (I, It);
1575          end loop;
1576
1577          --  After some error, a formal may have Any_Type and yield a spurious
1578          --  match. To avoid cascaded errors if possible, check for such a
1579          --  formal in either candidate.
1580
1581          if Serious_Errors_Detected > 0 then
1582             declare
1583                Formal : Entity_Id;
1584
1585             begin
1586                Formal := First_Formal (Nam1);
1587                while Present (Formal) loop
1588                   if Etype (Formal) = Any_Type then
1589                      return Disambiguate.It2;
1590                   end if;
1591
1592                   Next_Formal (Formal);
1593                end loop;
1594
1595                Formal := First_Formal (Nam2);
1596                while Present (Formal) loop
1597                   if Etype (Formal) = Any_Type then
1598                      return Disambiguate.It1;
1599                   end if;
1600
1601                   Next_Formal (Formal);
1602                end loop;
1603             end;
1604          end if;
1605
1606          return It1;
1607       end Remove_Conversions;
1608
1609       -----------------------
1610       -- Standard_Operator --
1611       -----------------------
1612
1613       function Standard_Operator return Boolean is
1614          Nam : Node_Id;
1615
1616       begin
1617          if Nkind (N) in N_Op then
1618             return True;
1619
1620          elsif Nkind (N) = N_Function_Call then
1621             Nam := Name (N);
1622
1623             if Nkind (Nam) /= N_Expanded_Name then
1624                return True;
1625             else
1626                return Entity (Prefix (Nam)) = Standard_Standard;
1627             end if;
1628          else
1629             return False;
1630          end if;
1631       end Standard_Operator;
1632
1633    --  Start of processing for Disambiguate
1634
1635    begin
1636       --  Recover the two legal interpretations
1637
1638       Get_First_Interp (N, I, It);
1639       while I /= I1 loop
1640          Get_Next_Interp (I, It);
1641       end loop;
1642
1643       It1  := It;
1644       Nam1 := It.Nam;
1645       while I /= I2 loop
1646          Get_Next_Interp (I, It);
1647       end loop;
1648
1649       It2  := It;
1650       Nam2 := It.Nam;
1651
1652       --  Check whether one of the entities is an Ada 2005/2012 and we are
1653       --  operating in an earlier mode, in which case we discard the Ada
1654       --  2005/2012 entity, so that we get proper Ada 95 overload resolution.
1655
1656       if Ada_Version < Ada_2005 then
1657          if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
1658             return It2;
1659          elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
1660             return It1;
1661          end if;
1662       end if;
1663
1664       --  Check whether one of the entities is an Ada 2012 entity and we are
1665       --  operating in Ada 2005 mode, in which case we discard the Ada 2012
1666       --  entity, so that we get proper Ada 2005 overload resolution.
1667
1668       if Ada_Version = Ada_2005 then
1669          if Is_Ada_2012_Only (Nam1) then
1670             return It2;
1671          elsif Is_Ada_2012_Only (Nam2) then
1672             return It1;
1673          end if;
1674       end if;
1675
1676       --  Check for overloaded CIL convention stuff because the CIL libraries
1677       --  do sick things like Console.Write_Line where it matches two different
1678       --  overloads, so just pick the first ???
1679
1680       if Convention (Nam1) = Convention_CIL
1681         and then Convention (Nam2) = Convention_CIL
1682         and then Ekind (Nam1) = Ekind (Nam2)
1683         and then (Ekind (Nam1) = E_Procedure
1684                    or else Ekind (Nam1) = E_Function)
1685       then
1686          return It2;
1687       end if;
1688
1689       --  If the context is universal, the predefined operator is preferred.
1690       --  This includes bounds in numeric type declarations, and expressions
1691       --  in type conversions. If no interpretation yields a universal type,
1692       --  then we must check whether the user-defined entity hides the prede-
1693       --  fined one.
1694
1695       if Chars (Nam1) in Any_Operator_Name
1696         and then Standard_Operator
1697       then
1698          if        Typ = Universal_Integer
1699            or else Typ = Universal_Real
1700            or else Typ = Any_Integer
1701            or else Typ = Any_Discrete
1702            or else Typ = Any_Real
1703            or else Typ = Any_Type
1704          then
1705             --  Find an interpretation that yields the universal type, or else
1706             --  a predefined operator that yields a predefined numeric type.
1707
1708             declare
1709                Candidate : Interp := No_Interp;
1710
1711             begin
1712                Get_First_Interp (N, I, It);
1713                while Present (It.Typ) loop
1714                   if (Covers (Typ, It.Typ)
1715                         or else Typ = Any_Type)
1716                     and then
1717                      (It.Typ = Universal_Integer
1718                        or else It.Typ = Universal_Real)
1719                   then
1720                      return It;
1721
1722                   elsif Covers (Typ, It.Typ)
1723                     and then Scope (It.Typ) = Standard_Standard
1724                     and then Scope (It.Nam) = Standard_Standard
1725                     and then Is_Numeric_Type (It.Typ)
1726                   then
1727                      Candidate := It;
1728                   end if;
1729
1730                   Get_Next_Interp (I, It);
1731                end loop;
1732
1733                if Candidate /= No_Interp then
1734                   return Candidate;
1735                end if;
1736             end;
1737
1738          elsif Chars (Nam1) /= Name_Op_Not
1739            and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1740          then
1741             --  Equality or comparison operation. Choose predefined operator if
1742             --  arguments are universal. The node may be an operator, name, or
1743             --  a function call, so unpack arguments accordingly.
1744
1745             declare
1746                Arg1, Arg2 : Node_Id;
1747
1748             begin
1749                if Nkind (N) in N_Op then
1750                   Arg1 := Left_Opnd  (N);
1751                   Arg2 := Right_Opnd (N);
1752
1753                elsif Is_Entity_Name (N) then
1754                   Arg1 := First_Entity (Entity (N));
1755                   Arg2 := Next_Entity (Arg1);
1756
1757                else
1758                   Arg1 := First_Actual (N);
1759                   Arg2 := Next_Actual (Arg1);
1760                end if;
1761
1762                if Present (Arg2)
1763                  and then Present (Universal_Interpretation (Arg1))
1764                  and then Universal_Interpretation (Arg2) =
1765                           Universal_Interpretation (Arg1)
1766                then
1767                   Get_First_Interp (N, I, It);
1768                   while Scope (It.Nam) /= Standard_Standard loop
1769                      Get_Next_Interp (I, It);
1770                   end loop;
1771
1772                   return It;
1773                end if;
1774             end;
1775          end if;
1776       end if;
1777
1778       --  If no universal interpretation, check whether user-defined operator
1779       --  hides predefined one, as well as other special cases. If the node
1780       --  is a range, then one or both bounds are ambiguous. Each will have
1781       --  to be disambiguated w.r.t. the context type. The type of the range
1782       --  itself is imposed by the context, so we can return either legal
1783       --  interpretation.
1784
1785       if Ekind (Nam1) = E_Operator then
1786          Predef_Subp := Nam1;
1787          User_Subp   := Nam2;
1788
1789       elsif Ekind (Nam2) = E_Operator then
1790          Predef_Subp := Nam2;
1791          User_Subp   := Nam1;
1792
1793       elsif Nkind (N) = N_Range then
1794          return It1;
1795
1796       --  Implement AI05-105: A renaming declaration with an access
1797       --  definition must resolve to an anonymous access type. This
1798       --  is a resolution rule and can be used to disambiguate.
1799
1800       elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1801         and then Present (Access_Definition (Parent (N)))
1802       then
1803          if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
1804                                E_Anonymous_Access_Subprogram_Type)
1805          then
1806             if Ekind (It2.Typ) = Ekind (It1.Typ) then
1807
1808                --  True ambiguity
1809
1810                return No_Interp;
1811
1812             else
1813                return It1;
1814             end if;
1815
1816          elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
1817                                   E_Anonymous_Access_Subprogram_Type)
1818          then
1819             return It2;
1820
1821          --  No legal interpretation
1822
1823          else
1824             return No_Interp;
1825          end if;
1826
1827       --  If two user defined-subprograms are visible, it is a true ambiguity,
1828       --  unless one of them is an entry and the context is a conditional or
1829       --  timed entry call, or unless we are within an instance and this is
1830       --  results from two formals types with the same actual.
1831
1832       else
1833          if Nkind (N) = N_Procedure_Call_Statement
1834            and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1835            and then N = Entry_Call_Statement (Parent (N))
1836          then
1837             if Ekind (Nam2) = E_Entry then
1838                return It2;
1839             elsif Ekind (Nam1) = E_Entry then
1840                return It1;
1841             else
1842                return No_Interp;
1843             end if;
1844
1845          --  If the ambiguity occurs within an instance, it is due to several
1846          --  formal types with the same actual. Look for an exact match between
1847          --  the types of the formals of the overloadable entities, and the
1848          --  actuals in the call, to recover the unambiguous match in the
1849          --  original generic.
1850
1851          --  The ambiguity can also be due to an overloading between a formal
1852          --  subprogram and a subprogram declared outside the generic. If the
1853          --  node is overloaded, it did not resolve to the global entity in
1854          --  the generic, and we choose the formal subprogram.
1855
1856          --  Finally, the ambiguity can be between an explicit subprogram and
1857          --  one inherited (with different defaults) from an actual. In this
1858          --  case the resolution was to the explicit declaration in the
1859          --  generic, and remains so in the instance.
1860
1861          --  The same sort of disambiguation needed for calls is also required
1862          --  for the name given in a subprogram renaming, and that case is
1863          --  handled here as well. We test Comes_From_Source to exclude this
1864          --  treatment for implicit renamings created for formal subprograms.
1865
1866          elsif In_Instance
1867            and then not In_Generic_Actual (N)
1868          then
1869             if Nkind (N) = N_Function_Call
1870               or else Nkind (N) = N_Procedure_Call_Statement
1871               or else
1872                 (Nkind (N) in N_Has_Entity
1873                   and then
1874                     Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
1875                   and then Comes_From_Source (Parent (N)))
1876             then
1877                declare
1878                   Actual  : Node_Id;
1879                   Formal  : Entity_Id;
1880                   Renam   : Entity_Id        := Empty;
1881                   Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1882                   Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1883
1884                begin
1885                   if Is_Act1 and then not Is_Act2 then
1886                      return It1;
1887
1888                   elsif Is_Act2 and then not Is_Act1 then
1889                      return It2;
1890
1891                   elsif Inherited_From_Actual (Nam1)
1892                     and then Comes_From_Source (Nam2)
1893                   then
1894                      return It2;
1895
1896                   elsif Inherited_From_Actual (Nam2)
1897                     and then Comes_From_Source (Nam1)
1898                   then
1899                      return It1;
1900                   end if;
1901
1902                   --  In the case of a renamed subprogram, pick up the entity
1903                   --  of the renaming declaration so we can traverse its
1904                   --  formal parameters.
1905
1906                   if Nkind (N) in N_Has_Entity then
1907                      Renam := Defining_Unit_Name (Specification (Parent (N)));
1908                   end if;
1909
1910                   if Present (Renam) then
1911                      Actual := First_Formal (Renam);
1912                   else
1913                      Actual := First_Actual (N);
1914                   end if;
1915
1916                   Formal := First_Formal (Nam1);
1917                   while Present (Actual) loop
1918                      if Etype (Actual) /= Etype (Formal) then
1919                         return It2;
1920                      end if;
1921
1922                      if Present (Renam) then
1923                         Next_Formal (Actual);
1924                      else
1925                         Next_Actual (Actual);
1926                      end if;
1927
1928                      Next_Formal (Formal);
1929                   end loop;
1930
1931                   return It1;
1932                end;
1933
1934             elsif Nkind (N) in N_Binary_Op then
1935                if Matches (Left_Opnd (N), First_Formal (Nam1))
1936                  and then
1937                    Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1938                then
1939                   return It1;
1940                else
1941                   return It2;
1942                end if;
1943
1944             elsif Nkind (N) in  N_Unary_Op then
1945                if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1946                   return It1;
1947                else
1948                   return It2;
1949                end if;
1950
1951             else
1952                return Remove_Conversions;
1953             end if;
1954          else
1955             return Remove_Conversions;
1956          end if;
1957       end if;
1958
1959       --  An implicit concatenation operator on a string type cannot be
1960       --  disambiguated from the predefined concatenation. This can only
1961       --  happen with concatenation of string literals.
1962
1963       if Chars (User_Subp) = Name_Op_Concat
1964         and then Ekind (User_Subp) = E_Operator
1965         and then Is_String_Type (Etype (First_Formal (User_Subp)))
1966       then
1967          return No_Interp;
1968
1969       --  If the user-defined operator is in an open scope, or in the scope
1970       --  of the resulting type, or given by an expanded name that names its
1971       --  scope, it hides the predefined operator for the type. Exponentiation
1972       --  has to be special-cased because the implicit operator does not have
1973       --  a symmetric signature, and may not be hidden by the explicit one.
1974
1975       elsif (Nkind (N) = N_Function_Call
1976               and then Nkind (Name (N)) = N_Expanded_Name
1977               and then (Chars (Predef_Subp) /= Name_Op_Expon
1978                           or else Hides_Op (User_Subp, Predef_Subp))
1979               and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1980         or else Hides_Op (User_Subp, Predef_Subp)
1981       then
1982          if It1.Nam = User_Subp then
1983             return It1;
1984          else
1985             return It2;
1986          end if;
1987
1988       --  Otherwise, the predefined operator has precedence, or if the user-
1989       --  defined operation is directly visible we have a true ambiguity.
1990
1991       --  If this is a fixed-point multiplication and division in Ada 83 mode,
1992       --  exclude the universal_fixed operator, which often causes ambiguities
1993       --  in legacy code.
1994
1995       --  Ditto in Ada 2012, where an ambiguity may arise for an operation
1996       --  on a partial view that is completed with a fixed point type. See
1997       --  AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
1998       --  user-defined subprogram so that a client of the package has the
1999       --  same resulution as the body of the package.
2000
2001       else
2002          if (In_Open_Scopes (Scope (User_Subp))
2003            or else Is_Potentially_Use_Visible (User_Subp))
2004            and then not In_Instance
2005          then
2006             if Is_Fixed_Point_Type (Typ)
2007               and then (Chars (Nam1) = Name_Op_Multiply
2008                           or else Chars (Nam1) = Name_Op_Divide)
2009               and then
2010                 (Ada_Version = Ada_83
2011                   or else
2012                    (Ada_Version >= Ada_2012
2013                      and then
2014                        In_Same_Declaration_List
2015                          (Typ, Unit_Declaration_Node (User_Subp))))
2016             then
2017                if It2.Nam = Predef_Subp then
2018                   return It1;
2019                else
2020                   return It2;
2021                end if;
2022
2023             --  Ada 2005, AI-420: preference rule for "=" on Universal_Access
2024             --  states that the operator defined in Standard is not available
2025             --  if there is a user-defined equality with the proper signature,
2026             --  declared in the same declarative list as the type. The node
2027             --  may be an operator or a function call.
2028
2029             elsif (Chars (Nam1) = Name_Op_Eq
2030                      or else
2031                    Chars (Nam1) = Name_Op_Ne)
2032               and then Ada_Version >= Ada_2005
2033               and then Etype (User_Subp) = Standard_Boolean
2034               and then Ekind (Operand_Type) = E_Anonymous_Access_Type
2035               and then
2036                 In_Same_Declaration_List
2037                   (Designated_Type (Operand_Type),
2038                      Unit_Declaration_Node (User_Subp))
2039             then
2040                if It2.Nam = Predef_Subp then
2041                   return It1;
2042                else
2043                   return It2;
2044                end if;
2045
2046             --  An immediately visible operator hides a use-visible user-
2047             --  defined operation. This disambiguation cannot take place
2048             --  earlier because the visibility of the predefined operator
2049             --  can only be established when operand types are known.
2050
2051             elsif Ekind (User_Subp) = E_Function
2052               and then Ekind (Predef_Subp) = E_Operator
2053               and then Nkind (N) in N_Op
2054               and then not Is_Overloaded (Right_Opnd (N))
2055               and then
2056                 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N))))
2057               and then Is_Potentially_Use_Visible (User_Subp)
2058             then
2059                if It2.Nam = Predef_Subp then
2060                   return It1;
2061                else
2062                   return It2;
2063                end if;
2064
2065             else
2066                return No_Interp;
2067             end if;
2068
2069          elsif It1.Nam = Predef_Subp then
2070             return It1;
2071
2072          else
2073             return It2;
2074          end if;
2075       end if;
2076    end Disambiguate;
2077
2078    ---------------------
2079    -- End_Interp_List --
2080    ---------------------
2081
2082    procedure End_Interp_List is
2083    begin
2084       All_Interp.Table (All_Interp.Last) := No_Interp;
2085       All_Interp.Increment_Last;
2086    end End_Interp_List;
2087
2088    -------------------------
2089    -- Entity_Matches_Spec --
2090    -------------------------
2091
2092    function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
2093    begin
2094       --  Simple case: same entity kinds, type conformance is required. A
2095       --  parameterless function can also rename a literal.
2096
2097       if Ekind (Old_S) = Ekind (New_S)
2098         or else (Ekind (New_S) = E_Function
2099                   and then Ekind (Old_S) = E_Enumeration_Literal)
2100       then
2101          return Type_Conformant (New_S, Old_S);
2102
2103       elsif Ekind (New_S) = E_Function
2104         and then Ekind (Old_S) = E_Operator
2105       then
2106          return Operator_Matches_Spec (Old_S, New_S);
2107
2108       elsif Ekind (New_S) = E_Procedure
2109         and then Is_Entry (Old_S)
2110       then
2111          return Type_Conformant (New_S, Old_S);
2112
2113       else
2114          return False;
2115       end if;
2116    end Entity_Matches_Spec;
2117
2118    ----------------------
2119    -- Find_Unique_Type --
2120    ----------------------
2121
2122    function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
2123       T  : constant Entity_Id := Etype (L);
2124       I  : Interp_Index;
2125       It : Interp;
2126       TR : Entity_Id := Any_Type;
2127
2128    begin
2129       if Is_Overloaded (R) then
2130          Get_First_Interp (R, I, It);
2131          while Present (It.Typ) loop
2132             if Covers (T, It.Typ) or else Covers (It.Typ, T) then
2133
2134                --  If several interpretations are possible and L is universal,
2135                --  apply preference rule.
2136
2137                if TR /= Any_Type then
2138
2139                   if (T = Universal_Integer or else T = Universal_Real)
2140                     and then It.Typ = T
2141                   then
2142                      TR := It.Typ;
2143                   end if;
2144
2145                else
2146                   TR := It.Typ;
2147                end if;
2148             end if;
2149
2150             Get_Next_Interp (I, It);
2151          end loop;
2152
2153          Set_Etype (R, TR);
2154
2155       --  In the non-overloaded case, the Etype of R is already set correctly
2156
2157       else
2158          null;
2159       end if;
2160
2161       --  If one of the operands is Universal_Fixed, the type of the other
2162       --  operand provides the context.
2163
2164       if Etype (R) = Universal_Fixed then
2165          return T;
2166
2167       elsif T = Universal_Fixed then
2168          return Etype (R);
2169
2170       --  Ada 2005 (AI-230): Support the following operators:
2171
2172       --    function "="  (L, R : universal_access) return Boolean;
2173       --    function "/=" (L, R : universal_access) return Boolean;
2174
2175       --  Pool specific access types (E_Access_Type) are not covered by these
2176       --  operators because of the legality rule of 4.5.2(9.2): "The operands
2177       --  of the equality operators for universal_access shall be convertible
2178       --  to one another (see 4.6)". For example, considering the type decla-
2179       --  ration "type P is access Integer" and an anonymous access to Integer,
2180       --  P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2181       --  is no rule in 4.6 that allows "access Integer" to be converted to P.
2182
2183       elsif Ada_Version >= Ada_2005
2184         and then
2185           (Ekind (Etype (L)) = E_Anonymous_Access_Type
2186              or else
2187            Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
2188         and then Is_Access_Type (Etype (R))
2189         and then Ekind (Etype (R)) /= E_Access_Type
2190       then
2191          return Etype (L);
2192
2193       elsif Ada_Version >= Ada_2005
2194         and then
2195           (Ekind (Etype (R)) = E_Anonymous_Access_Type
2196             or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
2197         and then Is_Access_Type (Etype (L))
2198         and then Ekind (Etype (L)) /= E_Access_Type
2199       then
2200          return Etype (R);
2201
2202       else
2203          return Specific_Type (T, Etype (R));
2204       end if;
2205    end Find_Unique_Type;
2206
2207    -------------------------------------
2208    -- Function_Interp_Has_Abstract_Op --
2209    -------------------------------------
2210
2211    function Function_Interp_Has_Abstract_Op
2212      (N : Node_Id;
2213       E : Entity_Id) return Entity_Id
2214    is
2215       Abstr_Op  : Entity_Id;
2216       Act       : Node_Id;
2217       Act_Parm  : Node_Id;
2218       Form_Parm : Node_Id;
2219
2220    begin
2221       --  Why is check on E needed below ???
2222       --  In any case this para needs comments ???
2223
2224       if Is_Overloaded (N) and then Is_Overloadable (E) then
2225          Act_Parm  := First_Actual (N);
2226          Form_Parm := First_Formal (E);
2227          while Present (Act_Parm)
2228            and then Present (Form_Parm)
2229          loop
2230             Act := Act_Parm;
2231
2232             if Nkind (Act) = N_Parameter_Association then
2233                Act := Explicit_Actual_Parameter (Act);
2234             end if;
2235
2236             Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2237
2238             if Present (Abstr_Op) then
2239                return Abstr_Op;
2240             end if;
2241
2242             Next_Actual (Act_Parm);
2243             Next_Formal (Form_Parm);
2244          end loop;
2245       end if;
2246
2247       return Empty;
2248    end Function_Interp_Has_Abstract_Op;
2249
2250    ----------------------
2251    -- Get_First_Interp --
2252    ----------------------
2253
2254    procedure Get_First_Interp
2255      (N  : Node_Id;
2256       I  : out Interp_Index;
2257       It : out Interp)
2258    is
2259       Int_Ind : Interp_Index;
2260       Map_Ptr : Int;
2261       O_N     : Node_Id;
2262
2263    begin
2264       --  If a selected component is overloaded because the selector has
2265       --  multiple interpretations, the node is a call to a protected
2266       --  operation or an indirect call. Retrieve the interpretation from
2267       --  the selector name. The selected component may be overloaded as well
2268       --  if the prefix is overloaded. That case is unchanged.
2269
2270       if Nkind (N) = N_Selected_Component
2271         and then Is_Overloaded (Selector_Name (N))
2272       then
2273          O_N := Selector_Name (N);
2274       else
2275          O_N := N;
2276       end if;
2277
2278       Map_Ptr := Headers (Hash (O_N));
2279       while Map_Ptr /= No_Entry loop
2280          if Interp_Map.Table (Map_Ptr).Node = O_N then
2281             Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2282             It := All_Interp.Table (Int_Ind);
2283             I := Int_Ind;
2284             return;
2285          else
2286             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2287          end if;
2288       end loop;
2289
2290       --  Procedure should never be called if the node has no interpretations
2291
2292       raise Program_Error;
2293    end Get_First_Interp;
2294
2295    ---------------------
2296    -- Get_Next_Interp --
2297    ---------------------
2298
2299    procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2300    begin
2301       I  := I + 1;
2302       It := All_Interp.Table (I);
2303    end Get_Next_Interp;
2304
2305    -------------------------
2306    -- Has_Compatible_Type --
2307    -------------------------
2308
2309    function Has_Compatible_Type
2310      (N   : Node_Id;
2311       Typ : Entity_Id) return Boolean
2312    is
2313       I  : Interp_Index;
2314       It : Interp;
2315
2316    begin
2317       if N = Error then
2318          return False;
2319       end if;
2320
2321       if Nkind (N) = N_Subtype_Indication
2322         or else not Is_Overloaded (N)
2323       then
2324          return
2325            Covers (Typ, Etype (N))
2326
2327             --  Ada 2005 (AI-345): The context may be a synchronized interface.
2328             --  If the type is already frozen use the corresponding_record
2329             --  to check whether it is a proper descendant.
2330
2331            or else
2332              (Is_Record_Type (Typ)
2333                 and then Is_Concurrent_Type (Etype (N))
2334                 and then Present (Corresponding_Record_Type (Etype (N)))
2335                 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2336
2337            or else
2338              (Is_Concurrent_Type (Typ)
2339                 and then Is_Record_Type (Etype (N))
2340                 and then Present (Corresponding_Record_Type (Typ))
2341                 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2342
2343            or else
2344              (not Is_Tagged_Type (Typ)
2345                 and then Ekind (Typ) /= E_Anonymous_Access_Type
2346                 and then Covers (Etype (N), Typ));
2347
2348       else
2349          Get_First_Interp (N, I, It);
2350          while Present (It.Typ) loop
2351             if (Covers (Typ, It.Typ)
2352                   and then
2353                     (Scope (It.Nam) /= Standard_Standard
2354                        or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2355
2356                --  Ada 2005 (AI-345)
2357
2358               or else
2359                 (Is_Concurrent_Type (It.Typ)
2360                   and then Present (Corresponding_Record_Type
2361                                                              (Etype (It.Typ)))
2362                   and then Covers (Typ, Corresponding_Record_Type
2363                                                              (Etype (It.Typ))))
2364
2365               or else (not Is_Tagged_Type (Typ)
2366                          and then Ekind (Typ) /= E_Anonymous_Access_Type
2367                          and then Covers (It.Typ, Typ))
2368             then
2369                return True;
2370             end if;
2371
2372             Get_Next_Interp (I, It);
2373          end loop;
2374
2375          return False;
2376       end if;
2377    end Has_Compatible_Type;
2378
2379    ---------------------
2380    -- Has_Abstract_Op --
2381    ---------------------
2382
2383    function Has_Abstract_Op
2384      (N   : Node_Id;
2385       Typ : Entity_Id) return Entity_Id
2386    is
2387       I  : Interp_Index;
2388       It : Interp;
2389
2390    begin
2391       if Is_Overloaded (N) then
2392          Get_First_Interp (N, I, It);
2393          while Present (It.Nam) loop
2394             if Present (It.Abstract_Op)
2395               and then Etype (It.Abstract_Op) = Typ
2396             then
2397                return It.Abstract_Op;
2398             end if;
2399
2400             Get_Next_Interp (I, It);
2401          end loop;
2402       end if;
2403
2404       return Empty;
2405    end Has_Abstract_Op;
2406
2407    ----------
2408    -- Hash --
2409    ----------
2410
2411    function Hash (N : Node_Id) return Int is
2412    begin
2413       --  Nodes have a size that is power of two, so to select significant
2414       --  bits only we remove the low-order bits.
2415
2416       return ((Int (N) / 2 ** 5) mod Header_Size);
2417    end Hash;
2418
2419    --------------
2420    -- Hides_Op --
2421    --------------
2422
2423    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2424       Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2425    begin
2426       return Operator_Matches_Spec (Op, F)
2427         and then (In_Open_Scopes (Scope (F))
2428                     or else Scope (F) = Scope (Btyp)
2429                     or else (not In_Open_Scopes (Scope (Btyp))
2430                               and then not In_Use (Btyp)
2431                               and then not In_Use (Scope (Btyp))));
2432    end Hides_Op;
2433
2434    ------------------------
2435    -- Init_Interp_Tables --
2436    ------------------------
2437
2438    procedure Init_Interp_Tables is
2439    begin
2440       All_Interp.Init;
2441       Interp_Map.Init;
2442       Headers := (others => No_Entry);
2443    end Init_Interp_Tables;
2444
2445    -----------------------------------
2446    -- Interface_Present_In_Ancestor --
2447    -----------------------------------
2448
2449    function Interface_Present_In_Ancestor
2450      (Typ   : Entity_Id;
2451       Iface : Entity_Id) return Boolean
2452    is
2453       Target_Typ : Entity_Id;
2454       Iface_Typ  : Entity_Id;
2455
2456       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2457       --  Returns True if Typ or some ancestor of Typ implements Iface
2458
2459       -------------------------------
2460       -- Iface_Present_In_Ancestor --
2461       -------------------------------
2462
2463       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2464          E    : Entity_Id;
2465          AI   : Entity_Id;
2466          Elmt : Elmt_Id;
2467
2468       begin
2469          if Typ = Iface_Typ then
2470             return True;
2471          end if;
2472
2473          --  Handle private types
2474
2475          if Present (Full_View (Typ))
2476            and then not Is_Concurrent_Type (Full_View (Typ))
2477          then
2478             E := Full_View (Typ);
2479          else
2480             E := Typ;
2481          end if;
2482
2483          loop
2484             if Present (Interfaces (E))
2485               and then Present (Interfaces (E))
2486               and then not Is_Empty_Elmt_List (Interfaces (E))
2487             then
2488                Elmt := First_Elmt (Interfaces (E));
2489                while Present (Elmt) loop
2490                   AI := Node (Elmt);
2491
2492                   if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2493                      return True;
2494                   end if;
2495
2496                   Next_Elmt (Elmt);
2497                end loop;
2498             end if;
2499
2500             exit when Etype (E) = E
2501
2502                --  Handle private types
2503
2504                or else (Present (Full_View (Etype (E)))
2505                          and then Full_View (Etype (E)) = E);
2506
2507             --  Check if the current type is a direct derivation of the
2508             --  interface
2509
2510             if Etype (E) = Iface_Typ then
2511                return True;
2512             end if;
2513
2514             --  Climb to the immediate ancestor handling private types
2515
2516             if Present (Full_View (Etype (E))) then
2517                E := Full_View (Etype (E));
2518             else
2519                E := Etype (E);
2520             end if;
2521          end loop;
2522
2523          return False;
2524       end Iface_Present_In_Ancestor;
2525
2526    --  Start of processing for Interface_Present_In_Ancestor
2527
2528    begin
2529       --  Iface might be a class-wide subtype, so we have to apply Base_Type
2530
2531       if Is_Class_Wide_Type (Iface) then
2532          Iface_Typ := Etype (Base_Type (Iface));
2533       else
2534          Iface_Typ := Iface;
2535       end if;
2536
2537       --  Handle subtypes
2538
2539       Iface_Typ := Base_Type (Iface_Typ);
2540
2541       if Is_Access_Type (Typ) then
2542          Target_Typ := Etype (Directly_Designated_Type (Typ));
2543       else
2544          Target_Typ := Typ;
2545       end if;
2546
2547       if Is_Concurrent_Record_Type (Target_Typ) then
2548          Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2549       end if;
2550
2551       Target_Typ := Base_Type (Target_Typ);
2552
2553       --  In case of concurrent types we can't use the Corresponding Record_Typ
2554       --  to look for the interface because it is built by the expander (and
2555       --  hence it is not always available). For this reason we traverse the
2556       --  list of interfaces (available in the parent of the concurrent type)
2557
2558       if Is_Concurrent_Type (Target_Typ) then
2559          if Present (Interface_List (Parent (Target_Typ))) then
2560             declare
2561                AI : Node_Id;
2562
2563             begin
2564                AI := First (Interface_List (Parent (Target_Typ)));
2565                while Present (AI) loop
2566                   if Etype (AI) = Iface_Typ then
2567                      return True;
2568
2569                   elsif Present (Interfaces (Etype (AI)))
2570                      and then Iface_Present_In_Ancestor (Etype (AI))
2571                   then
2572                      return True;
2573                   end if;
2574
2575                   Next (AI);
2576                end loop;
2577             end;
2578          end if;
2579
2580          return False;
2581       end if;
2582
2583       if Is_Class_Wide_Type (Target_Typ) then
2584          Target_Typ := Etype (Target_Typ);
2585       end if;
2586
2587       if Ekind (Target_Typ) = E_Incomplete_Type then
2588          pragma Assert (Present (Non_Limited_View (Target_Typ)));
2589          Target_Typ := Non_Limited_View (Target_Typ);
2590
2591          --  Protect the frontend against previously detected errors
2592
2593          if Ekind (Target_Typ) = E_Incomplete_Type then
2594             return False;
2595          end if;
2596       end if;
2597
2598       return Iface_Present_In_Ancestor (Target_Typ);
2599    end Interface_Present_In_Ancestor;
2600
2601    ---------------------
2602    -- Intersect_Types --
2603    ---------------------
2604
2605    function Intersect_Types (L, R : Node_Id) return Entity_Id is
2606       Index : Interp_Index;
2607       It    : Interp;
2608       Typ   : Entity_Id;
2609
2610       function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2611       --  Find interpretation of right arg that has type compatible with T
2612
2613       --------------------------
2614       -- Check_Right_Argument --
2615       --------------------------
2616
2617       function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2618          Index : Interp_Index;
2619          It    : Interp;
2620          T2    : Entity_Id;
2621
2622       begin
2623          if not Is_Overloaded (R) then
2624             return Specific_Type (T, Etype (R));
2625
2626          else
2627             Get_First_Interp (R, Index, It);
2628             loop
2629                T2 := Specific_Type (T, It.Typ);
2630
2631                if T2 /= Any_Type then
2632                   return T2;
2633                end if;
2634
2635                Get_Next_Interp (Index, It);
2636                exit when No (It.Typ);
2637             end loop;
2638
2639             return Any_Type;
2640          end if;
2641       end Check_Right_Argument;
2642
2643    --  Start of processing for Intersect_Types
2644
2645    begin
2646       if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2647          return Any_Type;
2648       end if;
2649
2650       if not Is_Overloaded (L) then
2651          Typ := Check_Right_Argument (Etype (L));
2652
2653       else
2654          Typ := Any_Type;
2655          Get_First_Interp (L, Index, It);
2656          while Present (It.Typ) loop
2657             Typ := Check_Right_Argument (It.Typ);
2658             exit when Typ /= Any_Type;
2659             Get_Next_Interp (Index, It);
2660          end loop;
2661
2662       end if;
2663
2664       --  If Typ is Any_Type, it means no compatible pair of types was found
2665
2666       if Typ = Any_Type then
2667          if Nkind (Parent (L)) in N_Op then
2668             Error_Msg_N ("incompatible types for operator", Parent (L));
2669
2670          elsif Nkind (Parent (L)) = N_Range then
2671             Error_Msg_N ("incompatible types given in constraint", Parent (L));
2672
2673          --  Ada 2005 (AI-251): Complete the error notification
2674
2675          elsif Is_Class_Wide_Type (Etype (R))
2676              and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2677          then
2678             Error_Msg_NE ("(Ada 2005) does not implement interface }",
2679                           L, Etype (Class_Wide_Type (Etype (R))));
2680
2681          else
2682             Error_Msg_N ("incompatible types", Parent (L));
2683          end if;
2684       end if;
2685
2686       return Typ;
2687    end Intersect_Types;
2688
2689    -----------------------
2690    -- In_Generic_Actual --
2691    -----------------------
2692
2693    function In_Generic_Actual (Exp : Node_Id) return Boolean is
2694       Par : constant Node_Id := Parent (Exp);
2695
2696    begin
2697       if No (Par) then
2698          return False;
2699
2700       elsif Nkind (Par) in N_Declaration then
2701          if Nkind (Par) = N_Object_Declaration then
2702             return Present (Corresponding_Generic_Association (Par));
2703          else
2704             return False;
2705          end if;
2706
2707       elsif Nkind (Par) = N_Object_Renaming_Declaration then
2708          return Present (Corresponding_Generic_Association (Par));
2709
2710       elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2711          return False;
2712
2713       else
2714          return In_Generic_Actual (Parent (Par));
2715       end if;
2716    end In_Generic_Actual;
2717
2718    -----------------
2719    -- Is_Ancestor --
2720    -----------------
2721
2722    function Is_Ancestor
2723      (T1            : Entity_Id;
2724       T2            : Entity_Id;
2725       Use_Full_View : Boolean := False) return Boolean
2726    is
2727       BT1 : Entity_Id;
2728       BT2 : Entity_Id;
2729       Par : Entity_Id;
2730
2731    begin
2732       BT1 := Base_Type (T1);
2733       BT2 := Base_Type (T2);
2734
2735       --  Handle underlying view of records with unknown discriminants using
2736       --  the original entity that motivated the construction of this
2737       --  underlying record view (see Build_Derived_Private_Type).
2738
2739       if Is_Underlying_Record_View (BT1) then
2740          BT1 := Underlying_Record_View (BT1);
2741       end if;
2742
2743       if Is_Underlying_Record_View (BT2) then
2744          BT2 := Underlying_Record_View (BT2);
2745       end if;
2746
2747       if BT1 = BT2 then
2748          return True;
2749
2750       --  The predicate must look past privacy
2751
2752       elsif Is_Private_Type (T1)
2753         and then Present (Full_View (T1))
2754         and then BT2 = Base_Type (Full_View (T1))
2755       then
2756          return True;
2757
2758       elsif Is_Private_Type (T2)
2759         and then Present (Full_View (T2))
2760         and then BT1 = Base_Type (Full_View (T2))
2761       then
2762          return True;
2763
2764       else
2765          --  Obtain the parent of the base type of T2 (use the full view if
2766          --  allowed).
2767
2768          if Use_Full_View
2769            and then Is_Private_Type (BT2)
2770            and then Present (Full_View (BT2))
2771          then
2772             --  No climbing needed if its full view is the root type
2773
2774             if Full_View (BT2) = Root_Type (Full_View (BT2)) then
2775                return False;
2776             end if;
2777
2778             Par := Etype (Full_View (BT2));
2779
2780          else
2781             Par := Etype (BT2);
2782          end if;
2783
2784          loop
2785             --  If there was a error on the type declaration, do not recurse
2786
2787             if Error_Posted (Par) then
2788                return False;
2789
2790             elsif BT1 = Base_Type (Par)
2791               or else (Is_Private_Type (T1)
2792                          and then Present (Full_View (T1))
2793                          and then Base_Type (Par) = Base_Type (Full_View (T1)))
2794             then
2795                return True;
2796
2797             elsif Is_Private_Type (Par)
2798               and then Present (Full_View (Par))
2799               and then Full_View (Par) = BT1
2800             then
2801                return True;
2802
2803             --  Root type found
2804
2805             elsif Par = Root_Type (Par) then
2806                return False;
2807
2808             --  Continue climbing
2809
2810             else
2811                --  Use the full-view of private types (if allowed)
2812
2813                if Use_Full_View
2814                  and then Is_Private_Type (Par)
2815                  and then Present (Full_View (Par))
2816                then
2817                   Par := Etype (Full_View (Par));
2818                else
2819                   Par := Etype (Par);
2820                end if;
2821             end if;
2822          end loop;
2823       end if;
2824    end Is_Ancestor;
2825
2826    ---------------------------
2827    -- Is_Invisible_Operator --
2828    ---------------------------
2829
2830    function Is_Invisible_Operator
2831      (N : Node_Id;
2832       T : Entity_Id) return Boolean
2833    is
2834       Orig_Node : constant Node_Id := Original_Node (N);
2835
2836    begin
2837       if Nkind (N) not in N_Op then
2838          return False;
2839
2840       elsif not Comes_From_Source (N) then
2841          return False;
2842
2843       elsif No (Universal_Interpretation (Right_Opnd (N))) then
2844          return False;
2845
2846       elsif Nkind (N) in N_Binary_Op
2847         and then No (Universal_Interpretation (Left_Opnd (N)))
2848       then
2849          return False;
2850
2851       else
2852          return Is_Numeric_Type (T)
2853            and then not In_Open_Scopes (Scope (T))
2854            and then not Is_Potentially_Use_Visible (T)
2855            and then not In_Use (T)
2856            and then not In_Use (Scope (T))
2857            and then
2858             (Nkind (Orig_Node) /= N_Function_Call
2859               or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2860               or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2861            and then not In_Instance;
2862       end if;
2863    end Is_Invisible_Operator;
2864
2865    --------------------
2866    --  Is_Progenitor --
2867    --------------------
2868
2869    function Is_Progenitor
2870      (Iface : Entity_Id;
2871       Typ   : Entity_Id) return Boolean
2872    is
2873    begin
2874       return Implements_Interface (Typ, Iface, Exclude_Parents => True);
2875    end Is_Progenitor;
2876
2877    -------------------
2878    -- Is_Subtype_Of --
2879    -------------------
2880
2881    function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2882       S : Entity_Id;
2883
2884    begin
2885       S := Ancestor_Subtype (T1);
2886       while Present (S) loop
2887          if S = T2 then
2888             return True;
2889          else
2890             S := Ancestor_Subtype (S);
2891          end if;
2892       end loop;
2893
2894       return False;
2895    end Is_Subtype_Of;
2896
2897    ------------------
2898    -- List_Interps --
2899    ------------------
2900
2901    procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
2902       Index : Interp_Index;
2903       It    : Interp;
2904
2905    begin
2906       Get_First_Interp (Nam, Index, It);
2907       while Present (It.Nam) loop
2908          if Scope (It.Nam) = Standard_Standard
2909            and then Scope (It.Typ) /= Standard_Standard
2910          then
2911             Error_Msg_Sloc := Sloc (Parent (It.Typ));
2912             Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
2913
2914          else
2915             Error_Msg_Sloc := Sloc (It.Nam);
2916             Error_Msg_NE ("\\& declared#!", Err, It.Nam);
2917          end if;
2918
2919          Get_Next_Interp (Index, It);
2920       end loop;
2921    end List_Interps;
2922
2923    -----------------
2924    -- New_Interps --
2925    -----------------
2926
2927    procedure New_Interps (N : Node_Id)  is
2928       Map_Ptr : Int;
2929
2930    begin
2931       All_Interp.Append (No_Interp);
2932
2933       Map_Ptr := Headers (Hash (N));
2934
2935       if Map_Ptr = No_Entry then
2936
2937          --  Place new node at end of table
2938
2939          Interp_Map.Increment_Last;
2940          Headers (Hash (N)) := Interp_Map.Last;
2941
2942       else
2943          --   Place node at end of chain, or locate its previous entry
2944
2945          loop
2946             if Interp_Map.Table (Map_Ptr).Node = N then
2947
2948                --  Node is already in the table, and is being rewritten.
2949                --  Start a new interp section, retain hash link.
2950
2951                Interp_Map.Table (Map_Ptr).Node  := N;
2952                Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
2953                Set_Is_Overloaded (N, True);
2954                return;
2955
2956             else
2957                exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
2958                Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2959             end if;
2960          end loop;
2961
2962          --  Chain the new node
2963
2964          Interp_Map.Increment_Last;
2965          Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
2966       end if;
2967
2968       Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
2969       Set_Is_Overloaded (N, True);
2970    end New_Interps;
2971
2972    ---------------------------
2973    -- Operator_Matches_Spec --
2974    ---------------------------
2975
2976    function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
2977       Op_Name : constant Name_Id   := Chars (Op);
2978       T       : constant Entity_Id := Etype (New_S);
2979       New_F   : Entity_Id;
2980       Old_F   : Entity_Id;
2981       Num     : Int;
2982       T1      : Entity_Id;
2983       T2      : Entity_Id;
2984
2985    begin
2986       --  To verify that a predefined operator matches a given signature,
2987       --  do a case analysis of the operator classes. Function can have one
2988       --  or two formals and must have the proper result type.
2989
2990       New_F := First_Formal (New_S);
2991       Old_F := First_Formal (Op);
2992       Num := 0;
2993       while Present (New_F) and then Present (Old_F) loop
2994          Num := Num + 1;
2995          Next_Formal (New_F);
2996          Next_Formal (Old_F);
2997       end loop;
2998
2999       --  Definite mismatch if different number of parameters
3000
3001       if Present (Old_F) or else Present (New_F) then
3002          return False;
3003
3004       --  Unary operators
3005
3006       elsif Num = 1 then
3007          T1 := Etype (First_Formal (New_S));
3008
3009          if Op_Name = Name_Op_Subtract
3010            or else Op_Name = Name_Op_Add
3011            or else Op_Name = Name_Op_Abs
3012          then
3013             return Base_Type (T1) = Base_Type (T)
3014               and then Is_Numeric_Type (T);
3015
3016          elsif Op_Name = Name_Op_Not then
3017             return Base_Type (T1) = Base_Type (T)
3018               and then Valid_Boolean_Arg (Base_Type (T));
3019
3020          else
3021             return False;
3022          end if;
3023
3024       --  Binary operators
3025
3026       else
3027          T1 := Etype (First_Formal (New_S));
3028          T2 := Etype (Next_Formal (First_Formal (New_S)));
3029
3030          if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
3031            or else Op_Name = Name_Op_Xor
3032          then
3033             return Base_Type (T1) = Base_Type (T2)
3034               and then Base_Type (T1) = Base_Type (T)
3035               and then Valid_Boolean_Arg (Base_Type (T));
3036
3037          elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
3038             return Base_Type (T1) = Base_Type (T2)
3039               and then not Is_Limited_Type (T1)
3040               and then Is_Boolean_Type (T);
3041
3042          elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
3043            or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
3044          then
3045             return Base_Type (T1) = Base_Type (T2)
3046               and then Valid_Comparison_Arg (T1)
3047               and then Is_Boolean_Type (T);
3048
3049          elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
3050             return Base_Type (T1) = Base_Type (T2)
3051               and then Base_Type (T1) = Base_Type (T)
3052               and then Is_Numeric_Type (T);
3053
3054          --  For division and multiplication, a user-defined function does not
3055          --  match the predefined universal_fixed operation, except in Ada 83.
3056
3057          elsif Op_Name = Name_Op_Divide then
3058             return (Base_Type (T1) = Base_Type (T2)
3059               and then Base_Type (T1) = Base_Type (T)
3060               and then Is_Numeric_Type (T)
3061               and then (not Is_Fixed_Point_Type (T)
3062                          or else Ada_Version = Ada_83))
3063
3064             --  Mixed_Mode operations on fixed-point types
3065
3066               or else (Base_Type (T1) = Base_Type (T)
3067                         and then Base_Type (T2) = Base_Type (Standard_Integer)
3068                         and then Is_Fixed_Point_Type (T))
3069
3070             --  A user defined operator can also match (and hide) a mixed
3071             --  operation on universal literals.
3072
3073               or else (Is_Integer_Type (T2)
3074                         and then Is_Floating_Point_Type (T1)
3075                         and then Base_Type (T1) = Base_Type (T));
3076
3077          elsif Op_Name = Name_Op_Multiply then
3078             return (Base_Type (T1) = Base_Type (T2)
3079               and then Base_Type (T1) = Base_Type (T)
3080               and then Is_Numeric_Type (T)
3081               and then (not Is_Fixed_Point_Type (T)
3082                          or else Ada_Version = Ada_83))
3083
3084             --  Mixed_Mode operations on fixed-point types
3085
3086               or else (Base_Type (T1) = Base_Type (T)
3087                         and then Base_Type (T2) = Base_Type (Standard_Integer)
3088                         and then Is_Fixed_Point_Type (T))
3089
3090               or else (Base_Type (T2) = Base_Type (T)
3091                         and then Base_Type (T1) = Base_Type (Standard_Integer)
3092                         and then Is_Fixed_Point_Type (T))
3093
3094               or else (Is_Integer_Type (T2)
3095                         and then Is_Floating_Point_Type (T1)
3096                         and then Base_Type (T1) = Base_Type (T))
3097
3098               or else (Is_Integer_Type (T1)
3099                         and then Is_Floating_Point_Type (T2)
3100                         and then Base_Type (T2) = Base_Type (T));
3101
3102          elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
3103             return Base_Type (T1) = Base_Type (T2)
3104               and then Base_Type (T1) = Base_Type (T)
3105               and then Is_Integer_Type (T);
3106
3107          elsif Op_Name = Name_Op_Expon then
3108             return Base_Type (T1) = Base_Type (T)
3109               and then Is_Numeric_Type (T)
3110               and then Base_Type (T2) = Base_Type (Standard_Integer);
3111
3112          elsif Op_Name = Name_Op_Concat then
3113             return Is_Array_Type (T)
3114               and then (Base_Type (T) = Base_Type (Etype (Op)))
3115               and then (Base_Type (T1) = Base_Type (T)
3116                          or else
3117                         Base_Type (T1) = Base_Type (Component_Type (T)))
3118               and then (Base_Type (T2) = Base_Type (T)
3119                          or else
3120                         Base_Type (T2) = Base_Type (Component_Type (T)));
3121
3122          else
3123             return False;
3124          end if;
3125       end if;
3126    end Operator_Matches_Spec;
3127
3128    -------------------
3129    -- Remove_Interp --
3130    -------------------
3131
3132    procedure Remove_Interp (I : in out Interp_Index) is
3133       II : Interp_Index;
3134
3135    begin
3136       --  Find end of interp list and copy downward to erase the discarded one
3137
3138       II := I + 1;
3139       while Present (All_Interp.Table (II).Typ) loop
3140          II := II + 1;
3141       end loop;
3142
3143       for J in I + 1 .. II loop
3144          All_Interp.Table (J - 1) := All_Interp.Table (J);
3145       end loop;
3146
3147       --  Back up interp index to insure that iterator will pick up next
3148       --  available interpretation.
3149
3150       I := I - 1;
3151    end Remove_Interp;
3152
3153    ------------------
3154    -- Save_Interps --
3155    ------------------
3156
3157    procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
3158       Map_Ptr : Int;
3159       O_N     : Node_Id := Old_N;
3160
3161    begin
3162       if Is_Overloaded (Old_N) then
3163          if Nkind (Old_N) = N_Selected_Component
3164            and then Is_Overloaded (Selector_Name (Old_N))
3165          then
3166             O_N := Selector_Name (Old_N);
3167          end if;
3168
3169          Map_Ptr := Headers (Hash (O_N));
3170
3171          while Interp_Map.Table (Map_Ptr).Node /= O_N loop
3172             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
3173             pragma Assert (Map_Ptr /= No_Entry);
3174          end loop;
3175
3176          New_Interps (New_N);
3177          Interp_Map.Table (Interp_Map.Last).Index :=
3178            Interp_Map.Table (Map_Ptr).Index;
3179       end if;
3180    end Save_Interps;
3181
3182    -------------------
3183    -- Specific_Type --
3184    -------------------
3185
3186    function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
3187       T1 : constant Entity_Id := Available_View (Typ_1);
3188       T2 : constant Entity_Id := Available_View (Typ_2);
3189       B1 : constant Entity_Id := Base_Type (T1);
3190       B2 : constant Entity_Id := Base_Type (T2);
3191
3192       function Is_Remote_Access (T : Entity_Id) return Boolean;
3193       --  Check whether T is the equivalent type of a remote access type.
3194       --  If distribution is enabled, T is a legal context for Null.
3195
3196       ----------------------
3197       -- Is_Remote_Access --
3198       ----------------------
3199
3200       function Is_Remote_Access (T : Entity_Id) return Boolean is
3201       begin
3202          return Is_Record_Type (T)
3203            and then (Is_Remote_Call_Interface (T)
3204                       or else Is_Remote_Types (T))
3205            and then Present (Corresponding_Remote_Type (T))
3206            and then Is_Access_Type (Corresponding_Remote_Type (T));
3207       end Is_Remote_Access;
3208
3209    --  Start of processing for Specific_Type
3210
3211    begin
3212       if T1 = Any_Type or else T2 = Any_Type then
3213          return Any_Type;
3214       end if;
3215
3216       if B1 = B2 then
3217          return B1;
3218
3219       elsif     (T1 = Universal_Integer and then Is_Integer_Type (T2))
3220         or else (T1 = Universal_Real    and then Is_Real_Type (T2))
3221         or else (T1 = Universal_Fixed   and then Is_Fixed_Point_Type (T2))
3222         or else (T1 = Any_Fixed         and then Is_Fixed_Point_Type (T2))
3223       then
3224          return B2;
3225
3226       elsif     (T2 = Universal_Integer and then Is_Integer_Type (T1))
3227         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
3228         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
3229         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
3230       then
3231          return B1;
3232
3233       elsif T2 = Any_String and then Is_String_Type (T1) then
3234          return B1;
3235
3236       elsif T1 = Any_String and then Is_String_Type (T2) then
3237          return B2;
3238
3239       elsif T2 = Any_Character and then Is_Character_Type (T1) then
3240          return B1;
3241
3242       elsif T1 = Any_Character and then Is_Character_Type (T2) then
3243          return B2;
3244
3245       elsif T1 = Any_Access
3246         and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3247       then
3248          return T2;
3249
3250       elsif T2 = Any_Access
3251         and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3252       then
3253          return T1;
3254
3255       --  In an instance, the specific type may have a private view. Use full
3256       --  view to check legality.
3257
3258       elsif T2 = Any_Access
3259         and then Is_Private_Type (T1)
3260         and then Present (Full_View (T1))
3261         and then Is_Access_Type (Full_View (T1))
3262         and then In_Instance
3263       then
3264          return T1;
3265
3266       elsif T2 = Any_Composite
3267         and then Is_Aggregate_Type (T1)
3268       then
3269          return T1;
3270
3271       elsif T1 = Any_Composite
3272         and then Is_Aggregate_Type (T2)
3273       then
3274          return T2;
3275
3276       elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3277          return T2;
3278
3279       elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3280          return T1;
3281
3282       --  ----------------------------------------------------------
3283       --  Special cases for equality operators (all other predefined
3284       --  operators can never apply to tagged types)
3285       --  ----------------------------------------------------------
3286
3287       --  Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3288       --  interface
3289
3290       elsif Is_Class_Wide_Type (T1)
3291         and then Is_Class_Wide_Type (T2)
3292         and then Is_Interface (Etype (T2))
3293       then
3294          return T1;
3295
3296       --  Ada 2005 (AI-251): T1 is a concrete type that implements the
3297       --  class-wide interface T2
3298
3299       elsif Is_Class_Wide_Type (T2)
3300         and then Is_Interface (Etype (T2))
3301         and then Interface_Present_In_Ancestor (Typ => T1,
3302                                                 Iface => Etype (T2))
3303       then
3304          return T1;
3305
3306       elsif Is_Class_Wide_Type (T1)
3307         and then Is_Ancestor (Root_Type (T1), T2)
3308       then
3309          return T1;
3310
3311       elsif Is_Class_Wide_Type (T2)
3312         and then Is_Ancestor (Root_Type (T2), T1)
3313       then
3314          return T2;
3315
3316       elsif (Ekind (B1) = E_Access_Subprogram_Type
3317                or else
3318              Ekind (B1) = E_Access_Protected_Subprogram_Type)
3319         and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3320         and then Is_Access_Type (T2)
3321       then
3322          return T2;
3323
3324       elsif (Ekind (B2) = E_Access_Subprogram_Type
3325                or else
3326              Ekind (B2) = E_Access_Protected_Subprogram_Type)
3327         and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3328         and then Is_Access_Type (T1)
3329       then
3330          return T1;
3331
3332       elsif (Ekind (T1) = E_Allocator_Type
3333               or else Ekind (T1) = E_Access_Attribute_Type
3334               or else Ekind (T1) = E_Anonymous_Access_Type)
3335         and then Is_Access_Type (T2)
3336       then
3337          return T2;
3338
3339       elsif (Ekind (T2) = E_Allocator_Type
3340               or else Ekind (T2) = E_Access_Attribute_Type
3341               or else Ekind (T2) = E_Anonymous_Access_Type)
3342         and then Is_Access_Type (T1)
3343       then
3344          return T1;
3345
3346       --  If none of the above cases applies, types are not compatible
3347
3348       else
3349          return Any_Type;
3350       end if;
3351    end Specific_Type;
3352
3353    ---------------------
3354    -- Set_Abstract_Op --
3355    ---------------------
3356
3357    procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3358    begin
3359       All_Interp.Table (I).Abstract_Op := V;
3360    end Set_Abstract_Op;
3361
3362    -----------------------
3363    -- Valid_Boolean_Arg --
3364    -----------------------
3365
3366    --  In addition to booleans and arrays of booleans, we must include
3367    --  aggregates as valid boolean arguments, because in the first pass of
3368    --  resolution their components are not examined. If it turns out not to be
3369    --  an aggregate of booleans, this will be diagnosed in Resolve.
3370    --  Any_Composite must be checked for prior to the array type checks because
3371    --  Any_Composite does not have any associated indexes.
3372
3373    function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3374    begin
3375       return Is_Boolean_Type (T)
3376         or else T = Any_Composite
3377         or else (Is_Array_Type (T)
3378                   and then T /= Any_String
3379                   and then Number_Dimensions (T) = 1
3380                   and then Is_Boolean_Type (Component_Type (T))
3381                   and then (not Is_Private_Composite (T)
3382                              or else In_Instance)
3383                   and then (not Is_Limited_Composite (T)
3384                              or else In_Instance))
3385         or else Is_Modular_Integer_Type (T)
3386         or else T = Universal_Integer;
3387    end Valid_Boolean_Arg;
3388
3389    --------------------------
3390    -- Valid_Comparison_Arg --
3391    --------------------------
3392
3393    function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3394    begin
3395
3396       if T = Any_Composite then
3397          return False;
3398       elsif Is_Discrete_Type (T)
3399         or else Is_Real_Type (T)
3400       then
3401          return True;
3402       elsif Is_Array_Type (T)
3403           and then Number_Dimensions (T) = 1
3404           and then Is_Discrete_Type (Component_Type (T))
3405           and then (not Is_Private_Composite (T)
3406                      or else In_Instance)
3407           and then (not Is_Limited_Composite (T)
3408                      or else In_Instance)
3409       then
3410          return True;
3411       elsif Is_String_Type (T) then
3412          return True;
3413       else
3414          return False;
3415       end if;
3416    end Valid_Comparison_Arg;
3417
3418    ----------------------
3419    -- Write_Interp_Ref --
3420    ----------------------
3421
3422    procedure Write_Interp_Ref (Map_Ptr : Int) is
3423    begin
3424       Write_Str (" Node:  ");
3425       Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3426       Write_Str (" Index: ");
3427       Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3428       Write_Str (" Next:  ");
3429       Write_Int (Interp_Map.Table (Map_Ptr).Next);
3430       Write_Eol;
3431    end Write_Interp_Ref;
3432
3433    ---------------------
3434    -- Write_Overloads --
3435    ---------------------
3436
3437    procedure Write_Overloads (N : Node_Id) is
3438       I   : Interp_Index;
3439       It  : Interp;
3440       Nam : Entity_Id;
3441
3442    begin
3443       if not Is_Overloaded (N) then
3444          Write_Str ("Non-overloaded entity ");
3445          Write_Eol;
3446          Write_Entity_Info (Entity (N), " ");
3447
3448       else
3449          Get_First_Interp (N, I, It);
3450          Write_Str ("Overloaded entity ");
3451          Write_Eol;
3452          Write_Str ("      Name           Type           Abstract Op");
3453          Write_Eol;
3454          Write_Str ("===============================================");
3455          Write_Eol;
3456          Nam := It.Nam;
3457
3458          while Present (Nam) loop
3459             Write_Int (Int (Nam));
3460             Write_Str ("   ");
3461             Write_Name (Chars (Nam));
3462             Write_Str ("   ");
3463             Write_Int (Int (It.Typ));
3464             Write_Str ("   ");
3465             Write_Name (Chars (It.Typ));
3466
3467             if Present (It.Abstract_Op) then
3468                Write_Str ("   ");
3469                Write_Int (Int (It.Abstract_Op));
3470                Write_Str ("   ");
3471                Write_Name (Chars (It.Abstract_Op));
3472             end if;
3473
3474             Write_Eol;
3475             Get_Next_Interp (I, It);
3476             Nam := It.Nam;
3477          end loop;
3478       end if;
3479    end Write_Overloads;
3480
3481 end Sem_Type;