gcc/ada/sem_type.adb

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