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