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