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) return Interp
1151    is
1152       I           : Interp_Index;
1153       It          : Interp;
1154       It1, It2    : Interp;
1155       Nam1, Nam2  : Entity_Id;
1156       Predef_Subp : Entity_Id;
1157       User_Subp   : Entity_Id;
1158
1159       function Inherited_From_Actual (S : Entity_Id) return Boolean;
1160       --  Determine whether one of the candidates is an operation inherited by
1161       --  a type that is derived from an actual in an instantiation.
1162
1163       function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
1164       --  Determine whether a subprogram is an actual in an enclosing instance.
1165       --  An overloading between such a subprogram and one declared outside the
1166       --  instance is resolved in favor of the first, because it resolved in
1167       --  the generic.
1168
1169       function Matches (Actual, Formal : Node_Id) return Boolean;
1170       --  Look for exact type match in an instance, to remove spurious
1171       --  ambiguities when two formal types have the same actual.
1172
1173       function Standard_Operator return Boolean;
1174       --  Check whether subprogram is predefined operator declared in Standard.
1175       --  It may given by an operator name, or by an expanded name whose prefix
1176       --  is Standard.
1177
1178       function Remove_Conversions return Interp;
1179       --  Last chance for pathological cases involving comparisons on literals,
1180       --  and user overloadings of the same operator. Such pathologies have
1181       --  been removed from the ACVC, but still appear in two DEC tests, with
1182       --  the following notable quote from Ben Brosgol:
1183       --
1184       --  [Note: I disclaim all credit/responsibility/blame for coming up with
1185       --  this example; Robert Dewar brought it to our attention, since it is
1186       --  apparently found in the ACVC 1.5. I did not attempt to find the
1187       --  reason in the Reference Manual that makes the example legal, since I
1188       --  was too nauseated by it to want to pursue it further.]
1189       --
1190       --  Accordingly, this is not a fully recursive solution, but it handles
1191       --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1192       --  pathology in the other direction with calls whose multiple overloaded
1193       --  actuals make them truly unresolvable.
1194
1195       --  The new rules concerning abstract operations create additional need
1196       --  for special handling of expressions with universal operands, see
1197       --  comments to Has_Abstract_Interpretation below.
1198
1199       ---------------------------
1200       -- Inherited_From_Actual --
1201       ---------------------------
1202
1203       function Inherited_From_Actual (S : Entity_Id) return Boolean is
1204          Par : constant Node_Id := Parent (S);
1205       begin
1206          if Nkind (Par) /= N_Full_Type_Declaration
1207            or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1208          then
1209             return False;
1210          else
1211             return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1212               and then
1213                Is_Generic_Actual_Type (
1214                  Entity (Subtype_Indication (Type_Definition (Par))));
1215          end if;
1216       end Inherited_From_Actual;
1217
1218       --------------------------
1219       -- Is_Actual_Subprogram --
1220       --------------------------
1221
1222       function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1223       begin
1224          return In_Open_Scopes (Scope (S))
1225            and then
1226              (Is_Generic_Instance (Scope (S))
1227                or else Is_Wrapper_Package (Scope (S)));
1228       end Is_Actual_Subprogram;
1229
1230       -------------
1231       -- Matches --
1232       -------------
1233
1234       function Matches (Actual, Formal : Node_Id) return Boolean is
1235          T1 : constant Entity_Id := Etype (Actual);
1236          T2 : constant Entity_Id := Etype (Formal);
1237       begin
1238          return T1 = T2
1239            or else
1240              (Is_Numeric_Type (T2)
1241                and then (T1 = Universal_Real or else T1 = Universal_Integer));
1242       end Matches;
1243
1244       ------------------------
1245       -- Remove_Conversions --
1246       ------------------------
1247
1248       function Remove_Conversions return Interp is
1249          I    : Interp_Index;
1250          It   : Interp;
1251          It1  : Interp;
1252          F1   : Entity_Id;
1253          Act1 : Node_Id;
1254          Act2 : Node_Id;
1255
1256          function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1257          --  If an operation has universal operands the universal operation
1258          --  is present among its interpretations. If there is an abstract
1259          --  interpretation for the operator, with a numeric result, this
1260          --  interpretation was already removed in sem_ch4, but the universal
1261          --  one is still visible. We must rescan the list of operators and
1262          --  remove the universal interpretation to resolve the ambiguity.
1263
1264          ---------------------------------
1265          -- Has_Abstract_Interpretation --
1266          ---------------------------------
1267
1268          function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1269             E : Entity_Id;
1270
1271          begin
1272             if Nkind (N) not in N_Op
1273               or else Ada_Version < Ada_05
1274               or else not Is_Overloaded (N)
1275               or else No (Universal_Interpretation (N))
1276             then
1277                return False;
1278
1279             else
1280                E := Get_Name_Entity_Id (Chars (N));
1281                while Present (E) loop
1282                   if Is_Overloadable (E)
1283                     and then Is_Abstract_Subprogram (E)
1284                     and then Is_Numeric_Type (Etype (E))
1285                   then
1286                      return True;
1287                   else
1288                      E := Homonym (E);
1289                   end if;
1290                end loop;
1291
1292                --  Finally, if an operand of the binary operator is itself
1293                --  an operator, recurse to see whether its own abstract
1294                --  interpretation is responsible for the spurious ambiguity.
1295
1296                if Nkind (N) in N_Binary_Op then
1297                   return Has_Abstract_Interpretation (Left_Opnd (N))
1298                     or else Has_Abstract_Interpretation (Right_Opnd (N));
1299
1300                elsif Nkind (N) in N_Unary_Op then
1301                   return Has_Abstract_Interpretation (Right_Opnd (N));
1302
1303                else
1304                   return False;
1305                end if;
1306             end if;
1307          end Has_Abstract_Interpretation;
1308
1309       --  Start of processing for Remove_Conversions
1310
1311       begin
1312          It1 := No_Interp;
1313
1314          Get_First_Interp (N, I, It);
1315          while Present (It.Typ) loop
1316             if not Is_Overloadable (It.Nam) then
1317                return No_Interp;
1318             end if;
1319
1320             F1 := First_Formal (It.Nam);
1321
1322             if No (F1) then
1323                return It1;
1324
1325             else
1326                if Nkind (N) = N_Function_Call
1327                  or else Nkind (N) = N_Procedure_Call_Statement
1328                then
1329                   Act1 := First_Actual (N);
1330
1331                   if Present (Act1) then
1332                      Act2 := Next_Actual (Act1);
1333                   else
1334                      Act2 := Empty;
1335                   end if;
1336
1337                elsif Nkind (N) in N_Unary_Op then
1338                   Act1 := Right_Opnd (N);
1339                   Act2 := Empty;
1340
1341                elsif Nkind (N) in N_Binary_Op then
1342                   Act1 := Left_Opnd (N);
1343                   Act2 := Right_Opnd (N);
1344
1345                   --  Use type of second formal, so as to include
1346                   --  exponentiation, where the exponent may be
1347                   --  ambiguous and the result non-universal.
1348
1349                   Next_Formal (F1);
1350
1351                else
1352                   return It1;
1353                end if;
1354
1355                if Nkind (Act1) in N_Op
1356                  and then Is_Overloaded (Act1)
1357                  and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1358                             or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1359                  and then Has_Compatible_Type (Act1, Standard_Boolean)
1360                  and then Etype (F1) = Standard_Boolean
1361                then
1362                   --  If the two candidates are the original ones, the
1363                   --  ambiguity is real. Otherwise keep the original, further
1364                   --  calls to Disambiguate will take care of others in the
1365                   --  list of candidates.
1366
1367                   if It1 /= No_Interp then
1368                      if It = Disambiguate.It1
1369                        or else It = Disambiguate.It2
1370                      then
1371                         if It1 = Disambiguate.It1
1372                           or else It1 = Disambiguate.It2
1373                         then
1374                            return No_Interp;
1375                         else
1376                            It1 := It;
1377                         end if;
1378                      end if;
1379
1380                   elsif Present (Act2)
1381                     and then Nkind (Act2) in N_Op
1382                     and then Is_Overloaded (Act2)
1383                     and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
1384                                                           N_Real_Literal)
1385                     and then Has_Compatible_Type (Act2, Standard_Boolean)
1386                   then
1387                      --  The preference rule on the first actual is not
1388                      --  sufficient to disambiguate.
1389
1390                      goto Next_Interp;
1391
1392                   else
1393                      It1 := It;
1394                   end if;
1395
1396                elsif Is_Numeric_Type (Etype (F1))
1397                  and then Has_Abstract_Interpretation (Act1)
1398                then
1399                   --  Current interpretation is not the right one because it
1400                   --  expects a numeric operand. Examine all the other ones.
1401
1402                   declare
1403                      I  : Interp_Index;
1404                      It : Interp;
1405
1406                   begin
1407                      Get_First_Interp (N, I, It);
1408                      while Present (It.Typ) loop
1409                         if
1410                           not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
1411                         then
1412                            if No (Act2)
1413                              or else not Has_Abstract_Interpretation (Act2)
1414                              or else not
1415                                Is_Numeric_Type
1416                                  (Etype (Next_Formal (First_Formal (It.Nam))))
1417                            then
1418                               return It;
1419                            end if;
1420                         end if;
1421
1422                         Get_Next_Interp (I, It);
1423                      end loop;
1424
1425                      return No_Interp;
1426                   end;
1427                end if;
1428             end if;
1429
1430             <<Next_Interp>>
1431                Get_Next_Interp (I, It);
1432          end loop;
1433
1434          --  After some error, a formal may have Any_Type and yield a spurious
1435          --  match. To avoid cascaded errors if possible, check for such a
1436          --  formal in either candidate.
1437
1438          if Serious_Errors_Detected > 0 then
1439             declare
1440                Formal : Entity_Id;
1441
1442             begin
1443                Formal := First_Formal (Nam1);
1444                while Present (Formal) loop
1445                   if Etype (Formal) = Any_Type then
1446                      return Disambiguate.It2;
1447                   end if;
1448
1449                   Next_Formal (Formal);
1450                end loop;
1451
1452                Formal := First_Formal (Nam2);
1453                while Present (Formal) loop
1454                   if Etype (Formal) = Any_Type then
1455                      return Disambiguate.It1;
1456                   end if;
1457
1458                   Next_Formal (Formal);
1459                end loop;
1460             end;
1461          end if;
1462
1463          return It1;
1464       end Remove_Conversions;
1465
1466       -----------------------
1467       -- Standard_Operator --
1468       -----------------------
1469
1470       function Standard_Operator return Boolean is
1471          Nam : Node_Id;
1472
1473       begin
1474          if Nkind (N) in N_Op then
1475             return True;
1476
1477          elsif Nkind (N) = N_Function_Call then
1478             Nam := Name (N);
1479
1480             if Nkind (Nam) /= N_Expanded_Name then
1481                return True;
1482             else
1483                return Entity (Prefix (Nam)) = Standard_Standard;
1484             end if;
1485          else
1486             return False;
1487          end if;
1488       end Standard_Operator;
1489
1490    --  Start of processing for Disambiguate
1491
1492    begin
1493       --  Recover the two legal interpretations
1494
1495       Get_First_Interp (N, I, It);
1496       while I /= I1 loop
1497          Get_Next_Interp (I, It);
1498       end loop;
1499
1500       It1  := It;
1501       Nam1 := It.Nam;
1502       while I /= I2 loop
1503          Get_Next_Interp (I, It);
1504       end loop;
1505
1506       It2  := It;
1507       Nam2 := It.Nam;
1508
1509       if Ada_Version < Ada_05 then
1510
1511          --  Check whether one of the entities is an Ada 2005 entity and we are
1512          --  operating in an earlier mode, in which case we discard the Ada
1513          --  2005 entity, so that we get proper Ada 95 overload resolution.
1514
1515          if Is_Ada_2005_Only (Nam1) then
1516             return It2;
1517          elsif Is_Ada_2005_Only (Nam2) then
1518             return It1;
1519          end if;
1520       end if;
1521
1522       --  Check for overloaded CIL convention stuff because the CIL libraries
1523       --  do sick things like Console.Write_Line where it matches two different
1524       --  overloads, so just pick the first ???
1525
1526       if Convention (Nam1) = Convention_CIL
1527         and then Convention (Nam2) = Convention_CIL
1528         and then Ekind (Nam1) = Ekind (Nam2)
1529         and then (Ekind (Nam1) = E_Procedure
1530                    or else Ekind (Nam1) = E_Function)
1531       then
1532          return It2;
1533       end if;
1534
1535       --  If the context is universal, the predefined operator is preferred.
1536       --  This includes bounds in numeric type declarations, and expressions
1537       --  in type conversions. If no interpretation yields a universal type,
1538       --  then we must check whether the user-defined entity hides the prede-
1539       --  fined one.
1540
1541       if Chars (Nam1) in Any_Operator_Name
1542         and then Standard_Operator
1543       then
1544          if        Typ = Universal_Integer
1545            or else Typ = Universal_Real
1546            or else Typ = Any_Integer
1547            or else Typ = Any_Discrete
1548            or else Typ = Any_Real
1549            or else Typ = Any_Type
1550          then
1551             --  Find an interpretation that yields the universal type, or else
1552             --  a predefined operator that yields a predefined numeric type.
1553
1554             declare
1555                Candidate : Interp := No_Interp;
1556
1557             begin
1558                Get_First_Interp (N, I, It);
1559                while Present (It.Typ) loop
1560                   if (Covers (Typ, It.Typ)
1561                         or else Typ = Any_Type)
1562                     and then
1563                      (It.Typ = Universal_Integer
1564                        or else It.Typ = Universal_Real)
1565                   then
1566                      return It;
1567
1568                   elsif Covers (Typ, It.Typ)
1569                     and then Scope (It.Typ) = Standard_Standard
1570                     and then Scope (It.Nam) = Standard_Standard
1571                     and then Is_Numeric_Type (It.Typ)
1572                   then
1573                      Candidate := It;
1574                   end if;
1575
1576                   Get_Next_Interp (I, It);
1577                end loop;
1578
1579                if Candidate /= No_Interp then
1580                   return Candidate;
1581                end if;
1582             end;
1583
1584          elsif Chars (Nam1) /= Name_Op_Not
1585            and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1586          then
1587             --  Equality or comparison operation. Choose predefined operator if
1588             --  arguments are universal. The node may be an operator, name, or
1589             --  a function call, so unpack arguments accordingly.
1590
1591             declare
1592                Arg1, Arg2 : Node_Id;
1593
1594             begin
1595                if Nkind (N) in N_Op then
1596                   Arg1 := Left_Opnd  (N);
1597                   Arg2 := Right_Opnd (N);
1598
1599                elsif Is_Entity_Name (N)
1600                  or else Nkind (N) = N_Operator_Symbol
1601                then
1602                   Arg1 := First_Entity (Entity (N));
1603                   Arg2 := Next_Entity (Arg1);
1604
1605                else
1606                   Arg1 := First_Actual (N);
1607                   Arg2 := Next_Actual (Arg1);
1608                end if;
1609
1610                if Present (Arg2)
1611                  and then Present (Universal_Interpretation (Arg1))
1612                  and then Universal_Interpretation (Arg2) =
1613                           Universal_Interpretation (Arg1)
1614                then
1615                   Get_First_Interp (N, I, It);
1616                   while Scope (It.Nam) /= Standard_Standard loop
1617                      Get_Next_Interp (I, It);
1618                   end loop;
1619
1620                   return It;
1621                end if;
1622             end;
1623          end if;
1624       end if;
1625
1626       --  If no universal interpretation, check whether user-defined operator
1627       --  hides predefined one, as well as other special cases. If the node
1628       --  is a range, then one or both bounds are ambiguous. Each will have
1629       --  to be disambiguated w.r.t. the context type. The type of the range
1630       --  itself is imposed by the context, so we can return either legal
1631       --  interpretation.
1632
1633       if Ekind (Nam1) = E_Operator then
1634          Predef_Subp := Nam1;
1635          User_Subp   := Nam2;
1636
1637       elsif Ekind (Nam2) = E_Operator then
1638          Predef_Subp := Nam2;
1639          User_Subp   := Nam1;
1640
1641       elsif Nkind (N) = N_Range then
1642          return It1;
1643
1644       --  Implement AI05-105: A renaming declaration with an access
1645       --  definition must resolve to an anonymous access type. This
1646       --  is a resolution rule and can be used to disambiguate.
1647
1648       elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
1649         and then Present (Access_Definition (Parent (N)))
1650       then
1651          if Ekind (It1.Typ) = E_Anonymous_Access_Type
1652               or else
1653             Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type
1654          then
1655             if Ekind (It2.Typ) = Ekind (It1.Typ) then
1656
1657                --  True ambiguity
1658
1659                return No_Interp;
1660
1661             else
1662                return It1;
1663             end if;
1664
1665          elsif Ekind (It2.Typ) = E_Anonymous_Access_Type
1666                  or else
1667                Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type
1668          then
1669             return It2;
1670
1671          --  No legal interpretation
1672
1673          else
1674             return No_Interp;
1675          end if;
1676
1677       --  If two user defined-subprograms are visible, it is a true ambiguity,
1678       --  unless one of them is an entry and the context is a conditional or
1679       --  timed entry call, or unless we are within an instance and this is
1680       --  results from two formals types with the same actual.
1681
1682       else
1683          if Nkind (N) = N_Procedure_Call_Statement
1684            and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1685            and then N = Entry_Call_Statement (Parent (N))
1686          then
1687             if Ekind (Nam2) = E_Entry then
1688                return It2;
1689             elsif Ekind (Nam1) = E_Entry then
1690                return It1;
1691             else
1692                return No_Interp;
1693             end if;
1694
1695          --  If the ambiguity occurs within an instance, it is due to several
1696          --  formal types with the same actual. Look for an exact match between
1697          --  the types of the formals of the overloadable entities, and the
1698          --  actuals in the call, to recover the unambiguous match in the
1699          --  original generic.
1700
1701          --  The ambiguity can also be due to an overloading between a formal
1702          --  subprogram and a subprogram declared outside the generic. If the
1703          --  node is overloaded, it did not resolve to the global entity in
1704          --  the generic, and we choose the formal subprogram.
1705
1706          --  Finally, the ambiguity can be between an explicit subprogram and
1707          --  one inherited (with different defaults) from an actual. In this
1708          --  case the resolution was to the explicit declaration in the
1709          --  generic, and remains so in the instance.
1710
1711          elsif In_Instance
1712            and then not In_Generic_Actual (N)
1713          then
1714             if Nkind (N) = N_Function_Call
1715               or else Nkind (N) = N_Procedure_Call_Statement
1716             then
1717                declare
1718                   Actual  : Node_Id;
1719                   Formal  : Entity_Id;
1720                   Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1721                   Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1722
1723                begin
1724                   if Is_Act1 and then not Is_Act2 then
1725                      return It1;
1726
1727                   elsif Is_Act2 and then not Is_Act1 then
1728                      return It2;
1729
1730                   elsif Inherited_From_Actual (Nam1)
1731                     and then Comes_From_Source (Nam2)
1732                   then
1733                      return It2;
1734
1735                   elsif Inherited_From_Actual (Nam2)
1736                     and then Comes_From_Source (Nam1)
1737                   then
1738                      return It1;
1739                   end if;
1740
1741                   Actual := First_Actual (N);
1742                   Formal := First_Formal (Nam1);
1743                   while Present (Actual) loop
1744                      if Etype (Actual) /= Etype (Formal) then
1745                         return It2;
1746                      end if;
1747
1748                      Next_Actual (Actual);
1749                      Next_Formal (Formal);
1750                   end loop;
1751
1752                   return It1;
1753                end;
1754
1755             elsif Nkind (N) in N_Binary_Op then
1756                if Matches (Left_Opnd (N), First_Formal (Nam1))
1757                  and then
1758                    Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1759                then
1760                   return It1;
1761                else
1762                   return It2;
1763                end if;
1764
1765             elsif Nkind (N) in  N_Unary_Op then
1766                if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1767                   return It1;
1768                else
1769                   return It2;
1770                end if;
1771
1772             else
1773                return Remove_Conversions;
1774             end if;
1775          else
1776             return Remove_Conversions;
1777          end if;
1778       end if;
1779
1780       --  An implicit concatenation operator on a string type cannot be
1781       --  disambiguated from the predefined concatenation. This can only
1782       --  happen with concatenation of string literals.
1783
1784       if Chars (User_Subp) = Name_Op_Concat
1785         and then Ekind (User_Subp) = E_Operator
1786         and then Is_String_Type (Etype (First_Formal (User_Subp)))
1787       then
1788          return No_Interp;
1789
1790       --  If the user-defined operator is in an open scope, or in the scope
1791       --  of the resulting type, or given by an expanded name that names its
1792       --  scope, it hides the predefined operator for the type. Exponentiation
1793       --  has to be special-cased because the implicit operator does not have
1794       --  a symmetric signature, and may not be hidden by the explicit one.
1795
1796       elsif (Nkind (N) = N_Function_Call
1797               and then Nkind (Name (N)) = N_Expanded_Name
1798               and then (Chars (Predef_Subp) /= Name_Op_Expon
1799                           or else Hides_Op (User_Subp, Predef_Subp))
1800               and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1801         or else Hides_Op (User_Subp, Predef_Subp)
1802       then
1803          if It1.Nam = User_Subp then
1804             return It1;
1805          else
1806             return It2;
1807          end if;
1808
1809       --  Otherwise, the predefined operator has precedence, or if the user-
1810       --  defined operation is directly visible we have a true ambiguity. If
1811       --  this is a fixed-point multiplication and division in Ada83 mode,
1812       --  exclude the universal_fixed operator, which often causes ambiguities
1813       --  in legacy code.
1814
1815       else
1816          if (In_Open_Scopes (Scope (User_Subp))
1817            or else Is_Potentially_Use_Visible (User_Subp))
1818            and then not In_Instance
1819          then
1820             if Is_Fixed_Point_Type (Typ)
1821               and then (Chars (Nam1) = Name_Op_Multiply
1822                           or else Chars (Nam1) = Name_Op_Divide)
1823               and then Ada_Version = Ada_83
1824             then
1825                if It2.Nam = Predef_Subp then
1826                   return It1;
1827                else
1828                   return It2;
1829                end if;
1830
1831             --  Ada 2005, AI-420: preference rule for "=" on Universal_Access
1832             --  states that the operator defined in Standard is not available
1833             --  if there is a user-defined equality with the proper signature,
1834             --  declared in the same declarative list as the type. The node
1835             --  may be an operator or a function call.
1836
1837             elsif (Chars (Nam1) = Name_Op_Eq
1838                      or else
1839                    Chars (Nam1) = Name_Op_Ne)
1840               and then Ada_Version >= Ada_05
1841               and then Etype (User_Subp) = Standard_Boolean
1842             then
1843                declare
1844                   Opnd : Node_Id;
1845                begin
1846                   if Nkind (N) = N_Function_Call then
1847                      Opnd := First_Actual (N);
1848                   else
1849                      Opnd := Left_Opnd (N);
1850                   end if;
1851
1852                   if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
1853                     and then
1854                      List_Containing (Parent (Designated_Type (Etype (Opnd))))
1855                        = List_Containing (Unit_Declaration_Node (User_Subp))
1856                   then
1857                      if It2.Nam = Predef_Subp then
1858                         return It1;
1859                      else
1860                         return It2;
1861                      end if;
1862                   else
1863                      return Remove_Conversions;
1864                   end if;
1865                end;
1866
1867             else
1868                return No_Interp;
1869             end if;
1870
1871          elsif It1.Nam = Predef_Subp then
1872             return It1;
1873
1874          else
1875             return It2;
1876          end if;
1877       end if;
1878    end Disambiguate;
1879
1880    ---------------------
1881    -- End_Interp_List --
1882    ---------------------
1883
1884    procedure End_Interp_List is
1885    begin
1886       All_Interp.Table (All_Interp.Last) := No_Interp;
1887       All_Interp.Increment_Last;
1888    end End_Interp_List;
1889
1890    -------------------------
1891    -- Entity_Matches_Spec --
1892    -------------------------
1893
1894    function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1895    begin
1896       --  Simple case: same entity kinds, type conformance is required. A
1897       --  parameterless function can also rename a literal.
1898
1899       if Ekind (Old_S) = Ekind (New_S)
1900         or else (Ekind (New_S) = E_Function
1901                   and then Ekind (Old_S) = E_Enumeration_Literal)
1902       then
1903          return Type_Conformant (New_S, Old_S);
1904
1905       elsif Ekind (New_S) = E_Function
1906         and then Ekind (Old_S) = E_Operator
1907       then
1908          return Operator_Matches_Spec (Old_S, New_S);
1909
1910       elsif Ekind (New_S) = E_Procedure
1911         and then Is_Entry (Old_S)
1912       then
1913          return Type_Conformant (New_S, Old_S);
1914
1915       else
1916          return False;
1917       end if;
1918    end Entity_Matches_Spec;
1919
1920    ----------------------
1921    -- Find_Unique_Type --
1922    ----------------------
1923
1924    function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1925       T  : constant Entity_Id := Etype (L);
1926       I  : Interp_Index;
1927       It : Interp;
1928       TR : Entity_Id := Any_Type;
1929
1930    begin
1931       if Is_Overloaded (R) then
1932          Get_First_Interp (R, I, It);
1933          while Present (It.Typ) loop
1934             if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1935
1936                --  If several interpretations are possible and L is universal,
1937                --  apply preference rule.
1938
1939                if TR /= Any_Type then
1940
1941                   if (T = Universal_Integer or else T = Universal_Real)
1942                     and then It.Typ = T
1943                   then
1944                      TR := It.Typ;
1945                   end if;
1946
1947                else
1948                   TR := It.Typ;
1949                end if;
1950             end if;
1951
1952             Get_Next_Interp (I, It);
1953          end loop;
1954
1955          Set_Etype (R, TR);
1956
1957       --  In the non-overloaded case, the Etype of R is already set correctly
1958
1959       else
1960          null;
1961       end if;
1962
1963       --  If one of the operands is Universal_Fixed, the type of the other
1964       --  operand provides the context.
1965
1966       if Etype (R) = Universal_Fixed then
1967          return T;
1968
1969       elsif T = Universal_Fixed then
1970          return Etype (R);
1971
1972       --  Ada 2005 (AI-230): Support the following operators:
1973
1974       --    function "="  (L, R : universal_access) return Boolean;
1975       --    function "/=" (L, R : universal_access) return Boolean;
1976
1977       --  Pool specific access types (E_Access_Type) are not covered by these
1978       --  operators because of the legality rule of 4.5.2(9.2): "The operands
1979       --  of the equality operators for universal_access shall be convertible
1980       --  to one another (see 4.6)". For example, considering the type decla-
1981       --  ration "type P is access Integer" and an anonymous access to Integer,
1982       --  P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
1983       --  is no rule in 4.6 that allows "access Integer" to be converted to P.
1984
1985       elsif Ada_Version >= Ada_05
1986         and then
1987           (Ekind (Etype (L)) = E_Anonymous_Access_Type
1988              or else
1989            Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
1990         and then Is_Access_Type (Etype (R))
1991         and then Ekind (Etype (R)) /= E_Access_Type
1992       then
1993          return Etype (L);
1994
1995       elsif Ada_Version >= Ada_05
1996         and then
1997           (Ekind (Etype (R)) = E_Anonymous_Access_Type
1998             or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
1999         and then Is_Access_Type (Etype (L))
2000         and then Ekind (Etype (L)) /= E_Access_Type
2001       then
2002          return Etype (R);
2003
2004       else
2005          return Specific_Type (T, Etype (R));
2006       end if;
2007    end Find_Unique_Type;
2008
2009    -------------------------------------
2010    -- Function_Interp_Has_Abstract_Op --
2011    -------------------------------------
2012
2013    function Function_Interp_Has_Abstract_Op
2014      (N : Node_Id;
2015       E : Entity_Id) return Entity_Id
2016    is
2017       Abstr_Op  : Entity_Id;
2018       Act       : Node_Id;
2019       Act_Parm  : Node_Id;
2020       Form_Parm : Node_Id;
2021
2022    begin
2023       --  Why is check on E needed below ???
2024       --  In any case this para needs comments ???
2025
2026       if Is_Overloaded (N) and then Is_Overloadable (E) then
2027          Act_Parm  := First_Actual (N);
2028          Form_Parm := First_Formal (E);
2029          while Present (Act_Parm)
2030            and then Present (Form_Parm)
2031          loop
2032             Act := Act_Parm;
2033
2034             if Nkind (Act) = N_Parameter_Association then
2035                Act := Explicit_Actual_Parameter (Act);
2036             end if;
2037
2038             Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
2039
2040             if Present (Abstr_Op) then
2041                return Abstr_Op;
2042             end if;
2043
2044             Next_Actual (Act_Parm);
2045             Next_Formal (Form_Parm);
2046          end loop;
2047       end if;
2048
2049       return Empty;
2050    end Function_Interp_Has_Abstract_Op;
2051
2052    ----------------------
2053    -- Get_First_Interp --
2054    ----------------------
2055
2056    procedure Get_First_Interp
2057      (N  : Node_Id;
2058       I  : out Interp_Index;
2059       It : out Interp)
2060    is
2061       Int_Ind : Interp_Index;
2062       Map_Ptr : Int;
2063       O_N     : Node_Id;
2064
2065    begin
2066       --  If a selected component is overloaded because the selector has
2067       --  multiple interpretations, the node is a call to a protected
2068       --  operation or an indirect call. Retrieve the interpretation from
2069       --  the selector name. The selected component may be overloaded as well
2070       --  if the prefix is overloaded. That case is unchanged.
2071
2072       if Nkind (N) = N_Selected_Component
2073         and then Is_Overloaded (Selector_Name (N))
2074       then
2075          O_N := Selector_Name (N);
2076       else
2077          O_N := N;
2078       end if;
2079
2080       Map_Ptr := Headers (Hash (O_N));
2081       while Map_Ptr /= No_Entry loop
2082          if Interp_Map.Table (Map_Ptr).Node = O_N then
2083             Int_Ind := Interp_Map.Table (Map_Ptr).Index;
2084             It := All_Interp.Table (Int_Ind);
2085             I := Int_Ind;
2086             return;
2087          else
2088             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2089          end if;
2090       end loop;
2091
2092       --  Procedure should never be called if the node has no interpretations
2093
2094       raise Program_Error;
2095    end Get_First_Interp;
2096
2097    ---------------------
2098    -- Get_Next_Interp --
2099    ---------------------
2100
2101    procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
2102    begin
2103       I  := I + 1;
2104       It := All_Interp.Table (I);
2105    end Get_Next_Interp;
2106
2107    -------------------------
2108    -- Has_Compatible_Type --
2109    -------------------------
2110
2111    function Has_Compatible_Type
2112      (N   : Node_Id;
2113       Typ : Entity_Id) return Boolean
2114    is
2115       I  : Interp_Index;
2116       It : Interp;
2117
2118    begin
2119       if N = Error then
2120          return False;
2121       end if;
2122
2123       if Nkind (N) = N_Subtype_Indication
2124         or else not Is_Overloaded (N)
2125       then
2126          return
2127            Covers (Typ, Etype (N))
2128
2129             --  Ada 2005 (AI-345): The context may be a synchronized interface.
2130             --  If the type is already frozen use the corresponding_record
2131             --  to check whether it is a proper descendant.
2132
2133            or else
2134              (Is_Record_Type (Typ)
2135                 and then Is_Concurrent_Type (Etype (N))
2136                 and then Present (Corresponding_Record_Type (Etype (N)))
2137                 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
2138
2139            or else
2140              (Is_Concurrent_Type (Typ)
2141                 and then Is_Record_Type (Etype (N))
2142                 and then Present (Corresponding_Record_Type (Typ))
2143                 and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
2144
2145            or else
2146              (not Is_Tagged_Type (Typ)
2147                 and then Ekind (Typ) /= E_Anonymous_Access_Type
2148                 and then Covers (Etype (N), Typ));
2149
2150       else
2151          Get_First_Interp (N, I, It);
2152          while Present (It.Typ) loop
2153             if (Covers (Typ, It.Typ)
2154                   and then
2155                     (Scope (It.Nam) /= Standard_Standard
2156                        or else not Is_Invisible_Operator (N, Base_Type (Typ))))
2157
2158                --  Ada 2005 (AI-345)
2159
2160               or else
2161                 (Is_Concurrent_Type (It.Typ)
2162                   and then Present (Corresponding_Record_Type
2163                                                              (Etype (It.Typ)))
2164                   and then Covers (Typ, Corresponding_Record_Type
2165                                                              (Etype (It.Typ))))
2166
2167               or else (not Is_Tagged_Type (Typ)
2168                          and then Ekind (Typ) /= E_Anonymous_Access_Type
2169                          and then Covers (It.Typ, Typ))
2170             then
2171                return True;
2172             end if;
2173
2174             Get_Next_Interp (I, It);
2175          end loop;
2176
2177          return False;
2178       end if;
2179    end Has_Compatible_Type;
2180
2181    ---------------------
2182    -- Has_Abstract_Op --
2183    ---------------------
2184
2185    function Has_Abstract_Op
2186      (N   : Node_Id;
2187       Typ : Entity_Id) return Entity_Id
2188    is
2189       I  : Interp_Index;
2190       It : Interp;
2191
2192    begin
2193       if Is_Overloaded (N) then
2194          Get_First_Interp (N, I, It);
2195          while Present (It.Nam) loop
2196             if Present (It.Abstract_Op)
2197               and then Etype (It.Abstract_Op) = Typ
2198             then
2199                return It.Abstract_Op;
2200             end if;
2201
2202             Get_Next_Interp (I, It);
2203          end loop;
2204       end if;
2205
2206       return Empty;
2207    end Has_Abstract_Op;
2208
2209    ----------
2210    -- Hash --
2211    ----------
2212
2213    function Hash (N : Node_Id) return Int is
2214    begin
2215       --  Nodes have a size that is power of two, so to select significant
2216       --  bits only we remove the low-order bits.
2217
2218       return ((Int (N) / 2 ** 5) mod Header_Size);
2219    end Hash;
2220
2221    --------------
2222    -- Hides_Op --
2223    --------------
2224
2225    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
2226       Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
2227    begin
2228       return Operator_Matches_Spec (Op, F)
2229         and then (In_Open_Scopes (Scope (F))
2230                     or else Scope (F) = Scope (Btyp)
2231                     or else (not In_Open_Scopes (Scope (Btyp))
2232                               and then not In_Use (Btyp)
2233                               and then not In_Use (Scope (Btyp))));
2234    end Hides_Op;
2235
2236    ------------------------
2237    -- Init_Interp_Tables --
2238    ------------------------
2239
2240    procedure Init_Interp_Tables is
2241    begin
2242       All_Interp.Init;
2243       Interp_Map.Init;
2244       Headers := (others => No_Entry);
2245    end Init_Interp_Tables;
2246
2247    -----------------------------------
2248    -- Interface_Present_In_Ancestor --
2249    -----------------------------------
2250
2251    function Interface_Present_In_Ancestor
2252      (Typ   : Entity_Id;
2253       Iface : Entity_Id) return Boolean
2254    is
2255       Target_Typ : Entity_Id;
2256       Iface_Typ  : Entity_Id;
2257
2258       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
2259       --  Returns True if Typ or some ancestor of Typ implements Iface
2260
2261       -------------------------------
2262       -- Iface_Present_In_Ancestor --
2263       -------------------------------
2264
2265       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
2266          E    : Entity_Id;
2267          AI   : Entity_Id;
2268          Elmt : Elmt_Id;
2269
2270       begin
2271          if Typ = Iface_Typ then
2272             return True;
2273          end if;
2274
2275          --  Handle private types
2276
2277          if Present (Full_View (Typ))
2278            and then not Is_Concurrent_Type (Full_View (Typ))
2279          then
2280             E := Full_View (Typ);
2281          else
2282             E := Typ;
2283          end if;
2284
2285          loop
2286             if Present (Interfaces (E))
2287               and then Present (Interfaces (E))
2288               and then not Is_Empty_Elmt_List (Interfaces (E))
2289             then
2290                Elmt := First_Elmt (Interfaces (E));
2291                while Present (Elmt) loop
2292                   AI := Node (Elmt);
2293
2294                   if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
2295                      return True;
2296                   end if;
2297
2298                   Next_Elmt (Elmt);
2299                end loop;
2300             end if;
2301
2302             exit when Etype (E) = E
2303
2304                --  Handle private types
2305
2306                or else (Present (Full_View (Etype (E)))
2307                          and then Full_View (Etype (E)) = E);
2308
2309             --  Check if the current type is a direct derivation of the
2310             --  interface
2311
2312             if Etype (E) = Iface_Typ then
2313                return True;
2314             end if;
2315
2316             --  Climb to the immediate ancestor handling private types
2317
2318             if Present (Full_View (Etype (E))) then
2319                E := Full_View (Etype (E));
2320             else
2321                E := Etype (E);
2322             end if;
2323          end loop;
2324
2325          return False;
2326       end Iface_Present_In_Ancestor;
2327
2328    --  Start of processing for Interface_Present_In_Ancestor
2329
2330    begin
2331       --  Iface might be a class-wide subtype, so we have to apply Base_Type
2332
2333       if Is_Class_Wide_Type (Iface) then
2334          Iface_Typ := Etype (Base_Type (Iface));
2335       else
2336          Iface_Typ := Iface;
2337       end if;
2338
2339       --  Handle subtypes
2340
2341       Iface_Typ := Base_Type (Iface_Typ);
2342
2343       if Is_Access_Type (Typ) then
2344          Target_Typ := Etype (Directly_Designated_Type (Typ));
2345       else
2346          Target_Typ := Typ;
2347       end if;
2348
2349       if Is_Concurrent_Record_Type (Target_Typ) then
2350          Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
2351       end if;
2352
2353       Target_Typ := Base_Type (Target_Typ);
2354
2355       --  In case of concurrent types we can't use the Corresponding Record_Typ
2356       --  to look for the interface because it is built by the expander (and
2357       --  hence it is not always available). For this reason we traverse the
2358       --  list of interfaces (available in the parent of the concurrent type)
2359
2360       if Is_Concurrent_Type (Target_Typ) then
2361          if Present (Interface_List (Parent (Target_Typ))) then
2362             declare
2363                AI : Node_Id;
2364
2365             begin
2366                AI := First (Interface_List (Parent (Target_Typ)));
2367                while Present (AI) loop
2368                   if Etype (AI) = Iface_Typ then
2369                      return True;
2370
2371                   elsif Present (Interfaces (Etype (AI)))
2372                      and then Iface_Present_In_Ancestor (Etype (AI))
2373                   then
2374                      return True;
2375                   end if;
2376
2377                   Next (AI);
2378                end loop;
2379             end;
2380          end if;
2381
2382          return False;
2383       end if;
2384
2385       if Is_Class_Wide_Type (Target_Typ) then
2386          Target_Typ := Etype (Target_Typ);
2387       end if;
2388
2389       if Ekind (Target_Typ) = E_Incomplete_Type then
2390          pragma Assert (Present (Non_Limited_View (Target_Typ)));
2391          Target_Typ := Non_Limited_View (Target_Typ);
2392
2393          --  Protect the frontend against previously detected errors
2394
2395          if Ekind (Target_Typ) = E_Incomplete_Type then
2396             return False;
2397          end if;
2398       end if;
2399
2400       return Iface_Present_In_Ancestor (Target_Typ);
2401    end Interface_Present_In_Ancestor;
2402
2403    ---------------------
2404    -- Intersect_Types --
2405    ---------------------
2406
2407    function Intersect_Types (L, R : Node_Id) return Entity_Id is
2408       Index : Interp_Index;
2409       It    : Interp;
2410       Typ   : Entity_Id;
2411
2412       function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2413       --  Find interpretation of right arg that has type compatible with T
2414
2415       --------------------------
2416       -- Check_Right_Argument --
2417       --------------------------
2418
2419       function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2420          Index : Interp_Index;
2421          It    : Interp;
2422          T2    : Entity_Id;
2423
2424       begin
2425          if not Is_Overloaded (R) then
2426             return Specific_Type (T, Etype (R));
2427
2428          else
2429             Get_First_Interp (R, Index, It);
2430             loop
2431                T2 := Specific_Type (T, It.Typ);
2432
2433                if T2 /= Any_Type then
2434                   return T2;
2435                end if;
2436
2437                Get_Next_Interp (Index, It);
2438                exit when No (It.Typ);
2439             end loop;
2440
2441             return Any_Type;
2442          end if;
2443       end Check_Right_Argument;
2444
2445    --  Start of processing for Intersect_Types
2446
2447    begin
2448       if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2449          return Any_Type;
2450       end if;
2451
2452       if not Is_Overloaded (L) then
2453          Typ := Check_Right_Argument (Etype (L));
2454
2455       else
2456          Typ := Any_Type;
2457          Get_First_Interp (L, Index, It);
2458          while Present (It.Typ) loop
2459             Typ := Check_Right_Argument (It.Typ);
2460             exit when Typ /= Any_Type;
2461             Get_Next_Interp (Index, It);
2462          end loop;
2463
2464       end if;
2465
2466       --  If Typ is Any_Type, it means no compatible pair of types was found
2467
2468       if Typ = Any_Type then
2469          if Nkind (Parent (L)) in N_Op then
2470             Error_Msg_N ("incompatible types for operator", Parent (L));
2471
2472          elsif Nkind (Parent (L)) = N_Range then
2473             Error_Msg_N ("incompatible types given in constraint", Parent (L));
2474
2475          --  Ada 2005 (AI-251): Complete the error notification
2476
2477          elsif Is_Class_Wide_Type (Etype (R))
2478              and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2479          then
2480             Error_Msg_NE ("(Ada 2005) does not implement interface }",
2481                           L, Etype (Class_Wide_Type (Etype (R))));
2482
2483          else
2484             Error_Msg_N ("incompatible types", Parent (L));
2485          end if;
2486       end if;
2487
2488       return Typ;
2489    end Intersect_Types;
2490
2491    -----------------------
2492    -- In_Generic_Actual --
2493    -----------------------
2494
2495    function In_Generic_Actual (Exp : Node_Id) return Boolean is
2496       Par : constant Node_Id := Parent (Exp);
2497
2498    begin
2499       if No (Par) then
2500          return False;
2501
2502       elsif Nkind (Par) in N_Declaration then
2503          if Nkind (Par) = N_Object_Declaration then
2504             return Present (Corresponding_Generic_Association (Par));
2505          else
2506             return False;
2507          end if;
2508
2509       elsif Nkind (Par) = N_Object_Renaming_Declaration then
2510          return Present (Corresponding_Generic_Association (Par));
2511
2512       elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
2513          return False;
2514
2515       else
2516          return In_Generic_Actual (Parent (Par));
2517       end if;
2518    end In_Generic_Actual;
2519
2520    -----------------
2521    -- Is_Ancestor --
2522    -----------------
2523
2524    function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
2525       BT1 : Entity_Id;
2526       BT2 : Entity_Id;
2527       Par : Entity_Id;
2528
2529    begin
2530       BT1 := Base_Type (T1);
2531       BT2 := Base_Type (T2);
2532
2533       --  Handle underlying view of records with unknown discriminants
2534       --  using the original entity that motivated the construction of
2535       --  this underlying record view (see Build_Derived_Private_Type).
2536
2537       if Is_Underlying_Record_View (BT1) then
2538          BT1 := Underlying_Record_View (BT1);
2539       end if;
2540
2541       if Is_Underlying_Record_View (BT2) then
2542          BT2 := Underlying_Record_View (BT2);
2543       end if;
2544
2545       if BT1 = BT2 then
2546          return True;
2547
2548       elsif Is_Private_Type (T1)
2549         and then Present (Full_View (T1))
2550         and then BT2 = Base_Type (Full_View (T1))
2551       then
2552          return True;
2553
2554       else
2555          Par := Etype (BT2);
2556
2557          loop
2558             --  If there was a error on the type declaration, do not recurse
2559
2560             if Error_Posted (Par) then
2561                return False;
2562
2563             elsif BT1 = Base_Type (Par)
2564               or else (Is_Private_Type (T1)
2565                          and then Present (Full_View (T1))
2566                          and then Base_Type (Par) = Base_Type (Full_View (T1)))
2567             then
2568                return True;
2569
2570             elsif Is_Private_Type (Par)
2571               and then Present (Full_View (Par))
2572               and then Full_View (Par) = BT1
2573             then
2574                return True;
2575
2576             elsif Etype (Par) /= Par then
2577                Par := Etype (Par);
2578             else
2579                return False;
2580             end if;
2581          end loop;
2582       end if;
2583    end Is_Ancestor;
2584
2585    ---------------------------
2586    -- Is_Invisible_Operator --
2587    ---------------------------
2588
2589    function Is_Invisible_Operator
2590      (N : Node_Id;
2591       T : Entity_Id) return Boolean
2592    is
2593       Orig_Node : constant Node_Id := Original_Node (N);
2594
2595    begin
2596       if Nkind (N) not in N_Op then
2597          return False;
2598
2599       elsif not Comes_From_Source (N) then
2600          return False;
2601
2602       elsif No (Universal_Interpretation (Right_Opnd (N))) then
2603          return False;
2604
2605       elsif Nkind (N) in N_Binary_Op
2606         and then No (Universal_Interpretation (Left_Opnd (N)))
2607       then
2608          return False;
2609
2610       else
2611          return Is_Numeric_Type (T)
2612            and then not In_Open_Scopes (Scope (T))
2613            and then not Is_Potentially_Use_Visible (T)
2614            and then not In_Use (T)
2615            and then not In_Use (Scope (T))
2616            and then
2617             (Nkind (Orig_Node) /= N_Function_Call
2618               or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2619               or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2620            and then not In_Instance;
2621       end if;
2622    end Is_Invisible_Operator;
2623
2624    -------------------
2625    -- Is_Subtype_Of --
2626    -------------------
2627
2628    function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2629       S : Entity_Id;
2630
2631    begin
2632       S := Ancestor_Subtype (T1);
2633       while Present (S) loop
2634          if S = T2 then
2635             return True;
2636          else
2637             S := Ancestor_Subtype (S);
2638          end if;
2639       end loop;
2640
2641       return False;
2642    end Is_Subtype_Of;
2643
2644    ------------------
2645    -- List_Interps --
2646    ------------------
2647
2648    procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
2649       Index : Interp_Index;
2650       It    : Interp;
2651
2652    begin
2653       Get_First_Interp (Nam, Index, It);
2654       while Present (It.Nam) loop
2655          if Scope (It.Nam) = Standard_Standard
2656            and then Scope (It.Typ) /= Standard_Standard
2657          then
2658             Error_Msg_Sloc := Sloc (Parent (It.Typ));
2659             Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
2660
2661          else
2662             Error_Msg_Sloc := Sloc (It.Nam);
2663             Error_Msg_NE ("\\& declared#!", Err, It.Nam);
2664          end if;
2665
2666          Get_Next_Interp (Index, It);
2667       end loop;
2668    end List_Interps;
2669
2670    -----------------
2671    -- New_Interps --
2672    -----------------
2673
2674    procedure New_Interps (N : Node_Id)  is
2675       Map_Ptr : Int;
2676
2677    begin
2678       All_Interp.Append (No_Interp);
2679
2680       Map_Ptr := Headers (Hash (N));
2681
2682       if Map_Ptr = No_Entry then
2683
2684          --  Place new node at end of table
2685
2686          Interp_Map.Increment_Last;
2687          Headers (Hash (N)) := Interp_Map.Last;
2688
2689       else
2690          --   Place node at end of chain, or locate its previous entry
2691
2692          loop
2693             if Interp_Map.Table (Map_Ptr).Node = N then
2694
2695                --  Node is already in the table, and is being rewritten.
2696                --  Start a new interp section, retain hash link.
2697
2698                Interp_Map.Table (Map_Ptr).Node  := N;
2699                Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
2700                Set_Is_Overloaded (N, True);
2701                return;
2702
2703             else
2704                exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
2705                Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2706             end if;
2707          end loop;
2708
2709          --  Chain the new node
2710
2711          Interp_Map.Increment_Last;
2712          Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
2713       end if;
2714
2715       Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
2716       Set_Is_Overloaded (N, True);
2717    end New_Interps;
2718
2719    ---------------------------
2720    -- Operator_Matches_Spec --
2721    ---------------------------
2722
2723    function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
2724       Op_Name : constant Name_Id   := Chars (Op);
2725       T       : constant Entity_Id := Etype (New_S);
2726       New_F   : Entity_Id;
2727       Old_F   : Entity_Id;
2728       Num     : Int;
2729       T1      : Entity_Id;
2730       T2      : Entity_Id;
2731
2732    begin
2733       --  To verify that a predefined operator matches a given signature,
2734       --  do a case analysis of the operator classes. Function can have one
2735       --  or two formals and must have the proper result type.
2736
2737       New_F := First_Formal (New_S);
2738       Old_F := First_Formal (Op);
2739       Num := 0;
2740       while Present (New_F) and then Present (Old_F) loop
2741          Num := Num + 1;
2742          Next_Formal (New_F);
2743          Next_Formal (Old_F);
2744       end loop;
2745
2746       --  Definite mismatch if different number of parameters
2747
2748       if Present (Old_F) or else Present (New_F) then
2749          return False;
2750
2751       --  Unary operators
2752
2753       elsif Num = 1 then
2754          T1 := Etype (First_Formal (New_S));
2755
2756          if Op_Name = Name_Op_Subtract
2757            or else Op_Name = Name_Op_Add
2758            or else Op_Name = Name_Op_Abs
2759          then
2760             return Base_Type (T1) = Base_Type (T)
2761               and then Is_Numeric_Type (T);
2762
2763          elsif Op_Name = Name_Op_Not then
2764             return Base_Type (T1) = Base_Type (T)
2765               and then Valid_Boolean_Arg (Base_Type (T));
2766
2767          else
2768             return False;
2769          end if;
2770
2771       --  Binary operators
2772
2773       else
2774          T1 := Etype (First_Formal (New_S));
2775          T2 := Etype (Next_Formal (First_Formal (New_S)));
2776
2777          if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
2778            or else Op_Name = Name_Op_Xor
2779          then
2780             return Base_Type (T1) = Base_Type (T2)
2781               and then Base_Type (T1) = Base_Type (T)
2782               and then Valid_Boolean_Arg (Base_Type (T));
2783
2784          elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
2785             return Base_Type (T1) = Base_Type (T2)
2786               and then not Is_Limited_Type (T1)
2787               and then Is_Boolean_Type (T);
2788
2789          elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
2790            or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
2791          then
2792             return Base_Type (T1) = Base_Type (T2)
2793               and then Valid_Comparison_Arg (T1)
2794               and then Is_Boolean_Type (T);
2795
2796          elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
2797             return Base_Type (T1) = Base_Type (T2)
2798               and then Base_Type (T1) = Base_Type (T)
2799               and then Is_Numeric_Type (T);
2800
2801          --  For division and multiplication, a user-defined function does not
2802          --  match the predefined universal_fixed operation, except in Ada 83.
2803
2804          elsif Op_Name = Name_Op_Divide then
2805             return (Base_Type (T1) = Base_Type (T2)
2806               and then Base_Type (T1) = Base_Type (T)
2807               and then Is_Numeric_Type (T)
2808               and then (not Is_Fixed_Point_Type (T)
2809                          or else Ada_Version = Ada_83))
2810
2811             --  Mixed_Mode operations on fixed-point types
2812
2813               or else (Base_Type (T1) = Base_Type (T)
2814                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2815                         and then Is_Fixed_Point_Type (T))
2816
2817             --  A user defined operator can also match (and hide) a mixed
2818             --  operation on universal literals.
2819
2820               or else (Is_Integer_Type (T2)
2821                         and then Is_Floating_Point_Type (T1)
2822                         and then Base_Type (T1) = Base_Type (T));
2823
2824          elsif Op_Name = Name_Op_Multiply then
2825             return (Base_Type (T1) = Base_Type (T2)
2826               and then Base_Type (T1) = Base_Type (T)
2827               and then Is_Numeric_Type (T)
2828               and then (not Is_Fixed_Point_Type (T)
2829                          or else Ada_Version = Ada_83))
2830
2831             --  Mixed_Mode operations on fixed-point types
2832
2833               or else (Base_Type (T1) = Base_Type (T)
2834                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2835                         and then Is_Fixed_Point_Type (T))
2836
2837               or else (Base_Type (T2) = Base_Type (T)
2838                         and then Base_Type (T1) = Base_Type (Standard_Integer)
2839                         and then Is_Fixed_Point_Type (T))
2840
2841               or else (Is_Integer_Type (T2)
2842                         and then Is_Floating_Point_Type (T1)
2843                         and then Base_Type (T1) = Base_Type (T))
2844
2845               or else (Is_Integer_Type (T1)
2846                         and then Is_Floating_Point_Type (T2)
2847                         and then Base_Type (T2) = Base_Type (T));
2848
2849          elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
2850             return Base_Type (T1) = Base_Type (T2)
2851               and then Base_Type (T1) = Base_Type (T)
2852               and then Is_Integer_Type (T);
2853
2854          elsif Op_Name = Name_Op_Expon then
2855             return Base_Type (T1) = Base_Type (T)
2856               and then Is_Numeric_Type (T)
2857               and then Base_Type (T2) = Base_Type (Standard_Integer);
2858
2859          elsif Op_Name = Name_Op_Concat then
2860             return Is_Array_Type (T)
2861               and then (Base_Type (T) = Base_Type (Etype (Op)))
2862               and then (Base_Type (T1) = Base_Type (T)
2863                          or else
2864                         Base_Type (T1) = Base_Type (Component_Type (T)))
2865               and then (Base_Type (T2) = Base_Type (T)
2866                          or else
2867                         Base_Type (T2) = Base_Type (Component_Type (T)));
2868
2869          else
2870             return False;
2871          end if;
2872       end if;
2873    end Operator_Matches_Spec;
2874
2875    -------------------
2876    -- Remove_Interp --
2877    -------------------
2878
2879    procedure Remove_Interp (I : in out Interp_Index) is
2880       II : Interp_Index;
2881
2882    begin
2883       --  Find end of interp list and copy downward to erase the discarded one
2884
2885       II := I + 1;
2886       while Present (All_Interp.Table (II).Typ) loop
2887          II := II + 1;
2888       end loop;
2889
2890       for J in I + 1 .. II loop
2891          All_Interp.Table (J - 1) := All_Interp.Table (J);
2892       end loop;
2893
2894       --  Back up interp index to insure that iterator will pick up next
2895       --  available interpretation.
2896
2897       I := I - 1;
2898    end Remove_Interp;
2899
2900    ------------------
2901    -- Save_Interps --
2902    ------------------
2903
2904    procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
2905       Map_Ptr : Int;
2906       O_N     : Node_Id := Old_N;
2907
2908    begin
2909       if Is_Overloaded (Old_N) then
2910          if Nkind (Old_N) = N_Selected_Component
2911            and then Is_Overloaded (Selector_Name (Old_N))
2912          then
2913             O_N := Selector_Name (Old_N);
2914          end if;
2915
2916          Map_Ptr := Headers (Hash (O_N));
2917
2918          while Interp_Map.Table (Map_Ptr).Node /= O_N loop
2919             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2920             pragma Assert (Map_Ptr /= No_Entry);
2921          end loop;
2922
2923          New_Interps (New_N);
2924          Interp_Map.Table (Interp_Map.Last).Index :=
2925            Interp_Map.Table (Map_Ptr).Index;
2926       end if;
2927    end Save_Interps;
2928
2929    -------------------
2930    -- Specific_Type --
2931    -------------------
2932
2933    function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
2934       T1 : constant Entity_Id := Available_View (Typ_1);
2935       T2 : constant Entity_Id := Available_View (Typ_2);
2936       B1 : constant Entity_Id := Base_Type (T1);
2937       B2 : constant Entity_Id := Base_Type (T2);
2938
2939       function Is_Remote_Access (T : Entity_Id) return Boolean;
2940       --  Check whether T is the equivalent type of a remote access type.
2941       --  If distribution is enabled, T is a legal context for Null.
2942
2943       ----------------------
2944       -- Is_Remote_Access --
2945       ----------------------
2946
2947       function Is_Remote_Access (T : Entity_Id) return Boolean is
2948       begin
2949          return Is_Record_Type (T)
2950            and then (Is_Remote_Call_Interface (T)
2951                       or else Is_Remote_Types (T))
2952            and then Present (Corresponding_Remote_Type (T))
2953            and then Is_Access_Type (Corresponding_Remote_Type (T));
2954       end Is_Remote_Access;
2955
2956    --  Start of processing for Specific_Type
2957
2958    begin
2959       if T1 = Any_Type or else T2 = Any_Type then
2960          return Any_Type;
2961       end if;
2962
2963       if B1 = B2 then
2964          return B1;
2965
2966       elsif     (T1 = Universal_Integer and then Is_Integer_Type (T2))
2967         or else (T1 = Universal_Real    and then Is_Real_Type (T2))
2968         or else (T1 = Universal_Fixed   and then Is_Fixed_Point_Type (T2))
2969         or else (T1 = Any_Fixed         and then Is_Fixed_Point_Type (T2))
2970       then
2971          return B2;
2972
2973       elsif     (T2 = Universal_Integer and then Is_Integer_Type (T1))
2974         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
2975         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
2976         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
2977       then
2978          return B1;
2979
2980       elsif T2 = Any_String and then Is_String_Type (T1) then
2981          return B1;
2982
2983       elsif T1 = Any_String and then Is_String_Type (T2) then
2984          return B2;
2985
2986       elsif T2 = Any_Character and then Is_Character_Type (T1) then
2987          return B1;
2988
2989       elsif T1 = Any_Character and then Is_Character_Type (T2) then
2990          return B2;
2991
2992       elsif T1 = Any_Access
2993         and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
2994       then
2995          return T2;
2996
2997       elsif T2 = Any_Access
2998         and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
2999       then
3000          return T1;
3001
3002       elsif T2 = Any_Composite
3003         and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
3004       then
3005          return T1;
3006
3007       elsif T1 = Any_Composite
3008         and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
3009       then
3010          return T2;
3011
3012       elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
3013          return T2;
3014
3015       elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
3016          return T1;
3017
3018       --  ----------------------------------------------------------
3019       --  Special cases for equality operators (all other predefined
3020       --  operators can never apply to tagged types)
3021       --  ----------------------------------------------------------
3022
3023       --  Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
3024       --  interface
3025
3026       elsif Is_Class_Wide_Type (T1)
3027         and then Is_Class_Wide_Type (T2)
3028         and then Is_Interface (Etype (T2))
3029       then
3030          return T1;
3031
3032       --  Ada 2005 (AI-251): T1 is a concrete type that implements the
3033       --  class-wide interface T2
3034
3035       elsif Is_Class_Wide_Type (T2)
3036         and then Is_Interface (Etype (T2))
3037         and then Interface_Present_In_Ancestor (Typ => T1,
3038                                                 Iface => Etype (T2))
3039       then
3040          return T1;
3041
3042       elsif Is_Class_Wide_Type (T1)
3043         and then Is_Ancestor (Root_Type (T1), T2)
3044       then
3045          return T1;
3046
3047       elsif Is_Class_Wide_Type (T2)
3048         and then Is_Ancestor (Root_Type (T2), T1)
3049       then
3050          return T2;
3051
3052       elsif (Ekind (B1) = E_Access_Subprogram_Type
3053                or else
3054              Ekind (B1) = E_Access_Protected_Subprogram_Type)
3055         and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
3056         and then Is_Access_Type (T2)
3057       then
3058          return T2;
3059
3060       elsif (Ekind (B2) = E_Access_Subprogram_Type
3061                or else
3062              Ekind (B2) = E_Access_Protected_Subprogram_Type)
3063         and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
3064         and then Is_Access_Type (T1)
3065       then
3066          return T1;
3067
3068       elsif (Ekind (T1) = E_Allocator_Type
3069               or else Ekind (T1) = E_Access_Attribute_Type
3070               or else Ekind (T1) = E_Anonymous_Access_Type)
3071         and then Is_Access_Type (T2)
3072       then
3073          return T2;
3074
3075       elsif (Ekind (T2) = E_Allocator_Type
3076               or else Ekind (T2) = E_Access_Attribute_Type
3077               or else Ekind (T2) = E_Anonymous_Access_Type)
3078         and then Is_Access_Type (T1)
3079       then
3080          return T1;
3081
3082       --  If none of the above cases applies, types are not compatible
3083
3084       else
3085          return Any_Type;
3086       end if;
3087    end Specific_Type;
3088
3089    ---------------------
3090    -- Set_Abstract_Op --
3091    ---------------------
3092
3093    procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
3094    begin
3095       All_Interp.Table (I).Abstract_Op := V;
3096    end Set_Abstract_Op;
3097
3098    -----------------------
3099    -- Valid_Boolean_Arg --
3100    -----------------------
3101
3102    --  In addition to booleans and arrays of booleans, we must include
3103    --  aggregates as valid boolean arguments, because in the first pass of
3104    --  resolution their components are not examined. If it turns out not to be
3105    --  an aggregate of booleans, this will be diagnosed in Resolve.
3106    --  Any_Composite must be checked for prior to the array type checks because
3107    --  Any_Composite does not have any associated indexes.
3108
3109    function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
3110    begin
3111       return Is_Boolean_Type (T)
3112         or else T = Any_Composite
3113         or else (Is_Array_Type (T)
3114                   and then T /= Any_String
3115                   and then Number_Dimensions (T) = 1
3116                   and then Is_Boolean_Type (Component_Type (T))
3117                   and then (not Is_Private_Composite (T)
3118                              or else In_Instance)
3119                   and then (not Is_Limited_Composite (T)
3120                              or else In_Instance))
3121         or else Is_Modular_Integer_Type (T)
3122         or else T = Universal_Integer;
3123    end Valid_Boolean_Arg;
3124
3125    --------------------------
3126    -- Valid_Comparison_Arg --
3127    --------------------------
3128
3129    function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
3130    begin
3131
3132       if T = Any_Composite then
3133          return False;
3134       elsif Is_Discrete_Type (T)
3135         or else Is_Real_Type (T)
3136       then
3137          return True;
3138       elsif Is_Array_Type (T)
3139           and then Number_Dimensions (T) = 1
3140           and then Is_Discrete_Type (Component_Type (T))
3141           and then (not Is_Private_Composite (T)
3142                      or else In_Instance)
3143           and then (not Is_Limited_Composite (T)
3144                      or else In_Instance)
3145       then
3146          return True;
3147       elsif Is_String_Type (T) then
3148          return True;
3149       else
3150          return False;
3151       end if;
3152    end Valid_Comparison_Arg;
3153
3154    ----------------------
3155    -- Write_Interp_Ref --
3156    ----------------------
3157
3158    procedure Write_Interp_Ref (Map_Ptr : Int) is
3159    begin
3160       Write_Str (" Node:  ");
3161       Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
3162       Write_Str (" Index: ");
3163       Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
3164       Write_Str (" Next:  ");
3165       Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
3166       Write_Eol;
3167    end Write_Interp_Ref;
3168
3169    ---------------------
3170    -- Write_Overloads --
3171    ---------------------
3172
3173    procedure Write_Overloads (N : Node_Id) is
3174       I   : Interp_Index;
3175       It  : Interp;
3176       Nam : Entity_Id;
3177
3178    begin
3179       if not Is_Overloaded (N) then
3180          Write_Str ("Non-overloaded entity ");
3181          Write_Eol;
3182          Write_Entity_Info (Entity (N), " ");
3183
3184       else
3185          Get_First_Interp (N, I, It);
3186          Write_Str ("Overloaded entity ");
3187          Write_Eol;
3188          Write_Str ("      Name           Type           Abstract Op");
3189          Write_Eol;
3190          Write_Str ("===============================================");
3191          Write_Eol;
3192          Nam := It.Nam;
3193
3194          while Present (Nam) loop
3195             Write_Int (Int (Nam));
3196             Write_Str ("   ");
3197             Write_Name (Chars (Nam));
3198             Write_Str ("   ");
3199             Write_Int (Int (It.Typ));
3200             Write_Str ("   ");
3201             Write_Name (Chars (It.Typ));
3202
3203             if Present (It.Abstract_Op) then
3204                Write_Str ("   ");
3205                Write_Int (Int (It.Abstract_Op));
3206                Write_Str ("   ");
3207                Write_Name (Chars (It.Abstract_Op));
3208             end if;
3209
3210             Write_Eol;
3211             Get_Next_Interp (I, It);
3212             Nam := It.Nam;
3213          end loop;
3214       end if;
3215    end Write_Overloads;
3216
3217 end Sem_Type;