gcc/ada/sem_type.adb

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