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