gcc/ada/sem_type.adb

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