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-2010, 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    begin
 574       New_Interps (N);
 575
 576       --  Unconditionally add the entity that was initially matched
 577
 578       First_Interp := All_Interp.Last;
 579       Add_One_Interp (N, Ent, Etype (N));
 580
 581       --  For expanded name, pick up all additional entities from the
 582       --  same scope, since these are obviously also visible. Note that
 583       --  these are not necessarily contiguous on the homonym chain.
 584
 585       if Nkind (N) = N_Expanded_Name then
 586          H := Homonym (Ent);
 587          while Present (H) loop
 588             if Scope (H) = Scope (Entity (N)) then
 589                Add_One_Interp (N, H, Etype (H));
 590             end if;
 591
 592             H := Homonym (H);
 593          end loop;
 594
 595       --  Case of direct name
 596
 597       else
 598          --  First, search the homonym chain for directly visible entities
 599
 600          H := Current_Entity (Ent);
 601          while Present (H) loop
 602             exit when (not Is_Overloadable (H))
 603               and then Is_Immediately_Visible (H);
 604
 605             if Is_Immediately_Visible (H)
 606               and then H /= Ent
 607             then
 608                --  Only add interpretation if not hidden by an inner
 609                --  immediately visible one.
 610
 611                for J in First_Interp .. All_Interp.Last - 1 loop
 612
 613                   --  Current homograph is not hidden. Add to overloads
 614
 615                   if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
 616                      exit;
 617
 618                   --  Homograph is hidden, unless it is a predefined operator
 619
 620                   elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
 621
 622                      --  A homograph in the same scope can occur within an
 623                      --  instantiation, the resulting ambiguity has to be
 624                      --  resolved later.
 625
 626                      if Scope (H) = Scope (Ent)
 627                         and then In_Instance
 628                         and then not Is_Inherited_Operation (H)
 629                      then
 630                         All_Interp.Table (All_Interp.Last) :=
 631                           (H, Etype (H), Empty);
 632                         All_Interp.Append (No_Interp);
 633                         goto Next_Homograph;
 634
 635                      elsif Scope (H) /= Standard_Standard then
 636                         goto Next_Homograph;
 637                      end if;
 638                   end if;
 639                end loop;
 640
 641                --  On exit, we know that current homograph is not hidden
 642
 643                Add_One_Interp (N, H, Etype (H));
 644
 645                if Debug_Flag_E then
 646                   Write_Str ("Add overloaded interpretation ");
 647                   Write_Int (Int (H));
 648                   Write_Eol;
 649                end if;
 650             end if;
 651
 652             <<Next_Homograph>>
 653                H := Homonym (H);
 654          end loop;
 655
 656          --  Scan list of homographs for use-visible entities only
 657
 658          H := Current_Entity (Ent);
 659
 660          while Present (H) loop
 661             if Is_Potentially_Use_Visible (H)
 662               and then H /= Ent
 663               and then Is_Overloadable (H)
 664             then
 665                for J in First_Interp .. All_Interp.Last - 1 loop
 666
 667                   if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
 668                      exit;
 669
 670                   elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
 671                      goto Next_Use_Homograph;
 672                   end if;
 673                end loop;
 674
 675                Add_One_Interp (N, H, Etype (H));
 676             end if;
 677
 678             <<Next_Use_Homograph>>
 679                H := Homonym (H);
 680          end loop;
 681       end if;
 682
 683       if All_Interp.Last = First_Interp + 1 then
 684
 685          --  The final interpretation is in fact not overloaded. Note that the
 686          --  unique legal interpretation may or may not be the original one,
 687          --  so we need to update N's entity and etype now, because once N
 688          --  is marked as not overloaded it is also expected to carry the
 689          --  proper interpretation.
 690
 691          Set_Is_Overloaded (N, False);
 692          Set_Entity (N, All_Interp.Table (First_Interp).Nam);
 693          Set_Etype  (N, All_Interp.Table (First_Interp).Typ);
 694       end if;
 695    end Collect_Interps;
 696
 697    ------------
 698    -- Covers --
 699    ------------
 700
 701    function Covers (T1, T2 : Entity_Id) return Boolean is
 702
 703       BT1 : Entity_Id;
 704       BT2 : Entity_Id;
 705
 706       function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
 707       --  In an instance the proper view may not always be correct for
 708       --  private types, but private and full view are compatible. This
 709       --  removes spurious errors from nested instantiations that involve,
 710       --  among other things, types derived from private types.
 711
 712       ----------------------
 713       -- Full_View_Covers --
 714       ----------------------
 715
 716       function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
 717       begin
 718          return
 719            Is_Private_Type (Typ1)
 720              and then
 721               ((Present (Full_View (Typ1))
 722                     and then Covers (Full_View (Typ1), Typ2))
 723                  or else Base_Type (Typ1) = Typ2
 724                  or else Base_Type (Typ2) = Typ1);
 725       end Full_View_Covers;
 726
 727    --  Start of processing for Covers
 728
 729    begin
 730       --  If either operand missing, then this is an error, but ignore it (and
 731       --  pretend we have a cover) if errors already detected, since this may
 732       --  simply mean we have malformed trees or a semantic error upstream.
 733
 734       if No (T1) or else No (T2) then
 735          if Total_Errors_Detected /= 0 then
 736             return True;
 737          else
 738             raise Program_Error;
 739          end if;
 740
 741       else
 742          BT1 := Base_Type (T1);
 743          BT2 := Base_Type (T2);
 744
 745          --  Handle underlying view of records with unknown discriminants
 746          --  using the original entity that motivated the construction of
 747          --  this underlying record view (see Build_Derived_Private_Type).
 748
 749          if Is_Underlying_Record_View (BT1) then
 750             BT1 := Underlying_Record_View (BT1);
 751          end if;
 752
 753          if Is_Underlying_Record_View (BT2) then
 754             BT2 := Underlying_Record_View (BT2);
 755          end if;
 756       end if;
 757
 758       --  First check for Standard_Void_Type, which is special. Subsequent
 759       --  processing in this routine assumes T1 and T2 are bona fide types;
 760       --  Standard_Void_Type is a special entity that has some, but not all,
 761       --  properties of types.
 762
 763       if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
 764          return False;
 765
 766       --  Simplest case: same types are compatible, and types that have the
 767       --  same base type and are not generic actuals are compatible. Generic
 768       --  actuals  belong to their class but are not compatible with other
 769       --  types of their class, and in particular with other generic actuals.
 770       --  They are however compatible with their own subtypes, and itypes
 771       --  with the same base are compatible as well. Similarly, constrained
 772       --  subtypes obtained from expressions of an unconstrained nominal type
 773       --  are compatible with the base type (may lead to spurious ambiguities
 774       --  in obscure cases ???)
 775
 776       --  Generic actuals require special treatment to avoid spurious ambi-
 777       --  guities in an instance, when two formal types are instantiated with
 778       --  the same actual, so that different subprograms end up with the same
 779       --  signature in the instance.
 780
 781       elsif T1 = T2 then
 782          return True;
 783
 784       elsif BT1 = BT2
 785         or else BT1 = T2
 786         or else BT2 = T1
 787       then
 788          if not Is_Generic_Actual_Type (T1) then
 789             return True;
 790          else
 791             return (not Is_Generic_Actual_Type (T2)
 792                      or else Is_Itype (T1)
 793                      or else Is_Itype (T2)
 794                      or else Is_Constr_Subt_For_U_Nominal (T1)
 795                      or else Is_Constr_Subt_For_U_Nominal (T2)
 796                      or else Scope (T1) /= Scope (T2));
 797          end if;
 798
 799       --  Literals are compatible with types in a given "class"
 800
 801       elsif     (T2 = Universal_Integer and then Is_Integer_Type (T1))
 802         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
 803         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
 804         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
 805         or else (T2 = Any_String        and then Is_String_Type (T1))
 806         or else (T2 = Any_Character     and then Is_Character_Type (T1))
 807         or else (T2 = Any_Access        and then Is_Access_Type (T1))
 808       then
 809          return True;
 810
 811       --  The context may be class wide, and a class-wide type is compatible
 812       --  with any member of the class.
 813
 814       elsif Is_Class_Wide_Type (T1)
 815         and then Is_Ancestor (Root_Type (T1), T2)
 816       then
 817          return True;
 818
 819       elsif Is_Class_Wide_Type (T1)
 820         and then Is_Class_Wide_Type (T2)
 821         and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
 822       then
 823          return True;
 824
 825       --  Ada 2005 (AI-345): A class-wide abstract interface type covers a
 826       --  task_type or protected_type that implements the interface.
 827
 828       elsif Ada_Version >= Ada_2005
 829         and then Is_Class_Wide_Type (T1)
 830         and then Is_Interface (Etype (T1))
 831         and then Is_Concurrent_Type (T2)
 832         and then Interface_Present_In_Ancestor
 833                    (Typ   => Base_Type (T2),
 834                     Iface => Etype (T1))
 835       then
 836          return True;
 837
 838       --  Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
 839       --  object T2 implementing T1
 840
 841       elsif Ada_Version >= Ada_2005
 842         and then Is_Class_Wide_Type (T1)
 843         and then Is_Interface (Etype (T1))
 844         and then Is_Tagged_Type (T2)
 845       then
 846          if Interface_Present_In_Ancestor (Typ   => T2,
 847                                            Iface => Etype (T1))
 848          then
 849             return True;
 850          end if;
 851
 852          declare
 853             E    : Entity_Id;
 854             Elmt : Elmt_Id;
 855
 856          begin
 857             if Is_Concurrent_Type (BT2) then
 858                E := Corresponding_Record_Type (BT2);
 859             else
 860                E := BT2;
 861             end if;
 862
 863             --  Ada 2005 (AI-251): A class-wide abstract interface type T1
 864             --  covers an object T2 that implements a direct derivation of T1.
 865             --  Note: test for presence of E is defense against previous error.
 866
 867             if Present (E)
 868               and then Present (Interfaces (E))
 869             then
 870                Elmt := First_Elmt (Interfaces (E));
 871                while Present (Elmt) loop
 872                   if Is_Ancestor (Etype (T1), Node (Elmt)) then
 873                      return True;
 874                   end if;
 875
 876                   Next_Elmt (Elmt);
 877                end loop;
 878             end if;
 879
 880             --  We should also check the case in which T1 is an ancestor of
 881             --  some implemented interface???
 882
 883             return False;
 884          end;
 885
 886          --  In a dispatching call the actual may be class-wide, the formal
 887          --  may be its specific type, or that of a descendent of it.
 888
 889       elsif Is_Class_Wide_Type (T2)
 890         and then
 891           (Class_Wide_Type (T1) = T2
 892              or else Base_Type (Root_Type (T2)) = Base_Type (T1))
 893       then
 894          return True;
 895
 896       --  Some contexts require a class of types rather than a specific type.
 897       --  For example, conditions require any boolean type, fixed point
 898       --  attributes require some real type, etc. The built-in types Any_XXX
 899       --  represent these classes.
 900
 901       elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
 902         or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
 903         or else (T1 = Any_Real and then Is_Real_Type (T2))
 904         or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
 905         or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
 906       then
 907          return True;
 908
 909       --  An aggregate is compatible with an array or record type
 910
 911       elsif T2 = Any_Composite
 912         and then Is_Aggregate_Type (T1)
 913       then
 914          return True;
 915
 916       --  If the expected type is an anonymous access, the designated type must
 917       --  cover that of the expression. Use the base type for this check: even
 918       --  though access subtypes are rare in sources, they are generated for
 919       --  actuals in instantiations.
 920
 921       elsif Ekind (BT1) = E_Anonymous_Access_Type
 922         and then Is_Access_Type (T2)
 923         and then Covers (Designated_Type (T1), Designated_Type (T2))
 924       then
 925          return True;
 926
 927       --  An Access_To_Subprogram is compatible with itself, or with an
 928       --  anonymous type created for an attribute reference Access.
 929
 930       elsif (Ekind (BT1) = E_Access_Subprogram_Type
 931                or else
 932              Ekind (BT1) = E_Access_Protected_Subprogram_Type)
 933         and then Is_Access_Type (T2)
 934         and then (not Comes_From_Source (T1)
 935                    or else not Comes_From_Source (T2))
 936         and then (Is_Overloadable (Designated_Type (T2))
 937                     or else
 938                   Ekind (Designated_Type (T2)) = E_Subprogram_Type)
 939         and then
 940           Type_Conformant (Designated_Type (T1), Designated_Type (T2))
 941         and then
 942           Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
 943       then
 944          return True;
 945
 946       --  Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
 947       --  with itself, or with an anonymous type created for an attribute
 948       --  reference Access.
 949
 950       elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type
 951                or else
 952              Ekind (BT1)
 953                       = E_Anonymous_Access_Protected_Subprogram_Type)
 954         and then Is_Access_Type (T2)
 955         and then (not Comes_From_Source (T1)
 956                    or else not Comes_From_Source (T2))
 957         and then (Is_Overloadable (Designated_Type (T2))
 958                     or else
 959                   Ekind (Designated_Type (T2)) = E_Subprogram_Type)
 960         and then
 961            Type_Conformant (Designated_Type (T1), Designated_Type (T2))
 962         and then
 963            Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
 964       then
 965          return True;
 966
 967       --  The context can be a remote access type, and the expression the
 968       --  corresponding source type declared in a categorized package, or
 969       --  vice versa.
 970
 971       elsif Is_Record_Type (T1)
 972         and then (Is_Remote_Call_Interface (T1)
 973                    or else Is_Remote_Types (T1))
 974         and then Present (Corresponding_Remote_Type (T1))
 975       then
 976          return Covers (Corresponding_Remote_Type (T1), T2);
 977
 978       --  and conversely.
 979
 980       elsif Is_Record_Type (T2)
 981         and then (Is_Remote_Call_Interface (T2)
 982                    or else Is_Remote_Types (T2))
 983         and then Present (Corresponding_Remote_Type (T2))
 984       then
 985          return Covers (Corresponding_Remote_Type (T2), T1);
 986
 987       --  Synchronized types are represented at run time by their corresponding
 988       --  record type. During expansion one is replaced with the other, but
 989       --  they are compatible views of the same type.
 990
 991       elsif Is_Record_Type (T1)
 992         and then Is_Concurrent_Type (T2)
 993         and then Present (Corresponding_Record_Type (T2))
 994       then
 995          return Covers (T1, Corresponding_Record_Type (T2));
 996
 997       elsif Is_Concurrent_Type (T1)
 998         and then Present (Corresponding_Record_Type (T1))
 999         and then Is_Record_Type (T2)
1000       then
1001          return Covers (Corresponding_Record_Type (T1), T2);
1002
1003       --  During analysis, an attribute reference 'Access has a special type
1004       --  kind: Access_Attribute_Type, to be replaced eventually with the type
1005       --  imposed by context.
1006
1007       elsif Ekind (T2) = E_Access_Attribute_Type
1008         and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
1009         and then Covers (Designated_Type (T1), Designated_Type (T2))
1010       then
1011          --  If the target type is a RACW type while the source is an access
1012          --  attribute type, we are building a RACW that may be exported.
1013
1014          if Is_Remote_Access_To_Class_Wide_Type (BT1) then
1015             Set_Has_RACW (Current_Sem_Unit);
1016          end if;
1017
1018          return True;
1019
1020       --  Ditto for allocators, which eventually resolve to the context type
1021
1022       elsif Ekind (T2) = E_Allocator_Type
1023         and then Is_Access_Type (T1)
1024       then
1025          return Covers (Designated_Type (T1), Designated_Type (T2))
1026           or else
1027             (From_With_Type (Designated_Type (T1))
1028               and then Covers (Designated_Type (T2), Designated_Type (T1)));
1029
1030       --  A boolean operation on integer literals is compatible with modular
1031       --  context.
1032
1033       elsif T2 = Any_Modular
1034         and then Is_Modular_Integer_Type (T1)
1035       then
1036          return True;
1037
1038       --  The actual type may be the result of a previous error
1039
1040       elsif Base_Type (T2) = Any_Type then
1041          return True;
1042
1043       --  A packed array type covers its corresponding non-packed type. This is
1044       --  not legitimate Ada, but allows the omission of a number of otherwise
1045       --  useless unchecked conversions, and since this can only arise in
1046       --  (known correct) expanded code, no harm is done.
1047
1048       elsif Is_Array_Type (T2)
1049         and then Is_Packed (T2)
1050         and then T1 = Packed_Array_Type (T2)
1051       then
1052          return True;
1053
1054       --  Similarly an array type covers its corresponding packed array type
1055
1056       elsif Is_Array_Type (T1)
1057         and then Is_Packed (T1)
1058         and then T2 = Packed_Array_Type (T1)
1059       then
1060          return True;
1061
1062       --  In instances, or with types exported from instantiations, check
1063       --  whether a partial and a full view match. Verify that types are
1064       --  legal, to prevent cascaded errors.
1065
1066       elsif In_Instance
1067         and then
1068           (Full_View_Covers (T1, T2)
1069             or else Full_View_Covers (T2, T1))
1070       then
1071          return True;
1072
1073       elsif Is_Type (T2)
1074         and then Is_Generic_Actual_Type (T2)
1075         and then Full_View_Covers (T1, T2)
1076       then
1077          return True;
1078
1079       elsif Is_Type (T1)
1080         and then Is_Generic_Actual_Type (T1)
1081         and then Full_View_Covers (T2, T1)
1082       then
1083          return True;
1084
1085       --  In the expansion of inlined bodies, types are compatible if they
1086       --  are structurally equivalent.
1087
1088       elsif In_Inlined_Body
1089         and then (Underlying_Type (T1) = Underlying_Type (T2)
1090                    or else (Is_Access_Type (T1)
1091                               and then Is_Access_Type (T2)
1092                               and then
1093                                 Designated_Type (T1) = Designated_Type (T2))
1094                    or else (T1 = Any_Access
1095                               and then Is_Access_Type (Underlying_Type (T2)))
1096                    or else (T2 = Any_Composite
1097                               and then
1098                                 Is_Composite_Type (Underlying_Type (T1))))
1099       then
1100          return True;
1101
1102       --  Ada 2005 (AI-50217): Additional branches to make the shadow entity
1103       --  obtained through a limited_with compatible with its real entity.
1104
1105       elsif From_With_Type (T1) then
1106
1107          --  If the expected type is the non-limited view of a type, the
1108          --  expression may have the limited view. If that one in turn is
1109          --  incomplete, get full view if available.
1110
1111          if Is_Incomplete_Type (T1) then
1112             return Covers (Get_Full_View (Non_Limited_View (T1)), T2);
1113
1114          elsif Ekind (T1) = E_Class_Wide_Type then
1115             return
1116               Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
1117          else
1118             return False;
1119          end if;
1120
1121       elsif From_With_Type (T2) then
1122
1123          --  If units in the context have Limited_With clauses on each other,
1124          --  either type might have a limited view. Checks performed elsewhere
1125          --  verify that the context type is the nonlimited view.
1126
1127          if Is_Incomplete_Type (T2) then
1128             return Covers (T1, Get_Full_View (Non_Limited_View (T2)));
1129
1130          elsif Ekind (T2) = E_Class_Wide_Type then
1131             return
1132               Present (Non_Limited_View (Etype (T2)))
1133                 and then
1134                   Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
1135          else
1136             return False;
1137          end if;
1138
1139       --  Ada 2005 (AI-412): Coverage for regular incomplete subtypes
1140
1141       elsif Ekind (T1) = E_Incomplete_Subtype then
1142          return Covers (Full_View (Etype (T1)), T2);
1143
1144       elsif Ekind (T2) = E_Incomplete_Subtype then
1145          return Covers (T1, Full_View (Etype (T2)));
1146
1147       --  Ada 2005 (AI-423): Coverage of formal anonymous access types
1148       --  and actual anonymous access types in the context of generic
1149       --  instantiations. We have the following situation:
1150
1151       --     generic
1152       --        type Formal is private;
1153       --        Formal_Obj : access Formal;  --  T1
1154       --     package G is ...
1155
1156       --     package P is
1157       --        type Actual is ...
1158       --        Actual_Obj : access Actual;  --  T2
1159       --        package Instance is new G (Formal     => Actual,
1160       --                                   Formal_Obj => Actual_Obj);
1161
1162       elsif Ada_Version >= Ada_2005
1163         and then Ekind (T1) = E_Anonymous_Access_Type
1164         and then Ekind (T2) = E_Anonymous_Access_Type
1165         and then Is_Generic_Type (Directly_Designated_Type (T1))
1166         and then Get_Instance_Of (Directly_Designated_Type (T1)) =
1167                    Directly_Designated_Type (T2)
1168       then
1169          return True;
1170
1171       --  Otherwise, types are not compatible!
1172
1173       else
1174          return False;
1175       end if;
1176    end Covers;
1177
1178    ------------------
1179    -- Disambiguate --
1180    ------------------
1181
1182    function Disambiguate
1183      (N      : Node_Id;
1184       I1, I2 : Interp_Index;
1185       Typ    : Entity_Id) return Interp
1186    is
1187       I           : Interp_Index;
1188       It          : Interp;
1189       It1, It2    : Interp;
1190       Nam1, Nam2  : Entity_Id;
1191       Predef_Subp : Entity_Id;
1192       User_Subp   : Entity_Id;
1193
1194       function Inherited_From_Actual (S : Entity_Id) return Boolean;
1195       --  Determine whether one of the candidates is an operation inherited by
1196       --  a type that is derived from an actual in an instantiation.
1197
1198       function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1199       --  Determine whether a subprogram is an actual in an enclosing instance.
1200       --  An overloading between such a subprogram and one declared outside the
1201       --  instance is resolved in favor of the first, because it resolved in
1202       --  the generic.
1203
1204       function Matches (Actual, Formal : Node_Id) return Boolean;
1205       --  Look for exact type match in an instance, to remove spurious
1206       --  ambiguities when two formal types have the same actual.
1207
1208       function Standard_Operator return Boolean;
1209       --  Check whether subprogram is predefined operator declared in Standard.
1210       --  It may given by an operator name, or by an expanded name whose prefix
1211       --  is Standard.
1212
1213       function Remove_Conversions return Interp;
1214       --  Last chance for pathological cases involving comparisons on literals,
1215       --  and user overloadings of the same operator. Such pathologies have
1216       --  been removed from the ACVC, but still appear in two DEC tests, with
1217       --  the following notable quote from Ben Brosgol:
1218       --
1219       --  [Note: I disclaim all credit/responsibility/blame for coming up with
1220       --  this example; Robert Dewar brought it to our attention, since it is
1221       --  apparently found in the ACVC 1.5. I did not attempt to find the
1222       --  reason in the Reference Manual that makes the example legal, since I
1223       --  was too nauseated by it to want to pursue it further.]
1224       --
1225       --  Accordingly, this is not a fully recursive solution, but it handles
1226       --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1227       --  pathology in the other direction with calls whose multiple overloaded
1228       --  actuals make them truly unresolvable.
1229
1230       --  The new rules concerning abstract operations create additional need
1231       --  for special handling of expressions with universal operands, see
1232       --  comments to Has_Abstract_Interpretation below.
1233
1234       ---------------------------
1235       -- Inherited_From_Actual --
1236       ---------------------------
1237
1238       function Inherited_From_Actual (S : Entity_Id) return Boolean is
1239          Par : constant Node_Id := Parent (S);
1240       begin
1241          if Nkind (Par) /= N_Full_Type_Declaration
1242            or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1243          then
1244             return False;
1245          else
1246             return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1247               and then
1248                Is_Generic_Actual_Type (
1249                  Entity (Subtype_Indication (Type_Definition (Par))));
1250          end if;
1251       end Inherited_From_Actual;
1252
1253       --------------------------
1254       -- Is_Actual_Subprogram --
1255       --------------------------
1256
1257       function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1258       begin
1259          return In_Open_Scopes (Scope (S))
1260            and then
1261              (Is_Generic_Instance (Scope (S))
1262                or else Is_Wrapper_Package (Scope (S)));
1263       end Is_Actual_Subprogram;
1264
1265       -------------
1266       -- Matches --
1267       -------------
1268
1269       function Matches (Actual, Formal : Node_Id) return Boolean is
1270          T1 : constant Entity_Id := Etype (Actual);
1271          T2 : constant Entity_Id := Etype (Formal);
1272       begin
1273          return T1 = T2
1274            or else
1275              (Is_Numeric_Type (T2)
1276                and then (T1 = Universal_Real or else T1 = Universal_Integer));
1277       end Matches;
1278
1279       ------------------------
1280       -- Remove_Conversions --
1281       ------------------------
1282
1283       function Remove_Conversions return Interp is
1284          I    : Interp_Index;
1285          It   : Interp;
1286          It1  : Interp;
1287          F1   : Entity_Id;
1288          Act1 : Node_Id;
1289          Act2 : Node_Id;
1290
1291          function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1292          --  If an operation has universal operands the universal operation
1293          --  is present among its interpretations. If there is an abstract
1294          --  interpretation for the operator, with a numeric result, this
1295          --  interpretation was already removed in sem_ch4, but the universal
1296          --  one is still visible. We must rescan the list of operators and
1297          --  remove the universal interpretation to resolve the ambiguity.
1298
1299          ---------------------------------
1300          -- Has_Abstract_Interpretation --
1301          ---------------------------------
1302
1303          function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1304             E : Entity_Id;
1305
1306          begin
1307             if Nkind (N) not in N_Op
1308               or else Ada_Version < Ada_2005
1309               or else not Is_Overloaded (N)
1310               or else No (Universal_Interpretation (N))
1311             then
1312                return False;
1313
1314             else
1315                E := Get_Name_Entity_Id (Chars (N));
1316                while Present (E) loop
1317                   if Is_Overloadable (E)
1318                     and then Is_Abstract_Subprogram (E)
1319                     and then Is_Numeric_Type (Etype (E))
1320                   then
1321                      return True;
1322                   else
1323                      E := Homonym (E);
1324                   end if;
1325                end loop;
1326
1327                --  Finally, if an operand of the binary operator is itself
1328                --  an operator, recurse to see whether its own abstract
1329                --  interpretation is responsible for the spurious ambiguity.
1330
1331                if Nkind (N) in N_Binary_Op then
1332                   return Has_Abstract_Interpretation (Left_Opnd (N))
1333                     or else Has_Abstract_Interpretation (Right_Opnd (N));
1334
1335                elsif Nkind (N) in N_Unary_Op then
1336                   return Has_Abstract_Interpretation (Right_Opnd (N));
1337
1338                else
1339                   return False;
1340                end if;
1341             end if;
1342          end Has_Abstract_Interpretation;
1343
1344       --  Start of processing for Remove_Conversions
1345
1346       begin
1347          It1 := No_Interp;
1348
1349          Get_First_Interp (N, I, It);
1350          while Present (It.Typ) loop
1351             if not Is_Overloadable (It.Nam) then
1352                return No_Interp;
1353             end if;
1354
1355             F1 := First_Formal (It.Nam);
1356
1357             if No (F1) then
1358                return It1;
1359
1360             else
1361                if Nkind (N) = N_Function_Call
1362                  or else Nkind (N) = N_Procedure_Call_Statement
1363                then
1364                   Act1 := First_Actual (N);
1365
1366                   if Present (Act1) then
1367                      Act2 := Next_Actual (Act1);
1368                   else
1369                      Act2 := Empty;
1370                   end if;
1371
1372                elsif Nkind (N) in N_Unary_Op then
1373                   Act1 := Right_Opnd (N);
1374                   Act2 := Empty;
1375
1376                elsif Nkind (N) in N_Binary_Op then
1377                   Act1 := Left_Opnd (N);
1378                   Act2 := Right_Opnd (N);
1379
1380                   --  Use type of second formal, so as to include
1381                   --  exponentiation, where the exponent may be
1382                   --  ambiguous and the result non-universal.
1383
1384                   Next_Formal (F1);
1385
1386                else
1387                   return It1;
1388                end if;
1389
1390                if Nkind (Act1) in N_Op
1391                  and then Is_Overloaded (Act1)
1392                  and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1393                             or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1394                  and then Has_Compatible_Type (Act1, Standard_Boolean)
1395                  and then Etype (F1) = Standard_Boolean
1396                then
1397                   --  If the two candidates are the original ones, the
1398                   --  ambiguity is real. Otherwise keep the original, further
1399                   --  calls to Disambiguate will take care of others in the
1400                   --  list of candidates.
1401
1402                   if It1 /= No_Interp then
1403                      if It = Disambiguate.It1
1404                        or else It = Disambiguate.It2
1405                      then
1406                         if It1 = Disambiguate.It1
1407                           or else It1 = Disambiguate.It2
1408                         then
1409                            return No_Interp;
1410                         else
1411                            It1 := It;
1412                         end if;
1413                      end if;
1414
1415                   elsif Present (Act2)
1416                     and then Nkind (Act2) in N_Op
1417                     and then Is_Overloaded (Act2)
1418                     and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1419                                                           N_Real_Literal)
1420                     and then Has_Compatible_Type (Act2, Standard_Boolean)
1421                   then
1422                      --  The preference rule on the first actual is not
1423                      --  sufficient to disambiguate.
1424
1425                      goto Next_Interp;
1426
1427                   else
1428                      It1 := It;
1429                   end if;
1430
1431                elsif Is_Numeric_Type (Etype (F1))
1432                  and then Has_Abstract_Interpretation (Act1)
1433                then
1434                   --  Current interpretation is not the right one because it
1435                   --  expects a numeric operand. Examine all the other ones.
1436
1437                   declare
1438                      I  : Interp_Index;
1439                      It : Interp;
1440
1441                   begin
1442                      Get_First_Interp (N, I, It);
1443                      while Present (It.Typ) loop
1444                         if
1445                           not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1446                         then
1447                            if No (Act2)
1448                              or else not Has_Abstract_Interpretation (Act2)
1449                              or else not
1450                                Is_Numeric_Type
1451                                  (Etype (Next_Formal (First_Formal (It.Nam))))
1452                            then
1453                               return It;
1454                            end if;
1455                         end if;
1456
1457                         Get_Next_Interp (I, It);
1458                      end loop;
1459
1460                      return No_Interp;
1461                   end;
1462                end if;
1463             end if;
1464
1465             <<Next_Interp>>
1466                Get_Next_Interp (I, It);
1467          end loop;
1468
1469          --  After some error, a formal may have Any_Type and yield a spurious
1470          --  match. To avoid cascaded errors if possible, check for such a
1471          --  formal in either candidate.
1472
1473          if Serious_Errors_Detected > 0 then
1474             declare
1475                Formal : Entity_Id;
1476
1477             begin
1478                Formal := First_Formal (Nam1);
1479                while Present (Formal) loop
1480                   if Etype (Formal) = Any_Type then
1481                      return Disambiguate.It2;
1482                   end if;
1483
1484                   Next_Formal (Formal);
1485                end loop;
1486
1487                Formal := First_Formal (Nam2);
1488                while Present (Formal) loop
1489                   if Etype (Formal) = Any_Type then
1490                      return Disambiguate.It1;
1491                   end if;
1492
1493                   Next_Formal (Formal);
1494                end loop;
1495             end;
1496          end if;
1497
1498          return It1;
1499       end Remove_Conversions;
1500
1501       -----------------------
1502       -- Standard_Operator --
1503       -----------------------
1504
1505       function Standard_Operator return Boolean is
1506          Nam : Node_Id;
1507
1508       begin
1509          if Nkind (N) in N_Op then
1510             return True;
1511
1512          elsif Nkind (N) = N_Function_Call then
1513             Nam := Name (N);
1514
1515             if Nkind (Nam) /= N_Expanded_Name then
1516                return True;
1517             else
1518                return Entity (Prefix (Nam)) = Standard_Standard;
1519             end if;
1520          else
1521             return False;
1522          end if;
1523       end Standard_Operator;
1524
1525    --  Start of processing for Disambiguate
1526
1527    begin
1528       --  Recover the two legal interpretations
1529
1530       Get_First_Interp (N, I, It);
1531       while I /= I1 loop
1532          Get_Next_Interp (I, It);
1533       end loop;
1534
1535       It1  := It;
1536       Nam1 := It.Nam;
1537       while I /= I2 loop
1538          Get_Next_Interp (I, It);
1539       end loop;
1540
1541       It2  := It;
1542       Nam2 := It.Nam;
1543
1544       --  Check whether one of the entities is an Ada 2005/2012 and we are
1545       --  operating in an earlier mode, in which case we discard the Ada
1546       --  2005/2012 entity, so that we get proper Ada 95 overload resolution.
1547
1548       if Ada_Version < Ada_2005 then
1549          if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
1550             return It2;
1551          elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
1552             return It1;
1553          end if;
1554       end if;
1555
1556       --  Check whether one of the entities is an Ada 2012 entity and we are
1557       --  operating in Ada 2005 mode, in which case we discard the Ada 2012
1558       --  entity, so that we get proper Ada 2005 overload resolution.
1559
1560       if Ada_Version = Ada_2005 then
1561          if Is_Ada_2012_Only (Nam1) then
1562             return It2;
1563          elsif Is_Ada_2012_Only (Nam2) then
1564             return It1;
1565          end if;
1566       end if;
1567
1568       --  Check for overloaded CIL convention stuff because the CIL libraries
1569       --  do sick things like Console.Write_Line where it matches two different
1570       --  overloads, so just pick the first ???
1571
1572       if Convention (Nam1) = Convention_CIL
1573         and then Convention (Nam2) = Convention_CIL
1574         and then Ekind (Nam1) = Ekind (Nam2)
1575         and then (Ekind (Nam1) = E_Procedure
1576                    or else Ekind (Nam1) = E_Function)
1577       then
1578          return It2;
1579       end if;
1580
1581       --  If the context is universal, the predefined operator is preferred.
1582       --  This includes bounds in numeric type declarations, and expressions
1583       --  in type conversions. If no interpretation yields a universal type,
1584       --  then we must check whether the user-defined entity hides the prede-
1585       --  fined one.
1586
1587       if Chars (Nam1) in Any_Operator_Name
1588         and then Standard_Operator
1589       then
1590          if        Typ = Universal_Integer
1591            or else Typ = Universal_Real
1592            or else Typ = Any_Integer
1593            or else Typ = Any_Discrete
1594            or else Typ = Any_Real
1595            or else Typ = Any_Type
1596          then
1597             --  Find an interpretation that yields the universal type, or else
1598             --  a predefined operator that yields a predefined numeric type.
1599
1600             declare
1601                Candidate : Interp := No_Interp;
1602
1603             begin
1604                Get_First_Interp (N, I, It);
1605                while Present (It.Typ) loop
1606                   if (Covers (Typ, It.Typ)
1607                         or else Typ = Any_Type)
1608                     and then
1609                      (It.Typ = Universal_Integer
1610                        or else It.Typ = Universal_Real)
1611                   then
1612                      return It;
1613
1614                   elsif Covers (Typ, It.Typ)
1615                     and then Scope (It.Typ) = Standard_Standard
1616                     and then Scope (It.Nam) = Standard_Standard
1617                     and then Is_Numeric_Type (It.Typ)
1618                   then
1619                      Candidate := It;
1620                   end if;
1621
1622                   Get_Next_Interp (I, It);
1623                end loop;
1624
1625                if Candidate /= No_Interp then
1626                   return Candidate;
1627                end if;
1628             end;
1629
1630          elsif Chars (Nam1) /= Name_Op_Not
1631            and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1632          then
1633             --  Equality or comparison operation. Choose predefined operator if
1634             --  arguments are universal. The node may be an operator, name, or
1635             --  a function call, so unpack arguments accordingly.
1636
1637             declare
1638                Arg1, Arg2 : Node_Id;
1639
1640             begin
1641                if Nkind (N) in N_Op then
1642                   Arg1 := Left_Opnd  (N);
1643                   Arg2 := Right_Opnd (N);
1644
1645                elsif Is_Entity_Name (N) then
1646                   Arg1 := First_Entity (Entity (N));
1647                   Arg2 := Next_Entity (Arg1);
1648
1649                else
1650                   Arg1 := First_Actual (N);
1651                   Arg2 := Next_Actual (Arg1);
1652                end if;
1653
1654                if Present (Arg2)
1655                  and then Present (Universal_Interpretation (Arg1))
1656                  and then Universal_Interpretation (Arg2) =
1657                           Universal_Interpretation (Arg1)
1658                then
1659                   Get_First_Interp (N, I, It);
1660                   while Scope (It.Nam) /= Standard_Standard loop
1661                      Get_Next_Interp (I, It);
1662                   end loop;
1663
1664                   return It;
1665                end if;
1666             end;
1667          end if;
1668       end if;
1669
1670       --  If no universal interpretation, check whether user-defined operator
1671       --  hides predefined one, as well as other special cases. If the node
1672       --  is a range, then one or both bounds are ambiguous. Each will have
1673       --  to be disambiguated w.r.t. the context type. The type of the range
1674       --  itself is imposed by the context, so we can return either legal
1675       --  interpretation.
1676
1677       if Ekind (Nam1) = E_Operator then
1678          Predef_Subp := Nam1;
1679          User_Subp   := Nam2;
1680
1681       elsif Ekind (Nam2) = E_Operator then
1682          Predef_Subp := Nam2;
1683          User_Subp   := Nam1;
1684
1685       elsif Nkind (N) = N_Range then
1686          return It1;
1687
1688       --  Implement AI05-105: A renaming declaration with an access
1689       --  definition must resolve to an anonymous access type. This
1690       --  is a resolution rule and can be used to disambiguate.
1691
1692       elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1693         and then Present (Access_Definition (Parent (N)))
1694       then
1695          if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
1696                                E_Anonymous_Access_Subprogram_Type)
1697          then
1698             if Ekind (It2.Typ) = Ekind (It1.Typ) then
1699
1700                --  True ambiguity
1701
1702                return No_Interp;
1703
1704             else
1705                return It1;
1706             end if;
1707
1708          elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
1709                                   E_Anonymous_Access_Subprogram_Type)
1710          then
1711             return It2;
1712
1713          --  No legal interpretation
1714
1715          else
1716             return No_Interp;
1717          end if;
1718
1719       --  If two user defined-subprograms are visible, it is a true ambiguity,
1720       --  unless one of them is an entry and the context is a conditional or
1721       --  timed entry call, or unless we are within an instance and this is
1722       --  results from two formals types with the same actual.
1723
1724       else
1725          if Nkind (N) = N_Procedure_Call_Statement
1726            and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1727            and then N = Entry_Call_Statement (Parent (N))
1728          then
1729             if Ekind (Nam2) = E_Entry then
1730                return It2;
1731             elsif Ekind (Nam1) = E_Entry then
1732                return It1;
1733             else
1734                return No_Interp;
1735             end if;
1736
1737          --  If the ambiguity occurs within an instance, it is due to several
1738          --  formal types with the same actual. Look for an exact match between
1739          --  the types of the formals of the overloadable entities, and the
1740          --  actuals in the call, to recover the unambiguous match in the
1741          --  original generic.
1742
1743          --  The ambiguity can also be due to an overloading between a formal
1744          --  subprogram and a subprogram declared outside the generic. If the
1745          --  node is overloaded, it did not resolve to the global entity in
1746          --  the generic, and we choose the formal subprogram.
1747
1748          --  Finally, the ambiguity can be between an explicit subprogram and
1749          --  one inherited (with different defaults) from an actual. In this
1750          --  case the resolution was to the explicit declaration in the
1751          --  generic, and remains so in the instance.
1752
1753          elsif In_Instance
1754            and then not In_Generic_Actual (N)
1755          then
1756             if Nkind (N) = N_Function_Call
1757               or else Nkind (N) = N_Procedure_Call_Statement
1758             then
1759                declare
1760                   Actual  : Node_Id;
1761                   Formal  : Entity_Id;
1762                   Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1763                   Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1764
1765                begin
1766                   if Is_Act1 and then not Is_Act2 then
1767                      return It1;
1768
1769                   elsif Is_Act2 and then not Is_Act1 then
1770                      return It2;
1771
1772                   elsif Inherited_From_Actual (Nam1)
1773                     and then Comes_From_Source (Nam2)
1774                   then
1775                      return It2;
1776
1777                   elsif Inherited_From_Actual (Nam2)
1778                     and then Comes_From_Source (Nam1)
1779                   then
1780                      return It1;
1781                   end if;
1782
1783                   Actual := First_Actual (N);
1784                   Formal := First_Formal (Nam1);
1785                   while Present (Actual) loop
1786                      if Etype (Actual) /= Etype (Formal) then
1787                         return It2;
1788                      end if;
1789
1790                      Next_Actual (Actual);
1791                      Next_Formal (Formal);
1792                   end loop;
1793
1794                   return It1;
1795                end;
1796
1797             elsif Nkind (N) in N_Binary_Op then
1798                if Matches (Left_Opnd (N), First_Formal (Nam1))
1799                  and then
1800                    Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1801                then
1802                   return It1;
1803                else
1804                   return It2;
1805                end if;
1806
1807             elsif Nkind (N) in  N_Unary_Op then
1808                if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1809                   return It1;
1810                else
1811                   return It2;
1812                end if;
1813
1814             else
1815                return Remove_Conversions;
1816             end if;
1817          else
1818             return Remove_Conversions;
1819          end if;
1820       end if;
1821
1822       --  An implicit concatenation operator on a string type cannot be
1823       --  disambiguated from the predefined concatenation. This can only
1824       --  happen with concatenation of string literals.
1825
1826       if Chars (User_Subp) = Name_Op_Concat
1827         and then Ekind (User_Subp) = E_Operator
1828         and then Is_String_Type (Etype (First_Formal (User_Subp)))
1829       then
1830          return No_Interp;
1831
1832       --  If the user-defined operator is in an open scope, or in the scope
1833       --  of the resulting type, or given by an expanded name that names its
1834       --  scope, it hides the predefined operator for the type. Exponentiation
1835       --  has to be special-cased because the implicit operator does not have
1836       --  a symmetric signature, and may not be hidden by the explicit one.
1837
1838       elsif (Nkind (N) = N_Function_Call
1839               and then Nkind (Name (N)) = N_Expanded_Name
1840               and then (Chars (Predef_Subp) /= Name_Op_Expon
1841                           or else Hides_Op (User_Subp, Predef_Subp))
1842               and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1843         or else Hides_Op (User_Subp, Predef_Subp)
1844       then
1845          if It1.Nam = User_Subp then
1846             return It1;
1847          else
1848             return It2;
1849          end if;
1850
1851       --  Otherwise, the predefined operator has precedence, or if the user-
1852       --  defined operation is directly visible we have a true ambiguity. If
1853       --  this is a fixed-point multiplication and division in Ada83 mode,
1854       --  exclude the universal_fixed operator, which often causes ambiguities
1855       --  in legacy code.
1856
1857       else
1858          if (In_Open_Scopes (Scope (User_Subp))
1859            or else Is_Potentially_Use_Visible (User_Subp))
1860            and then not In_Instance
1861          then
1862             if Is_Fixed_Point_Type (Typ)
1863               and then (Chars (Nam1) = Name_Op_Multiply
1864                           or else Chars (Nam1) = Name_Op_Divide)
1865               and then Ada_Version = Ada_83
1866             then
1867                if It2.Nam = Predef_Subp then
1868                   return It1;
1869                else
1870                   return It2;
1871                end if;
1872
1873             --  Ada 2005, AI-420: preference rule for "=" on Universal_Access
1874             --  states that the operator defined in Standard is not available
1875             --  if there is a user-defined equality with the proper signature,
1876             --  declared in the same declarative list as the type. The node
1877             --  may be an operator or a function call.
1878
1879             elsif (Chars (Nam1) = Name_Op_Eq
1880                      or else
1881                    Chars (Nam1) = Name_Op_Ne)
1882               and then Ada_Version >= Ada_2005
1883               and then Etype (User_Subp) = Standard_Boolean
1884             then
1885                declare
1886                   Opnd : Node_Id;
1887
1888                begin
1889                   if Nkind (N) = N_Function_Call then
1890                      Opnd := First_Actual (N);
1891                   else
1892                      Opnd := Left_Opnd (N);
1893                   end if;
1894
1895                   if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
1896                     and then
1897                       In_Same_List (Parent (Designated_Type (Etype (Opnd))),
1898                                     Unit_Declaration_Node (User_Subp))
1899                   then
1900                      if It2.Nam = Predef_Subp then
1901                         return It1;
1902                      else
1903                         return It2;
1904                      end if;
1905                   else
1906                      return Remove_Conversions;
1907                   end if;
1908                end;
1909
1910             else
1911                return No_Interp;
1912             end if;
1913
1914          elsif It1.Nam = Predef_Subp then
1915             return It1;
1916
1917          else
1918             return It2;
1919          end if;
1920       end if;
1921    end Disambiguate;
1922
1923    ---------------------
1924    -- End_Interp_List --
1925    ---------------------
1926
1927    procedure End_Interp_List is
1928    begin
1929       All_Interp.Table (All_Interp.Last) := No_Interp;
1930       All_Interp.Increment_Last;
1931    end End_Interp_List;
1932
1933    -------------------------
1934    -- Entity_Matches_Spec --
1935    -------------------------
1936
1937    function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1938    begin
1939       --  Simple case: same entity kinds, type conformance is required. A
1940       --  parameterless function can also rename a literal.
1941
1942       if Ekind (Old_S) = Ekind (New_S)
1943         or else (Ekind (New_S) = E_Function
1944                   and then Ekind (Old_S) = E_Enumeration_Literal)
1945       then
1946          return Type_Conformant (New_S, Old_S);
1947
1948       elsif Ekind (New_S) = E_Function
1949         and then Ekind (Old_S) = E_Operator
1950       then
1951          return Operator_Matches_Spec (Old_S, New_S);
1952
1953       elsif Ekind (New_S) = E_Procedure
1954         and then Is_Entry (Old_S)
1955       then
1956          return Type_Conformant (New_S, Old_S);
1957
1958       else
1959          return False;
1960       end if;
1961    end Entity_Matches_Spec;
1962
1963    ----------------------
1964    -- Find_Unique_Type --
1965    ----------------------
1966
1967    function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1968       T  : constant Entity_Id := Etype (L);
1969       I  : Interp_Index;
1970       It : Interp;
1971       TR : Entity_Id := Any_Type;
1972
1973    begin
1974       if Is_Overloaded (R) then
1975          Get_First_Interp (R, I, It);
1976          while Present (It.Typ) loop
1977             if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1978
1979                --  If several interpretations are possible and L is universal,
1980                --  apply preference rule.
1981
1982                if TR /= Any_Type then
1983
1984                   if (T = Universal_Integer or else T = Universal_Real)
1985                     and then It.Typ = T
1986                   then
1987                      TR := It.Typ;
1988                   end if;
1989
1990                else
1991                   TR := It.Typ;
1992                end if;
1993             end if;
1994
1995             Get_Next_Interp (I, It);
1996          end loop;
1997
1998          Set_Etype (R, TR);
1999
2000       --  In the non-overloaded case, the Etype of R is already set correctly
2001
2002       else
2003          null;
2004       end if;
2005
2006       --  If one of the operands is Universal_Fixed, the type of the other
2007       --  operand provides the context.
2008
2009       if Etype (R) = Universal_Fixed then
2010          return T;
2011
2012       elsif T = Universal_Fixed then
2013          return Etype (R);
2014
2015       --  Ada 2005 (AI-230): Support the following operators:
2016
2017       --    function "="  (L, R : universal_access) return Boolean;
2018       --    function "/=" (L, R : universal_access) return Boolean;
2019
2020       --  Pool specific access types (E_Access_Type) are not covered by these
2021       --  operators because of the legality rule of 4.5.2(9.2): "The operands
2022       --  of the equality operators for universal_access shall be convertible
2023       --  to one another (see 4.6)". For example, considering the type decla-
2024       --  ration "type P is access Integer" and an anonymous access to Integer,
2025       --  P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
2026       --  is no rule in 4.6 that allows "access Integer" to be converted to P.
2027
2028       elsif Ada_Version >= Ada_2005
2029         and then
2030           (Ekind (Etype (L)) = E_Anonymous_Access_Type
2031              or else
2032            Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
2033         and then Is_Access_Type (Etype (R))
2034         and then Ekind (Etype (R)) /= E_Access_Type
2035       then
2036          return Etype (L);
2037
2038       elsif Ada_Version >= Ada_2005
2039         and then
2040           (Ekind (Etype (R)) = E_Anonymous_Access_Type
2041             or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
2042         and then Is_Access_Type (Etype (L))
2043         and then Ekind (Etype (L)) /= E_Access_Type
2044       then
2045          return Etype (R);
2046
2047       else
2048          return Specific_Type (T, Etype (R));
2049       end if;
2050    end Find_Unique_Type;
2051
2052    -------------------------------------
2053    -- Function_Interp_Has_Abstract_Op --
2054    -------------------------------------
2055
2056    function Function_Interp_Has_Abstract_Op
2057      (N : Node_Id;
2058       E : Entity_Id) return Entity_Id
2059    is
2060       Abstr_Op  : Entity_Id;
2061       Act       : Node_Id;
2062       Act_Parm  : Node_Id;
2063       Form_Parm : Node_Id;
2064
2065    begin
2066       --  Why is check on E needed below ???
2067       --  In any case this para needs comments ???
2068
2069       if Is_Overloaded (N) and then Is_Overloadable (E) then
2070          Act_Parm  := First_Actual (N);
2071          Form_Parm := First_Formal (E);
2072          while Present (Act_Parm)
2073            and then Present (Form_Parm)
2074          loop
2075             Act := Act_Parm;
2076
2077             if Nkind (Act) = N_Parameter_Association then
2078                Act := Explicit_Actual_Parameter (Act);
2079             end if;
2080
2081             Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2082
2083             if Present (Abstr_Op) then
2084                return Abstr_Op;
2085             end if;
2086
2087             Next_Actual (Act_Parm);
2088             Next_Formal (Form_Parm);
2089          end loop;
2090       end if;
2091
2092       return Empty;
2093    end Function_Interp_Has_Abstract_Op;
2094
2095    ----------------------
2096    -- Get_First_Interp --
2097    ----------------------
2098
2099    procedure Get_First_Interp
2100      (N  : Node_Id;
2101       I  : out Interp_Index;
2102       It : out Interp)
2103    is
2104       Int_Ind : Interp_Index;
2105       Map_Ptr : Int;
2106       O_N     : Node_Id;
2107
2108    begin
2109       --  If a selected component is overloaded because the selector has
2110       --  multiple interpretations, the node is a call to a protected
2111       --  operation or an indirect call. Retrieve the interpretation from
2112       --  the selector name. The selected component may be overloaded as well
2113       --  if the prefix is overloaded. That case is unchanged.
2114
2115       if Nkind (N) = N_Selected_Component
2116         and then Is_Overloaded (Selector_Name (N))
2117       then
2118          O_N := Selector_Name (N);
2119       else
2120          O_N := N;
2121       end if;
2122
2123       Map_Ptr := Headers (Hash (O_N));
2124       while Map_Ptr /= No_Entry loop
2125          if Interp_Map.Table (Map_Ptr).Node = O_N then
2126             Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2127             It := All_Interp.Table (Int_Ind);
2128             I := Int_Ind;
2129             return;
2130          else
2131             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2132          end if;
2133       end loop;
2134
2135       --  Procedure should never be called if the node has no interpretations
2136
2137       raise Program_Error;
2138    end Get_First_Interp;
2139
2140    ---------------------
2141    -- Get_Next_Interp --
2142    ---------------------
2143
2144    procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2145    begin
2146       I  := I + 1;
2147       It := All_Interp.Table (I);
2148    end Get_Next_Interp;
2149
2150    -------------------------
2151    -- Has_Compatible_Type --
2152    -------------------------
2153
2154    function Has_Compatible_Type
2155      (N   : Node_Id;
2156       Typ : Entity_Id) return Boolean
2157    is
2158       I  : Interp_Index;
2159       It : Interp;
2160
2161    begin
2162       if N = Error then
2163          return False;
2164       end if;
2165
2166       if Nkind (N) = N_Subtype_Indication
2167         or else not Is_Overloaded (N)
2168       then
2169          return
2170            Covers (Typ, Etype (N))
2171
2172             --  Ada 2005 (AI-345): The context may be a synchronized interface.
2173             --  If the type is already frozen use the corresponding_record
2174             --  to check whether it is a proper descendant.
2175
2176            or else
2177              (Is_Record_Type (Typ)
2178                 and then Is_Concurrent_Type (Etype (N))
2179                 and then Present (Corresponding_Record_Type (Etype (N)))
2180                 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2181
2182            or else
2183              (Is_Concurrent_Type (Typ)
2184                 and then Is_Record_Type (Etype (N))
2185                 and then Present (Corresponding_Record_Type (Typ))
2186                 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2187
2188            or else
2189              (not Is_Tagged_Type (Typ)
2190                 and then Ekind (Typ) /= E_Anonymous_Access_Type
2191                 and then Covers (Etype (N), Typ));
2192
2193       else
2194          Get_First_Interp (N, I, It);
2195          while Present (It.Typ) loop
2196             if (Covers (Typ, It.Typ)
2197                   and then
2198                     (Scope (It.Nam) /= Standard_Standard
2199                        or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2200
2201                --  Ada 2005 (AI-345)
2202
2203               or else
2204                 (Is_Concurrent_Type (It.Typ)
2205                   and then Present (Corresponding_Record_Type
2206                                                              (Etype (It.Typ)))
2207                   and then Covers (Typ, Corresponding_Record_Type
2208                                                              (Etype (It.Typ))))
2209
2210               or else (not Is_Tagged_Type (Typ)
2211                          and then Ekind (Typ) /= E_Anonymous_Access_Type
2212                          and then Covers (It.Typ, Typ))
2213             then
2214                return True;
2215             end if;
2216
2217             Get_Next_Interp (I, It);
2218          end loop;
2219
2220          return False;
2221       end if;
2222    end Has_Compatible_Type;
2223
2224    ---------------------
2225    -- Has_Abstract_Op --
2226    ---------------------
2227
2228    function Has_Abstract_Op
2229      (N   : Node_Id;
2230       Typ : Entity_Id) return Entity_Id
2231    is
2232       I  : Interp_Index;
2233       It : Interp;
2234
2235    begin
2236       if Is_Overloaded (N) then
2237          Get_First_Interp (N, I, It);
2238          while Present (It.Nam) loop
2239             if Present (It.Abstract_Op)
2240               and then Etype (It.Abstract_Op) = Typ
2241             then
2242                return It.Abstract_Op;
2243             end if;
2244
2245             Get_Next_Interp (I, It);
2246          end loop;
2247       end if;
2248
2249       return Empty;
2250    end Has_Abstract_Op;
2251
2252    ----------
2253    -- Hash --
2254    ----------
2255
2256    function Hash (N : Node_Id) return Int is
2257    begin
2258       --  Nodes have a size that is power of two, so to select significant
2259       --  bits only we remove the low-order bits.
2260
2261       return ((Int (N) / 2 ** 5) mod Header_Size);
2262    end Hash;
2263
2264    --------------
2265    -- Hides_Op --
2266    --------------
2267
2268    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2269       Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2270    begin
2271       return Operator_Matches_Spec (Op, F)
2272         and then (In_Open_Scopes (Scope (F))
2273                     or else Scope (F) = Scope (Btyp)
2274                     or else (not In_Open_Scopes (Scope (Btyp))
2275                               and then not In_Use (Btyp)
2276                               and then not In_Use (Scope (Btyp))));
2277    end Hides_Op;
2278
2279    ------------------------
2280    -- Init_Interp_Tables --
2281    ------------------------
2282
2283    procedure Init_Interp_Tables is
2284    begin
2285       All_Interp.Init;
2286       Interp_Map.Init;
2287       Headers := (others => No_Entry);
2288    end Init_Interp_Tables;
2289
2290    -----------------------------------
2291    -- Interface_Present_In_Ancestor --
2292    -----------------------------------
2293
2294    function Interface_Present_In_Ancestor
2295      (Typ   : Entity_Id;
2296       Iface : Entity_Id) return Boolean
2297    is
2298       Target_Typ : Entity_Id;
2299       Iface_Typ  : Entity_Id;
2300
2301       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2302       --  Returns True if Typ or some ancestor of Typ implements Iface
2303
2304       -------------------------------
2305       -- Iface_Present_In_Ancestor --
2306       -------------------------------
2307
2308       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2309          E    : Entity_Id;
2310          AI   : Entity_Id;
2311          Elmt : Elmt_Id;
2312
2313       begin
2314          if Typ = Iface_Typ then
2315             return True;
2316          end if;
2317
2318          --  Handle private types
2319
2320          if Present (Full_View (Typ))
2321            and then not Is_Concurrent_Type (Full_View (Typ))
2322          then
2323             E := Full_View (Typ);
2324          else
2325             E := Typ;
2326          end if;
2327
2328          loop
2329             if Present (Interfaces (E))
2330               and then Present (Interfaces (E))
2331               and then not Is_Empty_Elmt_List (Interfaces (E))
2332             then
2333                Elmt := First_Elmt (Interfaces (E));
2334                while Present (Elmt) loop
2335                   AI := Node (Elmt);
2336
2337                   if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2338                      return True;
2339                   end if;
2340
2341                   Next_Elmt (Elmt);
2342                end loop;
2343             end if;
2344
2345             exit when Etype (E) = E
2346
2347                --  Handle private types
2348
2349                or else (Present (Full_View (Etype (E)))
2350                          and then Full_View (Etype (E)) = E);
2351
2352             --  Check if the current type is a direct derivation of the
2353             --  interface
2354
2355             if Etype (E) = Iface_Typ then
2356                return True;
2357             end if;
2358
2359             --  Climb to the immediate ancestor handling private types
2360
2361             if Present (Full_View (Etype (E))) then
2362                E := Full_View (Etype (E));
2363             else
2364                E := Etype (E);
2365             end if;
2366          end loop;
2367
2368          return False;
2369       end Iface_Present_In_Ancestor;
2370
2371    --  Start of processing for Interface_Present_In_Ancestor
2372
2373    begin
2374       --  Iface might be a class-wide subtype, so we have to apply Base_Type
2375
2376       if Is_Class_Wide_Type (Iface) then
2377          Iface_Typ := Etype (Base_Type (Iface));
2378       else
2379          Iface_Typ := Iface;
2380       end if;
2381
2382       --  Handle subtypes
2383
2384       Iface_Typ := Base_Type (Iface_Typ);
2385
2386       if Is_Access_Type (Typ) then
2387          Target_Typ := Etype (Directly_Designated_Type (Typ));
2388       else
2389          Target_Typ := Typ;
2390       end if;
2391
2392       if Is_Concurrent_Record_Type (Target_Typ) then
2393          Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2394       end if;
2395
2396       Target_Typ := Base_Type (Target_Typ);
2397
2398       --  In case of concurrent types we can't use the Corresponding Record_Typ
2399       --  to look for the interface because it is built by the expander (and
2400       --  hence it is not always available). For this reason we traverse the
2401       --  list of interfaces (available in the parent of the concurrent type)
2402
2403       if Is_Concurrent_Type (Target_Typ) then
2404          if Present (Interface_List (Parent (Target_Typ))) then
2405             declare
2406                AI : Node_Id;
2407
2408             begin
2409                AI := First (Interface_List (Parent (Target_Typ)));
2410                while Present (AI) loop
2411                   if Etype (AI) = Iface_Typ then
2412                      return True;
2413
2414                   elsif Present (Interfaces (Etype (AI)))
2415                      and then Iface_Present_In_Ancestor (Etype (AI))
2416                   then
2417                      return True;
2418                   end if;
2419
2420                   Next (AI);
2421                end loop;
2422             end;
2423          end if;
2424
2425          return False;
2426       end if;
2427
2428       if Is_Class_Wide_Type (Target_Typ) then
2429          Target_Typ := Etype (Target_Typ);
2430       end if;
2431
2432       if Ekind (Target_Typ) = E_Incomplete_Type then
2433          pragma Assert (Present (Non_Limited_View (Target_Typ)));
2434          Target_Typ := Non_Limited_View (Target_Typ);
2435
2436          --  Protect the frontend against previously detected errors
2437
2438          if Ekind (Target_Typ) = E_Incomplete_Type then
2439             return False;
2440          end if;
2441       end if;
2442
2443       return Iface_Present_In_Ancestor (Target_Typ);
2444    end Interface_Present_In_Ancestor;
2445
2446    ---------------------
2447    -- Intersect_Types --
2448    ---------------------
2449
2450    function Intersect_Types (L, R : Node_Id) return Entity_Id is
2451       Index : Interp_Index;
2452       It    : Interp;
2453       Typ   : Entity_Id;
2454
2455       function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2456       --  Find interpretation of right arg that has type compatible with T
2457
2458       --------------------------
2459       -- Check_Right_Argument --
2460       --------------------------
2461
2462       function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2463          Index : Interp_Index;
2464          It    : Interp;
2465          T2    : Entity_Id;
2466
2467       begin
2468          if not Is_Overloaded (R) then
2469             return Specific_Type (T, Etype (R));
2470
2471          else
2472             Get_First_Interp (R, Index, It);
2473             loop
2474                T2 := Specific_Type (T, It.Typ);
2475
2476                if T2 /= Any_Type then
2477                   return T2;
2478                end if;
2479
2480                Get_Next_Interp (Index, It);
2481                exit when No (It.Typ);
2482             end loop;
2483
2484             return Any_Type;
2485          end if;
2486       end Check_Right_Argument;
2487
2488    --  Start of processing for Intersect_Types
2489
2490    begin
2491       if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2492          return Any_Type;
2493       end if;
2494
2495       if not Is_Overloaded (L) then
2496          Typ := Check_Right_Argument (Etype (L));
2497
2498       else
2499          Typ := Any_Type;
2500          Get_First_Interp (L, Index, It);
2501          while Present (It.Typ) loop
2502             Typ := Check_Right_Argument (It.Typ);
2503             exit when Typ /= Any_Type;
2504             Get_Next_Interp (Index, It);
2505          end loop;
2506
2507       end if;
2508
2509       --  If Typ is Any_Type, it means no compatible pair of types was found
2510
2511       if Typ = Any_Type then
2512          if Nkind (Parent (L)) in N_Op then
2513             Error_Msg_N ("incompatible types for operator", Parent (L));
2514
2515          elsif Nkind (Parent (L)) = N_Range then
2516             Error_Msg_N ("incompatible types given in constraint", Parent (L));
2517
2518          --  Ada 2005 (AI-251): Complete the error notification
2519
2520          elsif Is_Class_Wide_Type (Etype (R))
2521              and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2522          then
2523             Error_Msg_NE ("(Ada 2005) does not implement interface }",
2524                           L, Etype (Class_Wide_Type (Etype (R))));
2525
2526          else
2527             Error_Msg_N ("incompatible types", Parent (L));
2528          end if;
2529       end if;
2530
2531       return Typ;
2532    end Intersect_Types;
2533
2534    -----------------------
2535    -- In_Generic_Actual --
2536    -----------------------
2537
2538    function In_Generic_Actual (Exp : Node_Id) return Boolean is
2539       Par : constant Node_Id := Parent (Exp);
2540
2541    begin
2542       if No (Par) then
2543          return False;
2544
2545       elsif Nkind (Par) in N_Declaration then
2546          if Nkind (Par) = N_Object_Declaration then
2547             return Present (Corresponding_Generic_Association (Par));
2548          else
2549             return False;
2550          end if;
2551
2552       elsif Nkind (Par) = N_Object_Renaming_Declaration then
2553          return Present (Corresponding_Generic_Association (Par));
2554
2555       elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2556          return False;
2557
2558       else
2559          return In_Generic_Actual (Parent (Par));
2560       end if;
2561    end In_Generic_Actual;
2562
2563    -----------------
2564    -- Is_Ancestor --
2565    -----------------
2566
2567    function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
2568       BT1 : Entity_Id;
2569       BT2 : Entity_Id;
2570       Par : Entity_Id;
2571
2572    begin
2573       BT1 := Base_Type (T1);
2574       BT2 := Base_Type (T2);
2575
2576       --  Handle underlying view of records with unknown discriminants using
2577       --  the original entity that motivated the construction of this
2578       --  underlying record view (see Build_Derived_Private_Type).
2579
2580       if Is_Underlying_Record_View (BT1) then
2581          BT1 := Underlying_Record_View (BT1);
2582       end if;
2583
2584       if Is_Underlying_Record_View (BT2) then
2585          BT2 := Underlying_Record_View (BT2);
2586       end if;
2587
2588       if BT1 = BT2 then
2589          return True;
2590
2591       --  The predicate must look past privacy
2592
2593       elsif Is_Private_Type (T1)
2594         and then Present (Full_View (T1))
2595         and then BT2 = Base_Type (Full_View (T1))
2596       then
2597          return True;
2598
2599       elsif Is_Private_Type (T2)
2600         and then Present (Full_View (T2))
2601         and then BT1 = Base_Type (Full_View (T2))
2602       then
2603          return True;
2604
2605       else
2606          Par := Etype (BT2);
2607
2608          loop
2609             --  If there was a error on the type declaration, do not recurse
2610
2611             if Error_Posted (Par) then
2612                return False;
2613
2614             elsif BT1 = Base_Type (Par)
2615               or else (Is_Private_Type (T1)
2616                          and then Present (Full_View (T1))
2617                          and then Base_Type (Par) = Base_Type (Full_View (T1)))
2618             then
2619                return True;
2620
2621             elsif Is_Private_Type (Par)
2622               and then Present (Full_View (Par))
2623               and then Full_View (Par) = BT1
2624             then
2625                return True;
2626
2627             elsif Etype (Par) /= Par then
2628
2629                --  If this is a private type and its parent is an interface
2630                --  then use the parent of the full view (which is a type that
2631                --  implements such interface)
2632
2633                if Is_Private_Type (Par)
2634                  and then Is_Interface (Etype (Par))
2635                  and then Present (Full_View (Par))
2636                then
2637                   Par := Etype (Full_View (Par));
2638                else
2639                   Par := Etype (Par);
2640                end if;
2641
2642             --  For all other cases return False, not an Ancestor
2643
2644             else
2645                return False;
2646             end if;
2647          end loop;
2648       end if;
2649    end Is_Ancestor;
2650
2651    ---------------------------
2652    -- Is_Invisible_Operator --
2653    ---------------------------
2654
2655    function Is_Invisible_Operator
2656      (N : Node_Id;
2657       T : Entity_Id) return Boolean
2658    is
2659       Orig_Node : constant Node_Id := Original_Node (N);
2660
2661    begin
2662       if Nkind (N) not in N_Op then
2663          return False;
2664
2665       elsif not Comes_From_Source (N) then
2666          return False;
2667
2668       elsif No (Universal_Interpretation (Right_Opnd (N))) then
2669          return False;
2670
2671       elsif Nkind (N) in N_Binary_Op
2672         and then No (Universal_Interpretation (Left_Opnd (N)))
2673       then
2674          return False;
2675
2676       else
2677          return Is_Numeric_Type (T)
2678            and then not In_Open_Scopes (Scope (T))
2679            and then not Is_Potentially_Use_Visible (T)
2680            and then not In_Use (T)
2681            and then not In_Use (Scope (T))
2682            and then
2683             (Nkind (Orig_Node) /= N_Function_Call
2684               or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2685               or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2686            and then not In_Instance;
2687       end if;
2688    end Is_Invisible_Operator;
2689
2690    --------------------
2691    --  Is_Progenitor --
2692    --------------------
2693
2694    function Is_Progenitor
2695      (Iface : Entity_Id;
2696       Typ   : Entity_Id) return Boolean
2697    is
2698    begin
2699       return Implements_Interface (Typ, Iface, Exclude_Parents => True);
2700    end Is_Progenitor;
2701
2702    -------------------
2703    -- Is_Subtype_Of --
2704    -------------------
2705
2706    function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2707       S : Entity_Id;
2708
2709    begin
2710       S := Ancestor_Subtype (T1);
2711       while Present (S) loop
2712          if S = T2 then
2713             return True;
2714          else
2715             S := Ancestor_Subtype (S);
2716          end if;
2717       end loop;
2718
2719       return False;
2720    end Is_Subtype_Of;
2721
2722    ------------------
2723    -- List_Interps --
2724    ------------------
2725
2726    procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
2727       Index : Interp_Index;
2728       It    : Interp;
2729
2730    begin
2731       Get_First_Interp (Nam, Index, It);
2732       while Present (It.Nam) loop
2733          if Scope (It.Nam) = Standard_Standard
2734            and then Scope (It.Typ) /= Standard_Standard
2735          then
2736             Error_Msg_Sloc := Sloc (Parent (It.Typ));
2737             Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
2738
2739          else
2740             Error_Msg_Sloc := Sloc (It.Nam);
2741             Error_Msg_NE ("\\& declared#!", Err, It.Nam);
2742          end if;
2743
2744          Get_Next_Interp (Index, It);
2745       end loop;
2746    end List_Interps;
2747
2748    -----------------
2749    -- New_Interps --
2750    -----------------
2751
2752    procedure New_Interps (N : Node_Id)  is
2753       Map_Ptr : Int;
2754
2755    begin
2756       All_Interp.Append (No_Interp);
2757
2758       Map_Ptr := Headers (Hash (N));
2759
2760       if Map_Ptr = No_Entry then
2761
2762          --  Place new node at end of table
2763
2764          Interp_Map.Increment_Last;
2765          Headers (Hash (N)) := Interp_Map.Last;
2766
2767       else
2768          --   Place node at end of chain, or locate its previous entry
2769
2770          loop
2771             if Interp_Map.Table (Map_Ptr).Node = N then
2772
2773                --  Node is already in the table, and is being rewritten.
2774                --  Start a new interp section, retain hash link.
2775
2776                Interp_Map.Table (Map_Ptr).Node  := N;
2777                Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
2778                Set_Is_Overloaded (N, True);
2779                return;
2780
2781             else
2782                exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
2783                Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2784             end if;
2785          end loop;
2786
2787          --  Chain the new node
2788
2789          Interp_Map.Increment_Last;
2790          Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
2791       end if;
2792
2793       Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
2794       Set_Is_Overloaded (N, True);
2795    end New_Interps;
2796
2797    ---------------------------
2798    -- Operator_Matches_Spec --
2799    ---------------------------
2800
2801    function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
2802       Op_Name : constant Name_Id   := Chars (Op);
2803       T       : constant Entity_Id := Etype (New_S);
2804       New_F   : Entity_Id;
2805       Old_F   : Entity_Id;
2806       Num     : Int;
2807       T1      : Entity_Id;
2808       T2      : Entity_Id;
2809
2810    begin
2811       --  To verify that a predefined operator matches a given signature,
2812       --  do a case analysis of the operator classes. Function can have one
2813       --  or two formals and must have the proper result type.
2814
2815       New_F := First_Formal (New_S);
2816       Old_F := First_Formal (Op);
2817       Num := 0;
2818       while Present (New_F) and then Present (Old_F) loop
2819          Num := Num + 1;
2820          Next_Formal (New_F);
2821          Next_Formal (Old_F);
2822       end loop;
2823
2824       --  Definite mismatch if different number of parameters
2825
2826       if Present (Old_F) or else Present (New_F) then
2827          return False;
2828
2829       --  Unary operators
2830
2831       elsif Num = 1 then
2832          T1 := Etype (First_Formal (New_S));
2833
2834          if Op_Name = Name_Op_Subtract
2835            or else Op_Name = Name_Op_Add
2836            or else Op_Name = Name_Op_Abs
2837          then
2838             return Base_Type (T1) = Base_Type (T)
2839               and then Is_Numeric_Type (T);
2840
2841          elsif Op_Name = Name_Op_Not then
2842             return Base_Type (T1) = Base_Type (T)
2843               and then Valid_Boolean_Arg (Base_Type (T));
2844
2845          else
2846             return False;
2847          end if;
2848
2849       --  Binary operators
2850
2851       else
2852          T1 := Etype (First_Formal (New_S));
2853          T2 := Etype (Next_Formal (First_Formal (New_S)));
2854
2855          if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
2856            or else Op_Name = Name_Op_Xor
2857          then
2858             return Base_Type (T1) = Base_Type (T2)
2859               and then Base_Type (T1) = Base_Type (T)
2860               and then Valid_Boolean_Arg (Base_Type (T));
2861
2862          elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
2863             return Base_Type (T1) = Base_Type (T2)
2864               and then not Is_Limited_Type (T1)
2865               and then Is_Boolean_Type (T);
2866
2867          elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
2868            or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
2869          then
2870             return Base_Type (T1) = Base_Type (T2)
2871               and then Valid_Comparison_Arg (T1)
2872               and then Is_Boolean_Type (T);
2873
2874          elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
2875             return Base_Type (T1) = Base_Type (T2)
2876               and then Base_Type (T1) = Base_Type (T)
2877               and then Is_Numeric_Type (T);
2878
2879          --  For division and multiplication, a user-defined function does not
2880          --  match the predefined universal_fixed operation, except in Ada 83.
2881
2882          elsif Op_Name = Name_Op_Divide then
2883             return (Base_Type (T1) = Base_Type (T2)
2884               and then Base_Type (T1) = Base_Type (T)
2885               and then Is_Numeric_Type (T)
2886               and then (not Is_Fixed_Point_Type (T)
2887                          or else Ada_Version = Ada_83))
2888
2889             --  Mixed_Mode operations on fixed-point types
2890
2891               or else (Base_Type (T1) = Base_Type (T)
2892                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2893                         and then Is_Fixed_Point_Type (T))
2894
2895             --  A user defined operator can also match (and hide) a mixed
2896             --  operation on universal literals.
2897
2898               or else (Is_Integer_Type (T2)
2899                         and then Is_Floating_Point_Type (T1)
2900                         and then Base_Type (T1) = Base_Type (T));
2901
2902          elsif Op_Name = Name_Op_Multiply then
2903             return (Base_Type (T1) = Base_Type (T2)
2904               and then Base_Type (T1) = Base_Type (T)
2905               and then Is_Numeric_Type (T)
2906               and then (not Is_Fixed_Point_Type (T)
2907                          or else Ada_Version = Ada_83))
2908
2909             --  Mixed_Mode operations on fixed-point types
2910
2911               or else (Base_Type (T1) = Base_Type (T)
2912                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2913                         and then Is_Fixed_Point_Type (T))
2914
2915               or else (Base_Type (T2) = Base_Type (T)
2916                         and then Base_Type (T1) = Base_Type (Standard_Integer)
2917                         and then Is_Fixed_Point_Type (T))
2918
2919               or else (Is_Integer_Type (T2)
2920                         and then Is_Floating_Point_Type (T1)
2921                         and then Base_Type (T1) = Base_Type (T))
2922
2923               or else (Is_Integer_Type (T1)
2924                         and then Is_Floating_Point_Type (T2)
2925                         and then Base_Type (T2) = Base_Type (T));
2926
2927          elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
2928             return Base_Type (T1) = Base_Type (T2)
2929               and then Base_Type (T1) = Base_Type (T)
2930               and then Is_Integer_Type (T);
2931
2932          elsif Op_Name = Name_Op_Expon then
2933             return Base_Type (T1) = Base_Type (T)
2934               and then Is_Numeric_Type (T)
2935               and then Base_Type (T2) = Base_Type (Standard_Integer);
2936
2937          elsif Op_Name = Name_Op_Concat then
2938             return Is_Array_Type (T)
2939               and then (Base_Type (T) = Base_Type (Etype (Op)))
2940               and then (Base_Type (T1) = Base_Type (T)
2941                          or else
2942                         Base_Type (T1) = Base_Type (Component_Type (T)))
2943               and then (Base_Type (T2) = Base_Type (T)
2944                          or else
2945                         Base_Type (T2) = Base_Type (Component_Type (T)));
2946
2947          else
2948             return False;
2949          end if;
2950       end if;
2951    end Operator_Matches_Spec;
2952
2953    -------------------
2954    -- Remove_Interp --
2955    -------------------
2956
2957    procedure Remove_Interp (I : in out Interp_Index) is
2958       II : Interp_Index;
2959
2960    begin
2961       --  Find end of interp list and copy downward to erase the discarded one
2962
2963       II := I + 1;
2964       while Present (All_Interp.Table (II).Typ) loop
2965          II := II + 1;
2966       end loop;
2967
2968       for J in I + 1 .. II loop
2969          All_Interp.Table (J - 1) := All_Interp.Table (J);
2970       end loop;
2971
2972       --  Back up interp index to insure that iterator will pick up next
2973       --  available interpretation.
2974
2975       I := I - 1;
2976    end Remove_Interp;
2977
2978    ------------------
2979    -- Save_Interps --
2980    ------------------
2981
2982    procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
2983       Map_Ptr : Int;
2984       O_N     : Node_Id := Old_N;
2985
2986    begin
2987       if Is_Overloaded (Old_N) then
2988          if Nkind (Old_N) = N_Selected_Component
2989            and then Is_Overloaded (Selector_Name (Old_N))
2990          then
2991             O_N := Selector_Name (Old_N);
2992          end if;
2993
2994          Map_Ptr := Headers (Hash (O_N));
2995
2996          while Interp_Map.Table (Map_Ptr).Node /= O_N loop
2997             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2998             pragma Assert (Map_Ptr /= No_Entry);
2999          end loop;
3000
3001          New_Interps (New_N);
3002          Interp_Map.Table (Interp_Map.Last).Index :=
3003            Interp_Map.Table (Map_Ptr).Index;
3004       end if;
3005    end Save_Interps;
3006
3007    -------------------
3008    -- Specific_Type --
3009    -------------------
3010
3011    function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
3012       T1 : constant Entity_Id := Available_View (Typ_1);
3013       T2 : constant Entity_Id := Available_View (Typ_2);
3014       B1 : constant Entity_Id := Base_Type (T1);
3015       B2 : constant Entity_Id := Base_Type (T2);
3016
3017       function Is_Remote_Access (T : Entity_Id) return Boolean;
3018       --  Check whether T is the equivalent type of a remote access type.
3019       --  If distribution is enabled, T is a legal context for Null.
3020
3021       ----------------------
3022       -- Is_Remote_Access --
3023       ----------------------
3024
3025       function Is_Remote_Access (T : Entity_Id) return Boolean is
3026       begin
3027          return Is_Record_Type (T)
3028            and then (Is_Remote_Call_Interface (T)
3029                       or else Is_Remote_Types (T))
3030            and then Present (Corresponding_Remote_Type (T))
3031            and then Is_Access_Type (Corresponding_Remote_Type (T));
3032       end Is_Remote_Access;
3033
3034    --  Start of processing for Specific_Type
3035
3036    begin
3037       if T1 = Any_Type or else T2 = Any_Type then
3038          return Any_Type;
3039       end if;
3040
3041       if B1 = B2 then
3042          return B1;
3043
3044       elsif     (T1 = Universal_Integer and then Is_Integer_Type (T2))
3045         or else (T1 = Universal_Real    and then Is_Real_Type (T2))
3046         or else (T1 = Universal_Fixed   and then Is_Fixed_Point_Type (T2))
3047         or else (T1 = Any_Fixed         and then Is_Fixed_Point_Type (T2))
3048       then
3049          return B2;
3050
3051       elsif     (T2 = Universal_Integer and then Is_Integer_Type (T1))
3052         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
3053         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
3054         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
3055       then
3056          return B1;
3057
3058       elsif T2 = Any_String and then Is_String_Type (T1) then
3059          return B1;
3060
3061       elsif T1 = Any_String and then Is_String_Type (T2) then
3062          return B2;
3063
3064       elsif T2 = Any_Character and then Is_Character_Type (T1) then
3065          return B1;
3066
3067       elsif T1 = Any_Character and then Is_Character_Type (T2) then
3068          return B2;
3069
3070       elsif T1 = Any_Access
3071         and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
3072       then
3073          return T2;
3074
3075       elsif T2 = Any_Access
3076         and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
3077       then
3078          return T1;
3079
3080       elsif T2 = Any_Composite
3081         and then Is_Aggregate_Type (T1)
3082       then
3083          return T1;
3084
3085       elsif T1 = Any_Composite
3086         and then Is_Aggregate_Type (T2)
3087       then
3088          return T2;
3089
3090       elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3091          return T2;
3092
3093       elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3094          return T1;
3095
3096       --  ----------------------------------------------------------
3097       --  Special cases for equality operators (all other predefined
3098       --  operators can never apply to tagged types)
3099       --  ----------------------------------------------------------
3100
3101       --  Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3102       --  interface
3103
3104       elsif Is_Class_Wide_Type (T1)
3105         and then Is_Class_Wide_Type (T2)
3106         and then Is_Interface (Etype (T2))
3107       then
3108          return T1;
3109
3110       --  Ada 2005 (AI-251): T1 is a concrete type that implements the
3111       --  class-wide interface T2
3112
3113       elsif Is_Class_Wide_Type (T2)
3114         and then Is_Interface (Etype (T2))
3115         and then Interface_Present_In_Ancestor (Typ => T1,
3116                                                 Iface => Etype (T2))
3117       then
3118          return T1;
3119
3120       elsif Is_Class_Wide_Type (T1)
3121         and then Is_Ancestor (Root_Type (T1), T2)
3122       then
3123          return T1;
3124
3125       elsif Is_Class_Wide_Type (T2)
3126         and then Is_Ancestor (Root_Type (T2), T1)
3127       then
3128          return T2;
3129
3130       elsif (Ekind (B1) = E_Access_Subprogram_Type
3131                or else
3132              Ekind (B1) = E_Access_Protected_Subprogram_Type)
3133         and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3134         and then Is_Access_Type (T2)
3135       then
3136          return T2;
3137
3138       elsif (Ekind (B2) = E_Access_Subprogram_Type
3139                or else
3140              Ekind (B2) = E_Access_Protected_Subprogram_Type)
3141         and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3142         and then Is_Access_Type (T1)
3143       then
3144          return T1;
3145
3146       elsif (Ekind (T1) = E_Allocator_Type
3147               or else Ekind (T1) = E_Access_Attribute_Type
3148               or else Ekind (T1) = E_Anonymous_Access_Type)
3149         and then Is_Access_Type (T2)
3150       then
3151          return T2;
3152
3153       elsif (Ekind (T2) = E_Allocator_Type
3154               or else Ekind (T2) = E_Access_Attribute_Type
3155               or else Ekind (T2) = E_Anonymous_Access_Type)
3156         and then Is_Access_Type (T1)
3157       then
3158          return T1;
3159
3160       --  If none of the above cases applies, types are not compatible
3161
3162       else
3163          return Any_Type;
3164       end if;
3165    end Specific_Type;
3166
3167    ---------------------
3168    -- Set_Abstract_Op --
3169    ---------------------
3170
3171    procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3172    begin
3173       All_Interp.Table (I).Abstract_Op := V;
3174    end Set_Abstract_Op;
3175
3176    -----------------------
3177    -- Valid_Boolean_Arg --
3178    -----------------------
3179
3180    --  In addition to booleans and arrays of booleans, we must include
3181    --  aggregates as valid boolean arguments, because in the first pass of
3182    --  resolution their components are not examined. If it turns out not to be
3183    --  an aggregate of booleans, this will be diagnosed in Resolve.
3184    --  Any_Composite must be checked for prior to the array type checks because
3185    --  Any_Composite does not have any associated indexes.
3186
3187    function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3188    begin
3189       return Is_Boolean_Type (T)
3190         or else T = Any_Composite
3191         or else (Is_Array_Type (T)
3192                   and then T /= Any_String
3193                   and then Number_Dimensions (T) = 1
3194                   and then Is_Boolean_Type (Component_Type (T))
3195                   and then (not Is_Private_Composite (T)
3196                              or else In_Instance)
3197                   and then (not Is_Limited_Composite (T)
3198                              or else In_Instance))
3199         or else Is_Modular_Integer_Type (T)
3200         or else T = Universal_Integer;
3201    end Valid_Boolean_Arg;
3202
3203    --------------------------
3204    -- Valid_Comparison_Arg --
3205    --------------------------
3206
3207    function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3208    begin
3209
3210       if T = Any_Composite then
3211          return False;
3212       elsif Is_Discrete_Type (T)
3213         or else Is_Real_Type (T)
3214       then
3215          return True;
3216       elsif Is_Array_Type (T)
3217           and then Number_Dimensions (T) = 1
3218           and then Is_Discrete_Type (Component_Type (T))
3219           and then (not Is_Private_Composite (T)
3220                      or else In_Instance)
3221           and then (not Is_Limited_Composite (T)
3222                      or else In_Instance)
3223       then
3224          return True;
3225       elsif Is_String_Type (T) then
3226          return True;
3227       else
3228          return False;
3229       end if;
3230    end Valid_Comparison_Arg;
3231
3232    ----------------------
3233    -- Write_Interp_Ref --
3234    ----------------------
3235
3236    procedure Write_Interp_Ref (Map_Ptr : Int) is
3237    begin
3238       Write_Str (" Node:  ");
3239       Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3240       Write_Str (" Index: ");
3241       Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3242       Write_Str (" Next:  ");
3243       Write_Int (Interp_Map.Table (Map_Ptr).Next);
3244       Write_Eol;
3245    end Write_Interp_Ref;
3246
3247    ---------------------
3248    -- Write_Overloads --
3249    ---------------------
3250
3251    procedure Write_Overloads (N : Node_Id) is
3252       I   : Interp_Index;
3253       It  : Interp;
3254       Nam : Entity_Id;
3255
3256    begin
3257       if not Is_Overloaded (N) then
3258          Write_Str ("Non-overloaded entity ");
3259          Write_Eol;
3260          Write_Entity_Info (Entity (N), " ");
3261
3262       else
3263          Get_First_Interp (N, I, It);
3264          Write_Str ("Overloaded entity ");
3265          Write_Eol;
3266          Write_Str ("      Name           Type           Abstract Op");
3267          Write_Eol;
3268          Write_Str ("===============================================");
3269          Write_Eol;
3270          Nam := It.Nam;
3271
3272          while Present (Nam) loop
3273             Write_Int (Int (Nam));
3274             Write_Str ("   ");
3275             Write_Name (Chars (Nam));
3276             Write_Str ("   ");
3277             Write_Int (Int (It.Typ));
3278             Write_Str ("   ");
3279             Write_Name (Chars (It.Typ));
3280
3281             if Present (It.Abstract_Op) then
3282                Write_Str ("   ");
3283                Write_Int (Int (It.Abstract_Op));
3284                Write_Str ("   ");
3285                Write_Name (Chars (It.Abstract_Op));
3286             end if;
3287
3288             Write_Eol;
3289             Get_Next_Interp (I, It);
3290             Nam := It.Nam;
3291          end loop;
3292       end if;
3293    end Write_Overloads;
3294
3295 end Sem_Type;