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