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