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