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