gcc/ada/sem_type.adb

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