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