gcc/ada/sem_type.adb

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