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                    or else (T2 = Any_Composite
 918                               and then
 919                                 Is_Composite_Type (Underlying_Type (T1))))
 920       then
 921          return True;
 922
 923       --  Ada 2005 (AI-50217): Additional branches to make the shadow entity
 924       --  compatible with its real entity.
 925
 926       elsif From_With_Type (T1) then
 927
 928          --  If the expected type is the non-limited view of a type, the
 929          --  expression may have the limited view.
 930
 931          if Ekind (T1) = E_Incomplete_Type then
 932             return Covers (Non_Limited_View (T1), T2);
 933
 934          elsif Ekind (T1) = E_Class_Wide_Type then
 935             return
 936               Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
 937          else
 938             return False;
 939          end if;
 940
 941       elsif From_With_Type (T2) then
 942
 943          --  If units in the context have Limited_With clauses on each other,
 944          --  either type might have a limited view. Checks performed elsewhere
 945          --  verify that the context type is the non-limited view.
 946
 947          if Ekind (T2) = E_Incomplete_Type then
 948             return Covers (T1, Non_Limited_View (T2));
 949
 950          elsif Ekind (T2) = E_Class_Wide_Type then
 951             return
 952               Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
 953          else
 954             return False;
 955          end if;
 956
 957       --  Otherwise it doesn't cover!
 958
 959       else
 960          return False;
 961       end if;
 962    end Covers;
 963
 964    ------------------
 965    -- Disambiguate --
 966    ------------------
 967
 968    function Disambiguate
 969      (N      : Node_Id;
 970       I1, I2 : Interp_Index;
 971       Typ    : Entity_Id)
 972       return   Interp
 973    is
 974       I           : Interp_Index;
 975       It          : Interp;
 976       It1, It2    : Interp;
 977       Nam1, Nam2  : Entity_Id;
 978       Predef_Subp : Entity_Id;
 979       User_Subp   : Entity_Id;
 980
 981       function Inherited_From_Actual (S : Entity_Id) return Boolean;
 982       --  Determine whether one of the candidates is an operation inherited by
 983       --  a type that is derived from an actual in an instantiation.
 984
 985       function In_Generic_Actual (Exp : Node_Id) return Boolean;
 986       --  Determine whether the expression is part of a generic actual. At
 987       --  the time the actual is resolved the scope is already that of the
 988       --  instance, but conceptually the resolution of the actual takes place
 989       --  in the enclosing context, and no special disambiguation rules should
 990       --  be applied.
 991
 992       function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
 993       --  Determine whether a subprogram is an actual in an enclosing instance.
 994       --  An overloading between such a subprogram and one declared outside the
 995       --  instance is resolved in favor of the first, because it resolved in
 996       --  the generic.
 997
 998       function Matches (Actual, Formal : Node_Id) return Boolean;
 999       --  Look for exact type match in an instance, to remove spurious
1000       --  ambiguities when two formal types have the same actual.
1001
1002       function Standard_Operator return Boolean;
1003       --  Comment required ???
1004
1005       function Remove_Conversions return Interp;
1006       --  Last chance for pathological cases involving comparisons on literals,
1007       --  and user overloadings of the same operator. Such pathologies have
1008       --  been removed from the ACVC, but still appear in two DEC tests, with
1009       --  the following notable quote from Ben Brosgol:
1010       --
1011       --  [Note: I disclaim all credit/responsibility/blame for coming up with
1012       --  this example; Robert Dewar brought it to our attention, since it is
1013       --  apparently found in the ACVC 1.5. I did not attempt to find the
1014       --  reason in the Reference Manual that makes the example legal, since I
1015       --  was too nauseated by it to want to pursue it further.]
1016       --
1017       --  Accordingly, this is not a fully recursive solution, but it handles
1018       --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
1019       --  pathology in the other direction with calls whose multiple overloaded
1020       --  actuals make them truly unresolvable.
1021
1022       --  The new rules concerning abstract operations create additional
1023       --  for special handling of expressions with universal operands, See
1024       --  comments to Has_Abstract_Interpretation below.
1025
1026       ------------------------
1027       --  In_Generic_Actual --
1028       ------------------------
1029
1030       function In_Generic_Actual (Exp : Node_Id) return Boolean is
1031          Par : constant Node_Id := Parent (Exp);
1032
1033       begin
1034          if No (Par) then
1035             return False;
1036
1037          elsif Nkind (Par) in N_Declaration then
1038             if Nkind (Par) = N_Object_Declaration
1039               or else Nkind (Par) = N_Object_Renaming_Declaration
1040             then
1041                return Present (Corresponding_Generic_Association (Par));
1042             else
1043                return False;
1044             end if;
1045
1046          elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
1047             return False;
1048
1049          else
1050             return In_Generic_Actual (Parent (Par));
1051          end if;
1052       end In_Generic_Actual;
1053
1054       ---------------------------
1055       -- Inherited_From_Actual --
1056       ---------------------------
1057
1058       function Inherited_From_Actual (S : Entity_Id) return Boolean is
1059          Par : constant Node_Id := Parent (S);
1060       begin
1061          if Nkind (Par) /= N_Full_Type_Declaration
1062            or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
1063          then
1064             return False;
1065          else
1066             return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
1067               and then
1068                Is_Generic_Actual_Type (
1069                  Entity (Subtype_Indication (Type_Definition (Par))));
1070          end if;
1071       end Inherited_From_Actual;
1072
1073       --------------------------
1074       -- Is_Actual_Subprogram --
1075       --------------------------
1076
1077       function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
1078       begin
1079          return In_Open_Scopes (Scope (S))
1080            and then
1081              (Is_Generic_Instance (Scope (S))
1082                 or else Is_Wrapper_Package (Scope (S)));
1083       end Is_Actual_Subprogram;
1084
1085       -------------
1086       -- Matches --
1087       -------------
1088
1089       function Matches (Actual, Formal : Node_Id) return Boolean is
1090          T1 : constant Entity_Id := Etype (Actual);
1091          T2 : constant Entity_Id := Etype (Formal);
1092       begin
1093          return T1 = T2
1094            or else
1095              (Is_Numeric_Type (T2)
1096                and then
1097              (T1 = Universal_Real or else T1 = Universal_Integer));
1098       end Matches;
1099
1100       ------------------------
1101       -- Remove_Conversions --
1102       ------------------------
1103
1104       function Remove_Conversions return Interp is
1105          I    : Interp_Index;
1106          It   : Interp;
1107          It1  : Interp;
1108          F1   : Entity_Id;
1109          Act1 : Node_Id;
1110          Act2 : Node_Id;
1111
1112          function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
1113          --  If an operation has universal operands the universal operation
1114          --  is present among its interpretations. If there is an abstract
1115          --  interpretation for the operator, with a numeric result, this
1116          --  interpretation was already removed in sem_ch4, but the universal
1117          --  one is still visible. We must rescan the list of operators and
1118          --  remove the universal interpretation to resolve the ambiguity.
1119
1120          ---------------------------------
1121          -- Has_Abstract_Interpretation --
1122          ---------------------------------
1123
1124          function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
1125             E : Entity_Id;
1126
1127          begin
1128             E := Current_Entity (N);
1129             while Present (E) loop
1130                if Is_Abstract (E)
1131                  and then Is_Numeric_Type (Etype (E))
1132                then
1133                   return True;
1134                else
1135                   E := Homonym (E);
1136                end if;
1137             end loop;
1138
1139             return False;
1140          end Has_Abstract_Interpretation;
1141
1142       --  Start of processing for Remove_ConversionsMino
1143
1144       begin
1145          It1 := No_Interp;
1146
1147          Get_First_Interp (N, I, It);
1148          while Present (It.Typ) loop
1149             if not Is_Overloadable (It.Nam) then
1150                return No_Interp;
1151             end if;
1152
1153             F1 := First_Formal (It.Nam);
1154
1155             if No (F1) then
1156                return It1;
1157
1158             else
1159                if Nkind (N) = N_Function_Call
1160                  or else Nkind (N) = N_Procedure_Call_Statement
1161                then
1162                   Act1 := First_Actual (N);
1163
1164                   if Present (Act1) then
1165                      Act2 := Next_Actual (Act1);
1166                   else
1167                      Act2 := Empty;
1168                   end if;
1169
1170                elsif Nkind (N) in N_Unary_Op then
1171                   Act1 := Right_Opnd (N);
1172                   Act2 := Empty;
1173
1174                elsif Nkind (N) in N_Binary_Op then
1175                   Act1 := Left_Opnd (N);
1176                   Act2 := Right_Opnd (N);
1177
1178                else
1179                   return It1;
1180                end if;
1181
1182                if Nkind (Act1) in N_Op
1183                  and then Is_Overloaded (Act1)
1184                  and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1185                             or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1186                  and then Has_Compatible_Type (Act1, Standard_Boolean)
1187                  and then Etype (F1) = Standard_Boolean
1188                then
1189                   --  If the two candidates are the original ones, the
1190                   --  ambiguity is real. Otherwise keep the original, further
1191                   --  calls to Disambiguate will take care of others in the
1192                   --  list of candidates.
1193
1194                   if It1 /= No_Interp then
1195                      if It = Disambiguate.It1
1196                        or else It = Disambiguate.It2
1197                      then
1198                         if It1 = Disambiguate.It1
1199                           or else It1 = Disambiguate.It2
1200                         then
1201                            return No_Interp;
1202                         else
1203                            It1 := It;
1204                         end if;
1205                      end if;
1206
1207                   elsif Present (Act2)
1208                     and then Nkind (Act2) in N_Op
1209                     and then Is_Overloaded (Act2)
1210                     and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
1211                                 or else
1212                               Nkind (Right_Opnd (Act1)) = N_Real_Literal)
1213                     and then Has_Compatible_Type (Act2, Standard_Boolean)
1214                   then
1215                      --  The preference rule on the first actual is not
1216                      --  sufficient to disambiguate.
1217
1218                      goto Next_Interp;
1219
1220                   else
1221                      It1 := It;
1222                   end if;
1223
1224                elsif Nkind (Act1) in N_Op
1225                  and then Is_Overloaded (Act1)
1226                  and then Present (Universal_Interpretation (Act1))
1227                  and then Is_Numeric_Type (Etype (F1))
1228                  and then Ada_Version >= Ada_05
1229                  and then Has_Abstract_Interpretation (Act1)
1230                then
1231                   if It = Disambiguate.It1 then
1232                      return Disambiguate.It2;
1233                   elsif It = Disambiguate.It2 then
1234                      return Disambiguate.It1;
1235                   end if;
1236                end if;
1237             end if;
1238
1239             <<Next_Interp>>
1240                Get_Next_Interp (I, It);
1241          end loop;
1242
1243          --  After some error, a formal may have Any_Type and yield a spurious
1244          --  match. To avoid cascaded errors if possible, check for such a
1245          --  formal in either candidate.
1246
1247          if Serious_Errors_Detected > 0 then
1248             declare
1249                Formal : Entity_Id;
1250
1251             begin
1252                Formal := First_Formal (Nam1);
1253                while Present (Formal) loop
1254                   if Etype (Formal) = Any_Type then
1255                      return Disambiguate.It2;
1256                   end if;
1257
1258                   Next_Formal (Formal);
1259                end loop;
1260
1261                Formal := First_Formal (Nam2);
1262                while Present (Formal) loop
1263                   if Etype (Formal) = Any_Type then
1264                      return Disambiguate.It1;
1265                   end if;
1266
1267                   Next_Formal (Formal);
1268                end loop;
1269             end;
1270          end if;
1271
1272          return It1;
1273       end Remove_Conversions;
1274
1275       -----------------------
1276       -- Standard_Operator --
1277       -----------------------
1278
1279       function Standard_Operator return Boolean is
1280          Nam : Node_Id;
1281
1282       begin
1283          if Nkind (N) in N_Op then
1284             return True;
1285
1286          elsif Nkind (N) = N_Function_Call then
1287             Nam := Name (N);
1288
1289             if Nkind (Nam) /= N_Expanded_Name then
1290                return True;
1291             else
1292                return Entity (Prefix (Nam)) = Standard_Standard;
1293             end if;
1294          else
1295             return False;
1296          end if;
1297       end Standard_Operator;
1298
1299    --  Start of processing for Disambiguate
1300
1301    begin
1302       --  Recover the two legal interpretations
1303
1304       Get_First_Interp (N, I, It);
1305       while I /= I1 loop
1306          Get_Next_Interp (I, It);
1307       end loop;
1308
1309       It1  := It;
1310       Nam1 := It.Nam;
1311       while I /= I2 loop
1312          Get_Next_Interp (I, It);
1313       end loop;
1314
1315       It2  := It;
1316       Nam2 := It.Nam;
1317
1318       if Ada_Version < Ada_05 then
1319
1320          --  Check whether one of the entities is an Ada 2005 entity and we are
1321          --  operating in an earlier mode, in which case we discard the Ada
1322          --  2005 entity, so that we get proper Ada 95 overload resolution.
1323
1324          if Is_Ada_2005 (Nam1) then
1325             return It2;
1326          elsif Is_Ada_2005 (Nam2) then
1327             return It1;
1328          end if;
1329       end if;
1330
1331       --  If the context is universal, the predefined operator is preferred.
1332       --  This includes bounds in numeric type declarations, and expressions
1333       --  in type conversions. If no interpretation yields a universal type,
1334       --  then we must check whether the user-defined entity hides the prede-
1335       --  fined one.
1336
1337       if Chars (Nam1) in  Any_Operator_Name
1338         and then Standard_Operator
1339       then
1340          if        Typ = Universal_Integer
1341            or else Typ = Universal_Real
1342            or else Typ = Any_Integer
1343            or else Typ = Any_Discrete
1344            or else Typ = Any_Real
1345            or else Typ = Any_Type
1346          then
1347             --  Find an interpretation that yields the universal type, or else
1348             --  a predefined operator that yields a predefined numeric type.
1349
1350             declare
1351                Candidate : Interp := No_Interp;
1352
1353             begin
1354                Get_First_Interp (N, I, It);
1355                while Present (It.Typ) loop
1356                   if (Covers (Typ, It.Typ)
1357                         or else Typ = Any_Type)
1358                     and then
1359                      (It.Typ = Universal_Integer
1360                        or else It.Typ = Universal_Real)
1361                   then
1362                      return It;
1363
1364                   elsif Covers (Typ, It.Typ)
1365                     and then Scope (It.Typ) = Standard_Standard
1366                     and then Scope (It.Nam) = Standard_Standard
1367                     and then Is_Numeric_Type (It.Typ)
1368                   then
1369                      Candidate := It;
1370                   end if;
1371
1372                   Get_Next_Interp (I, It);
1373                end loop;
1374
1375                if Candidate /= No_Interp then
1376                   return Candidate;
1377                end if;
1378             end;
1379
1380          elsif Chars (Nam1) /= Name_Op_Not
1381            and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
1382          then
1383             --  Equality or comparison operation. Choose predefined operator if
1384             --  arguments are universal. The node may be an operator, name, or
1385             --  a function call, so unpack arguments accordingly.
1386
1387             declare
1388                Arg1, Arg2 : Node_Id;
1389
1390             begin
1391                if Nkind (N) in N_Op then
1392                   Arg1 := Left_Opnd  (N);
1393                   Arg2 := Right_Opnd (N);
1394
1395                elsif Is_Entity_Name (N)
1396                  or else Nkind (N) = N_Operator_Symbol
1397                then
1398                   Arg1 := First_Entity (Entity (N));
1399                   Arg2 := Next_Entity (Arg1);
1400
1401                else
1402                   Arg1 := First_Actual (N);
1403                   Arg2 := Next_Actual (Arg1);
1404                end if;
1405
1406                if Present (Arg2)
1407                  and then Present (Universal_Interpretation (Arg1))
1408                  and then Universal_Interpretation (Arg2) =
1409                           Universal_Interpretation (Arg1)
1410                then
1411                   Get_First_Interp (N, I, It);
1412                   while Scope (It.Nam) /= Standard_Standard loop
1413                      Get_Next_Interp (I, It);
1414                   end loop;
1415
1416                   return It;
1417                end if;
1418             end;
1419          end if;
1420       end if;
1421
1422       --  If no universal interpretation, check whether user-defined operator
1423       --  hides predefined one, as well as other special cases. If the node
1424       --  is a range, then one or both bounds are ambiguous. Each will have
1425       --  to be disambiguated w.r.t. the context type. The type of the range
1426       --  itself is imposed by the context, so we can return either legal
1427       --  interpretation.
1428
1429       if Ekind (Nam1) = E_Operator then
1430          Predef_Subp := Nam1;
1431          User_Subp   := Nam2;
1432
1433       elsif Ekind (Nam2) = E_Operator then
1434          Predef_Subp := Nam2;
1435          User_Subp   := Nam1;
1436
1437       elsif Nkind (N) = N_Range then
1438          return It1;
1439
1440       --  If two user defined-subprograms are visible, it is a true ambiguity,
1441       --  unless one of them is an entry and the context is a conditional or
1442       --  timed entry call, or unless we are within an instance and this is
1443       --  results from two formals types with the same actual.
1444
1445       else
1446          if Nkind (N) = N_Procedure_Call_Statement
1447            and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1448            and then N = Entry_Call_Statement (Parent (N))
1449          then
1450             if Ekind (Nam2) = E_Entry then
1451                return It2;
1452             elsif Ekind (Nam1) = E_Entry then
1453                return It1;
1454             else
1455                return No_Interp;
1456             end if;
1457
1458          --  If the ambiguity occurs within an instance, it is due to several
1459          --  formal types with the same actual. Look for an exact match between
1460          --  the types of the formals of the overloadable entities, and the
1461          --  actuals in the call, to recover the unambiguous match in the
1462          --  original generic.
1463
1464          --  The ambiguity can also be due to an overloading between a formal
1465          --  subprogram and a subprogram declared outside the generic. If the
1466          --  node is overloaded, it did not resolve to the global entity in
1467          --  the generic, and we choose the formal subprogram.
1468
1469          --  Finally, the ambiguity can be between an explicit subprogram and
1470          --  one inherited (with different defaults) from an actual. In this
1471          --  case the resolution was to the explicit declaration in the
1472          --  generic, and remains so in the instance.
1473
1474          elsif In_Instance
1475            and then not In_Generic_Actual (N)
1476          then
1477             if Nkind (N) = N_Function_Call
1478               or else Nkind (N) = N_Procedure_Call_Statement
1479             then
1480                declare
1481                   Actual  : Node_Id;
1482                   Formal  : Entity_Id;
1483                   Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
1484                   Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
1485
1486                begin
1487                   if Is_Act1 and then not Is_Act2 then
1488                      return It1;
1489
1490                   elsif Is_Act2 and then not Is_Act1 then
1491                      return It2;
1492
1493                   elsif Inherited_From_Actual (Nam1)
1494                     and then Comes_From_Source (Nam2)
1495                   then
1496                      return It2;
1497
1498                   elsif Inherited_From_Actual (Nam2)
1499                     and then Comes_From_Source (Nam1)
1500                   then
1501                      return It1;
1502                   end if;
1503
1504                   Actual := First_Actual (N);
1505                   Formal := First_Formal (Nam1);
1506                   while Present (Actual) loop
1507                      if Etype (Actual) /= Etype (Formal) then
1508                         return It2;
1509                      end if;
1510
1511                      Next_Actual (Actual);
1512                      Next_Formal (Formal);
1513                   end loop;
1514
1515                   return It1;
1516                end;
1517
1518             elsif Nkind (N) in N_Binary_Op then
1519                if Matches (Left_Opnd (N), First_Formal (Nam1))
1520                  and then
1521                    Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1522                then
1523                   return It1;
1524                else
1525                   return It2;
1526                end if;
1527
1528             elsif Nkind (N) in  N_Unary_Op then
1529                if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1530                   return It1;
1531                else
1532                   return It2;
1533                end if;
1534
1535             else
1536                return Remove_Conversions;
1537             end if;
1538          else
1539             return Remove_Conversions;
1540          end if;
1541       end if;
1542
1543       --  an implicit concatenation operator on a string type cannot be
1544       --  disambiguated from the predefined concatenation. This can only
1545       --  happen with concatenation of string literals.
1546
1547       if Chars (User_Subp) = Name_Op_Concat
1548         and then Ekind (User_Subp) = E_Operator
1549         and then Is_String_Type (Etype (First_Formal (User_Subp)))
1550       then
1551          return No_Interp;
1552
1553       --  If the user-defined operator is in  an open scope, or in the scope
1554       --  of the resulting type, or given by an expanded name that names its
1555       --  scope, it hides the predefined operator for the type. Exponentiation
1556       --  has to be special-cased because the implicit operator does not have
1557       --  a symmetric signature, and may not be hidden by the explicit one.
1558
1559       elsif (Nkind (N) = N_Function_Call
1560               and then Nkind (Name (N)) = N_Expanded_Name
1561               and then (Chars (Predef_Subp) /= Name_Op_Expon
1562                           or else Hides_Op (User_Subp, Predef_Subp))
1563               and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1564         or else Hides_Op (User_Subp, Predef_Subp)
1565       then
1566          if It1.Nam = User_Subp then
1567             return It1;
1568          else
1569             return It2;
1570          end if;
1571
1572       --  Otherwise, the predefined operator has precedence, or if the user-
1573       --  defined operation is directly visible we have a true ambiguity. If
1574       --  this is a fixed-point multiplication and division in Ada83 mode,
1575       --  exclude the universal_fixed operator, which often causes ambiguities
1576       --  in legacy code.
1577
1578       else
1579          if (In_Open_Scopes (Scope (User_Subp))
1580            or else Is_Potentially_Use_Visible (User_Subp))
1581            and then not In_Instance
1582          then
1583             if Is_Fixed_Point_Type (Typ)
1584               and then (Chars (Nam1) = Name_Op_Multiply
1585                           or else Chars (Nam1) = Name_Op_Divide)
1586               and then Ada_Version = Ada_83
1587             then
1588                if It2.Nam = Predef_Subp then
1589                   return It1;
1590                else
1591                   return It2;
1592                end if;
1593             else
1594                return No_Interp;
1595             end if;
1596
1597          elsif It1.Nam = Predef_Subp then
1598             return It1;
1599
1600          else
1601             return It2;
1602          end if;
1603       end if;
1604    end Disambiguate;
1605
1606    ---------------------
1607    -- End_Interp_List --
1608    ---------------------
1609
1610    procedure End_Interp_List is
1611    begin
1612       All_Interp.Table (All_Interp.Last) := No_Interp;
1613       All_Interp.Increment_Last;
1614    end End_Interp_List;
1615
1616    -------------------------
1617    -- Entity_Matches_Spec --
1618    -------------------------
1619
1620    function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1621    begin
1622       --  Simple case: same entity kinds, type conformance is required. A
1623       --  parameterless function can also rename a literal.
1624
1625       if Ekind (Old_S) = Ekind (New_S)
1626         or else (Ekind (New_S) = E_Function
1627                   and then Ekind (Old_S) = E_Enumeration_Literal)
1628       then
1629          return Type_Conformant (New_S, Old_S);
1630
1631       elsif Ekind (New_S) = E_Function
1632         and then Ekind (Old_S) = E_Operator
1633       then
1634          return Operator_Matches_Spec (Old_S, New_S);
1635
1636       elsif Ekind (New_S) = E_Procedure
1637         and then Is_Entry (Old_S)
1638       then
1639          return Type_Conformant (New_S, Old_S);
1640
1641       else
1642          return False;
1643       end if;
1644    end Entity_Matches_Spec;
1645
1646    ----------------------
1647    -- Find_Unique_Type --
1648    ----------------------
1649
1650    function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1651       T  : constant Entity_Id := Etype (L);
1652       I  : Interp_Index;
1653       It : Interp;
1654       TR : Entity_Id := Any_Type;
1655
1656    begin
1657       if Is_Overloaded (R) then
1658          Get_First_Interp (R, I, It);
1659          while Present (It.Typ) loop
1660             if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1661
1662                --  If several interpretations are possible and L is universal,
1663                --  apply preference rule.
1664
1665                if TR /= Any_Type then
1666
1667                   if (T = Universal_Integer or else T = Universal_Real)
1668                     and then It.Typ = T
1669                   then
1670                      TR := It.Typ;
1671                   end if;
1672
1673                else
1674                   TR := It.Typ;
1675                end if;
1676             end if;
1677
1678             Get_Next_Interp (I, It);
1679          end loop;
1680
1681          Set_Etype (R, TR);
1682
1683       --  In the non-overloaded case, the Etype of R is already set correctly
1684
1685       else
1686          null;
1687       end if;
1688
1689       --  If one of the operands is Universal_Fixed, the type of the other
1690       --  operand provides the context.
1691
1692       if Etype (R) = Universal_Fixed then
1693          return T;
1694
1695       elsif T = Universal_Fixed then
1696          return Etype (R);
1697
1698       --  Ada 2005 (AI-230): Support the following operators:
1699
1700       --    function "="  (L, R : universal_access) return Boolean;
1701       --    function "/=" (L, R : universal_access) return Boolean;
1702
1703       elsif Ada_Version >= Ada_05
1704         and then Ekind (Etype (L)) = E_Anonymous_Access_Type
1705         and then Is_Access_Type (Etype (R))
1706       then
1707          return Etype (L);
1708
1709       elsif Ada_Version >= Ada_05
1710         and then Ekind (Etype (R)) = E_Anonymous_Access_Type
1711         and then Is_Access_Type (Etype (L))
1712       then
1713          return Etype (R);
1714
1715       else
1716          return Specific_Type (T, Etype (R));
1717       end if;
1718
1719    end Find_Unique_Type;
1720
1721    ----------------------
1722    -- Get_First_Interp --
1723    ----------------------
1724
1725    procedure Get_First_Interp
1726      (N  : Node_Id;
1727       I  : out Interp_Index;
1728       It : out Interp)
1729    is
1730       Map_Ptr : Int;
1731       Int_Ind : Interp_Index;
1732       O_N     : Node_Id;
1733
1734    begin
1735       --  If a selected component is overloaded because the selector has
1736       --  multiple interpretations, the node is a call to a protected
1737       --  operation or an indirect call. Retrieve the interpretation from
1738       --  the selector name. The selected component may be overloaded as well
1739       --  if the prefix is overloaded. That case is unchanged.
1740
1741       if Nkind (N) = N_Selected_Component
1742         and then Is_Overloaded (Selector_Name (N))
1743       then
1744          O_N := Selector_Name (N);
1745       else
1746          O_N := N;
1747       end if;
1748
1749       Map_Ptr := Headers (Hash (O_N));
1750       while Present (Interp_Map.Table (Map_Ptr).Node) loop
1751          if Interp_Map.Table (Map_Ptr).Node = O_N then
1752             Int_Ind := Interp_Map.Table (Map_Ptr).Index;
1753             It := All_Interp.Table (Int_Ind);
1754             I := Int_Ind;
1755             return;
1756          else
1757             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
1758          end if;
1759       end loop;
1760
1761       --  Procedure should never be called if the node has no interpretations
1762
1763       raise Program_Error;
1764    end Get_First_Interp;
1765
1766    ---------------------
1767    -- Get_Next_Interp --
1768    ---------------------
1769
1770    procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
1771    begin
1772       I  := I + 1;
1773       It := All_Interp.Table (I);
1774    end Get_Next_Interp;
1775
1776    -------------------------
1777    -- Has_Compatible_Type --
1778    -------------------------
1779
1780    function Has_Compatible_Type
1781      (N    : Node_Id;
1782       Typ  : Entity_Id)
1783       return Boolean
1784    is
1785       I  : Interp_Index;
1786       It : Interp;
1787
1788    begin
1789       if N = Error then
1790          return False;
1791       end if;
1792
1793       if Nkind (N) = N_Subtype_Indication
1794         or else not Is_Overloaded (N)
1795       then
1796          return
1797            Covers (Typ, Etype (N))
1798
1799             --  Ada 2005 (AI-345) The context may be a synchronized interface.
1800             --  If the type is already frozen use the corresponding_record
1801             --  to check whether it is a proper descendant.
1802
1803            or else
1804              (Is_Concurrent_Type (Etype (N))
1805                 and then Present (Corresponding_Record_Type (Etype (N)))
1806                 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
1807
1808            or else
1809              (not Is_Tagged_Type (Typ)
1810                 and then Ekind (Typ) /= E_Anonymous_Access_Type
1811                 and then Covers (Etype (N), Typ));
1812
1813       else
1814          Get_First_Interp (N, I, It);
1815          while Present (It.Typ) loop
1816             if (Covers (Typ, It.Typ)
1817                   and then
1818                     (Scope (It.Nam) /= Standard_Standard
1819                        or else not Is_Invisible_Operator (N, Base_Type (Typ))))
1820
1821                --  Ada 2005 (AI-345)
1822
1823               or else
1824                 (Is_Concurrent_Type (It.Typ)
1825                   and then Present (Corresponding_Record_Type
1826                                                              (Etype (It.Typ)))
1827                   and then Covers (Typ, Corresponding_Record_Type
1828                                                              (Etype (It.Typ))))
1829
1830               or else (not Is_Tagged_Type (Typ)
1831                          and then Ekind (Typ) /= E_Anonymous_Access_Type
1832                          and then Covers (It.Typ, Typ))
1833             then
1834                return True;
1835             end if;
1836
1837             Get_Next_Interp (I, It);
1838          end loop;
1839
1840          return False;
1841       end if;
1842    end Has_Compatible_Type;
1843
1844    ----------
1845    -- Hash --
1846    ----------
1847
1848    function Hash (N : Node_Id) return Int is
1849    begin
1850       --  Nodes have a size that is power of two, so to select significant
1851       --  bits only we remove the low-order bits.
1852
1853       return ((Int (N) / 2 ** 5) mod Header_Size);
1854    end Hash;
1855
1856    --------------
1857    -- Hides_Op --
1858    --------------
1859
1860    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
1861       Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
1862    begin
1863       return Operator_Matches_Spec (Op, F)
1864         and then (In_Open_Scopes (Scope (F))
1865                     or else Scope (F) = Scope (Btyp)
1866                     or else (not In_Open_Scopes (Scope (Btyp))
1867                               and then not In_Use (Btyp)
1868                               and then not In_Use (Scope (Btyp))));
1869    end Hides_Op;
1870
1871    ------------------------
1872    -- Init_Interp_Tables --
1873    ------------------------
1874
1875    procedure Init_Interp_Tables is
1876    begin
1877       All_Interp.Init;
1878       Interp_Map.Init;
1879       Headers := (others => No_Entry);
1880    end Init_Interp_Tables;
1881
1882    -----------------------------------
1883    -- Interface_Present_In_Ancestor --
1884    -----------------------------------
1885
1886    function Interface_Present_In_Ancestor
1887      (Typ   : Entity_Id;
1888       Iface : Entity_Id) return Boolean
1889    is
1890       Target_Typ : Entity_Id;
1891
1892       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
1893       --  Returns True if Typ or some ancestor of Typ implements Iface
1894
1895       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
1896          E    : Entity_Id;
1897          AI   : Entity_Id;
1898          Elmt : Elmt_Id;
1899
1900       begin
1901          if Typ = Iface then
1902             return True;
1903          end if;
1904
1905          --  Handle private types
1906
1907          if Present (Full_View (Typ))
1908            and then not Is_Concurrent_Type (Full_View (Typ))
1909          then
1910             E := Full_View (Typ);
1911          else
1912             E := Typ;
1913          end if;
1914
1915          loop
1916             if Present (Abstract_Interfaces (E))
1917               and then Present (Abstract_Interfaces (E))
1918               and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
1919             then
1920                Elmt := First_Elmt (Abstract_Interfaces (E));
1921                while Present (Elmt) loop
1922                   AI := Node (Elmt);
1923
1924                   if AI = Iface or else Is_Ancestor (Iface, AI) then
1925                      return True;
1926                   end if;
1927
1928                   Next_Elmt (Elmt);
1929                end loop;
1930             end if;
1931
1932             exit when Etype (E) = E
1933
1934                --  Handle private types
1935
1936                or else (Present (Full_View (Etype (E)))
1937                          and then Full_View (Etype (E)) = E);
1938
1939             --  Check if the current type is a direct derivation of the
1940             --  interface
1941
1942             if Etype (E) = Iface then
1943                return True;
1944             end if;
1945
1946             --  Climb to the immediate ancestor handling private types
1947
1948             if Present (Full_View (Etype (E))) then
1949                E := Full_View (Etype (E));
1950             else
1951                E := Etype (E);
1952             end if;
1953          end loop;
1954
1955          return False;
1956       end Iface_Present_In_Ancestor;
1957
1958    --  Start of processing for Interface_Present_In_Ancestor
1959
1960    begin
1961       if Is_Access_Type (Typ) then
1962          Target_Typ := Etype (Directly_Designated_Type (Typ));
1963       else
1964          Target_Typ := Typ;
1965       end if;
1966
1967       --  In case of concurrent types we can't use the Corresponding Record_Typ
1968       --  to look for the interface because it is built by the expander (and
1969       --  hence it is not always available). For this reason we traverse the
1970       --  list of interfaces (available in the parent of the concurrent type)
1971
1972       if Is_Concurrent_Type (Target_Typ) then
1973          if Present (Interface_List (Parent (Target_Typ))) then
1974             declare
1975                AI : Node_Id;
1976
1977             begin
1978                AI := First (Interface_List (Parent (Target_Typ)));
1979                while Present (AI) loop
1980                   if Etype (AI) = Iface then
1981                      return True;
1982
1983                   elsif Present (Abstract_Interfaces (Etype (AI)))
1984                      and then Iface_Present_In_Ancestor (Etype (AI))
1985                   then
1986                      return True;
1987                   end if;
1988
1989                   Next (AI);
1990                end loop;
1991             end;
1992          end if;
1993
1994          return False;
1995       end if;
1996
1997       if Is_Class_Wide_Type (Target_Typ) then
1998          Target_Typ := Etype (Target_Typ);
1999       end if;
2000
2001       if Ekind (Target_Typ) = E_Incomplete_Type then
2002          pragma Assert (Present (Non_Limited_View (Target_Typ)));
2003          Target_Typ := Non_Limited_View (Target_Typ);
2004
2005          --  Protect the frontend against previously detected errors
2006
2007          if Ekind (Target_Typ) = E_Incomplete_Type then
2008             return False;
2009          end if;
2010       end if;
2011
2012       return Iface_Present_In_Ancestor (Target_Typ);
2013    end Interface_Present_In_Ancestor;
2014
2015    ---------------------
2016    -- Intersect_Types --
2017    ---------------------
2018
2019    function Intersect_Types (L, R : Node_Id) return Entity_Id is
2020       Index : Interp_Index;
2021       It    : Interp;
2022       Typ   : Entity_Id;
2023
2024       function Check_Right_Argument (T : Entity_Id) return Entity_Id;
2025       --  Find interpretation of right arg that has type compatible with T
2026
2027       --------------------------
2028       -- Check_Right_Argument --
2029       --------------------------
2030
2031       function Check_Right_Argument (T : Entity_Id) return Entity_Id is
2032          Index : Interp_Index;
2033          It    : Interp;
2034          T2    : Entity_Id;
2035
2036       begin
2037          if not Is_Overloaded (R) then
2038             return Specific_Type (T, Etype (R));
2039
2040          else
2041             Get_First_Interp (R, Index, It);
2042             loop
2043                T2 := Specific_Type (T, It.Typ);
2044
2045                if T2 /= Any_Type then
2046                   return T2;
2047                end if;
2048
2049                Get_Next_Interp (Index, It);
2050                exit when No (It.Typ);
2051             end loop;
2052
2053             return Any_Type;
2054          end if;
2055       end Check_Right_Argument;
2056
2057    --  Start processing for Intersect_Types
2058
2059    begin
2060       if Etype (L) = Any_Type or else Etype (R) = Any_Type then
2061          return Any_Type;
2062       end if;
2063
2064       if not Is_Overloaded (L) then
2065          Typ := Check_Right_Argument (Etype (L));
2066
2067       else
2068          Typ := Any_Type;
2069          Get_First_Interp (L, Index, It);
2070          while Present (It.Typ) loop
2071             Typ := Check_Right_Argument (It.Typ);
2072             exit when Typ /= Any_Type;
2073             Get_Next_Interp (Index, It);
2074          end loop;
2075
2076       end if;
2077
2078       --  If Typ is Any_Type, it means no compatible pair of types was found
2079
2080       if Typ = Any_Type then
2081          if Nkind (Parent (L)) in N_Op then
2082             Error_Msg_N ("incompatible types for operator", Parent (L));
2083
2084          elsif Nkind (Parent (L)) = N_Range then
2085             Error_Msg_N ("incompatible types given in constraint", Parent (L));
2086
2087          --  Ada 2005 (AI-251): Complete the error notification
2088
2089          elsif Is_Class_Wide_Type (Etype (R))
2090              and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
2091          then
2092             Error_Msg_NE ("(Ada 2005) does not implement interface }",
2093                           L, Etype (Class_Wide_Type (Etype (R))));
2094
2095          else
2096             Error_Msg_N ("incompatible types", Parent (L));
2097          end if;
2098       end if;
2099
2100       return Typ;
2101    end Intersect_Types;
2102
2103    -----------------
2104    -- Is_Ancestor --
2105    -----------------
2106
2107    function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
2108       Par : Entity_Id;
2109
2110    begin
2111       if Base_Type (T1) = Base_Type (T2) then
2112          return True;
2113
2114       elsif Is_Private_Type (T1)
2115         and then Present (Full_View (T1))
2116         and then Base_Type (T2) = Base_Type (Full_View (T1))
2117       then
2118          return True;
2119
2120       else
2121          Par := Etype (T2);
2122
2123          loop
2124             --  If there was a error on the type declaration, do not recurse
2125
2126             if Error_Posted (Par) then
2127                return False;
2128
2129             elsif Base_Type (T1) = Base_Type (Par)
2130               or else (Is_Private_Type (T1)
2131                          and then Present (Full_View (T1))
2132                          and then Base_Type (Par) = Base_Type (Full_View (T1)))
2133             then
2134                return True;
2135
2136             elsif Is_Private_Type (Par)
2137               and then Present (Full_View (Par))
2138               and then Full_View (Par) = Base_Type (T1)
2139             then
2140                return True;
2141
2142             elsif Etype (Par) /= Par then
2143                Par := Etype (Par);
2144             else
2145                return False;
2146             end if;
2147          end loop;
2148       end if;
2149    end Is_Ancestor;
2150
2151    ---------------------------
2152    -- Is_Invisible_Operator --
2153    ---------------------------
2154
2155    function Is_Invisible_Operator
2156      (N    : Node_Id;
2157       T    : Entity_Id)
2158       return Boolean
2159    is
2160       Orig_Node : constant Node_Id := Original_Node (N);
2161
2162    begin
2163       if Nkind (N) not in N_Op then
2164          return False;
2165
2166       elsif not Comes_From_Source (N) then
2167          return False;
2168
2169       elsif No (Universal_Interpretation (Right_Opnd (N))) then
2170          return False;
2171
2172       elsif Nkind (N) in N_Binary_Op
2173         and then No (Universal_Interpretation (Left_Opnd (N)))
2174       then
2175          return False;
2176
2177       else return
2178         Is_Numeric_Type (T)
2179           and then not In_Open_Scopes (Scope (T))
2180           and then not Is_Potentially_Use_Visible (T)
2181           and then not In_Use (T)
2182           and then not In_Use (Scope (T))
2183           and then
2184             (Nkind (Orig_Node) /= N_Function_Call
2185               or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
2186               or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
2187
2188           and then not In_Instance;
2189       end if;
2190    end Is_Invisible_Operator;
2191
2192    -------------------
2193    -- Is_Subtype_Of --
2194    -------------------
2195
2196    function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
2197       S : Entity_Id;
2198
2199    begin
2200       S := Ancestor_Subtype (T1);
2201       while Present (S) loop
2202          if S = T2 then
2203             return True;
2204          else
2205             S := Ancestor_Subtype (S);
2206          end if;
2207       end loop;
2208
2209       return False;
2210    end Is_Subtype_Of;
2211
2212    ------------------
2213    -- List_Interps --
2214    ------------------
2215
2216    procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
2217       Index : Interp_Index;
2218       It    : Interp;
2219
2220    begin
2221       Get_First_Interp (Nam, Index, It);
2222       while Present (It.Nam) loop
2223          if Scope (It.Nam) = Standard_Standard
2224            and then Scope (It.Typ) /= Standard_Standard
2225          then
2226             Error_Msg_Sloc := Sloc (Parent (It.Typ));
2227             Error_Msg_NE ("   & (inherited) declared#!", Err, It.Nam);
2228
2229          else
2230             Error_Msg_Sloc := Sloc (It.Nam);
2231             Error_Msg_NE ("   & declared#!", Err, It.Nam);
2232          end if;
2233
2234          Get_Next_Interp (Index, It);
2235       end loop;
2236    end List_Interps;
2237
2238    -----------------
2239    -- New_Interps --
2240    -----------------
2241
2242    procedure New_Interps (N : Node_Id)  is
2243       Map_Ptr : Int;
2244
2245    begin
2246       All_Interp.Increment_Last;
2247       All_Interp.Table (All_Interp.Last) := No_Interp;
2248
2249       Map_Ptr := Headers (Hash (N));
2250
2251       if Map_Ptr = No_Entry then
2252
2253          --  Place new node at end of table
2254
2255          Interp_Map.Increment_Last;
2256          Headers (Hash (N)) := Interp_Map.Last;
2257
2258       else
2259          --   Place node at end of chain, or locate its previous entry
2260
2261          loop
2262             if Interp_Map.Table (Map_Ptr).Node = N then
2263
2264                --  Node is already in the table, and is being rewritten.
2265                --  Start a new interp section, retain hash link.
2266
2267                Interp_Map.Table (Map_Ptr).Node  := N;
2268                Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
2269                Set_Is_Overloaded (N, True);
2270                return;
2271
2272             else
2273                exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
2274                Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2275             end if;
2276          end loop;
2277
2278          --  Chain the new node
2279
2280          Interp_Map.Increment_Last;
2281          Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
2282       end if;
2283
2284       Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
2285       Set_Is_Overloaded (N, True);
2286    end New_Interps;
2287
2288    ---------------------------
2289    -- Operator_Matches_Spec --
2290    ---------------------------
2291
2292    function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
2293       Op_Name : constant Name_Id   := Chars (Op);
2294       T       : constant Entity_Id := Etype (New_S);
2295       New_F   : Entity_Id;
2296       Old_F   : Entity_Id;
2297       Num     : Int;
2298       T1      : Entity_Id;
2299       T2      : Entity_Id;
2300
2301    begin
2302       --  To verify that a predefined operator matches a given signature,
2303       --  do a case analysis of the operator classes. Function can have one
2304       --  or two formals and must have the proper result type.
2305
2306       New_F := First_Formal (New_S);
2307       Old_F := First_Formal (Op);
2308       Num := 0;
2309       while Present (New_F) and then Present (Old_F) loop
2310          Num := Num + 1;
2311          Next_Formal (New_F);
2312          Next_Formal (Old_F);
2313       end loop;
2314
2315       --  Definite mismatch if different number of parameters
2316
2317       if Present (Old_F) or else Present (New_F) then
2318          return False;
2319
2320       --  Unary operators
2321
2322       elsif Num = 1 then
2323          T1 := Etype (First_Formal (New_S));
2324
2325          if Op_Name = Name_Op_Subtract
2326            or else Op_Name = Name_Op_Add
2327            or else Op_Name = Name_Op_Abs
2328          then
2329             return Base_Type (T1) = Base_Type (T)
2330               and then Is_Numeric_Type (T);
2331
2332          elsif Op_Name = Name_Op_Not then
2333             return Base_Type (T1) = Base_Type (T)
2334               and then Valid_Boolean_Arg (Base_Type (T));
2335
2336          else
2337             return False;
2338          end if;
2339
2340       --  Binary operators
2341
2342       else
2343          T1 := Etype (First_Formal (New_S));
2344          T2 := Etype (Next_Formal (First_Formal (New_S)));
2345
2346          if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
2347            or else Op_Name = Name_Op_Xor
2348          then
2349             return Base_Type (T1) = Base_Type (T2)
2350               and then Base_Type (T1) = Base_Type (T)
2351               and then Valid_Boolean_Arg (Base_Type (T));
2352
2353          elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
2354             return Base_Type (T1) = Base_Type (T2)
2355               and then not Is_Limited_Type (T1)
2356               and then Is_Boolean_Type (T);
2357
2358          elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
2359            or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
2360          then
2361             return Base_Type (T1) = Base_Type (T2)
2362               and then Valid_Comparison_Arg (T1)
2363               and then Is_Boolean_Type (T);
2364
2365          elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
2366             return Base_Type (T1) = Base_Type (T2)
2367               and then Base_Type (T1) = Base_Type (T)
2368               and then Is_Numeric_Type (T);
2369
2370          --  for division and multiplication, a user-defined function does
2371          --  not match the predefined universal_fixed operation, except in
2372          --  Ada83 mode.
2373
2374          elsif Op_Name = Name_Op_Divide then
2375             return (Base_Type (T1) = Base_Type (T2)
2376               and then Base_Type (T1) = Base_Type (T)
2377               and then Is_Numeric_Type (T)
2378               and then (not Is_Fixed_Point_Type (T)
2379                          or else Ada_Version = Ada_83))
2380
2381             --  Mixed_Mode operations on fixed-point types
2382
2383               or else (Base_Type (T1) = Base_Type (T)
2384                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2385                         and then Is_Fixed_Point_Type (T))
2386
2387             --  A user defined operator can also match (and hide) a mixed
2388             --  operation on universal literals.
2389
2390               or else (Is_Integer_Type (T2)
2391                         and then Is_Floating_Point_Type (T1)
2392                         and then Base_Type (T1) = Base_Type (T));
2393
2394          elsif Op_Name = Name_Op_Multiply then
2395             return (Base_Type (T1) = Base_Type (T2)
2396               and then Base_Type (T1) = Base_Type (T)
2397               and then Is_Numeric_Type (T)
2398               and then (not Is_Fixed_Point_Type (T)
2399                          or else Ada_Version = Ada_83))
2400
2401             --  Mixed_Mode operations on fixed-point types
2402
2403               or else (Base_Type (T1) = Base_Type (T)
2404                         and then Base_Type (T2) = Base_Type (Standard_Integer)
2405                         and then Is_Fixed_Point_Type (T))
2406
2407               or else (Base_Type (T2) = Base_Type (T)
2408                         and then Base_Type (T1) = Base_Type (Standard_Integer)
2409                         and then Is_Fixed_Point_Type (T))
2410
2411               or else (Is_Integer_Type (T2)
2412                         and then Is_Floating_Point_Type (T1)
2413                         and then Base_Type (T1) = Base_Type (T))
2414
2415               or else (Is_Integer_Type (T1)
2416                         and then Is_Floating_Point_Type (T2)
2417                         and then Base_Type (T2) = Base_Type (T));
2418
2419          elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
2420             return Base_Type (T1) = Base_Type (T2)
2421               and then Base_Type (T1) = Base_Type (T)
2422               and then Is_Integer_Type (T);
2423
2424          elsif Op_Name = Name_Op_Expon then
2425             return Base_Type (T1) = Base_Type (T)
2426               and then Is_Numeric_Type (T)
2427               and then Base_Type (T2) = Base_Type (Standard_Integer);
2428
2429          elsif Op_Name = Name_Op_Concat then
2430             return Is_Array_Type (T)
2431               and then (Base_Type (T) = Base_Type (Etype (Op)))
2432               and then (Base_Type (T1) = Base_Type (T)
2433                          or else
2434                         Base_Type (T1) = Base_Type (Component_Type (T)))
2435               and then (Base_Type (T2) = Base_Type (T)
2436                          or else
2437                         Base_Type (T2) = Base_Type (Component_Type (T)));
2438
2439          else
2440             return False;
2441          end if;
2442       end if;
2443    end Operator_Matches_Spec;
2444
2445    -------------------
2446    -- Remove_Interp --
2447    -------------------
2448
2449    procedure Remove_Interp (I : in out Interp_Index) is
2450       II : Interp_Index;
2451
2452    begin
2453       --  Find end of Interp list and copy downward to erase the discarded one
2454
2455       II := I + 1;
2456       while Present (All_Interp.Table (II).Typ) loop
2457          II := II + 1;
2458       end loop;
2459
2460       for J in I + 1 .. II loop
2461          All_Interp.Table (J - 1) := All_Interp.Table (J);
2462       end loop;
2463
2464       --  Back up interp. index to insure that iterator will pick up next
2465       --  available interpretation.
2466
2467       I := I - 1;
2468    end Remove_Interp;
2469
2470    ------------------
2471    -- Save_Interps --
2472    ------------------
2473
2474    procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
2475       Map_Ptr : Int;
2476       O_N     : Node_Id := Old_N;
2477
2478    begin
2479       if Is_Overloaded (Old_N) then
2480          if Nkind (Old_N) = N_Selected_Component
2481            and then Is_Overloaded (Selector_Name (Old_N))
2482          then
2483             O_N := Selector_Name (Old_N);
2484          end if;
2485
2486          Map_Ptr := Headers (Hash (O_N));
2487
2488          while Interp_Map.Table (Map_Ptr).Node /= O_N loop
2489             Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
2490             pragma Assert (Map_Ptr /= No_Entry);
2491          end loop;
2492
2493          New_Interps (New_N);
2494          Interp_Map.Table (Interp_Map.Last).Index :=
2495            Interp_Map.Table (Map_Ptr).Index;
2496       end if;
2497    end Save_Interps;
2498
2499    -------------------
2500    -- Specific_Type --
2501    -------------------
2502
2503    function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
2504       B1 : constant Entity_Id := Base_Type (T1);
2505       B2 : constant Entity_Id := Base_Type (T2);
2506
2507       function Is_Remote_Access (T : Entity_Id) return Boolean;
2508       --  Check whether T is the equivalent type of a remote access type.
2509       --  If distribution is enabled, T is a legal context for Null.
2510
2511       ----------------------
2512       -- Is_Remote_Access --
2513       ----------------------
2514
2515       function Is_Remote_Access (T : Entity_Id) return Boolean is
2516       begin
2517          return Is_Record_Type (T)
2518            and then (Is_Remote_Call_Interface (T)
2519                       or else Is_Remote_Types (T))
2520            and then Present (Corresponding_Remote_Type (T))
2521            and then Is_Access_Type (Corresponding_Remote_Type (T));
2522       end Is_Remote_Access;
2523
2524    --  Start of processing for Specific_Type
2525
2526    begin
2527       if T1 = Any_Type or else T2 = Any_Type then
2528          return Any_Type;
2529       end if;
2530
2531       if B1 = B2 then
2532          return B1;
2533
2534       elsif False
2535         or else (T1 = Universal_Integer and then Is_Integer_Type (T2))
2536         or else (T1 = Universal_Real    and then Is_Real_Type (T2))
2537         or else (T1 = Universal_Fixed   and then Is_Fixed_Point_Type (T2))
2538         or else (T1 = Any_Fixed         and then Is_Fixed_Point_Type (T2))
2539       then
2540          return B2;
2541
2542       elsif False
2543         or else (T2 = Universal_Integer and then Is_Integer_Type (T1))
2544         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
2545         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
2546         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
2547       then
2548          return B1;
2549
2550       elsif T2 = Any_String and then Is_String_Type (T1) then
2551          return B1;
2552
2553       elsif T1 = Any_String and then Is_String_Type (T2) then
2554          return B2;
2555
2556       elsif T2 = Any_Character and then Is_Character_Type (T1) then
2557          return B1;
2558
2559       elsif T1 = Any_Character and then Is_Character_Type (T2) then
2560          return B2;
2561
2562       elsif T1 = Any_Access
2563         and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
2564       then
2565          return T2;
2566
2567       elsif T2 = Any_Access
2568         and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
2569       then
2570          return T1;
2571
2572       elsif T2 = Any_Composite
2573         and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
2574       then
2575          return T1;
2576
2577       elsif T1 = Any_Composite
2578         and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
2579       then
2580          return T2;
2581
2582       elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
2583          return T2;
2584
2585       elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
2586          return T1;
2587
2588       --  ----------------------------------------------------------
2589       --  Special cases for equality operators (all other predefined
2590       --  operators can never apply to tagged types)
2591       --  ----------------------------------------------------------
2592
2593       --  Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
2594       --  interface
2595
2596       elsif Is_Class_Wide_Type (T1)
2597         and then Is_Class_Wide_Type (T2)
2598         and then Is_Interface (Etype (T2))
2599       then
2600          return T1;
2601
2602       --  Ada 2005 (AI-251): T1 is a concrete type that implements the
2603       --  class-wide interface T2
2604
2605       elsif Is_Class_Wide_Type (T2)
2606         and then Is_Interface (Etype (T2))
2607         and then Interface_Present_In_Ancestor (Typ => T1,
2608                                                 Iface => Etype (T2))
2609       then
2610          return T1;
2611
2612       elsif Is_Class_Wide_Type (T1)
2613         and then Is_Ancestor (Root_Type (T1), T2)
2614       then
2615          return T1;
2616
2617       elsif Is_Class_Wide_Type (T2)
2618         and then Is_Ancestor (Root_Type (T2), T1)
2619       then
2620          return T2;
2621
2622       elsif (Ekind (B1) = E_Access_Subprogram_Type
2623                or else
2624              Ekind (B1) = E_Access_Protected_Subprogram_Type)
2625         and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
2626         and then Is_Access_Type (T2)
2627       then
2628          return T2;
2629
2630       elsif (Ekind (B2) = E_Access_Subprogram_Type
2631                or else
2632              Ekind (B2) = E_Access_Protected_Subprogram_Type)
2633         and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
2634         and then Is_Access_Type (T1)
2635       then
2636          return T1;
2637
2638       elsif (Ekind (T1) = E_Allocator_Type
2639               or else Ekind (T1) = E_Access_Attribute_Type
2640               or else Ekind (T1) = E_Anonymous_Access_Type)
2641         and then Is_Access_Type (T2)
2642       then
2643          return T2;
2644
2645       elsif (Ekind (T2) = E_Allocator_Type
2646               or else Ekind (T2) = E_Access_Attribute_Type
2647               or else Ekind (T2) = E_Anonymous_Access_Type)
2648         and then Is_Access_Type (T1)
2649       then
2650          return T1;
2651
2652       --  If none of the above cases applies, types are not compatible
2653
2654       else
2655          return Any_Type;
2656       end if;
2657    end Specific_Type;
2658
2659    -----------------------
2660    -- Valid_Boolean_Arg --
2661    -----------------------
2662
2663    --  In addition to booleans and arrays of booleans, we must include
2664    --  aggregates as valid boolean arguments, because in the first pass of
2665    --  resolution their components are not examined. If it turns out not to be
2666    --  an aggregate of booleans, this will be diagnosed in Resolve.
2667    --  Any_Composite must be checked for prior to the array type checks because
2668    --  Any_Composite does not have any associated indexes.
2669
2670    function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
2671    begin
2672       return Is_Boolean_Type (T)
2673         or else T = Any_Composite
2674         or else (Is_Array_Type (T)
2675                   and then T /= Any_String
2676                   and then Number_Dimensions (T) = 1
2677                   and then Is_Boolean_Type (Component_Type (T))
2678                   and then (not Is_Private_Composite (T)
2679                              or else In_Instance)
2680                   and then (not Is_Limited_Composite (T)
2681                              or else In_Instance))
2682         or else Is_Modular_Integer_Type (T)
2683         or else T = Universal_Integer;
2684    end Valid_Boolean_Arg;
2685
2686    --------------------------
2687    -- Valid_Comparison_Arg --
2688    --------------------------
2689
2690    function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
2691    begin
2692
2693       if T = Any_Composite then
2694          return False;
2695       elsif Is_Discrete_Type (T)
2696         or else Is_Real_Type (T)
2697       then
2698          return True;
2699       elsif Is_Array_Type (T)
2700           and then Number_Dimensions (T) = 1
2701           and then Is_Discrete_Type (Component_Type (T))
2702           and then (not Is_Private_Composite (T)
2703                      or else In_Instance)
2704           and then (not Is_Limited_Composite (T)
2705                      or else In_Instance)
2706       then
2707          return True;
2708       elsif Is_String_Type (T) then
2709          return True;
2710       else
2711          return False;
2712       end if;
2713    end Valid_Comparison_Arg;
2714
2715    ---------------------
2716    -- Write_Overloads --
2717    ---------------------
2718
2719    procedure Write_Overloads (N : Node_Id) is
2720       I   : Interp_Index;
2721       It  : Interp;
2722       Nam : Entity_Id;
2723
2724    begin
2725       if not Is_Overloaded (N) then
2726          Write_Str ("Non-overloaded entity ");
2727          Write_Eol;
2728          Write_Entity_Info (Entity (N), " ");
2729
2730       else
2731          Get_First_Interp (N, I, It);
2732          Write_Str ("Overloaded entity ");
2733          Write_Eol;
2734          Nam := It.Nam;
2735
2736          while Present (Nam) loop
2737             Write_Entity_Info (Nam,  "      ");
2738             Write_Str ("=================");
2739             Write_Eol;
2740             Get_Next_Interp (I, It);
2741             Nam := It.Nam;
2742          end loop;
2743       end if;
2744    end Write_Overloads;
2745
2746    ----------------------
2747    -- Write_Interp_Ref --
2748    ----------------------
2749
2750    procedure Write_Interp_Ref (Map_Ptr : Int) is
2751    begin
2752       Write_Str (" Node:  ");
2753       Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
2754       Write_Str (" Index: ");
2755       Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
2756       Write_Str (" Next:  ");
2757       Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
2758       Write_Eol;
2759    end Write_Interp_Ref;
2760
2761 end Sem_Type;