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