gcc/ada/sem_type.adb

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