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