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